geniplate 0.4.0.1 → 0.5.0.0

raw patch · 3 files changed

+167/−125 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Generics/Geniplate.hs +131/−63
• examples/Main.hs +35/−61
• geniplate.cabal +1/−1

@@ -1,5 +1,12 @@-{-# LANGUAGE TemplateHaskell #-}-module Data.Generics.Geniplate(universeBi, universeBiT, transformBi, transformBiT, transformBiM, transformBiMT) where+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances #-}+module Data.Generics.Geniplate(+    genUniverseBi, genUniverseBiT,+    genTransformBi, genTransformBiT,+    genTransformBiM, genTransformBiMT,+    UniverseBi(..), universe, instanceUniverseBi, instanceUniverseBiT,+    TransformBi(..), transform, instanceTransformBi, instanceTransformBiT,+    TransformBiM(..), transformM, instanceTransformBiM, instanceTransformBiMT,+    ) where import Control.Monad import Control.Exception(assert) import Control.Monad.State.Strict@@ -8,16 +15,78 @@ import Language.Haskell.TH.Syntax hiding (lift) import System.IO +class UniverseBi s t where+    universeBi :: s -> [t]++class TransformBi s t where+    transformBi :: (s -> s) -> t -> t++class {-(Monad m) => -} TransformBiM m s t where+    transformBiM :: (s -> m s) -> t -> m t++universe :: (UniverseBi a a) => a -> [a]+universe = universeBi++transform :: (TransformBi a a) => (a -> a) -> a -> a+transform = transformBi++transformM :: (TransformBiM m a a) => (a -> m a) -> a -> m a+transformM = transformBiM+++instanceUniverseBi :: TypeQ -> TypeQ -> Q [Dec]+instanceUniverseBi = instanceUniverseBiT []++instanceUniverseBiT :: [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]+instanceUniverseBiT stops fromq toq = do+    from <- fromq+    to <- toq+    (ds, f) <- uniBiQ stops from to+    x <- newName "_x"+    let e = LamE [VarP x] $ LetE ds $ AppE (AppE f (VarE x)) (ListE [])+    [d|instance UniverseBi $fromq $toq where universeBi = $(return e) |]++instanceTransformBi :: TypeQ -> TypeQ -> Q [Dec]+instanceTransformBi = instanceTransformBiT []++instanceTransformBiT :: [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]+instanceTransformBiT stops ftq stq = do+    ft <- ftq+    st <- stq++    f <- newName "_f"+    x <- newName "_x"+    (ds, tr) <- trBiQ raNormal stops f ft st+    let e = LamE [VarP f, VarP x] $ LetE ds $ AppE tr (VarE x)++    [d|instance TransformBi $ftq $stq where transformBi = $(return e) |]++instanceTransformBiM :: TypeQ -> TypeQ -> TypeQ -> Q [Dec]+instanceTransformBiM = instanceTransformBiMT []++instanceTransformBiMT :: [TypeQ] -> TypeQ -> TypeQ -> TypeQ -> Q [Dec]+instanceTransformBiMT stops mndq ftq stq = do+    ft <- ftq+    st <- stq++    f <- newName "_f"+    x <- newName "_x"+    (ds, tr) <- trBiQ raMonad stops f ft st+    let e = LamE [VarP f, VarP x] $ LetE ds $ AppE tr (VarE x)++    [d|instance TransformBiM $mndq $ftq $stq where transformBiM = $(return e) |]++ -- | 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+-- The argument to 'genUniverseBi' is a name with the type @S -> [T]@, for some types -- @S@ and @T@.  The function will extract all subparts of type @T@ from @S@.-universeBi :: Name -> Q Exp-universeBi = universeBiT []+genUniverseBi :: Name -> Q Exp+genUniverseBi = genUniverseBiT [] --- | Same as 'universeBi', but does not look inside any types mention in the+-- | Same as 'genUniverseBi', but does not look inside any types mention in the -- list of types.-universeBiT :: [TypeQ] -> Name -> Q Exp-universeBiT stops name = do+genUniverseBiT :: [TypeQ] -> Name -> Q Exp+genUniverseBiT stops name = do     (_tvs, from, tos) <- getNameType name     let to = unList tos --    qRunIO $ print (from, to)@@ -27,31 +96,28 @@ --    qRunIO $ do putStrLn $ pprint e; hFlush stdout     return e -type U = StateT (Integer, Map Type [Dec], Map Type Bool) Q+type U = StateT (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+newNameU s = lift $ newName s  uniBiQ :: [TypeQ] -> Type -> Type -> Q ([Dec], Exp) uniBiQ stops from ato = do     ss <- sequence stops     to <- expandSyn ato-    (f, (_, m, _)) <- runStateT (uniBi from to) (0, mEmpty, mFromList $ zip ss (repeat False))-    return (concat $ mElems m, f)+    (f, (m, _)) <- runStateT (uniBi from to) (mEmpty, mFromList $ zip ss (repeat False))+    return (mElems m, f)  uniBi :: Type -> Type -> U Exp uniBi afrom to = do-    (n, m, c) <- get+    (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 <- newNameU "_f"             let mkRec = do-                    put (n, mInsert from [FunD f [Clause [] (NormalB $ TupE []) []]] m, c)   -- insert something to break recursion, will be replaced below.+                    put (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@@ -59,9 +125,9 @@                           -- Recursive data type, we need the current value and all values inside.                           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 $ \ (n', m', c') -> (n', mInsert (ConT g) dg m', c')+                          modify $ \ (m', c') -> (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.@@ -75,8 +141,8 @@                        else                           -- No occurrences of to inside from, so add nothing.                           lift $ fmap unFunD [d| f _ _r = _r |]-            let d = [FunD f cs]-            modify $ \ (n', m', c') -> (n', mInsert from d m', c')+            let d = FunD f cs+            modify $ \ (m', c') -> (mInsert from d m', c')             return $ VarE f  -- Check if the second type is contained anywhere in the first type.@@ -87,7 +153,7 @@     if from == to then         return True      else do-        c <- gets (\ (_,_,c) -> c)+        c <- gets snd         case mLookup from c of             Just b  -> return b             Nothing -> contains' to from@@ -97,15 +163,15 @@ contains' to from = do --    lift $ qRunIO $ print ("contains'", to, from)     let (con, ts) = splitTypeApp from-    modify $ \ (n, m, c) -> (n, m, mInsert from False c)        -- To make the fixpoint of the recursion False.+    modify $ \ (m, c) -> (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          ArrowT    -> return False-         ListT     -> contains to (head ts)+         ListT     -> if to == from then return True else contains to (head ts)          VarT _    -> return False          t         -> genError $ "contains: unexpected type: " ++ pprint from ++ " (" ++ show t ++ ")"-    modify $ \ (n, m, c) -> (n, m, mInsert from b c)+    modify $ \ (m, c) -> (m, mInsert from b c)     return b  containsCon :: Name -> Type -> [Type] -> U Bool@@ -225,6 +291,7 @@  expandSynApp :: Type -> [Type] -> Q Type expandSynApp (AppT t1 t2) ts = do t2' <- expandSyn t2; expandSynApp t1 (t2':ts)+expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl AppT ListT ts expandSynApp t@(ConT n) ts = do     info <- qReify n     case info of@@ -244,76 +311,78 @@  -- Exp has type (S -> S) -> T -> T, for some S and T -- | Generate TH code for a function that transforms all subparts of a certain type.--- The argument to 'transformBi' is a name with the type @(S->S) -> T -> T@, for some types+-- The argument to 'genTransformBi' is a name with the type @(S->S) -> T -> T@, for some types -- @S@ and @T@.  The function will transform all subparts of type @S@ inside @T@ using the given function.-transformBi :: Name -> Q Exp-transformBi = transformBiT []+genTransformBi :: Name -> Q Exp+genTransformBi = genTransformBiT [] --- | Same as 'transformBi', but does not look inside any types mention in the+-- | Same as 'genTransformBi', but does not look inside any types mention in the -- list of types.-transformBiT :: [TypeQ] -> Name -> Q Exp-transformBiT = transformBiG (Nothing, id, AppE, AppE)+genTransformBiT :: [TypeQ] -> Name -> Q Exp+genTransformBiT = transformBiG raNormal -transformBiM :: Name -> Q Exp-transformBiM = transformBiMT []+raNormal :: RetAp+raNormal = (id, AppE, AppE) -transformBiMT :: [TypeQ] -> Name -> Q Exp-transformBiMT = transformBiG (Just undefined, eret, eap, emap)+genTransformBiM :: Name -> Q Exp+genTransformBiM = genTransformBiMT []++genTransformBiMT :: [TypeQ] -> Name -> Q Exp+genTransformBiMT = transformBiG raMonad++raMonad :: RetAp+raMonad = (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 = (Maybe Type, Exp -> Exp, Exp -> Exp -> Exp, Exp -> Exp -> Exp)+type RetAp = (Exp -> Exp, Exp -> Exp -> Exp, Exp -> Exp -> Exp)  transformBiG :: RetAp -> [TypeQ] -> Name -> Q Exp transformBiG ra stops name = do     (_tvs, fcn, res) <- getNameType name     f <- newName "_f"     x <- newName "_x"-    (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+    (ds, tr) <-+        case (fcn, res) of+            (AppT (AppT ArrowT s) s',          AppT (AppT ArrowT t) t')           | s == s' && t == t'            -> trBiQ ra stops f s t+            (AppT (AppT ArrowT s) (AppT m s'), AppT (AppT ArrowT t) (AppT m' t')) | 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)"-    let e = LamE [VarP f {-`SigP` fty-}, VarP x {-`SigP` argty-}] $ LetE ds $ AppE tr (VarE x)+    let e = LamE [VarP f, VarP x] $ LetE ds $ AppE tr (VarE x) --    qRunIO $ do putStrLn $ pprint e; hFlush stdout     return e -trBiQ :: RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp, Type, Type)-trBiQ ra@(mty,_,_,_) 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 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)+    (tr, (m, _)) <- runStateT (trBi ra (VarE f) ft st) (mEmpty, mFromList $ zip ss (repeat False))+    return (mElems m, tr)  arrow :: Type -> Type -> Type arrow t1 t2 = AppT (AppT ArrowT t1) t2  trBi :: RetAp -> Exp -> Type -> Type -> U Exp-trBi ra@(mty, ret, _, rbind) f ft ast = do-    (n, m, c) <- get+trBi ra@(ret, _, rbind) f ft ast = do+    (m, c) <- get     st <- lift $ expandSyn ast --    lift $ qRunIO $ print (ft, st)     case mLookup st m of-        Just (FunD n _ : _) -> return $ VarE n-        Just (SigD n _ : _) -> return $ VarE n+        Just (FunD n _) -> return $ VarE n         _ -> do             tr <- newNameU "_tr"             let mkRec = do-                    put (n, mInsert st [FunD tr [Clause [] (NormalB $ TupE []) []]] m, c)  -- insert something to break recursion, will be replaced below.+                    put (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 <- newNameU "_g"                           gcs <- mkRec-                          let dg = [SigD g trty, FunD g gcs]+                          let dg = FunD g gcs                           -- Insert with a dummy type, just to get the definition in the map for mElems.-                          modify $ \ (n', m', c') -> (n', mInsert (ConT g) dg m', c')+                          modify $ \ (m', c') -> (mInsert (ConT g) dg m', c')                           x <- newNameU "_x"                           return [Clause [VarP x] (NormalB $ rbind f (AppE (VarE g) (VarE x))) []]                        else do@@ -327,8 +396,8 @@                        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')+            let d = FunD tr cs+            modify $ \ (m', c') -> (mInsert st d m', c')             return $ VarE tr  trBiCase :: RetAp -> Exp -> Type -> Type -> U [Clause]@@ -350,7 +419,7 @@ 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)+    let tupE = LamE (map VarP vs) $ TupE (map VarE vs)     c <- trMkArm ra f ft st [] TupP tupE ts     return [c] @@ -366,16 +435,15 @@     mapM genArm cons  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+trMkArm ra@(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 {- `SigE` t' -}) {- `SigE` mnd t' -}-        mnd x = maybe x (flip AppT x) mty+            return $ AppE tr (VarE v)         conTy = foldr arrow st (map (subst s) ts)     es <- zipWithM sub vs ts-    let body = foldl apl (ret ec {- `SigE` mnd conTy -}) es+    let body = foldl apl (ret ec) es     return $ Clause [c (map VarP vs)] (NormalB body) []  

@@ -1,6 +1,5 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses #-} module Main where---import Control.Monad import Data.Generics.Geniplate  data T a = T { x :: Int, y :: a } deriving (Show)@@ -9,69 +8,44 @@  tree x = Bin (Bin (MT True) x True (MT False)) x False (MT True) -uni :: [(Maybe Int, T Int, [Double])] -> [Int]-uni = $(universeBi 'uni)--uniT :: [(Maybe Int, T Int, [Double])] -> [Int]-uniT = $(universeBiT [ [t|Maybe Int|] ] 'uniT)--uni2 :: [B Bool] -> [Int]-uni2 = $(universeBi 'uni2)--uni3 :: [B Bool] -> [Bool]-uni3 = $(universeBi 'uni3)--uni4 :: B Char -> [B Char]-uni4 = $(universeBi 'uni4)--uni5 :: [Int] -> [[Int]]-uni5 = $(universeBi 'uni5)--trans :: (Int -> Int) -> [(Bool,T String)] -> [(Bool,T String)]-trans = $(transformBi 'trans)--trans1 :: (Bool -> Bool) -> B Char -> B Char-trans1 = $(transformBi 'trans1)--trans2 :: (Bool -> Bool) -> B Bool -> B Bool-trans2 = $(transformBi 'trans2)--trans4 :: (B Char -> B Char) -> B Char -> B Char-trans4 = $(transformBi 'trans4)--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)+instanceUniverseBi [t| [(Maybe Int, T Int, [Double])] |] [t| Int |]+instanceUniverseBiT [ [t|Maybe Int|] ] [t| [(Maybe Int, T Int, [Float])] |] [t| Int |]+instanceUniverseBi [t| [B Bool] |] [t| Int |]+instanceUniverseBi [t| [B Bool] |] [t| Bool |]+instanceUniverseBi [t| B Char |] [t| B Char |]+instanceUniverseBi [t| [Int] |] [t| [Int] |] -trans8 :: (Bool -> IO Bool) -> B Bool -> IO (B Bool)-trans8 = $(transformBiM 'trans8)+instanceTransformBi [t| Int |] [t| [(Bool,T String)] |]+instanceTransformBi [t| Bool |] [t| B Char |]+instanceTransformBi [t| Bool |] [t| B Bool |]+instanceTransformBi [t| B Char |] [t| B Char |] -trans9 :: (B Char -> IO (B Char)) -> B Char -> IO (B Char)-trans9 = $(transformBiM 'trans9)+instanceTransformBiM [t| Maybe |] [t| Int |] [t| [Int] |]+instanceTransformBiM [t| Maybe |] [t| Int |] [t| [(Int,Bool)] |]+instanceTransformBiM [t| IO |] [t| Int |] [t| B Int |]+instanceTransformBiM [t| IO |] [t| Bool |] [t| B Bool |]+instanceTransformBiM [t| IO |] [t| B Char |] [t| B Char |]  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])]-    print $ uniT [(Just 12, T 1 2, [1.1]), (Just 345, T 3 4, [2.2]), (Nothing, T 5 6, [3.3])]-    print $ uni2 $ [tree True, tree False]-    print $ uni3 $ [tree True, tree False]-    print $ trans (+1) [(True,T 1 "a"), (False,T 2 "b")]-    print $ trans1 not $ tree 'a'-    print $ trans2 not $ tree True-    print $ uni4 $ tree 'a'-    let f (MT b) = MT (not b)+    print (universeBi [(Just (12::Int), T 1 (2::Int), [1.1::Double]), (Just 345, T 3 4, [2.2]), (Nothing, T 5 6, [3.3])] :: [Int])+    print (universeBi [(Just (12::Int), T 1 (2::Int), [1.1::Float]),  (Just 345, T 3 4, [2.2]), (Nothing, T 5 6, [3.3])] :: [Int])+    print (universeBi [tree True, tree False] :: [Int])+    print (universeBi [tree True, tree False] :: [Bool])+    print (universeBi (tree 'a') :: [B Char])+    print (universeBi [1,2::Int] :: [[Int]])++    print $ transformBi ((+1) :: Int->Int) [(True,T 1 "a"), (False,T 2 "b")]+    print $ transformBi not $ tree 'a'+    print $ transformBi not $ tree True+    let f (MT b) = MT b         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]-    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+    print $ transformBi (f :: B Char -> B Char) $ tree 'a'++    print $ transformBiM (Just :: Int -> Maybe Int) [1::Int,2,3]+    print $ transformBiM (\ x -> if x==(2::Int) then Nothing else Just x) [1::Int,2,3]+    print $ transformBiM (Just :: Int -> Maybe Int) [(1::Int, True)]+    transformBiM (\ x -> do print (x::Int); return (x+100::Int)) (tree (3::Int)) >>= print+    transformBiM (\ x -> do print (x::Bool); return (not x)) (tree True) >>= print+    transformBiM (\ x -> do print (x::B Char); return x) (tree 'a') >>= print 

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