geniplate 0.5.0.1 → 0.6.0.0

raw patch · 4 files changed

+142/−74 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Generics/Geniplate.hs +83/−54
• examples/Main.hs +23/−17
• examples/output +33/−0
• geniplate.cabal +3/−3

@@ -15,12 +15,17 @@ import Language.Haskell.TH.Syntax hiding (lift) import System.IO +---- Overloaded interface, same as Usniplate++-- | Class for 'universeBi'. class UniverseBi s t where     universeBi :: s -> [t] +-- | Class for 'transformBi'. class TransformBi s t where     transformBi :: (s -> s) -> t -> t +-- | Class for 'transformBiM'. class {-(Monad m) => -} TransformBiM m s t where     transformBiM :: (s -> m s) -> t -> m t @@ -33,19 +38,26 @@ transformM :: (TransformBiM m a a) => (a -> m a) -> a -> m a transformM = transformBiM +---- -instanceUniverseBi :: TypeQ -> TypeQ -> Q [Dec]+-- | Create a 'UniverseBi' instance.+-- The 'TypeQ' argument should be a pair; the /source/ and /target/ types for 'universeBi'.+instanceUniverseBi :: TypeQ -> Q [Dec] instanceUniverseBi = instanceUniverseBiT [] -instanceUniverseBiT :: [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]-instanceUniverseBiT stops fromq toq = do-    from <- fromq-    to <- toq+-- | Create a 'UniverseBi' instance with certain types being abstract.+-- The 'TypeQ' argument should be a pair; the /source/ and /target/ types for 'universeBi'.+instanceUniverseBiT :: [TypeQ] -> TypeQ -> Q [Dec]+instanceUniverseBiT stops ty = instanceUniverseBiT' stops =<< ty++instanceUniverseBiT' :: [TypeQ] -> Type -> Q [Dec]+instanceUniverseBiT' stops (ForallT _ _ t) = instanceUniverseBiT' stops t+instanceUniverseBiT' stops ty | (TupleT _, [from, to]) <- splitTypeApp ty = do     (ds, f) <- uniBiQ stops from to     x <- newName "_x"     let e = LamE [VarP x] $ LetE ds $ AppE (AppE f (VarE x)) (ListE [])     return $ instDef ''UniverseBi [from, to] 'universeBi e---    [d|instance UniverseBi $fromq $toq where universeBi = $(return e) |]+instanceUniverseBiT' _ t = genError "instanceUniverseBi: the argument should be of the form [t| (S, T) |]"  funDef :: Name -> Exp -> [Dec] funDef f e = [FunD f [Clause [] (NormalB e) []]]@@ -53,30 +65,39 @@ instDef :: Name -> [Type] -> Name -> Exp -> [Dec] instDef cls ts met e = [InstanceD [] (foldl AppT (ConT cls) ts) (funDef met e)] -instanceTransformBi :: TypeQ -> TypeQ -> Q [Dec]+-- | Create a 'TransformBi' instance.+-- The 'TypeQ' argument should be a pair; the /inner/ and /outer/ types for 'transformBi'.+instanceTransformBi :: TypeQ -> Q [Dec] instanceTransformBi = instanceTransformBiT [] -instanceTransformBiT :: [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]-instanceTransformBiT stops ftq stq = do-    ft <- ftq-    st <- stq+-- | Create a 'TransformBi' instance with certain types being abstract.+-- The 'TypeQ' argument should be a pair; the /inner/ and /outer/ types for 'transformBi'.+instanceTransformBiT :: [TypeQ] -> TypeQ -> Q [Dec]+instanceTransformBiT stops ty = instanceTransformBiT' stops =<< ty +instanceTransformBiT' :: [TypeQ] -> Type -> Q [Dec]+instanceTransformBiT' stops (ForallT _ _ t) = instanceTransformBiT' stops t+instanceTransformBiT' stops ty | (TupleT _, [ft, st]) <- splitTypeApp ty = do     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)      return $ instDef ''TransformBi [ft, st] 'transformBi e---    [d|instance TransformBi $ftq $stq where transformBi = $(return e) |]+instanceTransformBiT' _ t = genError "instanceTransformBiT: the argument should be of the form [t| (S, T) |]" -instanceTransformBiM :: TypeQ -> TypeQ -> TypeQ -> Q [Dec]+-- | Create a 'TransformBiM' instance.+instanceTransformBiM :: TypeQ -> TypeQ -> Q [Dec] instanceTransformBiM = instanceTransformBiMT [] -instanceTransformBiMT :: [TypeQ] -> TypeQ -> TypeQ -> TypeQ -> Q [Dec]-instanceTransformBiMT stops mndq ftq stq = do+-- | Create a 'TransformBiM' instance with certain types being abstract.+instanceTransformBiMT :: [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]+instanceTransformBiMT stops mndq ty = instanceTransformBiMT' stops mndq =<< ty++instanceTransformBiMT' :: [TypeQ] -> TypeQ -> Type -> Q [Dec]+instanceTransformBiMT' stops mndq (ForallT _ _ t) = instanceTransformBiMT' stops mndq t+instanceTransformBiMT' stops mndq ty | (TupleT _, [ft, st]) <- splitTypeApp ty = do     mnd <- mndq-    ft <- ftq-    st <- stq      f <- newName "_f"     x <- newName "_x"@@ -84,7 +105,7 @@     let e = LamE [VarP f, VarP x] $ LetE ds $ AppE tr (VarE x)      return $ instDef ''TransformBiM [mnd, ft, st] 'transformBiM e---    [d|instance TransformBiM $mndq $ftq $stq where transformBiM = $(return e) |]+instanceTransformBiMT' _ _ t = genError "instanceTransformBiMT: the argument should be of the form [t| (S, T) |]"   -- | Generate TH code for a function that extracts all subparts of a certain type.@@ -108,8 +129,14 @@  type U = StateT (Map Type Dec, Map Type Bool) Q -newNameU :: String -> U Name-newNameU s = lift $ newName s+instance Quasi U where+    qNewName = lift . qNewName+    qReport b = lift . qReport b+    qRecover = error "Data.Generics.Geniplate: qRecover not implemented"+    qReify = lift . qReify+    qClassInstances n = lift . qClassInstances n+    qLocation = lift qLocation+    qRunIO = lift . qRunIO  uniBiQ :: [TypeQ] -> Type -> Type -> Q ([Dec], Exp) uniBiQ stops from ato = do@@ -121,11 +148,11 @@ uniBi :: Type -> Type -> U Exp uniBi afrom to = do     (m, c) <- get-    from <- lift $ expandSyn afrom+    from <- expandSyn afrom     case mLookup from m of         Just (FunD n _) -> return $ VarE n         _ -> do-            f <- newNameU "_f"+            f <- qNewName "_f"             let mkRec = do                     put (mInsert from (FunD f [Clause [] (NormalB $ TupE []) []]) m, c)   -- insert something to break recursion, will be replaced below.                     uniBiCase from to@@ -133,15 +160,15 @@                       b <- contains' to from                       if b then do                           -- Recursive data type, we need the current value and all values inside.-                          g <- newNameU "_g"+                          g <- qNewName "_g"                           gcs <- mkRec                           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')-                          lift $ fmap unFunD [d| f _x _r = _x : $(return (VarE g)) _x _r |]+                          unFun [d| f _x _r = _x : $(return (VarE g)) _x _r |]                        else                           -- Non-recursive type, just use this value.-                          lift $ fmap unFunD [d| f _x _r = _x : _r |]+                          unFun [d| f _x _r = _x : _r |]                   else do                       -- Types differ, look inside.                       b <- contains to from@@ -150,7 +177,7 @@                           mkRec                        else                           -- No occurrences of to inside from, so add nothing.-                          lift $ fmap unFunD [d| f _ _r = _r |]+                          unFun [d| f _ _r = _r |]             let d = FunD f cs             modify $ \ (m', c') -> (mInsert from d m', c')             return $ VarE f@@ -158,8 +185,8 @@ -- Check if the second type is contained anywhere in the first type. contains :: Type -> Type -> U Bool contains to afrom = do---    lift $ qRunIO $ print ("contains", to, from)-    from <- lift $ expandSyn afrom+--    qRunIO $ print ("contains", to, from)+    from <- expandSyn afrom     if from == to then         return True      else do@@ -171,7 +198,7 @@ -- Check if the second type is contained somewhere inside the first. contains' :: Type -> Type -> U Bool contains' to from = do---    lift $ qRunIO $ print ("contains'", to, from)+--    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.     b <- case con of@@ -186,8 +213,8 @@  containsCon :: Name -> Type -> [Type] -> U Bool containsCon con to ts = do---    lift $ qRunIO $ print ("containsCon", con, to, ts)-    (tvs, cons) <- lift $ getTyConInfo con+--    qRunIO $ print ("containsCon", con, to, ts)+    (tvs, cons) <- getTyConInfo con     let conCon (NormalC _ xs) = fmap or $ mapM (field . snd) xs         conCon (InfixC x1 _ x2) = fmap or $ mapM field [snd x1, snd x2]         conCon (RecC _ xs) = fmap or $ mapM field [ t | (_,_,t) <- xs ]@@ -200,13 +227,16 @@ unFunD [FunD _ cs] = cs unFunD _ = genError $ "unFunD" +unFun :: Q [Dec] -> U [Clause]+unFun = lift . fmap unFunD+ uniBiCase :: Type -> Type -> U [Clause] uniBiCase from to = do     let (con, ts) = splitTypeApp from     case con of         ConT n    -> uniBiCon n ts to         TupleT _  -> uniBiTuple ts to---        ArrowT    -> lift $ fmap unFunD [d| f _ _r = _r |]           -- Stop at functions+--        ArrowT    -> unFun [d| f _ _r = _r |]           -- Stop at functions         ListT     -> uniBiList (head ts) to         t         -> genError $ "uniBiCase: unexpected type: " ++ pprint from ++ " (" ++ show t ++ ")" @@ -214,14 +244,14 @@ uniBiList t to = do     uni <- uniBi t to     rec <- uniBi (AppT ListT t) to-    lift $ fmap unFunD [d| f [] _r = _r; f (_x:_xs) _r = $(return uni) _x ($(return rec) _xs _r) |]+    unFun [d| f [] _r = _r; f (_x:_xs) _r = $(return uni) _x ($(return rec) _xs _r) |]  uniBiTuple :: [Type] -> Type -> U [Clause] uniBiTuple ts to = fmap (:[]) $ mkArm to [] TupP ts  uniBiCon :: Name -> [Type] -> Type -> U [Clause] uniBiCon con ts to = do-    (tvs, cons) <- lift $ getTyConInfo con+    (tvs, cons) <- getTyConInfo con     let genArm (NormalC c xs) = arm (ConP c) xs         genArm (InfixC x1 c x2) = arm (\ [p1, p2] -> InfixP p1 c p2) [x1, x2]         genArm (RecC c xs) = arm (ConP c) [ (b,t) | (_,b,t) <- xs ]@@ -231,14 +261,14 @@      if null cons then         -- No constructurs, return nothing-        lift $ fmap unFunD [d| f _ _r = _r |]+        unFun [d| f _ _r = _r |]      else         mapM genArm cons  mkArm :: Type -> Subst -> ([Pat] -> Pat) -> [Type] -> U Clause mkArm to s c ts = do-    r <- newNameU "_r"-    vs <- mapM (const $ newNameU "_x") ts+    r <- qNewName "_r"+    vs <- mapM (const $ qNewName "_x") ts     let sub v t = do             let t' = subst s t             uni <- uniBi t' to@@ -264,7 +294,7 @@ subst s (SigT t k) = SigT (subst s t) k subst _ t = t -getTyConInfo :: Name -> Q ([TyVarBndr], [Con])+getTyConInfo :: (Quasi q) => Name -> q ([TyVarBndr], [Con]) getTyConInfo con = do     info <- qReify con     case info of@@ -273,7 +303,7 @@         PrimTyConI{} -> return ([], [])         i -> genError $ "unexpected TyCon: " ++ show i -getNameType :: Name -> Q ([TyVarBndr], Type, Type)+getNameType :: (Quasi q) => Name -> q ([TyVarBndr], Type, Type) getNameType name = do     info <- qReify name     let split (ForallT tvs _ t) = (tvs ++ tvs', from, to) where (tvs', from, to) = split t@@ -292,14 +322,14 @@ splitTypeApp (AppT a r) = (c, rs ++ [r]) where (c, rs) = splitTypeApp a splitTypeApp t = (t, []) -expandSyn :: Type -> Q Type+expandSyn :: (Quasi q) => Type -> q Type expandSyn (ForallT tvs ctx t) = liftM (ForallT tvs ctx) $ expandSyn t expandSyn t@AppT{} = expandSynApp t [] expandSyn t@ConT{} = expandSynApp t [] expandSyn (SigT t k) = liftM (flip SigT k) $ expandSyn t expandSyn t = return t -expandSynApp :: Type -> [Type] -> Q Type+expandSynApp :: (Quasi q) => 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@@ -313,7 +343,6 @@         _ -> return $ foldl AppT t ts expandSynApp t ts = do t' <- expandSyn t; return $ foldl AppT t' ts - genError :: String -> a genError msg = error $ "Data.Generics.Geniplate: " ++ msg @@ -375,12 +404,12 @@ trBi :: RetAp -> Exp -> Type -> Type -> U Exp trBi ra@(ret, _, rbind) f ft ast = do     (m, c) <- get-    st <- lift $ expandSyn ast---    lift $ qRunIO $ print (ft, st)+    st <- expandSyn ast+--    qRunIO $ print (ft, st)     case mLookup st m of         Just (FunD n _) -> return $ VarE n         _ -> do-            tr <- newNameU "_tr"+            tr <- qNewName "_tr"             let mkRec = do                     put (mInsert st (FunD tr [Clause [] (NormalB $ TupE []) []]) m, c)  -- insert something to break recursion, will be replaced below.                     trBiCase ra f ft st@@ -388,23 +417,23 @@             cs <- if ft == st then do                       b <- contains' ft st                       if b then do-                          g <- newNameU "_g"+                          g <- qNewName "_g"                           gcs <- mkRec                           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')-                          x <- newNameU "_x"+                          x <- qNewName "_x"                           return [Clause [VarP x] (NormalB $ rbind f (AppE (VarE g) (VarE x))) []]                        else do-                          x <- newNameU "_x"+                          x <- qNewName "_x"                           return [Clause [VarP x] (NormalB $ AppE f (VarE x)) []]                   else do                       b <- contains ft st---                      lift $ qRunIO $ print (b, ft, st)+--                      qRunIO $ print (b, ft, st)                       if b then do                           mkRec                        else do-                          x <- newNameU "_x"+                          x <- qNewName "_x"                           return [Clause [VarP x] (NormalB $ ret $ VarE x) []]             let d = FunD tr cs             modify $ \ (m', c') -> (mInsert st d m', c')@@ -416,7 +445,7 @@     case con of         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+--        ArrowT    -> unFun [d| f _ _r = _r |]           -- Stop at functions         ListT     -> trBiList ra f ft st (head ts)         _         -> genError $ "trBiCase: unexpected type: " ++ pprint st ++ " (" ++ show st ++ ")" @@ -428,14 +457,14 @@  trBiTuple :: RetAp -> Exp -> Type -> Type -> [Type] -> U [Clause] trBiTuple ra f ft st ts = do-    vs <- mapM (const $ newNameU "_t") ts+    vs <- mapM (const $ qNewName "_t") ts     let tupE = LamE (map VarP vs) $ TupE (map VarE vs)     c <- trMkArm ra f ft st [] TupP tupE ts     return [c]  trBiCon :: RetAp -> Exp -> Name -> Type -> Type -> [Type] -> U [Clause] trBiCon ra f con ft st ts = do-    (tvs, cons) <- lift $ getTyConInfo con+    (tvs, cons) <- 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 ]@@ -446,7 +475,7 @@  trMkArm :: RetAp -> Exp -> Type -> Type -> Subst -> ([Pat] -> Pat) -> Exp -> [Type] -> U Clause trMkArm ra@(ret, apl, _) f ft st s c ec ts = do-    vs <- mapM (const $ newNameU "_x") ts+    vs <- mapM (const $ qNewName "_x") ts     let sub v t = do             let t' = subst s t             tr <- trBi ra f ft t'

