th-expand-syns 0.1.1.0 → 0.2.0.0

raw patch · 3 files changed

+124/−43 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Language/Haskell/TH/ExpandSyns.hs +78/−32
• testing/Main.hs +45/−10
• th-expand-syns.cabal +1/−1

@@ -4,7 +4,7 @@ module Language.Haskell.TH.ExpandSyns(-- * Expand synonyms                                       expandSyns                                       -- * Misc utilities-                                     ,substInType, substInCon+                                     ,SubstTypeVariable(..)                                      ,evades,evade) where      import Language.Haskell.TH hiding(cxt)@@ -16,7 +16,7 @@ packagename = "th-expand-syns"          --- Compatibility layer for TH 2.4 vs. 2.3+-- Compatibility layer for TH >=2.4 vs. 2.3 tyVarBndrGetName :: TyVarBndr -> Name mapPred :: (Type -> Type) -> Pred -> Pred bindPred :: (Type -> Q Type) -> Pred -> Q Pred@@ -45,8 +45,6 @@                         #endif -substInPred :: (Name, Type) -> Pred -> Pred-substInPred s = mapPred (substInType s)   (<$>) :: (Functor f) => (a -> b) -> f a -> f b@@ -60,19 +58,35 @@ nameIsSyn n = do   i <- reify n   case i of-    TyConI d -> return (decIsSyn d)+    TyConI d -> decIsSyn d     ClassI {} -> return Nothing     PrimTyConI {} -> return Nothing-    _ -> fail (packagename ++ ": nameIsSyn: unexpected Info: "++show(n,i))+    _ -> 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.")+            return Nothing+         -decIsSyn :: Dec -> Maybe SynInfo-decIsSyn (ClassD {}) = Nothing-decIsSyn (DataD {}) = Nothing-decIsSyn (NewtypeD {}) = Nothing-decIsSyn (TySynD _ vars t) = Just (tyVarBndrGetName <$> vars,t)-decIsSyn x = error (packagename ++ ": decIsSyn: unexpected Dec: "++show x) --- | Expands type synonyms...+warn ::  String -> Q ()+warn msg = report False (packagename ++": "++"WARNING: "++msg)++-- | Handles only declaration constructs that can be returned by 'reify'ing a type name.+decIsSyn :: Dec -> Q (Maybe SynInfo)+decIsSyn (ClassD {}) = return Nothing+decIsSyn (DataD {}) = return Nothing+decIsSyn (NewtypeD {}) = return Nothing+decIsSyn (TySynD _ vars t) = return (Just (tyVarBndrGetName <$> vars,t))+#if __GLASGOW_HASKELL__ >= 611+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+    +#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 ->@@ -113,7 +127,7 @@                   else                        let                           substs = zip vars acc-                          expanded = foldr substInType body substs+                          expanded = foldr subst body substs                       in                         go (drop (length vars) acc) expanded                         @@ -125,9 +139,14 @@             return (acc',SigT t' kind) #endif --- | Capture-free substitution-substInType :: (Name, Type) -> Type -> Type-substInType (v, t) = go+class SubstTypeVariable a where+    -- | Capture-free substitution+    subst :: (Name, Type) -> a -> a++++instance SubstTypeVariable Type where+  subst (v, t) = go     where       go (AppT x y) = AppT (go x) (go y)       go s@(ConT _) = s@@ -136,7 +155,7 @@       go ArrowT = ArrowT       go ListT = ListT       go (ForallT vars cxt body) = -          commonForallCase (v,t) ForallT substInType (vars,cxt,body)+          commonForallCase (v,t) (vars,cxt,body)                                go s@(TupleT _) = s                         @@ -157,10 +176,24 @@ --                    (v "x" `AppT` v "y"))                          -+#if __GLASGOW_HASKELL__ >= 611+instance SubstTypeVariable Pred where+    subst s = mapPred (subst s)+#endif           -- | Make a name (based on the first arg) that's distinct from every name in the second arg+--+-- Example why this is necessary:+--+-- > type E x = forall y. Either x y+-- >+-- > ... expandSyns [t| forall y. E y |]+--+-- The example as given may actually work correctly without any special capture-avoidance depending+-- on how GHC handles the @y@s, but in any case, the input type to expandSyns may be an explicit+-- AST using 'mkName' to ensure a collision.+-- evade :: Data d => Name -> d -> Name evade n t =      let@@ -186,29 +219,41 @@ --             in --               evade v (AppT (VarT v) (VarT (mkName "fx"))) -substInCon :: (Name, Type) -> Con -> Con-substInCon (v,t) = go+instance SubstTypeVariable Con where+  subst (v,t) = go     where-      st = substInType (v,t)+      st = subst (v,t)        go (NormalC n ts) = NormalC n [(x, st y) | (x,y) <- ts]       go (RecC n ts) = RecC n [(x, y, st z) | (x,y,z) <- ts]       go (InfixC (y1,t1) op (y2,t2)) = InfixC (y1,st t1) op (y2,st t2)       go (ForallC vars cxt body) = -          commonForallCase (v,t) ForallC substInCon (vars,cxt,body)+          commonForallCase (v,t) (vars,cxt,body)   +class HasForallConstruct a where+    mkForall :: [TyVarBndr] -> Cxt -> a -> a +instance HasForallConstruct Type where+    mkForall = ForallT +instance HasForallConstruct Con where+    mkForall = ForallC -commonForallCase :: (Name,Type) -                 -> ([TyVarBndr] -> Cxt -> a -> a) -                 -> ((Name,Type) -> a -> a)+++commonForallCase :: (SubstTypeVariable a, HasForallConstruct a) => ++                    (Name,Type)                   -> ([TyVarBndr],Cxt,a)                  -> a-commonForallCase (v,t) forallCon bodySubst (bndrs,cxt,body)-          | v `elem` (tyVarBndrGetName <$> bndrs) = forallCon bndrs cxt body -- shadowed+commonForallCase vt@(v,t) (bndrs,cxt,body)++            -- If a variable with the same name as the one to be replaced is bound by the forall, +            -- the variable to be replaced is shadowed in the body, so we leave the whole thing alone (no recursion)+          | v `elem` (tyVarBndrGetName <$> bndrs) = mkForall bndrs cxt body +           | otherwise =                let                   -- prevent capture@@ -216,10 +261,11 @@                   freshes = evades vars t                   freshTyVarBndrs = zipWith tyVarBndrSetName freshes bndrs                   substs = zip vars (VarT <$> freshes)-                  doSubsts f x = foldr f x substs+                  doSubsts :: SubstTypeVariable b => b -> b+                  doSubsts x = foldr subst x substs                                               in-                forallCon +                mkForall                    freshTyVarBndrs-                  (fmap (substInPred (v,t) . doSubsts substInPred) cxt ) -                  (     (  bodySubst (v,t) . doSubsts bodySubst  ) body)+                  (fmap (subst vt . doSubsts) cxt ) +                  (     (subst vt . doSubsts) body)

