geniplate 0.1.0.0 → 0.2.0.0
raw patch · 3 files changed
+79/−31 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Data/Geniplate.hs +58/−25
- examples/Main.hs +20/−5
- geniplate.cabal +1/−1
Data/Geniplate.hs view
@@ -42,13 +42,28 @@ Just (FunD n _) -> return $ VarE n _ -> do f <- lift $ newName "_f"- cs <- if from == to then- lift $ fmap unFunD [d| f _x _r = _x : _r |]+ 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+ 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"+ 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 |]+ else+ -- Non-recursive type, just use this value.+ lift $ fmap unFunD [d| f _x _r = _x : _r |] else do+ -- Types differ, look inside. b <- contains to from if b then do- put (mInsert from (FunD f [Clause [] (NormalB $ TupE []) []]) m, c) -- insert something to break recursion, will be replaced below.- uniBiCase from to+ -- Occurrences inside, recurse.+ mkRec else -- No occurrences of to inside from, so add nothing. lift $ fmap unFunD [d| f _ _r = _r |]@@ -60,27 +75,33 @@ contains :: Type -> Type -> U Bool contains to afrom = do -- lift $ qRunIO $ print ("contains", to, from)- (m, c) <- get from <- lift $ expandSyn afrom- case mLookup from c of- Just b -> return b- Nothing -> do- if from == to then- return True -- Don't bother caching; we should reach this case where caching matters- else do- let (con, ts) = splitTypeApp from- put (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)- t -> genError $ "contains: unexpected type: " ++ pprint from ++ " (" ++ show t ++ ")"- modify $ \ (m', c') -> (m', mInsert from b c')- return b+ if from == to then+ return True+ else do+ c <- gets snd+ case mLookup from c of+ Just b -> return b+ Nothing -> contains' to from +-- 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)+ 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+ ConT n -> containsCon n to ts+ TupleT _ -> fmap or $ mapM (contains to) ts+ ArrowT -> return False+ ListT -> contains to (head ts)+ t -> genError $ "contains: unexpected type: " ++ pprint from ++ " (" ++ show t ++ ")"+ modify $ \ (m, c) -> (m, mInsert from b c)+ return b+ containsCon :: Name -> Type -> [Type] -> U Bool containsCon con to ts = do+-- lift $ qRunIO $ print ("containsCon", con, to, ts) (tvs, cons) <- lift $ getTyConInfo con let conCon (NormalC _ xs) = fmap or $ mapM (field . snd) xs conCon (InfixC x1 _ x2) = fmap or $ mapM field [snd x1, snd x2]@@ -249,14 +270,26 @@ Just (FunD n _) -> return $ VarE n _ -> do tr <- lift $ newName "_tr"- cs <- if ft == st then- lift $ fmap unFunD [d| _f _x = $(return f) _x |]+ 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++ cs <- if ft == st then do+ b <- contains' ft st+ if b then do+ g <- lift $ newName "_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 = $(return f) ($(return (VarE g))_x) |]+ else+ lift $ fmap unFunD [d| _f _x = $(return f) _x |] else do b <- contains ft st -- lift $ qRunIO $ print (b, ft, st) if b then do- put (mInsert st (FunD tr [Clause [] (NormalB $ TupE []) []]) m, c) -- insert something to break recursion, will be replaced below.- trBiCase f ft st+ mkRec else lift $ fmap unFunD [d| f _x = _x |] let d = FunD tr cs
examples/Main.hs view
@@ -1,7 +1,13 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} module Main where import Data.Geniplate +data T a = T { x :: Int, y :: a } deriving (Show)++data B a = MT Bool | Bin (B a) a Bool (B a) deriving (Show)++tree x = Bin (Bin (MT True) x True (MT False)) x False (MT True)+ uni :: [(Maybe Int, T Int, [Double])] -> [Int] uni = $(universeBi 'uni) @@ -14,11 +20,11 @@ uni3 :: [B Bool] -> [Bool] uni3 = $(universeBi 'uni3) -data T a = T { x :: Int, y :: a } deriving (Show)--data B a = MT | Bin (B a) a Bool (B a) deriving (Show)+uni4 :: B Char -> [B Char]+uni4 = $(universeBi 'uni4) -tree x = Bin (Bin MT x True MT) x False MT+uni5 :: [Int] -> [[Int]]+uni5 = $(universeBi 'uni5) trans :: (Int -> Int) -> [(Bool,T String)] -> [(Bool,T String)] trans = $(transformBi 'trans)@@ -29,6 +35,10 @@ trans2 :: (Bool -> Bool) -> B Bool -> B Bool trans2 = $(transformBi 'trans2) +trans4 :: (B Char -> B Char) -> B Char -> B Char+trans4 = $(transformBi 'trans4)++ 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])]@@ -38,3 +48,8 @@ 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)+ f (Bin t1 x b t2) = Bin t1 x (not b) t2+ print $ trans4 f $ tree 'a'+ print $ uni5 [1,2]
geniplate.cabal view
@@ -1,6 +1,6 @@ Name: geniplate Cabal-Version: >= 1.2-Version: 0.1.0.0+Version: 0.2.0.0 License: BSD3 Author: Lennart Augustsson Maintainer: Lennart Augustsson