@@ -8,24 +8,27 @@  tree x = Bin (Bin (MT True) x True (MT False)) x False (MT True) -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] |]+instanceUniverseBi [t| ([(Maybe Int, T Int, [Double])], Int) |]+instanceUniverseBiT [ [t|Maybe Int|] ] [t| ([(Maybe Int, T Int, [Float])], Int) |]+instanceUniverseBi [t| ([B Bool], Int) |]+instanceUniverseBi [t| ([B Bool], Bool) |]+instanceUniverseBi [t| (B Char, B Char) |]+instanceUniverseBi [t| ([Int], [Int]) |] -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 |]+instanceTransformBi [t| (Int , [(Bool,T String)]) |]+instanceTransformBi [t| (Bool , B Char) |]+instanceTransformBi [t| (Bool , B Bool) |]+instanceTransformBi [t| (B Char , B Char) |] -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 |]+instanceTransformBiM [t| Maybe |] [t| (Int , [Int]) |]+instanceTransformBiM [t| Maybe |] [t| (Int , [(Int,Bool)]) |]+instanceTransformBiM [t| IO |] [t| (Int , B Int) |]+instanceTransformBiM [t| IO |] [t| (Bool , B Bool) |]+instanceTransformBiM [t| IO |] [t| (B Char , B Char) |] +instanceUniverseBi [t| forall a . (B a, a) |]+instanceTransformBi [t| forall a . (a, [a]) |]+ main :: IO () main = do     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])@@ -38,9 +41,10 @@     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+    let f :: B Char -> B Char+        f (MT b) = MT b         f (Bin t1 x b t2) = Bin t1 x (not b) t2-    print $ transformBi (f :: B Char -> B Char) $ tree 'a'+    print $ transformBi f $ 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]@@ -49,3 +53,5 @@     transformBiM (\ x -> do print (x::Bool); return (not x)) (tree True) >>= print     transformBiM (\ x -> do print (x::B Char); return x) (tree 'a') >>= print +    print (universeBi (Bin (MT True) () False (MT True)) :: [()])+    print (transformBi ((+1)::Int->Int) [1::Int,10,100])