@@ -1,11 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+-- {-# OPTIONS -ddump-splices #-} module Main where  import Language.Haskell.TH.ExpandSyns import Language.Haskell.TH import Language.Haskell.TH.Syntax+import Util      -- type A = forall a. B a; type B a = Maybe a; expand [t|B A|] @@ -14,15 +17,47 @@ type C f = f Integer  -test1 = $(-    do-      t1 <-       [t| forall a. Show a => a -> B []            -> (Int,C []) |]-      expected <- [t| forall a. Show a => a -> (forall x. [] x) -> (Int,[] Integer) |]-      report False ("expected: "++pprint expected)-      actual <- expandSyns t1-      report False ("actual: "++pprint actual)-      if (pprint expected==pprint actual) then [| putStrLn "Ok" |] else [| error "expected /= actual" |] +$(sequence [tySynD (mkName "E") [PlainTV (mkName "x")]  +                (forallT'' ["y"] (conT ''Either `appT` varT' "x" `appT` varT' "y" --> conT ''Int))+           ]) - ) -main = test1+data family DF1 a++data instance DF1 Int = DInt (A ())++type family TF1 a++type instance TF1 Int = A ()++class Class1 a where+    type AT1 a++instance Class1 Int where type AT1 Int = A ()++type Int' = Int++main = do+    putStrLn "Basic test..."+    $(mkTest  [t| forall a. Show a => a -> B []             -> (Int,C []) |] +              [t| forall a. Show a => a -> (forall x. [] x) -> (Int,[] Integer) |])++    putStrLn "Variable capture avoidance test..."+    $(let+        expectedExpansion =+         forallT'' ["y_0"] (conT ''Either `appT` varT' "y" `appT` varT' "y_0" --> conT ''Int)+         -- the naive (and wrong) result would be:+         --   forall y. (forall y. Either y y -> Int)+      in+        mkTest  (forallT'' ["y"] (conT' "E" `appT` varT' "y")) +                (forallT'' ["y"] expectedExpansion))++    putStrLn "Testing that it doesn't crash on type families (expanding them is not supported yet)"+    $(let+        t = [t| (DF1 Int, TF1 Int, AT1 Int) |]+      in+        mkTest t t)+             +    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) |])

@@ -1,5 +1,5 @@ name:                th-expand-syns-version:             0.1.1.0+version:             0.2.0.0 synopsis:            Expands type synonyms in Template Haskell ASTs description:         Expands type synonyms in Template Haskell ASTs category:            Template Haskell