diff --git a/Data/Geniplate.hs b/Data/Geniplate.hs --- a/Data/Geniplate.hs +++ b/Data/Geniplate.hs @@ -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 diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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] diff --git a/geniplate.cabal b/geniplate.cabal --- a/geniplate.cabal +++ b/geniplate.cabal @@ -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