diff --git a/Data/Generics/Geniplate.hs b/Data/Generics/Geniplate.hs --- a/Data/Generics/Geniplate.hs +++ b/Data/Generics/Geniplate.hs @@ -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) [] diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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 + 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.4.0.0 +Version: 0.4.0.1 License: BSD3 Author: Lennart Augustsson Maintainer: Lennart Augustsson