diff --git a/README.md b/README.md index 9c6d154c..5f2b9771 100644 --- a/README.md +++ b/README.md @@ -811,6 +811,7 @@ The following constructs are fully supported: * constructors * if statements * infix expressions and types +* fixity declarations for infix expressions and types * `_` patterns * aliased patterns * lists (including list comprehensions) @@ -1540,7 +1541,6 @@ The following constructs are either unsupported or almost never work: * Irrefutable patterns * `{-# UNPACK #-}` pragmas * partial application of the `(->)` type -* namespace specifiers in fixity declarations * invisible type patterns See the following sections for more details. @@ -1728,19 +1728,6 @@ arguments. Attempting to promote `(->)` to zero or one argument will result in an error. As a consequence, it is impossible to promote instances like the `Functor ((->) r)` instance, so `singletons-base` does not provide them. -### Namespace specifiers in fixity declarations - -`singletons-th` will currently ignore namespace specifiers attached to fixity -declarations. For instance, if you attempt to promote this: - -```hs -infixl 4 data `f` -f :: a -> a -> a -``` - -Then it will be the same as if you had written `` infixl 4 `f` ``. See [this -`singletons` issue](https://github.com/goldfirere/singletons/issues/582). - ### Invisible type patterns `singletons-th` currently does not support invisible type patterns, such as the diff --git a/singletons-base/tests/SingletonsBaseTestSuite.hs b/singletons-base/tests/SingletonsBaseTestSuite.hs index e2d6082c..14988c72 100644 --- a/singletons-base/tests/SingletonsBaseTestSuite.hs +++ b/singletons-base/tests/SingletonsBaseTestSuite.hs @@ -153,6 +153,7 @@ tests = , compileAndDumpStdTest "T567" , compileAndDumpStdTest "T571" , compileAndDumpStdTest "T581" + , compileAndDumpStdTest "T582" , compileAndDumpStdTest "T585" , compileAndDumpStdTest "TypeAbstractions" , compileAndDumpStdTest "T589" diff --git a/singletons-base/tests/compile-and-dump/Singletons/T582.golden b/singletons-base/tests/compile-and-dump/Singletons/T582.golden new file mode 100644 index 00000000..c44813f8 --- /dev/null +++ b/singletons-base/tests/compile-and-dump/Singletons/T582.golden @@ -0,0 +1,151 @@ +Singletons/T582.hs:(0,0)-(0,0): Splicing declarations + singletons + [d| infixl 4 !!! + infixl 4 %%% + infixl 4 `Bar` + infixl 4 `foo` + + foo :: a -> a -> a + x `foo` _ = x + (%%%) :: a -> a -> a + x %%% _ = x + + type Bar :: a -> a -> a + type (!!!) :: a -> a -> a + + type x `Bar` y = x + type x !!! y = x |] + ======> + infixl 4 `foo` + foo :: a -> a -> a + foo x _ = x + infixl 4 `Bar` + type Bar :: a -> a -> a + type Bar x y = x + infixl 4 %%% + (%%%) :: a -> a -> a + (%%%) x _ = x + infixl 4 !!! + type (!!!) :: a -> a -> a + type (!!!) x y = x + type BarSym0 :: (~>) a ((~>) a a) + data BarSym0 :: (~>) a ((~>) a a) + where + BarSym0KindInference :: SameKind (Apply BarSym0 arg) (BarSym1 arg) => + BarSym0 a0123456789876543210 + type instance Apply BarSym0 a0123456789876543210 = BarSym1 a0123456789876543210 + instance SuppressUnusedWarnings BarSym0 where + suppressUnusedWarnings = snd ((,) BarSym0KindInference ()) + infixl 4 `BarSym0` + type BarSym1 :: a -> (~>) a a + data BarSym1 (a0123456789876543210 :: a) :: (~>) a a + where + BarSym1KindInference :: SameKind (Apply (BarSym1 a0123456789876543210) arg) (BarSym2 a0123456789876543210 arg) => + BarSym1 a0123456789876543210 a0123456789876543210 + type instance Apply (BarSym1 a0123456789876543210) a0123456789876543210 = Bar a0123456789876543210 a0123456789876543210 + instance SuppressUnusedWarnings (BarSym1 a0123456789876543210) where + suppressUnusedWarnings = snd ((,) BarSym1KindInference ()) + infixl 4 `BarSym1` + type BarSym2 :: a -> a -> a + type family BarSym2 @a (a0123456789876543210 :: a) (a0123456789876543210 :: a) :: a where + BarSym2 a0123456789876543210 a0123456789876543210 = Bar a0123456789876543210 a0123456789876543210 + infixl 4 `BarSym2` + type (!!!@#@$) :: (~>) a ((~>) a a) + data (!!!@#@$) :: (~>) a ((~>) a a) + where + (:!!!@#@$###) :: SameKind (Apply (!!!@#@$) arg) ((!!!@#@$$) arg) => + (!!!@#@$) a0123456789876543210 + type instance Apply (!!!@#@$) a0123456789876543210 = (!!!@#@$$) a0123456789876543210 + instance SuppressUnusedWarnings (!!!@#@$) where + suppressUnusedWarnings = snd ((,) (:!!!@#@$###) ()) + infixl 4 !!!@#@$ + type (!!!@#@$$) :: a -> (~>) a a + data (!!!@#@$$) (a0123456789876543210 :: a) :: (~>) a a + where + (:!!!@#@$$###) :: SameKind (Apply ((!!!@#@$$) a0123456789876543210) arg) ((!!!@#@$$$) a0123456789876543210 arg) => + (!!!@#@$$) a0123456789876543210 a0123456789876543210 + type instance Apply ((!!!@#@$$) a0123456789876543210) a0123456789876543210 = (!!!) a0123456789876543210 a0123456789876543210 + instance SuppressUnusedWarnings ((!!!@#@$$) a0123456789876543210) where + suppressUnusedWarnings = snd ((,) (:!!!@#@$$###) ()) + infixl 4 !!!@#@$$ + type (!!!@#@$$$) :: a -> a -> a + type family (!!!@#@$$$) @a (a0123456789876543210 :: a) (a0123456789876543210 :: a) :: a where + (!!!@#@$$$) a0123456789876543210 a0123456789876543210 = (!!!) a0123456789876543210 a0123456789876543210 + infixl 4 !!!@#@$$$ + type (%%%@#@$) :: (~>) a ((~>) a a) + data (%%%@#@$) :: (~>) a ((~>) a a) + where + (:%%%@#@$###) :: SameKind (Apply (%%%@#@$) arg) ((%%%@#@$$) arg) => + (%%%@#@$) a0123456789876543210 + type instance Apply (%%%@#@$) a0123456789876543210 = (%%%@#@$$) a0123456789876543210 + instance SuppressUnusedWarnings (%%%@#@$) where + suppressUnusedWarnings = snd ((,) (:%%%@#@$###) ()) + infixl 4 %%%@#@$ + type (%%%@#@$$) :: a -> (~>) a a + data (%%%@#@$$) (a0123456789876543210 :: a) :: (~>) a a + where + (:%%%@#@$$###) :: SameKind (Apply ((%%%@#@$$) a0123456789876543210) arg) ((%%%@#@$$$) a0123456789876543210 arg) => + (%%%@#@$$) a0123456789876543210 a0123456789876543210 + type instance Apply ((%%%@#@$$) a0123456789876543210) a0123456789876543210 = (%%%) a0123456789876543210 a0123456789876543210 + instance SuppressUnusedWarnings ((%%%@#@$$) a0123456789876543210) where + suppressUnusedWarnings = snd ((,) (:%%%@#@$$###) ()) + infixl 4 %%%@#@$$ + type (%%%@#@$$$) :: a -> a -> a + type family (%%%@#@$$$) @a (a0123456789876543210 :: a) (a0123456789876543210 :: a) :: a where + (%%%@#@$$$) a0123456789876543210 a0123456789876543210 = (%%%) a0123456789876543210 a0123456789876543210 + infixl 4 %%%@#@$$$ + type FooSym0 :: (~>) a ((~>) a a) + data FooSym0 :: (~>) a ((~>) a a) + where + FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => + FooSym0 a0123456789876543210 + type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 + instance SuppressUnusedWarnings FooSym0 where + suppressUnusedWarnings = snd ((,) FooSym0KindInference ()) + infixl 4 `FooSym0` + type FooSym1 :: a -> (~>) a a + data FooSym1 (a0123456789876543210 :: a) :: (~>) a a + where + FooSym1KindInference :: SameKind (Apply (FooSym1 a0123456789876543210) arg) (FooSym2 a0123456789876543210 arg) => + FooSym1 a0123456789876543210 a0123456789876543210 + type instance Apply (FooSym1 a0123456789876543210) a0123456789876543210 = Foo a0123456789876543210 a0123456789876543210 + instance SuppressUnusedWarnings (FooSym1 a0123456789876543210) where + suppressUnusedWarnings = snd ((,) FooSym1KindInference ()) + infixl 4 `FooSym1` + type FooSym2 :: a -> a -> a + type family FooSym2 @a (a0123456789876543210 :: a) (a0123456789876543210 :: a) :: a where + FooSym2 a0123456789876543210 a0123456789876543210 = Foo a0123456789876543210 a0123456789876543210 + infixl 4 `FooSym2` + type (%%%) :: a -> a -> a + type family (%%%) @a (a :: a) (a :: a) :: a where + (%%%) x _ = x + type Foo :: a -> a -> a + type family Foo @a (a :: a) (a :: a) :: a where + Foo x _ = x + infixl 4 %%% + infixl 4 `Foo` + infixl 4 %%%% + infixl 4 `sFoo` + (%%%%) :: + (forall (t :: a) (t :: a). + Sing t + -> Sing t -> Sing (Apply (Apply (%%%@#@$) t) t :: a) :: Type) + sFoo :: + (forall (t :: a) (t :: a). + Sing t -> Sing t -> Sing (Apply (Apply FooSym0 t) t :: a) :: Type) + (%%%%) (sX :: Sing x) _ = sX + sFoo (sX :: Sing x) _ = sX + instance SingI ((%%%@#@$) :: (~>) a ((~>) a a)) where + sing = singFun2 @(%%%@#@$) (%%%%) + instance SingI d => SingI ((%%%@#@$$) (d :: a) :: (~>) a a) where + sing = singFun1 @((%%%@#@$$) (d :: a)) ((%%%%) (sing @d)) + instance SingI1 ((%%%@#@$$) :: a -> (~>) a a) where + liftSing (s :: Sing (d :: a)) + = singFun1 @((%%%@#@$$) (d :: a)) ((%%%%) s) + instance SingI (FooSym0 :: (~>) a ((~>) a a)) where + sing = singFun2 @FooSym0 sFoo + instance SingI d => SingI (FooSym1 (d :: a) :: (~>) a a) where + sing = singFun1 @(FooSym1 (d :: a)) (sFoo (sing @d)) + instance SingI1 (FooSym1 :: a -> (~>) a a) where + liftSing (s :: Sing (d :: a)) + = singFun1 @(FooSym1 (d :: a)) (sFoo s) diff --git a/singletons-base/tests/compile-and-dump/Singletons/T582.hs b/singletons-base/tests/compile-and-dump/Singletons/T582.hs new file mode 100644 index 00000000..f96188ed --- /dev/null +++ b/singletons-base/tests/compile-and-dump/Singletons/T582.hs @@ -0,0 +1,21 @@ +module T582 where + +import Data.Singletons.TH + +$(singletons [d| + infixl 4 data `foo` + foo :: a -> a -> a + x `foo` _ = x + + infixl 4 type `Bar` + type Bar :: a -> a -> a + type x `Bar` y = x + + infixl 4 data %%% + (%%%) :: a -> a -> a + x %%% _ = x + + infixl 4 type !!! + type (!!!) :: a -> a -> a + type x !!! y = x + |]) diff --git a/singletons-th/src/Data/Singletons/TH/Partition.hs b/singletons-th/src/Data/Singletons/TH/Partition.hs index 7dff6897..3fcd248f 100644 --- a/singletons-th/src/Data/Singletons/TH/Partition.hs +++ b/singletons-th/src/Data/Singletons/TH/Partition.hs @@ -163,8 +163,8 @@ partitionClassDec (DLetDec (DValD (DVarP name) exp)) = pure (valueBinding name (UValue exp), mempty) partitionClassDec (DLetDec (DFunD name clauses)) = pure (valueBinding name (UFunction clauses), mempty) -partitionClassDec (DLetDec (DInfixD fixity _ name)) = - pure (infixDecl fixity name, mempty) +partitionClassDec (DLetDec (DInfixD fixity ns name)) = + pure (infixDecl fixity ns name, mempty) partitionClassDec (DLetDec (DPragmaD {})) = pure (mempty, mempty) partitionClassDec (DOpenTypeFamilyD tf_head) = diff --git a/singletons-th/src/Data/Singletons/TH/Promote.hs b/singletons-th/src/Data/Singletons/TH/Promote.hs index f1f603c5..694790bb 100644 --- a/singletons-th/src/Data/Singletons/TH/Promote.hs +++ b/singletons-th/src/Data/Singletons/TH/Promote.hs @@ -293,7 +293,7 @@ promoteClassDec decl@(ClassDecl { cd_name = cls_name <- mapAndUnzip3M (promoteMethod DefaultMethods meth_sigs cls_tvb_names) defaults_list defunAssociatedTypeFamilies orig_cls_tvbs atfs - infix_decls' <- mapMaybeM (uncurry (promoteInfixDecl Nothing)) $ + infix_decls' <- mapMaybeM (\(n, (f, ns)) -> promoteInfixDecl Nothing n f ns) $ OMap.assocs infix_decls cls_infix_decls <- promoteReifiedInfixDecls $ cls_name:meth_names @@ -830,14 +830,14 @@ promoteLetDecEnv :: Maybe Uniq -> ULetDecEnv -> PrM ([DDec], ALetDecEnv) promoteLetDecEnv mb_let_uniq (LetDecEnv { lde_defns = value_env , lde_types = type_env , lde_infix = fix_env }) = do - infix_decls <- mapMaybeM (uncurry (promoteInfixDecl mb_let_uniq)) $ + infix_decls <- mapMaybeM (\(n, (f, ns)) -> promoteInfixDecl mb_let_uniq n f ns) $ OMap.assocs fix_env -- promote all the declarations, producing annotated declarations let (names, rhss) = unzip $ OMap.assocs value_env (pro_decs, defun_decss, ann_rhss) <- fmap unzip3 $ - zipWithM (promoteLetDecRHS LetBindingRHS type_env fix_env mb_let_uniq) + zipWithM (promoteLetDecRHS LetBindingRHS type_env (fmap fst fix_env) mb_let_uniq) names rhss emitDecs $ concat defun_decss @@ -854,8 +854,15 @@ promoteLetDecEnv mb_let_uniq (LetDecEnv { lde_defns = value_env -- Promote a fixity declaration. promoteInfixDecl :: forall q. OptionsMonad q - => Maybe Uniq -> Name -> Fixity -> q (Maybe DDec) -promoteInfixDecl mb_let_uniq name fixity = do + => Maybe Uniq -> Name -> Fixity + -> NamespaceSpecifier + -- The namespace specifier for the fixity declaration. We + -- only pass this for the sake of checking if we need to + -- avoid promoting a fixity declaration (see `promote_val` + -- below). The actual namespace used in the promoted fixity + -- declaration will always be `type`. + -> q (Maybe DDec) +promoteInfixDecl mb_let_uniq name fixity ns = do opts <- getOptions fld_sels <- qIsExtEnabled LangExt.FieldSelectors mb_ns <- reifyNameSpace name @@ -874,9 +881,10 @@ promoteInfixDecl mb_let_uniq name fixity = do -> finish $ promotedClassName opts name _ -> never_mind where - -- Produce the fixity declaration. + -- Produce the fixity declaration. Promoted names always inhabit the `type` + -- namespace (i.e., `TypeNamespaceSpecifier`). finish :: Name -> q (Maybe DDec) - finish = pure . Just . DLetDec . DInfixD fixity NoNamespaceSpecifier + finish = pure . Just . DLetDec . DInfixD fixity TypeNamespaceSpecifier -- Don't produce a fixity declaration at all. This can happen in the -- following circumstances: @@ -892,16 +900,23 @@ promoteInfixDecl mb_let_uniq name fixity = do never_mind = pure Nothing -- Certain value names do not change when promoted (e.g., infix names). - -- Therefore, don't bother promoting their fixity declarations if - -- 'genQuotedDecs' is set to 'True', since that will run the risk of - -- generating duplicate fixity declarations. + -- Therefore, don't bother promoting their fixity declarations if the + -- following hold: + -- + -- - 'genQuotedDecs' is set to 'True'. + -- + -- - The name lacks an explicit namespace specifier. + -- + -- Doing so will run the risk of generating duplicate fixity declarations. -- See Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1. promote_val :: q (Maybe DDec) promote_val = do opts <- getOptions let promoted_name :: Name promoted_name = promotedValueName opts name mb_let_uniq - if nameBase name == nameBase promoted_name && genQuotedDecs opts + if nameBase name == nameBase promoted_name + && genQuotedDecs opts + && ns == NoNamespaceSpecifier then never_mind else finish promoted_name @@ -918,7 +933,15 @@ promoteReifiedInfixDecls = mapMaybeM tryPromoteFixityDeclaration mFixity <- qReifyFixity name case mFixity of Nothing -> pure Nothing - Just fixity -> promoteInfixDecl Nothing name fixity + -- NB: We don't have a NamespaceSpecifier in hand here. We could try + -- to look one up, but it doesn't actually matter which namespace we + -- pass here. If we reach this point in the code, we know we have a + -- non-quoted Name (as reification would failed earlier if the Name + -- were quoted). As such, the special case described in + -- [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, + -- wrinkle 1 won't apply, and we only pass a namespace specifier for + -- the sake of checking this special case. + Just fixity -> promoteInfixDecl Nothing name fixity NoNamespaceSpecifier -- Which sort of let-bound declaration's right-hand side is being promoted? data LetDecRHSSort diff --git a/singletons-th/src/Data/Singletons/TH/Promote/Defun.hs b/singletons-th/src/Data/Singletons/TH/Promote/Defun.hs index b4d3944d..c9a7abcf 100644 --- a/singletons-th/src/Data/Singletons/TH/Promote/Defun.hs +++ b/singletons-th/src/Data/Singletons/TH/Promote/Defun.hs @@ -445,7 +445,7 @@ defunctionalize name m_fixity defun_ki = do (noExactName <$> qNewName "e") mk_fix_decl :: Name -> Fixity -> DDec - mk_fix_decl n f = DLetDec $ DInfixD f NoNamespaceSpecifier n + mk_fix_decl n f = DLetDec $ DInfixD f TypeNamespaceSpecifier n -- Indicates whether the type being defunctionalized has a standalone kind -- signature. If it does, DefunSAK contains the kind. If not, DefunNoSAK @@ -529,10 +529,10 @@ Some things to note: to as "fully saturated" defunctionalization symbols. See Note [Fully saturated defunctionalization symbols]. -* If Foo had a fixity declaration (e.g., infixl 4 `Foo`), then we would also - generate fixity declarations for each defunctionalization symbol (e.g., - infixl 4 `FooSym0`). - See Note [Fixity declarations for defunctionalization symbols]. +* If Foo had a fixity declaration (e.g., infixl 4 type `Foo`), then we would + also generate fixity declarations for each defunctionalization symbol (e.g., + infixl 4 type `FooSym0`). See Note [Fixity declarations for + defunctionalization symbols]. * Foo has a vanilla kind signature. (See Note [Vanilla-type validity checking during promotion] in D.S.TH.Promote.Type @@ -883,7 +883,7 @@ following scenario: (.) :: (b -> c) -> (a -> b) -> (a -> c) (f . g) x = f (g x) - infixr 9 . + infixr 9 data . One often writes (f . g . h) at the value level, but because (.) is promoted to a type family with three arguments, this doesn't directly translate to the @@ -892,6 +892,6 @@ type level. Instead, one must write this: f .@#@$$$ g .@#@$$$ h But in order to ensure that this associates to the right as expected, one must -generate an `infixr 9 .@#@#$$$` declaration. This is why defunctionalize accepts -a Maybe Fixity argument. +generate an `infixr 9 type .@#@#$$$` declaration. This is why defunctionalize +accepts a Maybe Fixity argument. -} diff --git a/singletons-th/src/Data/Singletons/TH/Single.hs b/singletons-th/src/Data/Singletons/TH/Single.hs index c118a1a2..f1cc9b85 100644 --- a/singletons-th/src/Data/Singletons/TH/Single.hs +++ b/singletons-th/src/Data/Singletons/TH/Single.hs @@ -401,7 +401,7 @@ singClassD (ClassDecl { cd_cxt = cls_cxt tyvar_names res_kis sing_meths <- mapM (uncurry (singLetDecRHS (Map.fromList cxts))) (OMap.assocs default_defns) - fixities' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs fixities + fixities' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs $ fmap fst fixities cls_cxt' <- mapM singPred cls_cxt return $ DClassD cls_cxt' sing_cls_name @@ -519,7 +519,7 @@ singLetDecEnv (LetDecEnv { lde_defns = defns let prom_list = OMap.assocs proms (typeSigs, letBinds, _tyvarNames, cxts, _res_kis, singIDefunss) <- unzip6 <$> mapM (uncurry (singTySig defns types)) prom_list - infix_decls' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs infix_decls + infix_decls' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs $ fmap fst infix_decls bindLets letBinds $ do let_decs <- mapM (uncurry (singLetDecRHS (Map.fromList cxts))) (OMap.assocs defns) diff --git a/singletons-th/src/Data/Singletons/TH/Single/Fixity.hs b/singletons-th/src/Data/Singletons/TH/Single/Fixity.hs index 9eea913a..b6073c4b 100644 --- a/singletons-th/src/Data/Singletons/TH/Single/Fixity.hs +++ b/singletons-th/src/Data/Singletons/TH/Single/Fixity.hs @@ -17,24 +17,24 @@ singInfixDecl name fixity = do case mb_ns of -- If we can't find the Name for some odd reason, -- fall back to singValName - Nothing -> finish $ singledValueName opts name - Just VarName -> finish $ singledValueName opts name + Nothing -> finish DataNamespaceSpecifier $ singledValueName opts name + Just VarName -> finish DataNamespaceSpecifier $ singledValueName opts name Just (FldName _) - | fld_sels -> finish $ singledValueName opts name + | fld_sels -> finish DataNamespaceSpecifier $ singledValueName opts name | otherwise -> never_mind - Just DataName -> finish $ singledDataConName opts name + Just DataName -> finish DataNamespaceSpecifier $ singledDataConName opts name Just TcClsName -> do mb_info <- dsReify name case mb_info of Just (DTyConI DClassD{} _) - -> finish $ singledClassName opts name + -> finish TypeNamespaceSpecifier $ singledClassName opts name _ -> never_mind -- Don't produce anything for other type constructors (type synonyms, -- type families, data types, etc.). -- See [singletons-th and fixity declarations], wrinkle 1. where - finish :: Name -> q (Maybe DLetDec) - finish = pure . Just . DInfixD fixity NoNamespaceSpecifier + finish :: NamespaceSpecifier -> Name -> q (Maybe DLetDec) + finish ns n = pure $ Just $ DInfixD fixity ns n never_mind :: q (Maybe DLetDec) never_mind = pure Nothing @@ -68,15 +68,15 @@ one: singletons-th will produce promoted and singled versions of them: - infixl 5 `Foo` - infixl 5 `sFoo` + infixl 5 type `Foo` + infixl 5 data `sFoo` singletons-th will also produce fixity declarations for its defunctionalization symbols (see Note [Fixity declarations for defunctionalization symbols] in D.S.TH.Promote.Defun): - infixl 5 `FooSym0` - infixl 5 `FooSym1` + infixl 5 type `FooSym0` + infixl 5 type `FooSym1` ... ----- @@ -94,14 +94,15 @@ versions of fixity declarations: - Type synonyms - Type families - Data constructors - - Infix values + - Infix values (when their fixity declaration lack explicit namespaces) We exclude the first four because the promoted versions of these names are the same as the originals, so generating an extra fixity declaration for them would run the risk of having duplicates, which GHC would reject with an error. - We exclude infix value because while their promoted versions are different, - they share the same name base. In concrete terms, this: + We exclude infix values when their fixity declarations lack explicit + namespaces because while their promoted versions are different, they share + the same name base. In concrete terms, this: $(promote [d| infixl 4 ### @@ -112,22 +113,41 @@ versions of fixity declarations: type family (###) (x :: a) (y :: a) :: a where ... - So giving the type-level (###) a fixity declaration would clash with the - existing one for the value-level (###). - - There *is* a scenario where we should generate a fixity declaration for the - type-level (###), however. Imagine the above example used the `promoteOnly` - function instead of `promote`. Then the type-level (###) would lack a fixity - declaration altogether because the original fixity declaration was discarded - by `promoteOnly`! The same problem would arise if one had to choose between - the `singletons` and `singletonsOnly` functions. - - The difference between `promote` and `promoteOnly` (as well as `singletons` - and `singletonsOnly`) is whether the `genQuotedDecs` option is set to `True` - or `False`, respectively. Therefore, if `genQuotedDecs` is set to `False` - when promoting the fixity declaration for an infix value, we opt to generate - a fixity declaration (with the same name base) so that the type-level version - of that value gets one. + Note that the original `infixl 4 ###` declaration lacks an explicit + namespace, which means that it applies to both the term-level *and* + type-level (###) definitions. This means that giving the type-level (###) a + fixity declaration would clash with the original fixity declaration. + + There *are* scenarios where we should generate a fixity declaration for the + type-level (###), however: + + - Imagine if the fixity declaration had an explicit `data` namespace: + + $(promote [d| + infixl 4 data ### + (###) :: a -> a -> a + |]) + + Then it would be fine to give the promoted (###) definition this fixity + declaration: + + infixl 4 type ### + + This is because the two fixity declarations would refer to distinct names + in a different namespaces, so the two fixity declarations would not clash. + + - Imagine the above example used the `promoteOnly` function instead of + `promote`. Then the type-level (###) would lack a fixity declaration + altogether because the original fixity declaration was discarded by + `promoteOnly`! The same problem would arise if one had to choose between + the `singletons` and `singletonsOnly` functions. + + The difference between `promote` and `promoteOnly` (as well as `singletons` + and `singletonsOnly`) is whether the `genQuotedDecs` option is set to + `True` or `False`, respectively. Therefore, if `genQuotedDecs` is set to + `False` when promoting the fixity declaration for an infix value, we opt to + generate a fixity declaration (with the same name base) so that the + type-level version of that value gets one. * During singling, the following things will not have their fixity declarations singled: diff --git a/singletons-th/src/Data/Singletons/TH/Syntax.hs b/singletons-th/src/Data/Singletons/TH/Syntax.hs index 7bde9213..31cf7f74 100644 --- a/singletons-th/src/Data/Singletons/TH/Syntax.hs +++ b/singletons-th/src/Data/Singletons/TH/Syntax.hs @@ -158,7 +158,7 @@ type ULetDecRHS = LetDecRHS Unannotated data LetDecEnv ann = LetDecEnv { lde_defns :: OMap Name (LetDecRHS ann) , lde_types :: OMap Name DType -- type signatures - , lde_infix :: OMap Name Fixity -- infix declarations + , lde_infix :: OMap Name (Fixity, NamespaceSpecifier) -- infix declarations , lde_proms :: IfAnn ann (OMap Name DType) () -- possibly, promotions } type ALetDecEnv = LetDecEnv Annotated @@ -177,8 +177,8 @@ valueBinding n v = emptyLetDecEnv { lde_defns = OMap.singleton n v } typeBinding :: Name -> DType -> ULetDecEnv typeBinding n t = emptyLetDecEnv { lde_types = OMap.singleton n t } -infixDecl :: Fixity -> Name -> ULetDecEnv -infixDecl f n = emptyLetDecEnv { lde_infix = OMap.singleton n f } +infixDecl :: Fixity -> NamespaceSpecifier -> Name -> ULetDecEnv +infixDecl f ns n = emptyLetDecEnv { lde_infix = OMap.singleton n (f, ns) } emptyLetDecEnv :: ULetDecEnv emptyLetDecEnv = mempty @@ -196,8 +196,8 @@ buildLetDecEnv = go emptyLetDecEnv go acc (flattened ++ rest) go acc (DSigD name ty : rest) = go (typeBinding name ty <> acc) rest - go acc (DInfixD f _ n : rest) = - go (infixDecl f n <> acc) rest + go acc (DInfixD f ns n : rest) = + go (infixDecl f ns n <> acc) rest go acc (DPragmaD{} : rest) = go acc rest -- See Note [DerivedDecl]