th-expand-syns 0.3.0.3 → 0.3.0.4
raw patch · 3 files changed
+98/−28 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Language/Haskell/TH/ExpandSyns.hs +77/−18
- testing/Main.hs +20/−9
- th-expand-syns.cabal +1/−1
Language/Haskell/TH/ExpandSyns.hs view
@@ -67,15 +67,37 @@ TyConI d -> decIsSyn d ClassI {} -> return Nothing PrimTyConI {} -> return Nothing+#if MIN_VERSION_template_haskell(2,7,0)+ FamilyI (FamilyD flavour name _ _) _ -> maybeWarnTypeFamily flavour name >> return Nothing+#endif _ -> do - warn ("Don't know how to interpret the result of reify "++show n++" (= "++show i++"). I will assume that "++show n++" is not a type synonym.")+ warn ("Don't know how to interpret the result of reify "++show n++" (= "++show i++").\n"+++ "I will assume that "++show n++" is not a type synonym.") return Nothing warn :: String -> Q ()-warn msg = report False (packagename ++": "++"WARNING: "++msg)+warn msg = +#if MIN_VERSION_template_haskell(2,8,0)+ reportWarning+#else+ report False +#endif+ (packagename ++": "++"WARNING: "++msg) ++#if MIN_VERSION_template_haskell(2,4,0)+maybeWarnTypeFamily :: FamFlavour -> Name -> Q ()+maybeWarnTypeFamily flavour name = + case flavour of+ TypeFam ->+ warn ("Type synonym families (and associated type synonyms) are currently not supported (they won't be expanded). Name of unsupported family: "++show name) ++ DataFam -> return ()+ -- Nothing to expand for data families, so no warning+#endif+ -- | Handles only declaration constructs that can be returned by 'reify'ing a type name. decIsSyn :: Dec -> Q (Maybe SynInfo) decIsSyn (ClassD {}) = return Nothing@@ -83,34 +105,47 @@ decIsSyn (NewtypeD {}) = return Nothing decIsSyn (TySynD _ vars t) = return (Just (tyVarBndrGetName <$> vars,t)) #if MIN_VERSION_template_haskell(2,4,0)-decIsSyn (FamilyD _ name _ _) = do- warn ("Type families (data families, newtype families, associated types and type synonym families) are currently not supported (they won't be expanded). Name of unsupported family: "++show name) - return Nothing- +decIsSyn (FamilyD flavour name _ _) = maybeWarnTypeFamily flavour name >> return Nothing #endif decIsSyn x = do warn ("Unrecognized declaration construct: "++ show x++". I will assume that it's not a type synonym declaration.") return Nothing ++++ -- | Expands all type synonyms in the given type. Type families currently won't be expanded (but will be passed through). expandSyns :: Type -> Q Type-expandSyns = - (\t ->+expandSyns = \t -> do (acc,t') <- go [] t- return (foldl AppT t' acc))+ return (foldl AppT t' acc) where- go acc ListT = return (acc,ListT)- go acc ArrowT = return (acc,ArrowT)- go acc x@(TupleT _) = return (acc, x)- go acc x@(VarT _) = return (acc, x)+ -- Must only be called on an `x' requiring no expansion+ passThrough acc x = return (acc, x)++ -- If @go args t = (args', t')@,+ --+ -- Precondition: + -- All elements of `args' are expanded. + -- Postcondition:+ -- All elements of `args'' and `t'' are expanded.+ -- `t' applied to `args' equals `t'' applied to `args'' (up to expansion, of course)++ go :: [Type] -> Type -> Q ([Type], Type)++ go acc x@ListT = passThrough acc x+ go acc x@ArrowT = passThrough acc x+ go acc x@(TupleT _) = passThrough acc x+ go acc x@(VarT _) = passThrough acc x go [] (ForallT ns cxt t) = do cxt' <- mapM (bindPred expandSyns) cxt t' <- expandSyns t- return ([],ForallT ns cxt' t')+ return ([], ForallT ns cxt' t') go acc x@(ForallT _ _ _) = fail (packagename++": Unexpected application of the local quantification: "@@ -126,10 +161,10 @@ do i <- nameIsSyn n case i of- Nothing -> return (acc,x)+ Nothing -> return (acc, x) Just (vars,body) -> if length acc < length vars- then fail (packagename++": expandSyns: Underapplied type synonym:"++show(n,acc))+ then fail (packagename++": expandSyns: Underapplied type synonym: "++show(n,acc)) else let substs = zip vars acc@@ -142,13 +177,27 @@ go acc (SigT t kind) = do (acc',t') <- go acc t- return (acc',SigT t' kind)+ return + (acc', + SigT t' kind+ -- No expansion needed in kinds (todo: is this correct?)+ ) #endif #if MIN_VERSION_template_haskell(2,6,0)- go acc x@(UnboxedTupleT _) = return (acc, x)+ go acc x@(UnboxedTupleT _) = passThrough acc x #endif +#if MIN_VERSION_template_haskell(2,8,0)+ go acc x@(PromotedT _) = passThrough acc x+ go acc x@(PromotedTupleT _) = passThrough acc x+ go acc x@PromotedConsT = passThrough acc x+ go acc x@PromotedNilT = passThrough acc x+ go acc x@StarT = passThrough acc x+ go acc x@ConstraintT = passThrough acc x+ go acc x@(LitT _) = passThrough acc x+#endif+ class SubstTypeVariable a where -- | Capture-free substitution subst :: (Name, Type) -> a -> a@@ -175,6 +224,16 @@ #if MIN_VERSION_template_haskell(2,6,0) go s@(UnboxedTupleT _) = s+#endif++#if MIN_VERSION_template_haskell(2,8,0)+ go s@(PromotedT _) = s+ go s@(PromotedTupleT _) = s+ go s@PromotedConsT = s+ go s@PromotedNilT = s+ go s@StarT = s+ go s@ConstraintT = s+ go s@(LitT _) = s #endif -- testCapture :: Type
testing/Main.hs view
@@ -12,10 +12,12 @@ -- type A = forall a. B a; type B a = Maybe a; expand [t|B A|] -type A x = [x] -type B f = forall x. f x -type C f = f Integer-+type ListOf x = [x] +type ForAll f = forall x. f x +type ApplyToInteger f = f Integer+type Int' = Int+type Either' = Either+type Int'' = Int $(sequence [tySynD (mkName "E") [PlainTV (mkName "x")] (forallT'' ["y"] (conT ''Either `appT` varT' "x" `appT` varT' "y" --> conT ''Int))@@ -24,22 +26,21 @@ data family DF1 a -data instance DF1 Int = DInt (A ())+data instance DF1 Int = DInt (ListOf ()) type family TF1 a -type instance TF1 Int = A ()+type instance TF1 Int = ListOf () class Class1 a where type AT1 a -instance Class1 Int where type AT1 Int = A ()+instance Class1 Int where type AT1 Int = ListOf () -type Int' = Int main = do putStrLn "Basic test..."- $(mkTest [t| forall a. Show a => a -> B [] -> (Int,C []) |] + $(mkTest [t| forall a. Show a => a -> ForAll [] -> (Int,ApplyToInteger []) |] [t| forall a. Show a => a -> (forall x. [] x) -> (Int,[] Integer) |]) putStrLn "Variable capture avoidance test..."@@ -61,3 +62,13 @@ putStrLn "Testing that the args of type family applications are handled" $(mkTest [t| (DF1 Int', TF1 Int', AT1 Int') |] [t| (DF1 Int, TF1 Int, AT1 Int) |])++ putStrLn "Higher-kinded synonym"+ $(mkTest + [t| Either' (ListOf Int') (ListOf Char) |]+ [t| Either [Int] [Char] |])++ putStrLn "Nested"+ $(mkTest + [t| Int'' |]+ [t| Int |])
th-expand-syns.cabal view
@@ -1,5 +1,5 @@ name: th-expand-syns-version: 0.3.0.3+version: 0.3.0.4 synopsis: Expands type synonyms in Template Haskell ASTs description: Expands type synonyms in Template Haskell ASTs category: Template Haskell