geniplate 0.3.0.0 → 0.4.0.0

raw patch · 3 files changed

+65/−33 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Generics/Geniplate.hs +59/−32
• examples/Main.hs +5/−0
• geniplate.cabal +1/−1

@@ -1,10 +1,12 @@ {-# LANGUAGE TemplateHaskell #-}-module Data.Generics.Geniplate(universeBi, universeBiT, transformBi, transformBiT) where+module Data.Generics.Geniplate(universeBi, universeBiT, transformBi, transformBiT, transformBiM, transformBiMT) where+import Control.Monad import Control.Exception(assert) import Control.Monad.State.Strict import Data.Maybe import Language.Haskell.TH import Language.Haskell.TH.Syntax hiding (lift)+import System.IO  -- | Generate TH code for a function that extracts all subparts of a certain type. -- The argument to 'universeBi' is a name with the type @S -> [T]@, for some types@@ -22,7 +24,7 @@     (ds, f) <- uniBiQ stops from to     x <- newName "_x"     let e = LamE [VarP x] $ LetE ds $ AppE (AppE f (VarE x)) (ListE [])---    qRunIO $ putStrLn $ pprint e+    qRunIO $ do putStrLn $ pprint e; hFlush stdout     return e  type U = StateT (Map Type Dec, Map Type Bool) Q@@ -95,6 +97,7 @@          TupleT _  -> fmap or $ mapM (contains to) ts          ArrowT    -> return False          ListT     -> contains to (head ts)+         VarT _    -> return False          t         -> genError $ "contains: unexpected type: " ++ pprint from ++ " (" ++ show t ++ ")"     modify $ \ (m, c) -> (m, mInsert from b c)     return b@@ -184,6 +187,7 @@     info <- qReify con     case info of         TyConI (DataD _ _ tvs cs _) -> return (tvs, cs)+        TyConI (NewtypeD _ _ tvs c _) -> return (tvs, [c])         PrimTyConI{} -> return ([], [])         i -> genError $ "unexpected TyCon: " ++ show i @@ -242,27 +246,41 @@ -- | Same as 'transformBi', but does not look inside any types mention in the -- list of types. transformBiT :: [TypeQ] -> Name -> Q Exp-transformBiT stops name = do+transformBiT = transformBiG False (id, AppE)++transformBiM :: Name -> Q Exp+transformBiM = transformBiMT []++transformBiMT :: [TypeQ] -> Name -> Q Exp+transformBiMT = transformBiG True (eret, eap)+  where eret e = AppE (VarE 'Control.Monad.return) e+        eap f a = AppE (AppE (VarE 'Control.Monad.ap) f) a++type RetAp = (Exp -> Exp, Exp -> Exp -> Exp)++transformBiG :: Bool -> RetAp -> [TypeQ] -> Name -> Q Exp+transformBiG monad ra stops name = do     (_tvs, fcn, res) <- getNameType name     f <- newName "_f"     (ds, tr) <-         case (fcn, res) of-            (AppT (AppT ArrowT s) s', AppT (AppT ArrowT t) t') | s == s' && t == t' -> trBiQ stops f s t+            (AppT (AppT ArrowT s) s', AppT (AppT ArrowT t) t') | not monad && s == s' && t == t' -> trBiQ ra stops f s t+            (AppT (AppT ArrowT s) (AppT m s'), AppT (AppT ArrowT t) (AppT m' t')) | monad && s == s' && t == t' && m == m' -> trBiQ ra stops f s t             _ -> genError $ "transformBi: malformed type: " ++ pprint (AppT (AppT ArrowT fcn) res) ++ ", should have form (S->S) -> (T->T)"     x <- newName "_x"     let e = LamE [VarP f, VarP x] $ LetE ds $ AppE tr (VarE x)---    qRunIO $ putStrLn $ pprint e+    qRunIO $ do putStrLn $ pprint e; hFlush stdout     return e -trBiQ :: [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)-trBiQ stops f aft st = do+trBiQ :: RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)+trBiQ ra stops f aft st = do     ss <- sequence stops     ft <- expandSyn aft-    (tr, (m, _)) <- runStateT (trBi (VarE f) ft st) (mEmpty, mFromList $ zip ss (repeat False))+    (tr, (m, _)) <- runStateT (trBi ra (VarE f) ft st) (mEmpty, mFromList $ zip ss (repeat False))     return (mElems m, tr) -trBi :: Exp -> Type -> Type -> U Exp-trBi f ft ast = do+trBi :: RetAp -> Exp -> Type -> Type -> U Exp+trBi ra f ft ast = do     (m, c) <- get     st <- lift $ expandSyn ast --    lift $ qRunIO $ print (ft, st)@@ -272,7 +290,7 @@             tr <- lift $ newName "_tr"             let mkRec = do                     put (mInsert st (FunD tr [Clause [] (NormalB $ TupE []) []]) m, c)  -- insert something to break recursion, will be replaced below.-                    trBiCase f ft st+                    trBiCase ra f ft st              cs <- if ft == st then do                       b <- contains' ft st@@ -296,45 +314,54 @@             modify $ \ (m', c') -> (mInsert st d m', c')             return $ VarE tr -trBiCase :: Exp -> Type -> Type -> U [Clause]-trBiCase f ft st = do+trBiCase :: RetAp -> Exp -> Type -> Type -> U [Clause]+trBiCase ra f ft st = do     let (con, ts) = splitTypeApp st     case con of-        ConT n    -> trBiCon f n ft ts-        TupleT _  -> trBiTuple f ft ts+        ConT n    -> trBiCon ra f n ft ts+        TupleT _  -> trBiTuple ra f ft ts --        ArrowT    -> lift $ fmap unFunD [d| f _ _r = _r |]           -- Stop at functions-        ListT     -> trBiList f ft (head ts)+        ListT     -> trBiList ra f ft (head ts)         _         -> genError $ "trBiCase: unexpected type: " ++ pprint st ++ " (" ++ show st ++ ")" -trBiList :: Exp -> Type -> Type -> U [Clause]-trBiList f ft st = do-    tr <- trBi f ft st-    rec <- trBi f ft (AppT ListT st)+trBiList :: RetAp -> Exp -> Type -> Type -> U [Clause]+trBiList ra f ft st = do+    nil <- trMkArm ra f ft [] (const $ ListP []) (ListE []) []+    cons <- trMkArm ra f ft [] (ConP '(:)) (ConE '(:)) [st, AppT ListT st]+    return [nil, cons]+{-+    tr <- trBi ra f ft st+    rec <- trBi ra f ft (AppT ListT st)     lift $ fmap unFunD [d| _f [] = []; _f (_x:_xs) = ($(return tr) _x) : ($(return rec) _xs) |]+-} -trBiTuple :: Exp -> Type -> [Type] -> U [Clause]-trBiTuple f ft ts = fmap (:[]) $ trMkArm f ft [] TupP TupE ts+trBiTuple :: RetAp -> Exp -> Type -> [Type] -> U [Clause]+trBiTuple ra f ft ts = do+    vs <- mapM (const $ lift $ newName "t") ts+    let tupE = LamE (map VarP vs) $ ListE (map VarE vs)+    c <- trMkArm ra f ft [] TupP tupE ts+    return [c] -trBiCon :: Exp -> Name -> Type -> [Type] -> U [Clause]-trBiCon f con ft ts = do+trBiCon :: RetAp -> Exp -> Name -> Type -> [Type] -> U [Clause]+trBiCon ra f con ft ts = do     (tvs, cons) <- lift $ getTyConInfo con-    let genArm (NormalC c xs) = arm (ConP c) (foldl AppE $ ConE c) xs-        genArm (InfixC x1 c x2) = arm (\ [p1, p2] -> InfixP p1 c p2) (\ [e1, e2] -> InfixE (Just e1) (ConE c) (Just e2)) [x1, x2]-        genArm (RecC c xs) = arm (ConP c) (foldl AppE $ ConE c) [ (b,t) | (_,b,t) <- xs ]+    let genArm (NormalC c xs) = arm (ConP c) (ConE c) xs+        genArm (InfixC x1 c x2) = arm (\ [p1, p2] -> InfixP p1 c p2) (ConE c) [x1, x2]+        genArm (RecC c xs) = arm (ConP c) (ConE c) [ (b,t) | (_,b,t) <- xs ]         genArm c = genError $ "trBiCon: " ++ show c         s = mkSubst tvs ts-        arm c ec xs = trMkArm f ft s c ec $ map snd xs+        arm c ec xs = trMkArm ra f ft s c ec $ map snd xs     mapM genArm cons -trMkArm :: Exp -> Type -> Subst -> ([Pat] -> Pat) -> ([Exp] -> Exp) -> [Type] -> U Clause-trMkArm f ft s c ec ts = do+trMkArm :: RetAp -> Exp -> Type -> Subst -> ([Pat] -> Pat) -> Exp -> [Type] -> U Clause+trMkArm ra@(ret, apl) f ft s c ec ts = do     vs <- mapM (const $ lift $ newName "_x") ts     let sub v t = do             let t' = subst s t-            tr <- trBi f ft t'+            tr <- trBi ra f ft t'             return $ AppE tr (VarE v)     es <- zipWithM sub vs ts-    let body = ec es+    let body = foldl apl (ret ec) es     return $ Clause [c (map VarP vs)] (NormalB body) []  

@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} module Main where+--import Control.Monad import Data.Generics.Geniplate  data T a = T { x :: Int, y :: a } deriving (Show)@@ -38,6 +39,8 @@ trans4 :: (B Char -> B Char) -> B Char -> B Char trans4 = $(transformBi 'trans4) +trans5 :: (Int -> Maybe Int) -> [Int] -> Maybe [Int]+trans5 = $(transformBiM 'trans5)  main :: IO () main = do@@ -53,3 +56,5 @@         f (Bin t1 x b t2) = Bin t1 x (not b) t2     print $ trans4 f $ tree 'a'     print $ uni5 [1,2]+    print $ trans5 Just [1,2,3]+    print $ trans5 (\ x -> if x==2 then Nothing else Just x) [1,2,3]

@@ -1,6 +1,6 @@ Name:           geniplate Cabal-Version:  >= 1.2-Version:        0.3.0.0+Version:        0.4.0.0 License:        BSD3 Author:         Lennart Augustsson Maintainer:     Lennart Augustsson