@@ -0,0 +1,33 @@+./Main+[12,1,2,345,3,4,5,6]
+[1,2,3,4,5,6]
+[]
+[True,True,True,False,True,False,True,True,False,True,False,False,False,True]
+[Bin (Bin (MT True) 'a' True (MT False)) 'a' False (MT True),Bin (MT True) 'a' True (MT False),MT True,MT False,MT True]
+[[1,2],[2],[]]
+[(True,T {x = 2, y = "a"}),(False,T {x = 3, y = "b"})]
+Bin (Bin (MT False) 'a' False (MT True)) 'a' True (MT False)
+Bin (Bin (MT False) False False (MT True)) False True (MT False)
+Bin (Bin (MT True) 'a' False (MT False)) 'a' True (MT True)
+Just [1,2,3]
+Nothing
+Just [(1,True)]
+3
+3
+Bin (Bin (MT True) 103 True (MT False)) 103 False (MT True)
+True
+True
+True
+False
+True
+False
+True
+Bin (Bin (MT False) False False (MT True)) False True (MT False)
+MT True
+MT False
+Bin (MT True) 'a' True (MT False)
+MT True
+Bin (Bin (MT True) 'a' True (MT False)) 'a' False (MT True)
+Bin (Bin (MT True) 'a' True (MT False)) 'a' False (MT True)
+[()]
+[2,11,101]

@@ -1,10 +1,10 @@ Name:           geniplate Cabal-Version:  >= 1.2-Version:        0.5.0.1+Version:        0.6.0.0 License:        BSD3 Author:         Lennart Augustsson Maintainer:     Lennart Augustsson-Category:       Generic programming+Category:       Generics Synopsis:       Use template Haskell to generate Uniplate-like functions. Stability:      experimental Build-type:     Simple@@ -12,8 +12,8 @@  Extra-source-files:       examples/Main.hs+      examples/output  Library   Build-Depends: base >= 4 && < 5.0, template-haskell, mtl   Exposed-modules:      Data.Generics.Geniplate-