diff --git a/CHANGES.md b/CHANGES.md index f3bdd278..45bf8f8e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -24,6 +24,9 @@ Changelog for singletons project synonym did nothing whatsoever, and promoting or singling a type family produced an error.) +* `singletons` now produces fixity declarations for defunctionalization + symbols when appropriate. + * Add `(%<=?)`, a singled version of `(<=?)` from `GHC.TypeNats`, as well as defunctionalization symbols for `(<=?)`, to `Data.Singletons.TypeLits`. diff --git a/src/Data/Singletons/Promote.hs b/src/Data/Singletons/Promote.hs index 379b76f9..85d0f678 100644 --- a/src/Data/Singletons/Promote.hs +++ b/src/Data/Singletons/Promote.hs @@ -290,7 +290,8 @@ promoteClassDec decl@(ClassDecl { cd_cxt = cxt (default_decs, ann_rhss, prom_rhss) <- mapAndUnzip3M (promoteMethod Nothing meth_sigs) defaults_list - let infix_decls' = catMaybes $ map (uncurry promoteInfixDecl) infix_decls + let infix_decls' = catMaybes $ map (uncurry promoteInfixDecl) + $ Map.toList infix_decls -- no need to do anything to the fundeps. They work as is! emitDecs [DClassD pCxt pClsName tvbs fundeps @@ -312,7 +313,7 @@ promoteClassDec decl@(ClassDecl { cd_cxt = cxt let proName = promoteValNameLhs name (argKs, resK) <- promoteUnraveled ty args <- mapM (const $ qNewName "arg") argKs - emitDecsM $ defunctionalize proName (map Just argKs) (Just resK) + emitDecsM $ defunReifyFixity proName (map Just argKs) (Just resK) return $ DOpenTypeFamilyD (DTypeFamilyHead proName (zipWith DKindedTV args argKs) @@ -409,7 +410,8 @@ promoteMethod :: Maybe (Map Name DKind) promoteMethod m_subst sigs_map (meth_name, meth_rhs) = do (arg_kis, res_ki) <- lookup_meth_ty ((_, _, _, eqns), _defuns, ann_rhs) - <- promoteLetDecRHS (Just (arg_kis, res_ki)) sigs_map noPrefix meth_name meth_rhs + <- promoteLetDecRHS (Just (arg_kis, res_ki)) sigs_map Map.empty + noPrefix meth_name meth_rhs meth_arg_tvs <- mapM (const $ qNewName "a") arg_kis let -- If we're dealing with an associated type family instance, substitute -- in the kind of the instance for better kind information in the RHS @@ -443,7 +445,7 @@ promoteMethod m_subst sigs_map (meth_name, meth_rhs) = do (DKindSig meth_res_ki') Nothing) eqns] - emitDecsM (defunctionalize helperName (map Just meth_arg_kis') (Just meth_res_ki')) + emitDecsM (defunctionalize helperName Nothing (map Just meth_arg_kis') (Just meth_res_ki')) return ( DTySynInstD proName (DTySynEqn family_args @@ -504,22 +506,23 @@ promoted method implementations like MHelper2. promoteLetDecEnv :: (String, String) -> ULetDecEnv -> PrM ([DDec], ALetDecEnv) promoteLetDecEnv prefixes (LetDecEnv { lde_defns = value_env , lde_types = type_env - , lde_infix = infix_decls }) = do - let infix_decls' = catMaybes $ map (uncurry promoteInfixDecl) infix_decls + , lde_infix = fix_env }) = do + let infix_decls = catMaybes $ map (uncurry promoteInfixDecl) + $ Map.toList fix_env -- promote all the declarations, producing annotated declarations let (names, rhss) = unzip $ Map.toList value_env (payloads, defun_decss, ann_rhss) - <- fmap unzip3 $ zipWithM (promoteLetDecRHS Nothing type_env prefixes) names rhss + <- fmap unzip3 $ zipWithM (promoteLetDecRHS Nothing type_env fix_env prefixes) names rhss emitDecs $ concat defun_decss bound_kvs <- allBoundKindVars - let decs = map payload_to_dec payloads ++ infix_decls' + let decs = map payload_to_dec payloads ++ infix_decls -- build the ALetDecEnv let let_dec_env' = LetDecEnv { lde_defns = Map.fromList $ zip names ann_rhss , lde_types = type_env - , lde_infix = infix_decls + , lde_infix = fix_env , lde_proms = Map.empty -- filled in promoteLetDecs , lde_bound_kvs = Map.fromList $ map (, bound_kvs) names } @@ -531,8 +534,8 @@ promoteLetDecEnv prefixes (LetDecEnv { lde_defns = value_env where sig = maybe DNoSig DKindSig m_ki -promoteInfixDecl :: Fixity -> Name -> Maybe DDec -promoteInfixDecl fixity name +promoteInfixDecl :: Name -> Fixity -> Maybe DDec +promoteInfixDecl name fixity | nameBase name == nameBase promoted_name -- If a name and its promoted counterpart are the same (modulo module -- prefixes), then there's no need to promote a fixity declaration for @@ -554,13 +557,14 @@ promoteInfixDecl fixity name promoteLetDecRHS :: Maybe ([DKind], DKind) -- the promoted type of the RHS (if known) -- needed to fix #136 -> Map Name DType -- local type env't + -> Map Name Fixity -- local fixity env't -> (String, String) -- let-binding prefixes -> Name -- name of the thing being promoted -> ULetDecRHS -- body of the thing -> PrM ( (Name, [DTyVarBndr], Maybe DKind, [DTySynEqn]) -- "type family" , [DDec] -- defunctionalization , ALetDecRHS ) -- annotated RHS -promoteLetDecRHS m_rhs_ki type_env prefixes name (UValue exp) = do +promoteLetDecRHS m_rhs_ki type_env fix_env prefixes name (UValue exp) = do (res_kind, num_arrows) <- case m_rhs_ki of Just (arg_kis, res_ki) -> return ( Just (ravelTyFun (arg_kis ++ [res_ki])) @@ -575,8 +579,9 @@ promoteLetDecRHS m_rhs_ki type_env prefixes name (UValue exp) = do all_locals <- allLocals let lde_kvs_to_bind = foldMap fvDType res_kind (exp', ann_exp) <- forallBind lde_kvs_to_bind $ promoteExp exp - let proName = promoteValNameLhsPrefix prefixes name - defuns <- defunctionalize proName (map (const Nothing) all_locals) res_kind + let proName = promoteValNameLhsPrefix prefixes name + m_fixity = Map.lookup name fix_env + defuns <- defunctionalize proName m_fixity (map (const Nothing) all_locals) res_kind return ( ( proName, map DPlainTV all_locals, res_kind , [DTySynEqn (map DVarT all_locals) exp'] ) , defuns @@ -586,10 +591,10 @@ promoteLetDecRHS m_rhs_ki type_env prefixes name (UValue exp) = do names <- replicateM num_arrows (newUniqueName "a") let pats = map DVarPa names newArgs = map DVarE names - promoteLetDecRHS m_rhs_ki type_env prefixes name + promoteLetDecRHS m_rhs_ki type_env fix_env prefixes name (UFunction [DClause pats (foldExp exp newArgs)]) -promoteLetDecRHS m_rhs_ki type_env prefixes name (UFunction clauses) = do +promoteLetDecRHS m_rhs_ki type_env fix_env prefixes name (UFunction clauses) = do numArgs <- count_args clauses (m_argKs, m_resK, ty_num_args) <- case m_rhs_ki of Just (arg_kis, res_ki) -> return (map Just arg_kis, Just res_ki, length arg_kis) @@ -604,9 +609,10 @@ promoteLetDecRHS m_rhs_ki type_env prefixes name (UFunction clauses) = do | otherwise -> return (replicate numArgs Nothing, Nothing, numArgs) - let proName = promoteValNameLhsPrefix prefixes name + let proName = promoteValNameLhsPrefix prefixes name + m_fixity = Map.lookup name fix_env all_locals <- allLocals - defun_decs <- defunctionalize proName + defun_decs <- defunctionalize proName m_fixity (map (const Nothing) all_locals ++ m_argKs) m_resK let local_tvbs = map DPlainTV all_locals tyvarNames <- mapM (const $ qNewName "a") m_argKs @@ -728,7 +734,7 @@ promoteExp (DLamE names exp) = do Nothing) [DTySynEqn (map DVarT (all_locals ++ tyNames)) rhs]] - emitDecsM $ defunctionalize lambdaName (map (const Nothing) all_args) Nothing + emitDecsM $ defunctionalize lambdaName Nothing (map (const Nothing) all_args) Nothing let promLambda = foldl apply (DConT (promoteTySym lambdaName 0)) (map DVarT all_locals) return (promLambda, ADLamE tyNames promLambda names ann_exp) diff --git a/src/Data/Singletons/Promote/Defun.hs b/src/Data/Singletons/Promote/Defun.hs index d511e0e2..539de7f6 100644 --- a/src/Data/Singletons/Promote/Defun.hs +++ b/src/Data/Singletons/Promote/Defun.hs @@ -18,6 +18,7 @@ import Language.Haskell.TH.Syntax import Data.Singletons.Syntax import Data.Singletons.Util import Control.Monad +import Data.Maybe defunInfo :: DInfo -> PrM [DDec] defunInfo (DTyConI dec _instances) = buildDefunSyms dec @@ -55,7 +56,7 @@ buildDefunSyms (DTySynD name tvbs _type) = buildDefunSymsTySynD name tvbs buildDefunSyms (DClassD _cxt name tvbs _fundeps _members) = do let arg_m_kinds = map extractTvbKind tvbs - defunctionalize name arg_m_kinds (Just (DConT constraintName)) + defunReifyFixity name arg_m_kinds (Just (DConT constraintName)) buildDefunSyms _ = fail $ "Defunctionalization symbols can only be built for " ++ "type families and data declarations" @@ -74,12 +75,12 @@ buildDefunSymsTypeFamilyHead buildDefunSymsTypeFamilyHead default_kind (DTypeFamilyHead name tvbs result_sig _) = do let arg_kinds = map (default_kind . extractTvbKind) tvbs res_kind = default_kind (resultSigToMaybeKind result_sig) - defunctionalize name arg_kinds res_kind + defunReifyFixity name arg_kinds res_kind buildDefunSymsTySynD :: Name -> [DTyVarBndr] -> PrM [DDec] buildDefunSymsTySynD name tvbs = do let arg_m_kinds = map extractTvbKind tvbs - defunctionalize name arg_m_kinds Nothing + defunReifyFixity name arg_m_kinds Nothing buildDefunSymsDataD :: [DCon] -> PrM [DDec] buildDefunSymsDataD ctors = @@ -90,7 +91,15 @@ buildDefunSymsDataD ctors = let (name, arg_tys) = extractNameTypes ctor arg_kis <- mapM promoteType arg_tys res_ki <- promoteType res_ty - defunctionalize name (map Just arg_kis) (Just res_ki) + defunReifyFixity name (map Just arg_kis) (Just res_ki) + +-- Generate defunctionalization symbols for a name, using reifyFixityWithLocals +-- to determine what the fixity of each symbol should be. +-- See Note [Fixity declarations for defunctionalization symbols] +defunReifyFixity :: Name -> [Maybe DKind] -> Maybe DKind -> PrM [DDec] +defunReifyFixity name m_arg_kinds m_res_kind = do + m_fixity <- reifyFixityWithLocals name + defunctionalize name m_fixity m_arg_kinds m_res_kind -- Generate data declarations and apply instances -- required for defunctionalization. @@ -125,8 +134,10 @@ buildDefunSymsDataD ctors = -- -- The defunctionalize function takes Maybe DKinds so that the caller can -- indicate which kinds are known and which need to be inferred. -defunctionalize :: Name -> [Maybe DKind] -> Maybe DKind -> PrM [DDec] -defunctionalize name m_arg_kinds' m_res_kind' = do +defunctionalize :: Name + -> Maybe Fixity -- The name's fixity, if one was declared. + -> [Maybe DKind] -> Maybe DKind -> PrM [DDec] +defunctionalize name m_fixity m_arg_kinds' m_res_kind' = do let (m_arg_kinds, m_res_kind) = eta_expand (noExactTyVars m_arg_kinds') (noExactTyVars m_res_kind') num_args = length m_arg_kinds @@ -188,8 +199,12 @@ defunctionalize name m_arg_kinds' m_res_kind' = do mk_rhs' ns = foldType (DConT data_name) (map DVarT ns) + -- See Note [Fixity declarations for defunctionalization symbols] + mk_fix_decl f = DLetDec $ DInfixD f data_name + fixity_decl = maybeToList $ fmap mk_fix_decl m_fixity + decls <- go (n - 1) m_args (buildTyFunArrow_maybe m_arg m_result) mk_rhs' - return $ suppress : data_decl : app_decl : decls + return $ suppress : data_decl : app_decl : fixity_decl ++ decls -- This is a small function with large importance. When generating -- defunctionalization data types, we often need to fill in the blank in the @@ -264,3 +279,25 @@ ravelTyFun kinds = go tailK (buildTyFunArrow k2 k1) where (k1 : k2 : tailK) = reverse kinds go [] acc = acc go (k:ks) acc = go ks (buildTyFunArrow k acc) + +{- +Note [Fixity declarations for defunctionalization symbols] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Just like we promote fixity declarations, we should also generate fixity +declarations for defunctionaliztion symbols. A primary use case is the +following scenario: + + (.) :: (b -> c) -> (a -> b) -> (a -> c) + (f . g) x = f (g x) + infixr 9 . + +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 +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. +-} diff --git a/src/Data/Singletons/Single.hs b/src/Data/Singletons/Single.hs index 625f98ed..ec3f9ee1 100644 --- a/src/Data/Singletons/Single.hs +++ b/src/Data/Singletons/Single.hs @@ -324,7 +324,7 @@ singClassD (ClassDecl { cd_cxt = cls_cxt sing_meths <- mapM (uncurry (singLetDecRHS (Map.fromList tyvar_names) res_ki_map)) (Map.toList default_defns) - fixities' <- traverse (uncurry singInfixDecl) fixities + fixities' <- traverse (uncurry singInfixDecl) $ Map.toList fixities cls_cxt' <- mapM singPred cls_cxt return $ DClassD cls_cxt' (singClassName cls_name) @@ -430,7 +430,7 @@ singLetDecEnv (LetDecEnv { lde_defns = defns let prom_list = Map.toList proms (typeSigs, letBinds, tyvarNames, res_kis) <- unzip4 <$> mapM (uncurry (singTySig defns types bound_kvs)) prom_list - infix_decls' <- traverse (uncurry singInfixDecl) infix_decls + infix_decls' <- traverse (uncurry singInfixDecl) $ Map.toList infix_decls let res_ki_map = Map.fromList [ (name, res_ki) | ((name, _), Just res_ki) <- zip prom_list res_kis ] bindLets letBinds $ do diff --git a/src/Data/Singletons/Single/Fixity.hs b/src/Data/Singletons/Single/Fixity.hs index fe3b4b38..d001c476 100644 --- a/src/Data/Singletons/Single/Fixity.hs +++ b/src/Data/Singletons/Single/Fixity.hs @@ -7,8 +7,8 @@ import Data.Singletons.Util import Data.Singletons.Names import Language.Haskell.TH.Desugar -singInfixDecl :: DsMonad q => Fixity -> Name -> q DLetDec -singInfixDecl fixity name = do +singInfixDecl :: DsMonad q => Name -> Fixity -> q DLetDec +singInfixDecl name fixity = do mb_ns <- reifyNameSpace name pure $ DInfixD fixity $ case mb_ns of @@ -24,7 +24,7 @@ singFixityDeclaration name = do mFixity <- qReifyFixity name case mFixity of Nothing -> pure [] - Just fixity -> sequenceA [DLetDec <$> singInfixDecl fixity name] + Just fixity -> sequenceA [DLetDec <$> singInfixDecl name fixity] singFixityDeclarations :: DsMonad q => [Name] -> q [DDec] singFixityDeclarations = concatMapM trySingFixityDeclaration diff --git a/src/Data/Singletons/Syntax.hs b/src/Data/Singletons/Syntax.hs index 8fa9b311..d66915f2 100644 --- a/src/Data/Singletons/Syntax.hs +++ b/src/Data/Singletons/Syntax.hs @@ -146,7 +146,7 @@ type ULetDecRHS = LetDecRHS Unannotated data LetDecEnv ann = LetDecEnv { lde_defns :: Map Name (LetDecRHS ann) , lde_types :: Map Name DType -- type signatures - , lde_infix :: [(Fixity, Name)] -- infix declarations + , lde_infix :: Map Name Fixity -- infix declarations , lde_proms :: IfAnn ann (Map Name DType) () -- possibly, promotions , lde_bound_kvs :: IfAnn ann (Map Name (Set Name)) () -- The set of bound variables in scope. @@ -161,7 +161,7 @@ instance Semigroup ULetDecEnv where LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) () () instance Monoid ULetDecEnv where - mempty = LetDecEnv Map.empty Map.empty [] () () + mempty = LetDecEnv Map.empty Map.empty Map.empty () () valueBinding :: Name -> ULetDecRHS -> ULetDecEnv valueBinding n v = emptyLetDecEnv { lde_defns = Map.singleton n v } @@ -170,7 +170,7 @@ typeBinding :: Name -> DType -> ULetDecEnv typeBinding n t = emptyLetDecEnv { lde_types = Map.singleton n t } infixDecl :: Fixity -> Name -> ULetDecEnv -infixDecl f n = emptyLetDecEnv { lde_infix = [(f,n)] } +infixDecl f n = emptyLetDecEnv { lde_infix = Map.singleton n f } emptyLetDecEnv :: ULetDecEnv emptyLetDecEnv = mempty diff --git a/tests/SingletonsTestSuite.hs b/tests/SingletonsTestSuite.hs index 1700f665..f7613ccc 100644 --- a/tests/SingletonsTestSuite.hs +++ b/tests/SingletonsTestSuite.hs @@ -93,6 +93,7 @@ tests = , compileAndDumpStdTest "T313" , compileAndDumpStdTest "T316" , compileAndDumpStdTest "T322" + , compileAndDumpStdTest "T323" ], testCompileAndDumpGroup "Promote" [ compileAndDumpStdTest "Constructors" diff --git a/tests/compile-and-dump/Singletons/Classes.ghc84.template b/tests/compile-and-dump/Singletons/Classes.ghc84.template index ad5778f8..34a177b0 100644 --- a/tests/compile-and-dump/Singletons/Classes.ghc84.template +++ b/tests/compile-and-dump/Singletons/Classes.ghc84.template @@ -141,6 +141,7 @@ Singletons/Classes.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply ((<=>@#@$$) l) arg) ((<=>@#@$$$) l arg) => (<=>@#@$$) l l type instance Apply ((<=>@#@$$) l) l = (<=>) l l + infix 4 <=>@#@$$ instance SuppressUnusedWarnings (<=>@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (:<=>@#@$###)) GHC.Tuple.()) @@ -149,6 +150,7 @@ Singletons/Classes.hs:(0,0)-(0,0): Splicing declarations (:<=>@#@$###) :: forall l arg. SameKind (Apply (<=>@#@$) arg) ((<=>@#@$$) arg) => (<=>@#@$) l type instance Apply (<=>@#@$) l = (<=>@#@$$) l + infix 4 <=>@#@$ type family TFHelper_0123456789876543210 (a :: a) (a :: a) :: Ordering where TFHelper_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply MycompareSym0 a_0123456789876543210) a_0123456789876543210 type TFHelper_0123456789876543210Sym2 (t :: a0123456789876543210) (t :: a0123456789876543210) = diff --git a/tests/compile-and-dump/Singletons/Fixity.ghc84.template b/tests/compile-and-dump/Singletons/Fixity.ghc84.template index 51ff7a8d..6582ecb6 100644 --- a/tests/compile-and-dump/Singletons/Fixity.ghc84.template +++ b/tests/compile-and-dump/Singletons/Fixity.ghc84.template @@ -27,6 +27,7 @@ Singletons/Fixity.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply ((====@#@$$) l) arg) ((====@#@$$$) l arg) => (====@#@$$) l l type instance Apply ((====@#@$$) l) l = (====) l l + infix 4 ====@#@$$ instance SuppressUnusedWarnings (====@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (:====@#@$###)) GHC.Tuple.()) @@ -35,6 +36,7 @@ Singletons/Fixity.hs:(0,0)-(0,0): Splicing declarations (:====@#@$###) :: forall l arg. SameKind (Apply (====@#@$) arg) ((====@#@$$) arg) => (====@#@$) l type instance Apply (====@#@$) l = (====@#@$$) l + infix 4 ====@#@$ type family (====) (a :: a) (a :: a) :: a where (====) a _ = a type (<=>@#@$$$) (t :: a0123456789876543210) (t :: a0123456789876543210) = @@ -48,6 +50,7 @@ Singletons/Fixity.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply ((<=>@#@$$) l) arg) ((<=>@#@$$$) l arg) => (<=>@#@$$) l l type instance Apply ((<=>@#@$$) l) l = (<=>) l l + infix 4 <=>@#@$$ instance SuppressUnusedWarnings (<=>@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (:<=>@#@$###)) GHC.Tuple.()) @@ -56,6 +59,7 @@ Singletons/Fixity.hs:(0,0)-(0,0): Splicing declarations (:<=>@#@$###) :: forall l arg. SameKind (Apply (<=>@#@$) arg) ((<=>@#@$$) arg) => (<=>@#@$) l type instance Apply (<=>@#@$) l = (<=>@#@$$) l + infix 4 <=>@#@$ class PMyOrd (a :: GHC.Types.Type) where type (<=>) (arg :: a) (arg :: a) :: Ordering infix 4 %==== diff --git a/tests/compile-and-dump/Singletons/ShowDeriving.ghc84.template b/tests/compile-and-dump/Singletons/ShowDeriving.ghc84.template index 4aa39f13..6d5b665c 100644 --- a/tests/compile-and-dump/Singletons/ShowDeriving.ghc84.template +++ b/tests/compile-and-dump/Singletons/ShowDeriving.ghc84.template @@ -79,6 +79,7 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply (MkFoo2bSym1 l) arg) (MkFoo2bSym2 l arg) => MkFoo2bSym1 l l type instance Apply (MkFoo2bSym1 l) l = MkFoo2b l l + infixl 5 `MkFoo2bSym1` instance SuppressUnusedWarnings MkFoo2bSym0 where suppressUnusedWarnings = snd ((GHC.Tuple.(,) MkFoo2bSym0KindInference) GHC.Tuple.()) @@ -88,6 +89,7 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply MkFoo2bSym0 arg) (MkFoo2bSym1 arg) => MkFoo2bSym0 l type instance Apply MkFoo2bSym0 l = MkFoo2bSym1 l + infixl 5 `MkFoo2bSym0` type (:*:@#@$$$) (t :: a0123456789876543210) (t :: a0123456789876543210) = (:*:) t t instance SuppressUnusedWarnings (:*:@#@$$) where @@ -99,6 +101,7 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply ((:*:@#@$$) l) arg) ((:*:@#@$$$) l arg) => (:*:@#@$$) l l type instance Apply ((:*:@#@$$) l) l = (:*:) l l + infixl 5 :*:@#@$$ instance SuppressUnusedWarnings (:*:@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (::*:@#@$###)) GHC.Tuple.()) @@ -107,6 +110,7 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations (::*:@#@$###) :: forall l arg. SameKind (Apply (:*:@#@$) arg) ((:*:@#@$$) arg) => (:*:@#@$) l type instance Apply (:*:@#@$) l = (:*:@#@$$) l + infixl 5 :*:@#@$ type (:&:@#@$$$) (t :: a0123456789876543210) (t :: a0123456789876543210) = (:&:) t t instance SuppressUnusedWarnings (:&:@#@$$) where @@ -118,6 +122,7 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply ((:&:@#@$$) l) arg) ((:&:@#@$$$) l arg) => (:&:@#@$$) l l type instance Apply ((:&:@#@$$) l) l = (:&:) l l + infixl 5 :&:@#@$$ instance SuppressUnusedWarnings (:&:@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (::&:@#@$###)) GHC.Tuple.()) @@ -126,6 +131,7 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations (::&:@#@$###) :: forall l arg. SameKind (Apply (:&:@#@$) arg) ((:&:@#@$$) arg) => (:&:@#@$) l type instance Apply (:&:@#@$) l = (:&:@#@$$) l + infixl 5 :&:@#@$ type MkFoo3Sym2 (t :: Bool) (t :: Bool) = MkFoo3 t t instance SuppressUnusedWarnings MkFoo3Sym1 where suppressUnusedWarnings @@ -264,9 +270,9 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations type instance Apply ShowsPrec_0123456789876543210Sym0 l = ShowsPrec_0123456789876543210Sym1 l instance PShow Foo3 where type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - infixl 5 :%&: - infixl 5 :%*: infixl 5 `SMkFoo2b` + infixl 5 :%*: + infixl 5 :%&: data instance Sing :: Foo1 -> GHC.Types.Type :: Foo1 -> GHC.Types.Type where SMkFoo1 :: Sing MkFoo1 diff --git a/tests/compile-and-dump/Singletons/StandaloneDeriving.ghc84.template b/tests/compile-and-dump/Singletons/StandaloneDeriving.ghc84.template index a4d5956d..7a4b9f1e 100644 --- a/tests/compile-and-dump/Singletons/StandaloneDeriving.ghc84.template +++ b/tests/compile-and-dump/Singletons/StandaloneDeriving.ghc84.template @@ -36,6 +36,7 @@ Singletons/StandaloneDeriving.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply ((:*:@#@$$) l) arg) ((:*:@#@$$$) l arg) => (:*:@#@$$) l l type instance Apply ((:*:@#@$$) l) l = (:*:) l l + infixl 6 :*:@#@$$ instance SuppressUnusedWarnings (:*:@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (::*:@#@$###)) GHC.Tuple.()) @@ -44,6 +45,7 @@ Singletons/StandaloneDeriving.hs:(0,0)-(0,0): Splicing declarations (::*:@#@$###) :: forall l arg. SameKind (Apply (:*:@#@$) arg) ((:*:@#@$$) arg) => (:*:@#@$) l type instance Apply (:*:@#@$) l = (:*:@#@$$) l + infixl 6 :*:@#@$ type S1Sym0 = S1 type S2Sym0 = S2 type family Compare_0123456789876543210 (a :: T a ()) (a :: T a ()) :: Ordering where diff --git a/tests/compile-and-dump/Singletons/T159.ghc84.template b/tests/compile-and-dump/Singletons/T159.ghc84.template index d597d281..411babb0 100644 --- a/tests/compile-and-dump/Singletons/T159.ghc84.template +++ b/tests/compile-and-dump/Singletons/T159.ghc84.template @@ -52,6 +52,7 @@ Singletons/T159.hs:0:0:: Splicing declarations C1Sym1KindInference :: forall l l arg. SameKind (Apply (C1Sym1 l) arg) (C1Sym2 l arg) => C1Sym1 l l type instance Apply (C1Sym1 l) l = C1 l l + infixr 5 `C1Sym1` instance SuppressUnusedWarnings C1Sym0 where suppressUnusedWarnings = snd ((GHC.Tuple.(,) C1Sym0KindInference) GHC.Tuple.()) @@ -60,6 +61,7 @@ Singletons/T159.hs:0:0:: Splicing declarations C1Sym0KindInference :: forall l arg. SameKind (Apply C1Sym0 arg) (C1Sym1 arg) => C1Sym0 l type instance Apply C1Sym0 l = C1Sym1 l + infixr 5 `C1Sym0` type (:&&@#@$$$) (t :: T0) (t :: T1) = (:&&) t t instance SuppressUnusedWarnings (:&&@#@$$) where suppressUnusedWarnings @@ -70,6 +72,7 @@ Singletons/T159.hs:0:0:: Splicing declarations SameKind (Apply ((:&&@#@$$) l) arg) ((:&&@#@$$$) l arg) => (:&&@#@$$) l l type instance Apply ((:&&@#@$$) l) l = (:&&) l l + infixr 5 :&&@#@$$ instance SuppressUnusedWarnings (:&&@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (::&&@#@$###)) GHC.Tuple.()) @@ -78,6 +81,7 @@ Singletons/T159.hs:0:0:: Splicing declarations (::&&@#@$###) :: forall l arg. SameKind (Apply (:&&@#@$) arg) ((:&&@#@$$) arg) => (:&&@#@$) l type instance Apply (:&&@#@$) l = (:&&@#@$$) l + infixr 5 :&&@#@$ data instance Sing :: T1 -> GHC.Types.Type :: T1 -> GHC.Types.Type where SN1 :: Sing N1 @@ -132,6 +136,7 @@ Singletons/T159.hs:(0,0)-(0,0): Splicing declarations C2Sym1KindInference :: forall l l arg. SameKind (Apply (C2Sym1 l) arg) (C2Sym2 l arg) => C2Sym1 l l type instance Apply (C2Sym1 l) l = C2 l l + infixr 5 `C2Sym1` instance SuppressUnusedWarnings C2Sym0 where suppressUnusedWarnings = snd ((GHC.Tuple.(,) C2Sym0KindInference) GHC.Tuple.()) @@ -140,6 +145,7 @@ Singletons/T159.hs:(0,0)-(0,0): Splicing declarations C2Sym0KindInference :: forall l arg. SameKind (Apply C2Sym0 arg) (C2Sym1 arg) => C2Sym0 l type instance Apply C2Sym0 l = C2Sym1 l + infixr 5 `C2Sym0` type (:||@#@$$$) (t :: T0) (t :: T2) = (:||) t t instance SuppressUnusedWarnings (:||@#@$$) where suppressUnusedWarnings @@ -150,6 +156,7 @@ Singletons/T159.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply ((:||@#@$$) l) arg) ((:||@#@$$$) l arg) => (:||@#@$$) l l type instance Apply ((:||@#@$$) l) l = (:||) l l + infixr 5 :||@#@$$ instance SuppressUnusedWarnings (:||@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (::||@#@$###)) GHC.Tuple.()) @@ -158,8 +165,9 @@ Singletons/T159.hs:(0,0)-(0,0): Splicing declarations (::||@#@$###) :: forall l arg. SameKind (Apply (:||@#@$) arg) ((:||@#@$$) arg) => (:||@#@$) l type instance Apply (:||@#@$) l = (:||@#@$$) l - infixr 5 :%|| + infixr 5 :||@#@$ infixr 5 `SC2` + infixr 5 :%|| data instance Sing :: T2 -> GHC.Types.Type :: T2 -> GHC.Types.Type where SN2 :: Sing N2 diff --git a/tests/compile-and-dump/Singletons/T197.ghc84.template b/tests/compile-and-dump/Singletons/T197.ghc84.template index f895c07c..c40e3ed3 100644 --- a/tests/compile-and-dump/Singletons/T197.ghc84.template +++ b/tests/compile-and-dump/Singletons/T197.ghc84.template @@ -18,6 +18,7 @@ Singletons/T197.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply (($$:@#@$$) l) arg) (($$:@#@$$$) l arg) => ($$:@#@$$) l l type instance Apply (($$:@#@$$) l) l = ($$:) l l + infixl 5 $$:@#@$$ instance SuppressUnusedWarnings ($$:@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (:$$:@#@$###)) GHC.Tuple.()) @@ -26,6 +27,7 @@ Singletons/T197.hs:(0,0)-(0,0): Splicing declarations (:$$:@#@$###) :: forall l arg. SameKind (Apply ($$:@#@$) arg) (($$:@#@$$) arg) => ($$:@#@$) l type instance Apply ($$:@#@$) l = ($$:@#@$$) l + infixl 5 $$:@#@$ type family ($$:) (a :: Bool) (a :: Bool) :: Bool where ($$:) _ _ = FalseSym0 infixl 5 %$$: diff --git a/tests/compile-and-dump/Singletons/T197b.ghc84.template b/tests/compile-and-dump/Singletons/T197b.ghc84.template index 273045b0..4c3f9969 100644 --- a/tests/compile-and-dump/Singletons/T197b.ghc84.template +++ b/tests/compile-and-dump/Singletons/T197b.ghc84.template @@ -39,6 +39,7 @@ Singletons/T197b.hs:(0,0)-(0,0): Splicing declarations SameKind (Apply (MkPairSym1 l) arg) (MkPairSym2 l arg) => MkPairSym1 l l type instance Apply (MkPairSym1 l) l = MkPair l l + infixr 9 `MkPairSym1` instance SuppressUnusedWarnings MkPairSym0 where suppressUnusedWarnings = snd ((GHC.Tuple.(,) MkPairSym0KindInference) GHC.Tuple.()) @@ -47,8 +48,9 @@ Singletons/T197b.hs:(0,0)-(0,0): Splicing declarations MkPairSym0KindInference :: forall l arg. SameKind (Apply MkPairSym0 arg) (MkPairSym1 arg) => MkPairSym0 l type instance Apply MkPairSym0 l = MkPairSym1 l - infixr 9 `SMkPair` + infixr 9 `MkPairSym0` infixr 9 `SPair` + infixr 9 `SMkPair` data instance Sing :: (:*:) a b -> GHC.Types.Type :: (:*:) a b -> GHC.Types.Type where diff --git a/tests/compile-and-dump/Singletons/T322.ghc84.template b/tests/compile-and-dump/Singletons/T322.ghc84.template index 68a3767f..75613687 100644 --- a/tests/compile-and-dump/Singletons/T322.ghc84.template +++ b/tests/compile-and-dump/Singletons/T322.ghc84.template @@ -17,6 +17,7 @@ Singletons/T322.hs:(0,0)-(0,0): Splicing declarations (:!@#@$$###) :: forall l l arg. SameKind (Apply ((!@#@$$) l) arg) ((!@#@$$$) l arg) => (!@#@$$) l l type instance Apply ((!@#@$$) l) l = (:!) l l + infixr 2 !@#@$$ instance SuppressUnusedWarnings (!@#@$) where suppressUnusedWarnings = snd ((GHC.Tuple.(,) (:!@#@$###)) GHC.Tuple.()) @@ -25,6 +26,7 @@ Singletons/T322.hs:(0,0)-(0,0): Splicing declarations (:!@#@$###) :: forall l arg. SameKind (Apply (!@#@$) arg) ((!@#@$$) arg) => (!@#@$) l type instance Apply (!@#@$) l = (!@#@$$) l + infixr 2 !@#@$ type family (:!) (a :: Bool) (a :: Bool) :: Bool where (:!) a_0123456789876543210 a_0123456789876543210 = Apply (Apply (||@#@$) a_0123456789876543210) a_0123456789876543210 infixr 2 :! diff --git a/tests/compile-and-dump/Singletons/T323.ghc84.template b/tests/compile-and-dump/Singletons/T323.ghc84.template new file mode 100644 index 00000000..e69de29b diff --git a/tests/compile-and-dump/Singletons/T323.hs b/tests/compile-and-dump/Singletons/T323.hs new file mode 100644 index 00000000..3e32465e --- /dev/null +++ b/tests/compile-and-dump/Singletons/T323.hs @@ -0,0 +1,7 @@ +module T323 where + +import Data.Singletons.Prelude +import Data.Type.Equality + +test :: f .@#@$$$ (g .@#@$$$ h) :~: f .@#@$$$ g .@#@$$$ h +test = Refl