geniplate 0.4.0.0 → 0.4.0.1
raw patch · 3 files changed
+106/−75 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Data/Generics/Geniplate.hs +87/−73
- examples/Main.hs +18/−1
- geniplate.cabal +1/−1
Data/Generics/Geniplate.hs view
@@ -24,38 +24,44 @@ (ds, f) <- uniBiQ stops from to x <- newName "_x" let e = LamE [VarP x] $ LetE ds $ AppE (AppE f (VarE x)) (ListE [])- qRunIO $ do putStrLn $ pprint e; hFlush stdout+-- qRunIO $ do putStrLn $ pprint e; hFlush stdout return e -type U = StateT (Map Type Dec, Map Type Bool) Q+type U = StateT (Integer, Map Type [Dec], Map Type Bool) Q +newNameU :: String -> U Name+newNameU s = do+ (n, m, c) <- get+ put (n+1, m, c)+ lift $ newName $ s ++ "_" ++ show n+ uniBiQ :: [TypeQ] -> Type -> Type -> Q ([Dec], Exp) uniBiQ stops from ato = do ss <- sequence stops to <- expandSyn ato- (f, (m, _)) <- runStateT (uniBi from to) (mEmpty, mFromList $ zip ss (repeat False))- return (mElems m, f)+ (f, (_, m, _)) <- runStateT (uniBi from to) (0, mEmpty, mFromList $ zip ss (repeat False))+ return (concat $ mElems m, f) uniBi :: Type -> Type -> U Exp uniBi afrom to = do- (m, c) <- get+ (n, m, c) <- get from <- lift $ expandSyn afrom case mLookup from m of- Just (FunD n _) -> return $ VarE n+ Just (FunD n _ : _) -> return $ VarE n _ -> do- f <- lift $ newName "_f"+ f <- newNameU "_f" let mkRec = do- put (mInsert from (FunD f [Clause [] (NormalB $ TupE []) []]) m, c) -- insert something to break recursion, will be replaced below.+ put (n, mInsert from [FunD f [Clause [] (NormalB $ TupE []) []]] m, c) -- insert something to break recursion, will be replaced below. uniBiCase from to cs <- if from == to then do b <- contains' to from if b then do -- Recursive data type, we need the current value and all values inside.- g <- lift $ newName "_g"+ g <- newNameU "_g" gcs <- mkRec- let dg = FunD g gcs+ let dg = [FunD g gcs] -- Insert with a dummy type, just to get the definition in the map for mElems.- modify $ \ (m', c') -> (mInsert (ConT g) dg m', c')+ modify $ \ (n', m', c') -> (n', mInsert (ConT g) dg m', c') lift $ fmap unFunD [d| f _x _r = _x : $(return (VarE g)) _x _r |] else -- Non-recursive type, just use this value.@@ -69,8 +75,8 @@ else -- No occurrences of to inside from, so add nothing. lift $ fmap unFunD [d| f _ _r = _r |]- let d = FunD f cs- modify $ \ (m', c') -> (mInsert from d m', c')+ let d = [FunD f cs]+ modify $ \ (n', m', c') -> (n', mInsert from d m', c') return $ VarE f -- Check if the second type is contained anywhere in the first type.@@ -81,7 +87,7 @@ if from == to then return True else do- c <- gets snd+ c <- gets (\ (_,_,c) -> c) case mLookup from c of Just b -> return b Nothing -> contains' to from@@ -91,7 +97,7 @@ contains' to from = do -- lift $ qRunIO $ print ("contains'", to, from) let (con, ts) = splitTypeApp from- modify $ \ (m, c) -> (m, mInsert from False c) -- To make the fixpoint of the recursion False.+ modify $ \ (n, m, c) -> (n, m, mInsert from False c) -- To make the fixpoint of the recursion False. b <- case con of ConT n -> containsCon n to ts TupleT _ -> fmap or $ mapM (contains to) ts@@ -99,7 +105,7 @@ 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)+ modify $ \ (n, m, c) -> (n, m, mInsert from b c) return b containsCon :: Name -> Type -> [Type] -> U Bool@@ -155,8 +161,8 @@ mkArm :: Type -> Subst -> ([Pat] -> Pat) -> [Type] -> U Clause mkArm to s c ts = do- r <- lift $ newName "_r"- vs <- mapM (const $ lift $ newName "_x") ts+ r <- newNameU "_r"+ vs <- mapM (const $ newNameU "_x") ts let sub v t = do let t' = subst s t uni <- uniBi t' to@@ -246,122 +252,130 @@ -- | Same as 'transformBi', but does not look inside any types mention in the -- list of types. transformBiT :: [TypeQ] -> Name -> Q Exp-transformBiT = transformBiG False (id, AppE)+transformBiT = transformBiG (Nothing, id, AppE, AppE) transformBiM :: Name -> Q Exp transformBiM = transformBiMT [] transformBiMT :: [TypeQ] -> Name -> Q Exp-transformBiMT = transformBiG True (eret, eap)+transformBiMT = transformBiG (Just undefined, eret, eap, emap) where eret e = AppE (VarE 'Control.Monad.return) e eap f a = AppE (AppE (VarE 'Control.Monad.ap) f) a+ emap f a = AppE (AppE (VarE '(Control.Monad.=<<)) f) a -type RetAp = (Exp -> Exp, Exp -> Exp -> Exp)+type RetAp = (Maybe Type, Exp -> Exp, Exp -> Exp -> Exp, Exp -> Exp -> Exp) -transformBiG :: Bool -> RetAp -> [TypeQ] -> Name -> Q Exp-transformBiG monad ra stops name = do+transformBiG :: RetAp -> [TypeQ] -> Name -> Q Exp+transformBiG 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') | 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 $ do putStrLn $ pprint e; hFlush stdout+ (ds, tr, fty, argty) <-+ case (ra, fcn, res) of+ ((Nothing,_,_,_), AppT (AppT ArrowT s) s', AppT (AppT ArrowT t) t') | s == s' && t == t' -> trBiQ ra stops f s t+ ((Just _,ret, apl, rbn), AppT (AppT ArrowT s) (AppT m s'), AppT (AppT ArrowT t) (AppT m' t')) |+ s == s' && t == t' && m == m' -> trBiQ (Just m, ret, apl, rbn) stops f s t+ _ -> genError $ "transformBi: malformed type: " ++ pprint (AppT (AppT ArrowT fcn) res) ++ ", should have form (S->S) -> (T->T)"+ let e = LamE [VarP f {-`SigP` fty-}, VarP x {-`SigP` argty-}] $ LetE ds $ AppE tr (VarE x)+-- qRunIO $ do putStrLn $ pprint e; hFlush stdout return e -trBiQ :: RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)-trBiQ ra stops f aft st = do+trBiQ :: RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp, Type, Type)+trBiQ ra@(mty,_,_,_) stops f aft st = do ss <- sequence stops ft <- expandSyn aft- (tr, (m, _)) <- runStateT (trBi ra (VarE f) ft st) (mEmpty, mFromList $ zip ss (repeat False))- return (mElems m, tr)+ (tr, (_, m, _)) <- runStateT (trBi ra (VarE f) ft st) (0, mEmpty, mFromList $ zip ss (repeat False))+ let fty = ft `arrow` maybe ft (flip AppT ft) mty+ return (concat $ mElems m, tr, fty, st) +arrow :: Type -> Type -> Type+arrow t1 t2 = AppT (AppT ArrowT t1) t2+ trBi :: RetAp -> Exp -> Type -> Type -> U Exp-trBi ra f ft ast = do- (m, c) <- get+trBi ra@(mty, ret, _, rbind) f ft ast = do+ (n, m, c) <- get st <- lift $ expandSyn ast -- lift $ qRunIO $ print (ft, st) case mLookup st m of- Just (FunD n _) -> return $ VarE n+ Just (FunD n _ : _) -> return $ VarE n+ Just (SigD n _ : _) -> return $ VarE n _ -> do- tr <- lift $ newName "_tr"+ tr <- newNameU "_tr" let mkRec = do- put (mInsert st (FunD tr [Clause [] (NormalB $ TupE []) []]) m, c) -- insert something to break recursion, will be replaced below.+ put (n, mInsert st [FunD tr [Clause [] (NormalB $ TupE []) []]] m, c) -- insert something to break recursion, will be replaced below. trBiCase ra f ft st+ trty = st `arrow` (maybe st (flip AppT st) mty) cs <- if ft == st then do b <- contains' ft st if b then do- g <- lift $ newName "_g"+ g <- newNameU "_g" gcs <- mkRec- let dg = FunD g gcs+ let dg = [SigD g trty, FunD g gcs] -- Insert with a dummy type, just to get the definition in the map for mElems.- modify $ \ (m', c') -> (mInsert (ConT g) dg m', c')- lift $ fmap unFunD [d| _f _x = $(return f) ($(return (VarE g))_x) |]- else- lift $ fmap unFunD [d| _f _x = $(return f) _x |]+ modify $ \ (n', m', c') -> (n', mInsert (ConT g) dg m', c')+ x <- newNameU "_x"+ return [Clause [VarP x] (NormalB $ rbind f (AppE (VarE g) (VarE x))) []]+ else do+ x <- newNameU "_x"+ return [Clause [VarP x] (NormalB $ AppE f (VarE x)) []] else do b <- contains ft st -- lift $ qRunIO $ print (b, ft, st) if b then do mkRec- else- lift $ fmap unFunD [d| f _x = _x |]- let d = FunD tr cs- modify $ \ (m', c') -> (mInsert st d m', c')+ else do+ x <- newNameU "_x"+ return [Clause [VarP x] (NormalB $ ret $ VarE x) []]+ let d = [SigD tr trty, FunD tr cs]+ modify $ \ (n', m', c') -> (n', mInsert st d m', c') return $ VarE tr trBiCase :: RetAp -> Exp -> Type -> Type -> U [Clause] trBiCase ra f ft st = do let (con, ts) = splitTypeApp st case con of- ConT n -> trBiCon ra f n ft ts- TupleT _ -> trBiTuple ra f ft ts+ ConT n -> trBiCon ra f n ft st ts+ TupleT _ -> trBiTuple ra f ft st ts -- ArrowT -> lift $ fmap unFunD [d| f _ _r = _r |] -- Stop at functions- ListT -> trBiList ra f ft (head ts)+ ListT -> trBiList ra f ft st (head ts) _ -> genError $ "trBiCase: unexpected type: " ++ pprint st ++ " (" ++ show 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]+trBiList :: RetAp -> Exp -> Type -> Type -> Type -> U [Clause]+trBiList ra f ft st et = do+ nil <- trMkArm ra f ft st [] (const $ ListP []) (ListE []) []+ cons <- trMkArm ra f ft st [] (ConP '(:)) (ConE '(:)) [et, 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 :: RetAp -> Exp -> Type -> [Type] -> U [Clause]-trBiTuple ra f ft ts = do- vs <- mapM (const $ lift $ newName "t") ts+trBiTuple :: RetAp -> Exp -> Type -> Type -> [Type] -> U [Clause]+trBiTuple ra f ft st ts = do+ vs <- mapM (const $ newNameU "_t") ts let tupE = LamE (map VarP vs) $ ListE (map VarE vs)- c <- trMkArm ra f ft [] TupP tupE ts+ c <- trMkArm ra f ft st [] TupP tupE ts return [c] -trBiCon :: RetAp -> Exp -> Name -> Type -> [Type] -> U [Clause]-trBiCon ra f con ft ts = do+trBiCon :: RetAp -> Exp -> Name -> Type -> Type -> [Type] -> U [Clause]+trBiCon ra f con ft st ts = do (tvs, cons) <- lift $ getTyConInfo con 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 ra f ft s c ec $ map snd xs+ arm c ec xs = trMkArm ra f ft st s c ec $ map snd xs mapM genArm cons -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+trMkArm :: RetAp -> Exp -> Type -> Type -> Subst -> ([Pat] -> Pat) -> Exp -> [Type] -> U Clause+trMkArm ra@(mty, ret, apl, _) f ft st s c ec ts = do+ vs <- mapM (const $ newNameU "_x") ts let sub v t = do let t' = subst s t tr <- trBi ra f ft t'- return $ AppE tr (VarE v)+ return $ AppE tr (VarE v {- `SigE` t' -}) {- `SigE` mnd t' -}+ mnd x = maybe x (flip AppT x) mty+ conTy = foldr arrow st (map (subst s) ts) es <- zipWithM sub vs ts- let body = foldl apl (ret ec) es+ let body = foldl apl (ret ec {- `SigE` mnd conTy -}) es return $ Clause [c (map VarP vs)] (NormalB body) []
examples/Main.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} module Main where --import Control.Monad import Data.Generics.Geniplate@@ -42,6 +42,18 @@ trans5 :: (Int -> Maybe Int) -> [Int] -> Maybe [Int] trans5 = $(transformBiM 'trans5) +trans6 :: (Int -> Maybe Int) -> [(Int, Bool)] -> Maybe [(Int, Bool)]+trans6 = $(transformBiM 'trans6)++trans7 :: (Int -> IO Int) -> B Int -> IO (B Int)+trans7 = $(transformBiM 'trans7)++trans8 :: (Bool -> IO Bool) -> B Bool -> IO (B Bool)+trans8 = $(transformBiM 'trans8)++trans9 :: (B Char -> IO (B Char)) -> B Char -> IO (B Char)+trans9 = $(transformBiM 'trans9)+ main :: IO () main = do print $ uni [(Just 12, T 1 2, [1.1]), (Just 345, T 3 4, [2.2]), (Nothing, T 5 6, [3.3])]@@ -58,3 +70,8 @@ print $ uni5 [1,2] print $ trans5 Just [1,2,3] print $ trans5 (\ x -> if x==2 then Nothing else Just x) [1,2,3]+ print $ trans6 Just [(1, True)]+ trans7 (\ x -> do print x; return (x+100)) (tree 3) >>= print+ trans8 (\ x -> do print x; return (not x)) (tree True) >>= print+ trans9 (\ x -> do print x; return x) (tree 'a') >>= print+
geniplate.cabal view
@@ -1,6 +1,6 @@ Name: geniplate Cabal-Version: >= 1.2-Version: 0.4.0.0+Version: 0.4.0.1 License: BSD3 Author: Lennart Augustsson Maintainer: Lennart Augustsson