diff --git a/Data/Generics/TH.hs b/Data/Generics/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/TH.hs @@ -0,0 +1,1418 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +{-# OPTIONS_GHC -W -Wall #-} + +{-| +This is the code for \"Template Your Boilerplate\" under review at the Haskell Symposium 2012. + +A draft copy of that paper is available at +and provides more thorough documentation. +-} + +#define BENCHMARK 0 +module Data.Generics.TH + ( -- * Primitives + thcase, thcase', thfoldl + -- * Single-layer traversals + , thmapT, thmapM, thmapQ, thmapQl, thmapQr + -- * Memoization + , memoizeDec, memoizeDec2 -- TODO: 3, 4, 5, etc. + , memoizeExp, memoizeExp2 -- TOOD: 3, 4, 5, etc. + -- * Traversals + -- ** Transformations + , everywhere, everywhere', everywhereBut + , everywhereM, everywhereM', everywhereButM' + , everywhereFor, everywhereForM + , somewhere, somewhereM + -- ** Queries + , everything, everythingBut + , everythingAccL, everythingAccL', everythingButAccL, everythingButAccL' + , everythingAccR, everythingButAccR + , everythingForR, everythingForL, everythingForL' + -- * Extentions and adaptors + , extN, extE, extE' + , mkT, mkTs, mkQ, mkQs, mkM, mkMs + -- * Type manipulation functions + , eqType, eqTypes + , containsType, containsTypes + , constructorsOf, typeOfName +#if BENCHMARK + -- * Benchmarking implementations + , everything_slow + , everywhereM_slow +#endif +) where + +-- Imports for the 'seen' table in 'containsType' +import Control.Monad.State + +-- Imports for memoization tables +import Data.IORef +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- Imports for Template Haskell +import Language.Haskell.TH hiding (cxt{-avoid warnings when cxt is a variable-}) +import Language.Haskell.TH.Syntax hiding (lift{-conflicts with monadic 'lift'-}) + +-- Import for listing the 'primitive types'. +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.Array (Array) +import Foreign.Ptr (Ptr) +import Foreign.ForeignPtr (ForeignPtr) + +-- Imports of other TYB modules +import Data.Generics.TH.Instances () +import Data.Generics.TH.VarSet (varSet) + +-------------------------------------------------------------------------------- +-- thcase', thcase and thfoldl +-------------------------------------------------------------------------------- + +-- |Primitive case expression generation. Most users will want to use +-- 'thcase' instead. +thcase' :: (Quasi m) + => (Either Name {- prim :: t -} + (Name {- ctor :: a -> b -> t -}, [(Type, Name)] {- args :: [a, b] -}) + -> m Exp {- c t -}) + -- ^ Case handling function. If the 'Type' being inspected is + -- a primitive type, argument is @'Left' var@ where @var@ is a + -- variable bound to the case discriminant. Otherwise, + -- argument is @'Right' (ctor, args)@ where @ctor@ is the + -- constructor name and @args@ is a list of the argument's + -- types and the variable bound to the argument. + -> m Type -- ^ The type to inspect. + -> m Exp -- ^ The expression containing the @case@ + -- expression. If the type to inspect is @t@ and + -- the type of the 'Exp' returned by the case + -- handling function is @r@, the 'Exp' returned by + -- @thcase'@ is of type @t -> r@. +thcase' g t0 = do + ctors <- constructorsOf =<< t0 + x <- qNewName "_x" + body <- case ctors of + Nothing -> g (Left x) + Just ctors' -> return (CaseE (VarE x)) `ap` mapM doClause ctors' + return $ LamE [VarP x] body + where doClause (cons, ts) = do + xs <- mapM (const $ qNewName "arg") ts --sequence [do x <- qNewName "arg"; return (t, x) | t <- ts] + body <- g (Right (cons, zip ts xs)) + return $ Match (ConP cons (map VarP xs)) (NormalB body) [] + +-- |Case expression generation. This is the core function of the +-- Template Your Boilerplate library. +-- +-- This function is similar to @thcase'@, except that since most users +-- will note care about the distinction between types and primitive +-- types, this function smooths over the differences by treating primitive +-- types as types with nullary constructors. +thcase :: (Quasi m) + => (m Exp -> [(Type, m Exp)] -> m Exp) + -- ^ Case handling function. The first argument is the constructor. + -- The second argument is the list of arguments and their types. + -> m Type -- ^ The type to inspect. + -> m Exp -- ^ The expression containing the @case@ expression. If + -- the type to inspect is @t@ and the type of the 'Exp' + -- returned by the case handling function is @r@, the + -- 'Exp' returned by @thcase@ is of type @t -> r@. +thcase g t0 = thcase' g' t0 where + g' (Left var) = g (return (VarE var)) [] + g' (Right (name, args)) = g (return (ConE name)) [(t, return (VarE n)) | (t, n) <- args] + +-- |Scrap Your Boilerplate style case expression generation. The +-- 'thcase' function is generally simpler to use instead of this and +-- is more powerful. +thfoldl :: Quasi m + => (m Exp -> Type -> m Exp -> m Exp) + -- ^ Constructor argument application. If the first 'Exp' is of + -- type @c (a -> b)@, the 'Type' is @a@, and the second 'Exp' is of + -- type @a@, should return an 'Exp' of type @c b@. + -> (m Exp -> m Exp) -- ^ Constructor injection. The argument 'Exp' + -- will be one of the constructors from the type + -- to be inspected. If the argument 'Exp' is of + -- type @a@, should return an 'Exp' of type @c + -- a@. + -> m Type -- ^ The type to inspect. + -> m Exp -- ^ The expression containing the @case@ expression. If + -- the type to inspect is @t@ and the type of the 'Exp' + -- returned by the case handling function is @c t@, the + -- 'Exp' returned by @thcase@ is of type @t -> c t@. +thfoldl k z t = thcase g t where + g ctor args = foldl (uncurry . k) (z ctor) args + +-------------------------------------------------------------------------------- +-- Single-layer traversals +-------------------------------------------------------------------------------- + +-- |Generic single-layer transformation +thmapT :: (Quasi m) + => (Type -> m Exp) -- ^ The transformation. If the 'Type' is @t@, must + -- return an 'Exp' of type @t -> t@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- transformation to each immediate child. If + -- 'Type' is @t0@, returns an 'Exp' of type @t0 + -- -> t0@. +thmapT f t0 = thcase g t0 where + g ctor [] = ctor + g ctor ((t, x) : xs) = do ctor' <- ctor + f' <- f t + x' <- x + g (return (AppE ctor' (AppE f' x'))) xs + -- g [|$(ctor) ($(f t) $(x))|] xs + +-- |Generic single-layer query. +thmapQ :: (Quasi m) + => (Type -> m Exp) -- ^ The query. Extracts data from the given + -- type. If the 'Type' is @t@, must return an 'Exp' + -- of type @t -> a@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the query + -- to each immediate child. If the 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> [a]@. +thmapQ query topTy = thcase g topTy where + g _ctor [] = return (ConE '[]) + g ctor ((t, x) : xs) = do f' <- query t + rest <- g ctor xs + x' <- x + return (AppE (AppE (ConE '(:)) (AppE f' x')) rest) + -- [| $(f t) $(x) : $(g ctor xs) |] + + +-- |Generic single-layer query (right associative). +thmapQr :: (Quasi m) + => m Exp -- ^ Combining function. 'Exp' must have type @r' -> r -> r@ + -> m Exp -- ^ Starting value. 'Exp' must have type @r@. + -> (Type -> m Exp) -- ^ The query. Extract data from the given + -- type. If the 'Type' is @t@, must return an 'Exp' + -- of type @t -> r'@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the query + -- to each immediate child and uses the + -- starting value and combining functions to + -- fold the query results. If the 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> r@. +thmapQr combine zero query t0 = thcase g t0 where + g _ctor [] = zero + g ctor ((t, x) : xs) = do combine' <- combine + left <- query t + x' <- x + right <- g ctor xs + return (AppE (AppE combine' (AppE left x')) right) + -- [|$(combine) ($(query t) $x) $(g ctor xs)|] + +-- |Generic single-layer query (left associative). +thmapQl :: (Quasi m) + => (m Exp) -- ^ Combining function. 'Exp' must have type @r -> r' -> r@ + -> (m Exp) -- ^ Starting value. 'Exp' must have type @r@. + -> (Type -> m Exp) -- ^ The query. Extract data from the given + -- type. If the 'Type' is @t@, must return an 'Exp' + -- of type @t -> r'@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the query + -- to each immediate child and uses the + -- starting value and combining functions to + -- fold the query results. If the 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> r@. +thmapQl combine zero query t0 = thcase g' t0 where + g' _ctor xs = zero >>= \acc -> g acc xs + g acc [] = return acc + g acc ((t, x) : xs) = do combine' <- combine + left <- query t + x' <- x + g (AppE (AppE combine' acc) (AppE left x')) xs + --g [|$combine $acc ($(query t) $x)|] xs + +#if BENCHMARK +thmapM_slow :: (Type -> Q Exp) -> Q Type -> Q Exp +thmapM_slow f t0 = thfoldl k z t0 where + z ctor = [| return $(ctor) |] + k ctor t arg = + [| $ctor >>= \c -> $(f t) $(arg) >>= \a -> return (c a) |] +#endif + +-- | Generic single-layer monadic transformation. +thmapM :: (Quasi m) + => (Type -> m Exp) -- ^ The monadic transformation. If the 'Type' is + -- @t@, must return an 'Exp' of type @t -> m t@ + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- monadic transformation to each immediate + -- child. If the 'Type' is @t0@, returns an 'Exp' + -- of type @t0 -> m t0@. +thmapM f t0 = thcase g t0 where + g ctor [] = liftM (AppE (VarE 'return)) ctor -- [| return $(ctor) |] + g ctor ((t, x) : xs) = + do f' <- f t + x' <- x + xprime <- qNewName "x'" + body <- g (do ctor' <- ctor; return (AppE ctor' (VarE xprime))) xs + return $ InfixE (Just $ AppE f' x') + (VarE '(>>=)) + (Just $ LamE [VarP xprime] body) + -- [| $(f t) $(x) >>= \x' -> $(g [| $(ctor) x' |] xs) |] + +-------------------------------------------------------------------------------- +-- Memoization +-------------------------------------------------------------------------------- + +-- internal helper function +memoizeDec' :: (Quasi m, Ord a) + => IORef (Map.Map a Name) -- ^ Name table. + -> IORef [(Name, Exp)] -- ^ Body table. + -> (a -> m Exp) -- ^ Function to be memoized. + -> (a -> m Exp) -- ^ Memoized version of the function. +memoizeDec' nameRef bodyRef f1 a = do + names <- qRunIO (readIORef nameRef) + case Map.lookup a names of + Just name -> return $ VarE name + Nothing -> do + name <- qNewName $ "memoized" -- ++ map (\x -> if isAlpha x then x else '_') (pprint a) + qRunIO $ modifyIORef nameRef (Map.insert a name) + body <- f1 a + qRunIO $ modifyIORef bodyRef ((name, body):) + return $ VarE name + +{-| + +Memoizes a code generation function. Most users will want to use +'memoizeExp' instead as it provides a simplified interface, but all +the notes about this function also apply to 'memoizeExp'. + +We memoize a function returning an 'Exp' by creating a 'Dec' with a +body that is the 'Exp' returned by that function. The return value +of the function is replaced with a 'VarE' that refers to the 'Dec'. +This allows functions like 'everywhere' to avoid infinite +recursions when they traverse recursive types like lists. + +The memoization functions come in two flavors: 'memoizeDec' and +'memoizeExp'. With 'memoizeDec' it is the responsibility of the +caller to place the 'Dec' in an appropriate place. The +'memoizeExp' function automatically handles the 'Dec' by wrapping +them in a local 'LetE' form. + +Every memoized function is passed a memoized version of itself. +This is the function that should be used in recursive calls. +Failing to do so will prevent those calls from being memoized. + +Mutually recursive functions are possible using 'memoizeDec2', +etc. and 'memoizeExp2', etc. + +If the function being memoized needs to accept multiple arguments, +then they must be packed into a tuple and passed as a single argument. + +Effects in the @m@ monad are only performed the first time the +memoized function is called with a particular argument. Subsequent +times the monad is simply the result of a 'return'. Thus while it +is tempting to store extra return values in the monad, this should +be avoided due to the high likelihood of unexpected behavior. + +Implementation Notes: + +* Note that @m@ should not store a copy of the function, otherwise + a memory leak is introduced. It wouldn't even make sense to do + it anyway since the results refer to expressions that might not + be in scope. + +* The memoized function stores a reference to the memoization + table, Thus if a reference to the memoized function gets tucked + inside @m@, then a memory leak can be introduced. We could + eliminate this leak by clearing and invalidating the table when + 'memoizeDec' returns. To fully do this properly the table would + have to be invalidated in such a way that the memoized version of + the function would not continue to try populating the table if + the user called it after 'memoizeDec' return. + +* Conceptually we should use a State monad instead of an IORef but + we choose IORef since we can embed IO operations in a Quasi + without imposing extra restrictions on @m@. + +* Other designs are possible. This design was choosen for its + simplicity of use. The choice of memoization interface is + largely orthogonal to the rest of this library. + +* Type synonyms and kind annotations may lead to duplicate versions + of the code (e.g. versions for both 'String' and @['Char']@) + Usually this isn't a problem, but if it is, then the type + synonyms should be expanded before each call to the memoized + function. + +* GADTs and data/type families haven't been considered in this + code. It is unknown whether they work. + +Note that polymorphically recursive types (e.g. @data F a = N a | F (F +(Int, a))@) have an infinite number of types in them and thus despite +memoization this function will not terminate on those types. +-} + +memoizeDec :: (Quasi m, Ord a) + => ((a -> m Exp) -> a -> m Exp) -- ^ The function to memoize. Takes + -- a memoized version of the + -- function as argument. + -> a -- ^ The initial argument to the function. + -> m ([Dec], Exp) -- ^ The result of applying the + -- function to the initial argument. + -- The |Exp| is the result, but + -- expects the @['Dec']@ to be in + -- scope. +memoizeDec f1 a = do + nameRef1 <- qRunIO $ newIORef Map.empty + decsRef1 <- qRunIO $ newIORef [] + let f1' = memoizeDec' nameRef1 decsRef1 (f1 f1') + expr <- f1' a + decs1 <- qRunIO $ readIORef decsRef1 + return $ filterDecs decs1 expr + +-- Unreferenced variables may cause ambiguous types (e.g. "foo = return") +-- that fun afoul of the monomorphism restriction. +-- TODO: filter out recursive definitions by using SCC +filterDecs :: [(Name, Exp)] -> Exp -> ([Dec], Exp) +filterDecs decs expr = (decs', expr) where + decs' = map (\(name, body) -> ValD (VarP name) (NormalB body) []) $ + --decs + filter (\x -> Set.member (fst x) vars) $ decs + vars = Set.unions (varSet expr : map (varSet . snd) decs) + +-- | Simultaneously memoizes two code generation functions. All of +-- the notes about 'memoizeDec' also apply to this function. Most +-- users will want to use 'memoizeExp2' instead of this function as it +-- provides a simplified interface. +memoizeDec2 :: (Quasi m, Ord a, Ord b) + => ((a -> m Exp) -> (b -> m Exp) -> a -> m Exp) + -- ^ The first function to memoize. Takes memoized versions of the + -- two functions as arguments. + -> ((a -> m Exp) -> (b -> m Exp) -> b -> m Exp) + -- ^ The second function to memoize. Takes memoized versions of the + -- two functions as arguments. + -> a -- ^ The initial argument. + -> m ([Dec], Exp) -- ^ The result of applying the function to the + -- initial argument. The |Exp| is the result, but + -- expects the @['Dec']@ to be in scope. +memoizeDec2 f1 f2 a = do + nameRef1 <- qRunIO $ newIORef Map.empty + nameRef2 <- qRunIO $ newIORef Map.empty + decsRef1 <- qRunIO $ newIORef [] + decsRef2 <- qRunIO $ newIORef [] + let f1' = memoizeDec' nameRef1 decsRef1 (f1 f1' f2') + f2' = memoizeDec' nameRef2 decsRef2 (f2 f1' f2') + expr <- f1' a + decs1 <- qRunIO $ readIORef decsRef1 + decs2 <- qRunIO $ readIORef decsRef2 + return $ filterDecs (decs1 ++ decs2) expr + +-- |Memoizes a code generation function. Behaves identically to +-- 'memoizeDec' except that it returns a 'LetE' that binds the 'Dec' +-- resulting from 'memoizeDec' for the 'Exp' resulting from +-- 'memoizeDec'. +memoizeExp :: (Quasi m, Ord a) + => ((a -> m Exp) -> a -> m Exp) + -> a -> m Exp +memoizeExp f1 a = liftM (uncurry LetE) (memoizeDec f1 a) + +-- |Simultaneously memoizes two code generation functions. Behaves +-- identically to 'memoizeDec2' except that it returns a 'LetE' that +-- binds the 'Dec' resulting from 'memoizeDec2' for the 'Exp' +-- resulting from 'memoizeDec2'. +memoizeExp2 :: (Quasi m, Ord a, Ord b) + => ((a -> m Exp) -> (b -> m Exp) -> a -> m Exp) + -> ((a -> m Exp) -> (b -> m Exp) -> b -> m Exp) + -> a -> m Exp +memoizeExp2 f1 f2 a = liftM (uncurry LetE) (memoizeDec2 f1 f2 a) + +-------------------------------------------------------------------------------- +-- Transform traversals +-------------------------------------------------------------------------------- + +-- |Generic recursive transformation (bottom-up) +everywhere :: (Quasi m) + => (Type -> m Exp) -- ^ The transformation. If the 'Type' is @t@, must + -- return an 'Exp' of type @t -> t@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- transformation to each descendant. If + -- 'Type' is @t0@, returns an 'Exp' of type @t0 + -- -> t0@. +everywhere f t0 = t0 >>= memoizeExp rec where + rec r t = composeE (f t) (thmapT r (return t)) + +-- |Generic recursive transformation (top-down) +everywhere' :: (Quasi m) + => (Type -> m Exp) -- ^ The transformation. If the 'Type' is @t@, must + -- return an 'Exp' of type @t -> t@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- transformation to each descendant. If + -- 'Type' is @t0@, returns an 'Exp' of type @t0 + -- -> t0@. +everywhere' f t0 = t0 >>= memoizeExp rec where + rec r t = composeE (thmapT r (return t)) (f t) + +-- |Generic recursive transformation (bottom-up) with selective traversal. +-- Skips traversal when a given query returns 'True'. +everywhereBut :: (Quasi m) + => (Type -> m Bool) -- ^ The query. Should return 'True' when a + -- given type should not be traversed. + -> (Type -> m Exp) -- ^ The transformation. If the 'Type' is @t@, + -- must return an 'Exp' of type @t -> t@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- transformation to each descendant (except + -- for parts skipped due to the query returning + -- 'True'). If the 'Type' is @t0@, returns an + -- 'Exp' of type @t0 -> t0@. +everywhereBut q f t0 = t0 >>= memoizeExp rec where + rec k t = do q' <- q t + if q' then return (VarE 'id) + else composeE (f t) (thmapT k (return t)) + +-- |Generic recursive monadic transformation (bottom-up) +everywhereM :: (Quasi m) + => (Type -> m Exp) -- ^ The monadic transformation. If the 'Type' is @t@, must + -- return an 'Exp' of type @t -> m t@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- transformation to each descendant. If + -- 'Type' is @t0@, returns an 'Exp' of type @t0 + -- -> m t0@. +everywhereM f t0 = t0 >>= memoizeExp rec where + rec r t = composeM (f t) (thmapM r (return t)) + +#if BENCHMARK +everywhereM_slow :: + (Type {- forall a. -} -> Q Exp {- a -> a -}) + -> Q Type {- forall a. -} -> Q Exp {- a -> a -} +everywhereM_slow f t0 = t0 >>= memoizeExp rec where + rec k t = composeM (f t) (thmapM_slow k (return t)) +#endif + +-- | Generic recursive monadic transformation (top-down) +everywhereM' :: (Quasi m) + => (Type -> m Exp) -- ^ The monadic transformation. If the 'Type' is @t@, must + -- return an 'Exp' of type @t -> m t@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- transformation to each descendant. If + -- 'Type' is @t0@, returns an 'Exp' of type @t0 + -- -> m t0@. +everywhereM' f t0 = t0 >>= memoizeExp rec where + rec k t = composeM (thmapM k (return t)) (f t) + + +-- |Generic recursive monadic transformation (top-down) with selective traversal. +-- Skips traversal when a given query returns 'True'. +everywhereButM' :: (Quasi m) + => (Type -> m Bool) -- ^ The query. Should return 'True' when a + -- given type should not be traversed. + -> (Type -> m Exp) -- ^ The monadic transformation. If the 'Type' is @t@, + -- must return an 'Exp' of type @t -> m t@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- monadic transformation to each descendant (except + -- for parts skipped due to the query returning + -- 'True'). If the 'Type' is @t0@, returns an + -- 'Exp' of type @t0 -> m t0@. +everywhereButM' q f t0 = t0 >>= memoizeExp rec where + rec k t = do q' <- q t + if q' then return (VarE 'return) + else composeM (thmapM k (return t)) (f t) + +-- |Generic recursive transformation (bottom-up) with selective +-- traversal. Recurs on only types that can contain a type with type +-- specific behavior. +everywhereFor :: (Quasi m) + => Name -- ^ Name of a function of type @t -> t@ + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- transformation to each descendant that is of + -- type @t@. If the 'Type' is @t0@, returns an + -- 'Exp' of type @t0 -> t0@. +everywhereFor func topTy = do + everywhereBut (liftM not . containsType (argTypeOfName func)) + (const (return (VarE 'id)) `extE` + (eqType (argTypeOfName func), return (VarE func))) topTy + +-- |Generic recursive monadic transformation (bottom-up) with +-- selective traversal. Recurs on only types that can contain a type +-- with type specific behavior. +everywhereForM :: (Quasi m) + => Name -- ^ Name of a function of type @t -> m t@ + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the + -- monadic transformation to each descendant + -- that is of type @t@. If the 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> m t0@. +everywhereForM func topTy = do + everywhereButM' (liftM not . containsType (argTypeOfName func)) + (const (return (VarE 'return)) `extE` + (eqType (argTypeOfName func), return (VarE func))) topTy + +{- +This doesn't work because of the following: + + Dec <---+ + / \ | + ... ... | + / \ | + [Needed] Exp-+ + +It is impossible to know when processing Exp +whether [Needed] will be hit because answering +that requires processing all of the children of +Dec which then requires Exp, etc. + +Memoization does not help this problem. + +-- skip useless recursions +-- Names: everywhereNeeded, everywhereCan, ??? +-- effective, useful, isJust, May, Can +-- We use a state monad instead of a writer monad +-- because the memoization doesn't replay old effects +everywhere_ :: (Quasi m) + => (Type {- forall a. -} -> m (Maybe Exp) {- a -> a -}) + -> m Type {- forall a. -} -> m Exp {- a -> a -} +everywhere_ f t = do t' <- t; (e, _) <- runStateT (memoizeExp rec t') (Set.empty, Set.empty); return e where + --rec :: (Type -> WriterT Any Q Exp) -> Type -> WriterT Any Q Exp + rec k t = do r <- thmapT k' (return t) + f' <- lift $ f t + when (isJust f') (setSelf t) + needsChildren <- needChildren t + case (needsChildren, f') of + (False, Nothing) -> return (VarE 'id) + (True, Nothing) -> return r + (False, Just f'') -> return f'' + (True, Just f'') -> lift $ composeE (return f'') (return r) + where k' t' = do e <- k t' + needSelf t' >>= \x -> when x (setChildren t) + return e + needSelf t = gets (Set.member t . fst) + needChildren t = gets (Set.member t . snd) + setSelf t = modify (\(s1, s2) -> (Set.insert t s1, s2)) + setChildren t = modify (\(s1, s2) -> (s1, Set.insert t s1)) + +everywhereM'_ :: (Quasi m) + => (Type {- forall a. -} -> m (Maybe Exp) {- a -> a -}) + -> m Type {- forall a. -} -> m Exp {- a -> a -} +everywhereM'_ f t = do t' <- t; (e, s) <- runStateT (memoizeExp rec t') (Set.empty, Set.empty); trace (show (Set.toList (fst s), Set.toList (snd s))) $ return e where + --rec :: (Type -> WriterT Any Q Exp) -> Type -> WriterT Any Q Exp + rec1 k t = do f' <- lift $ f t + when (isJust f') (setSelf t f') + thmapM k (return t) + rec2 k t = do r <- thmapM k' (return t) + f' <- lift $ f t + needsChildren <- needChildren t + when needsChildren (setSelf t) + -- TODO: requires "Just"ness of "f" to be idempotent + where k' t' = needSelf t' >>= \x -> when x (setChildren t) >> k t' + +{- + rec k t = do r <- thmapM k' (return t) + f' <- lift $ f t + needsChildren <- needChildren t + trace (" ****** " ++ show (isJust f') ++ show needsChildren ++ show t) $ return () + when (isJust f' || needsChildren) (setSelf t) + case (needsChildren, f') of + (False, Nothing) -> return (VarE 'return) + (True, Nothing) -> return r + (False, Just f'') -> return f'' + (True, Just f'') -> lift $ composeM (return r) (return f'') + where k' t' = do e <- k t' + needSelf t' >>= \x -> when x (setChildren t) + return e + needSelf t = gets (Set.member t . fst) + needChildren t = gets (Set.member t . snd) + setSelf t = modify (\(s1, s2) -> (Set.insert t s1, s2)) + setChildren t = modify (\(s1, s2) -> (s1, Set.insert t s1)) +-} +-} + +{- +-- alternative interface to everywhereNeeded +everywhereBut' :: (Quasi m) + => (Type -> m Bool) + -> (Type {- forall a. -} -> m Exp {- a -> a -}) + -> Type {- forall a. -} -> m Exp {- a -> a -} +everywhereBut' q f t0 = do (e, _) <- runWriterT (memoizeExp rec t0); return e where +-- rec :: (Quasi m) => (Type -> WriterT Any m Exp) -> Type -> WriterT Any m Exp + rec k t = do (r, Any childRec) <- listen (thmapT k (return t)) + q' <- lift $ q t + tell (Any (not q')) + case (childRec, q') of + (False, True) -> return (VarE 'id) + (True, True) -> return r + (False, False) -> lift $ f t + (True, False) -> lift $ composeE (return r) (f t) +-} + + +-- |Generic recursive transformation (bottom-up) with selective traversal. +somewhere :: (Quasi m) + => ((Type -> m Exp) -> (Type -> m (Maybe Exp))) + -- ^ The transformation. The first argument is the memoized + -- recursion. If 'Nothing' is returned, then the standard, + -- automatic recursion is done. If 'Just' is returned, then no + -- automatic recursion is done and the resulting 'Exp' is used at + -- that type. In that case, if further recursion is desired, then + -- the expression should include a call to the memoized recursion. + -- If the 'Type' is @t@, then the returned 'Exp' must be of type @t + -- -> t@. + -- + -- We use 'Maybe' instead of 'MonadPlus' to avoid the user having to + -- play games with 'runMaybeT' and so forth. + -> (m Type -> m Exp) + -- ^ Generates an 'Exp' that applies the transformation to each + -- descendant. If 'Type' is @t0@, returns an 'Exp' of type @t0 -> + -- t0@. +somewhere f t0 = t0 >>= memoizeExp rec where + rec k t = do + f' <- f k t + case f' of + Nothing -> thmapT k (return t) -- `mplus` return (VarE 'id) + Just e -> return e + +-- |Generic recursive monadic transformation (bottom-up) with selective traversal. +somewhereM :: (Quasi m) + => ((Type -> m Exp) -> (Type -> m (Maybe Exp))) + -- ^ The monadic transformation. The first argument is the memoized + -- recursion. If 'Nothing' is returned, then the standard, + -- automatic recursion is done. If 'Just' is returned, then no + -- automatic recursion is done and the resulting 'Exp' is used at + -- that type. In that case, if further recursion is desired, then + -- the expression should include a call to the memoized recursion. + -- If the 'Type' is @t@, then the returned 'Exp' must be of type @t + -- -> m t@. + -- + -- We use 'Maybe' instead of 'MonadPlus' to avoid the user having to + -- play games with 'runMaybeT' and so forth. + -> (m Type -> m Exp) + -- ^ Generates an 'Exp' that applies the transformation to each + -- descendant. If 'Type' is @t0@, returns an 'Exp' of type @t0 -> + -- m t0@. +somewhereM f t0 = t0 >>= memoizeExp rec where + rec k t = do + f' <- f k t + case f' of + Nothing -> thmapM k (return t) + Just e -> return e + +-------------------------------------------------------------------------------- +-- Queries +-------------------------------------------------------------------------------- + +-- |Generic recursive query (bottom-up). +everything :: (Quasi m) + => m Exp -- ^ Combining function. 'Exp' must have type @r -> r -> r@. + -> (Type -> m Exp) -- ^ The query. Extract data from the given + -- type. If the 'Type' is @t@, must return an 'Exp' + -- of type @t -> r'@. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the query + -- to each descendant and uses the combining + -- function to combine the query results. If + -- the 'Type' is @t0@, returns an 'Exp' of type + -- @t0 -> r@. +everything collect query t0 = t0 >>= memoizeExp rec where + rec r t = do + --[|\x -> $(thmapQl collect [|$(query t) x|] r (return t)) x|] + x <- qNewName "x" + f <- query t + mapQ <- thmapQl collect (return (AppE f (VarE x))) r (return t) + return (LamE [VarP x] (AppE mapQ (VarE x))) + +#if BENCHMARK +everything_slow :: (Quasi m) + => (m Exp) -- Combine collections, expr :: c a -> c a -> c a + -> (Type -> m Exp) -- Extract values, expr :: d -> c a + -> m Type -- The top type, the first 'd'. + -> m Exp -- expr :: d -> c a +everything_slow collect query topTy = collect >>= \cExp -> topTy >>= memoizeExp (ething cExp) + where + ething cExp memoF currTy = do + f_curr <- query currTy + f_rest <- thmapQ memoF (return currTy) + x <- qNewName "x" + return (LamE [VarP x] + (AppE + (AppE (AppE (VarE 'foldl) cExp) + (AppE f_curr (VarE x))) + (AppE f_rest (VarE x)))) +#endif + +-- |Generic recursive query with left-associative accumulation. +everythingAccL + :: (Type -> Q Exp) -- ^ The query and combining function. If the + -- 'Type' is @t@, must return an 'Exp' of type @t + -- -> r -> r@. + -> (Q Type -> Q Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant. If 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> r -> r@ +everythingAccL query t0 = t0 >>= memoizeExp rec + where + rec memoF currTy = do + e <- query currTy + [|\x acc -> $(return e) x ($(thcase (g [|acc|]) (return currTy)) x)|] + where -- Left accumulator + g acc _ctor [] = acc + g acc ctor ((t, v):vs) = [|$(memoF t) $v $(g acc ctor vs)|] + +-- |Generic recursive query with strict left-associative accumulation +everythingAccL' + :: (Type -> Q Exp) -- ^ The query and combining function. If the + -- 'Type' is @t@, must return an 'Exp' of type @t + -- -> r -> r@. + -> (Q Type -> Q Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant. If 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> r -> r@ +everythingAccL' query t0 = t0 >>= memoizeExp rec + where + rec memoF currTy = do + e <- query currTy + [|\x acc -> $(return e) x ($(thcase (g [|acc|]) (return currTy)) x)|] + where -- Left accumulator + g acc _ctor [] = acc + g acc ctor ((t, v):vs) = [|$acc `seq` $(memoF t) $v $(g acc ctor vs)|] + + +-- |Generic recursive query with left-associative accumulation and selective traversal +everythingButAccL + :: (Type -> Q (Exp, Bool)) + -- ^ The query, combining, selectivity function. If the 'Type' is + -- @t@, must return an 'Exp' of type @t -> r -> r@. If the 'Bool' + -- is 'True' the traversal does not proceed further into the + -- recursion. + -> (Q Type -> Q Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant. If 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> r -> r@ +everythingButAccL query t0 = t0 >>= memoizeExp rec + where + rec memoF currTy = do + (e, stop) <- query currTy + if stop then return e + else [|\x acc -> $(return e) x ($(thcase (g [|acc|]) (return currTy)) x)|] + where -- Left accumulator + g acc _ctor [] = acc + g acc ctor ((t, v):vs) = [|$(memoF t) $v $(g acc ctor vs)|] + +-- |Generic recursive query with strict left-associative accumulation and selective traversal +everythingButAccL' + :: (Type -> Q (Exp, Bool)) + -- ^ The query, combining, selectivity function. If the 'Type' is + -- @t@, must return an 'Exp' of type @t -> r -> r@. If the 'Bool' + -- is 'True' the traversal does not proceed further into the + -- recursion. + -> (Q Type -> Q Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant. If 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> r -> r@ +everythingButAccL' query t0 = t0 >>= memoizeExp rec + where + rec memoF currTy = do + (e, stop) <- query currTy + if stop then return e + else [|\x acc -> $(return e) x ($(thcase (g [|acc|]) (return currTy)) x)|] + where -- Left accumulator + g acc _ctor [] = acc + g acc ctor ((t, v):vs) = [|$acc `seq` $(memoF t) $v $(g acc ctor vs)|] + +-- |Generic recursive query with right-associative accumulation +everythingAccR + :: (Type -> Q Exp) -- ^ The query and combining function. If the + -- 'Type' is @t@, must return an 'Exp' of type @t + -- -> r -> r@. + -> (Q Type -> Q Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant. If 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> r -> r@ +everythingAccR query t0 = t0 >>= memoizeExp rec + where + rec memoF currTy = do + e <- query currTy + [|\x acc -> $(return e) x ($(thcase (g [|acc|]) (return currTy)) x)|] + where -- Right accumulator + g acc _ctor [] = acc + g acc ctor ((t, v):vs) = g [|$(memoF t) $v $acc|] ctor vs + +-- |Generic recursive query with right-associative accumulation and selective traversal +everythingButAccR + :: (Type -> Q (Exp, Bool)) + -- ^ The query, combining, selectivity function. If the 'Type' is + -- @t@, must return an 'Exp' of type @t -> r -> r@. If the 'Bool' + -- is 'True' the traversal does not proceed further into the + -- recursion. + -> (Q Type -> Q Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant. If 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> r -> r@ +everythingButAccR query t0 = t0 >>= memoizeExp rec + where + rec memoF currTy = do + (e, stop) <- query currTy + if stop then return e + else [|\x acc -> $(return e) x ($(thcase (g [|acc|]) (return currTy)) x)|] + where -- Right accumulator + g acc _ctor [] = acc + g acc ctor ((t, v):vs) = g [|$(memoF t) $v $acc|] ctor vs + +-- |Generic recursive query with selective traversal +everythingBut :: (Quasi m) + => (m Exp) -- ^ Combining function. 'Exp' must have type @r -> r -> r@. + -> (Type -> m (Exp,Bool)) + -- ^ The query, combining, selectivity function. If the 'Type' is + -- @t@, must return an 'Exp' of type @t -> r -> r@. If the 'Bool' + -- is 'True' the traversal does not proceed further into the + -- recursion. + -> (m Type -> m Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant. If 'Type' is @t0@, + -- returns an 'Exp' of type @t0 -> r@ +everythingBut collect query topTy = topTy >>= memoizeExp rec + where + rec memoF currTy = do + x <- qNewName "x" + (f_curr,b) <- query currTy + if b then return f_curr + else do mapQ <- thmapQl collect (return (AppE f_curr (VarE x))) memoF (return currTy) + return (LamE [VarP x] (AppE mapQ (VarE x))) + +-- |Generic recursive traversal using left-associative accumulation +everythingForL + :: Name -- ^ Name of a function of type @t -> r -> r@ + -> (Q Type -> Q Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant that is of type @t@. If + -- 'Type' is @t0@, returns an 'Exp' of type @t0 + -- -> r -> r@ +everythingForL func topTy = do + a1 <- argTypeOfName func + let op = VarE func + g t = do + b <- eqType (return a1) t + c <- containsType (return a1) t + if b then return (op, not c) + else return (AppE (VarE 'const) (VarE 'id), not c) + everythingButAccL g topTy + +-- |Generic recursive traversal using strict left-associative accumulation +everythingForL' + :: Name -- ^ Name of a function of type @t -> r -> r@ + -> (Q Type -> Q Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant that is of type @t@. If + -- 'Type' is @t0@, returns an 'Exp' of type @t0 + -- -> r -> r@ +everythingForL' func topTy = do + a1 <- argTypeOfName func + let op = VarE func + g t = do + b <- eqType (return a1) t + c <- containsType (return a1) t + if b then return (op, not c) + else return (AppE (VarE 'const) (VarE 'id), not c) + everythingButAccL' g topTy + +-- |Generic recursive traversal using right-associative accumulation +everythingForR + :: Name -- ^ Name of a function of type @t -> r -> r@ + -> (Q Type -> Q Exp) -- ^ Generates an 'Exp' that applies the query + -- to each decendant that is of type @t@. If + -- 'Type' is @t0@, returns an 'Exp' of type @t0 + -- -> r -> r@ +everythingForR func topTy = do + a1 <- argTypeOfName func + let op = VarE func + g t = do + b <- eqType (return a1) t + c <- containsType (return a1) t + if b then return (op, not c) + else do h <- [|const id|] + return (h, not c) + everythingButAccR g topTy + +-------------------------------------------------------------------------------- +-- implementing "mkT" and friends +-------------------------------------------------------------------------------- + +{- + +In general "mkT" is simply a partially applied "extT" as in the +following thus we focus the description on "extT". + +mkT :: Type -> ExpQ -> (Type -> ExpQ) +mkT = extT (const [|id|]) + +The naive implementation of "extT" simply tests for type equality as +in the following. However, this would fail to treat "String" and +"[Char]" as equal. + +extT :: (Type -> ExpQ) -> Type -> ExpQ -> Type -> ExpQ +extT def t ext t' | t' == t = ext + | otherwise = def t' + +-} + +{- + +Since there are multiple notions of type equality (e.g. by name, exact +equality, instantiability, etc.), we do not write an "extT" version +for each. Instead we parameterize by the equality predicate. + +We pair the predicate with the function to use when that predicate is +true rather than passing them as separate arguments so that "extT" is +easier to use infix. An alternative would be to play with the +precedence. + +-} + +-- |Returns the type of a variable, method or constructor name. +typeOfName :: (Quasi m) => Name -> m Type +typeOfName n = do + info <- qReify n + case info of + DataConI _ ty _ _ -> return ty + VarI _ ty _ _ -> return ty + ClassOpI _ ty _ _ -> return ty + _ -> fail $ "'typeOfName' only applies to classes, variables, " ++ + "and constructors that are in the current environment, but " ++ + "was applied to :" ++ show n + +-- |Returns the type of the first argument of a variable, method or constructor name. +argTypeOfName :: (Quasi m) => Name -> m Type +argTypeOfName n = do + t <- typeOfName n + let getArg (AppT (AppT ArrowT t') _) = return t' + getArg (ForallT _ _ t') = getArg t' + getArg _ = fail $ "'argTypeOfName' applied to `" ++ show n ++ + " which has non-function type `" ++ show t ++ "'." + getArg t + +-- |Extends a generic operation with type specific behavior based on the type of the given name. +extN :: (Quasi m) + => (Type -> m Exp) -- ^ The operation to be extended. + -> Name -- ^ Name of the function implementing the type specific behavior. + -> (Type -> m Exp) + -- ^ The result of extending the operation. If the 'Name' has type + -- @t -> s@, then the extended operation has type specific behavior + -- at @t@. At other types it behaves as the original operation. +extN def name t0 = + extE def (eqType t', return (VarE name)) t0 + where t' = do ty <- typeOfName name + ty' <- argTypeOfName name + when (hasFreeVars ty') $ fail $ + "Underspecified type when using extN (or something based on it).\n" ++ + " A type variable or forall occurs in the type of the first argument to `" ++ show name ++ "'.\n" ++ + " Namely, `" ++ pprint ty' ++ "'\n" ++ + " in the type `"++ pprint ty++"'." + return ty' + + hasFreeVars (VarT _) = True + hasFreeVars (ForallT _tyVarBndrs _cxt _ty) = True + hasFreeVars (ConT _) = False + hasFreeVars (TupleT _) = False + hasFreeVars (ArrowT) = False + hasFreeVars (ListT) = False + hasFreeVars (AppT t1 t2) = hasFreeVars t1 || hasFreeVars t2 + hasFreeVars (SigT t _kind) = hasFreeVars t + +-- |Extends a generic operation with type specific behavior. +extE :: (Quasi m) + => (Type -> m exp) -- ^ The operation to be extended. + -> (Type -> m Bool, m exp) + -- ^ The 'fst' of the pair should return 'True' on types for which + -- the operation should be extended. The 'snd' of the pair is the + -- expression to use on those types. + -> (Type -> m exp) -- ^ The result of extending the operation. +extE def (typePred, ext) t = extE' def (typePred, const ext) t + +-- |Extends a generic operation with type specific behavior. +extE' :: (Quasi m) + => (Type -> m exp) -- ^ The operation to be extended. + -> (Type -> m Bool, Type -> m exp) + -- ^ The 'fst' of the pair should return 'True' on types for which + -- the operation should be extended. The 'snd' of the pair when given one of these 'Type's + -- should return the expression to use on that type. + -> (Type -> m exp) -- ^ The result of extending the operation. +extE' def (typePred, ext) t = do test <- typePred t + if test then ext t else def t + +-- |Makes a transformation from a named function. +mkT :: (Quasi m) + => Name -- ^ Name of a function of type @t -> t@ + -> (Type -> m Exp) -- ^ The generic transformation. If the 'Type' + -- is @t0@, then the 'Exp' has type @t0 -> t0@. + -- The 'Exp' is the named function at @t@, and + -- 'id' elsewhere. +mkT f = mkTs [f] + +-- |Makes a transformation from several named functions. +mkTs :: (Quasi m) + => [Name] -- ^ Names of functions of type @t -> t@ for various @t@. + -> (Type -> m Exp) -- ^ The generic transformation. If the 'Type' + -- is @t0@, then the 'Exp' has type @t0 -> t0@. + -- If one of the named functions matches @t0@, + -- then 'Exp' is that function. Otherwise, it is + -- 'id'. +mkTs = mkXs (return (VarE 'id)) + +-- |Makes a monadic transformation from a named function. +mkM :: (Quasi m) + => Name -- ^ Name of a function of type @t -> m t@ + -> (Type -> m Exp) -- ^ The generic monadic transformation. If the 'Type' + -- is @t0@, then the 'Exp' has type @t0 -> m t0@. + -- The 'Exp' is the named function at @t@, and + -- 'return' elsewhere. +mkM f = mkMs [f] + +-- |Makes a monadic transformation from several named functions. +mkMs :: (Quasi m) + => [Name] -- ^ Names of functions of type @t -> m t@ for various @t@. + -> (Type -> m Exp) -- ^ The generic monadic transformation. If the 'Type' + -- is @t0@, then the 'Exp' has type @t0 -> m t0@. + -- If one of the named functions matches @t0@, + -- then 'Exp' is that function. Otherwise, it is + -- 'return'. +mkMs = mkXs (return (VarE 'return)) + +-- |Makes a query from a named function. +mkQ :: (Quasi m) + => m Exp -- ^ Default value to return on types other than @t@. + -- The 'Exp' must be of type @r@. + -> Name -- ^ Name of a function of type @t -> r@ + -> (Type -> m Exp) -- ^ The generic transformation. If the 'Type' + -- is @t0@, then the 'Exp' has type @t0 -> r@. + -- The 'Exp' is the named function at @t@, and + -- the provided default value elsewhere. +mkQ z f t = mkQs z [f] t + +-- |Makes a query from several named functions. +mkQs :: (Quasi m) + => m Exp -- ^ Default value to return on types that do not + -- match the @t@ from any named function. The + -- 'Exp' must be of type @r@. + -> [Name] -- ^ Names of functions of type @t -> r@ for various @t@. + -> (Type -> m Exp) -- ^ The generic query. If the 'Type' + -- is @t0@, then the 'Exp' has type @t0 -> r@. + -- If one of the named functions matches @t0@, + -- then 'Exp' is that function. Otherwise, it is + -- 'const' of the provided default value. +mkQs zM = mkXs (zM >>= \z -> return (AppE (VarE 'const) z)) + +-- |Makes operations from several named functions. +mkXs :: (Quasi m) + => m Exp -- ^ Default function for types that do not + -- match the @t@ from any named function. The + -- 'Exp' must be of type @c t@. + -> [Name] -- ^ Names of functions of type @c t@ for various @t@. + -> (Type -> m Exp) -- ^ The generic query. If the 'Type' + -- is @t0@, then the 'Exp' has type @c t0@. + -- If one of the named functions matches @t0@, + -- then 'Exp' is that function. Otherwise, it is + -- the provided default function. +mkXs zM [] = const zM +mkXs zM (f:fs) = extN (mkXs zM fs) f + + +{- TODO: + +-- name vs expr +-- for expr: type predicate vs not +-- single vs plural + +-- extF appears pointless though it I think it is actually useful (thus omit from paper?) +extF :: ( Type{-|c|-}-> Q Exp{-|c -> h c|-}) + -> (Q Type{-|b|-}, Type -> Q Exp{-|b -> h b|-}) + -> Type{-|a|-} -> Q Exp{-|a -> h a|-} + +extNs :: (Type{-|c|-}-> Q Exp{-|c -> h c|-}) + -> [Name]{-|b -> h b|-} + -> Type{-|a|-}-> Q Exp{-|a -> h a|-} +extEs :: (Type -> Q Exp) + -> ([Q Type], Q Exp) + -> Type -> Q Exp + +extFs :: (Type -> Q Exp) + -> ([Q Type], Type -> Q Exp) + -> Type -> Q Exp + + +ext? :: (Quasi m) + => (Type -> m exp) + -> (Q Type, m exp) + -> Type -> m exp + +ext?s :: (Quasi m) + => (Type -> m exp) + -> ([Q Type], m exp) + -> Type -> m exp + +ext? :: (Quasi m) + => (Type -> m exp) + -> (Q Type, Type -> m exp) + -> Type -> m exp + +--TODO: extT' that doesn't take a type in the "ext" +extT' :: (Quasi m) + => (Type -> m exp) + -> (Type -> m Bool, m exp) + -> Type -> m exp +extT' = extE + +-} + +-------------------------------------------------------------------------------- +-- Type equality and containment +-------------------------------------------------------------------------------- + +-- |Tests if two types are equal modulo type synonyms and kind +-- annotations. Naive equality would fail to equate "String" and +-- "[Char]". +eqType :: (Quasi m) => m Type -> Type -> m Bool +eqType t1 t2 = do t1' <- expandType =<< t1 + t2' <- expandType t2 + return $ t1' == t2' + +-- |Test if any of a list of types is equal to a particular type +-- modulo type synonyms and kind annotations. Useful when multiple +-- types share the same type-specific behavior. +eqTypes :: (Quasi m) => [m Type] -> Type -> m Bool +eqTypes ts t = liftM or $ mapM (flip eqType t) ts + +-- |@containsType t1 t2 = True@ iff @t1@ is (even recursively) inside @t2@ +containsType :: (Quasi m) => m Type -> Type -> m Bool +containsType t1 t2 = + evalStateT (flip rec t2 =<< lift (expandType =<< t1)) Set.empty where + rec t1 t2 = do + t2' <- expandType t2 + s <- gets (Set.member t2') + if s then return False -- We've already seen and checked this type + else if t1 == t2' then return True -- We found a matching type + else do modify (Set.insert t2') -- Remember that we were here + ctors <- constructorsOf t2' -- We need to recur on the constructors + case ctors of + Nothing -> return False -- It's a function or primitive type + Just ctors' -> check t1 (concatMap snd ctors') -- Now we recur + check _t1 [] = return False + check t1 (t : ts) = do + t' <- rec t1 t + if t' then return True else check t1 ts + +-- |@containsTypes ts t2 = True@ iff any of @ts@ is (even recursively) inside @t2@ +containsTypes :: (Quasi m) => [m Type] -> Type -> m Bool +containsTypes t1qs t2 = fmap or (mapM (`containsType` t2) t1qs) + +-------------------------------------------------------------------------------- +-- Internal utilities +-------------------------------------------------------------------------------- + +---------------------------------------- +-- Constructor queries +---------------------------------------- + +-- We treat these types as primitive. They were generated from the list of +-- instances of the Data.Data class that have unboxed arguments. +primTypes :: [Name] +primTypes = [ + ''Char, + ''Double, + ''Float, + ''Int, + ''Int8, + ''Int16, + ''Int32, + ''Int64, + ''Integer, + ''Word, + ''Word8, + ''Word16, + ''Word32, + ''Word64, + ''Ptr, + ''ForeignPtr, + ''Array] + +-- |Returns the constructors of a given type. +-- Returns @Nothing@ if the type is primitive. +constructorsOf :: (Quasi m) => Type -> m (Maybe [(Name, [Type])]) +constructorsOf t = do + c <- getCtors t [] + case c of + Left _ -> return $ Nothing + Right c' -> return $ Just (map f c') + where f (name, ts) = (name, map snd ts) + +-- getCtors is used to implement constructorsOf. +-- +-- getCtors returns all the information about the constructors of the +-- type. In constructorsOf, we limit our selves to the useful +-- information. +-- +-- getCtors must dive into the lhs of type applications app to get +-- constructors and then substitute appropriately +getCtors :: (Quasi m) => Type -> [Type] -> m (Either (Int, Bool) [(Name, [(Strict, Type)])]) +getCtors (ForallT _tyVarBndrs _cxt ty) [] = getCtors ty [] -- needs in-scope variables? +getCtors (VarT name) _ = fail $ "constructorsOf: type variable `"++show name++"' in head position of type application" +getCtors (ConT name) _args | name `elem` primTypes = return $ Left (0, False) +getCtors (ConT name) args = do +-- TODO: check arg count + t <- qReify name + case t of + TyConI (DataD _cxt _tyName tyVarBndrs cons _derive) -> + return $ Right $ map (doCons tyVarBndrs) cons + TyConI (NewtypeD _cxt _tyName tyVarBndrs con _derive) -> + return $ Right [doCons tyVarBndrs con] + TyConI (TySynD _tyName tyVarBndrs ty) -> + getCtors (subst (zip tyVarBndrs args) ty) (drop (length tyVarBndrs) args) + PrimTyConI _name arity isUnLifted -> return $ Left (arity, isUnLifted) + -- PrimTyConI handles types that can't be expressed with a data type such as (->), Int# + _ -> fail $ "Attempt to call `constructorsOf' on non-type: " ++ (show t) + where doCons bndrs (NormalC name' ts) = + (name', [(strict, subst (zip bndrs args) t) | (strict, t) <- ts]) + doCons bndrs (InfixC t1 name' t2) = + doCons bndrs (NormalC name' [t1, t2]) + doCons bndrs (RecC name' ts) = + doCons bndrs (NormalC name' (map (\ (_, s, t) -> (s, t)) ts)) + --doCons bndrs (ForallC tyVarBndrs cxt con) = fail $ "GADT constructor found in "++show name++", but GADTs are not (yet) supported" + -- TODO: gadt in ForallC +-- foo (ClassP name' tys) = ... +-- foo (EqP ty1 ty2) + -- data Foo a b c = forall d e f. (a ~ b, c ~ Int) => Foo1 a b e f +getCtors (TupleT n) args | n == length args = + return $ Right [(tupleDataName n, [(NotStrict, t) | t <- args])] +getCtors (ArrowT) [_t1, _t2] = return $ Left (2, False) -- constants taken from "reify ''(->)" +getCtors (ListT) [t] = + return $ Right [('[], []), ('(:), [(NotStrict, t), (NotStrict, AppT ListT t)])] +getCtors (AppT t1 t2) args = getCtors t1 (t2 : args) +getCtors (SigT t _kind) args = getCtors t args +getCtors t args = + fail $ "constructorsOf: wrong number of arguments passed to type constructor\n" ++ + " Constructor: " ++ show t ++ "\n" ++ + " Arguments: " ++ show args ++ "\n" + +-- Apply a substitution (a.k.a. a list of type-variable bindings) to a type. +-- +-- Note: Predicates might be able to be simplified as a result of the +-- substitution, but this function does not perform that +-- simplification. +subst :: [(TyVarBndr, Type)] -> Type -> Type +subst env0 t0 = subst' [(stripKind bndr, Just t) | (bndr, t) <- env0] t0 where + stripKind (PlainTV name) = name + stripKind (KindedTV name _kind) = name + + subst' :: [(Name, Maybe Type)] -> Type -> Type + subst' env (ForallT tyVarBndrs cxt t) = + ForallT tyVarBndrs + (map (substPred env) cxt) + (subst' ([(stripKind bndr, Nothing) | bndr <- tyVarBndrs] ++ env) t) + subst' env t@(VarT name) | Just (Just t') <- lookup name env = t' + | otherwise = t + subst' env (AppT t1 t2) = AppT (subst' env t1) (subst' env t2) + subst' env (SigT t kind) = SigT (subst' env t) kind + subst' _ t@(ConT _) = t + subst' _ t@(TupleT _) = t + subst' _ t@(ArrowT) = t + subst' _ t@(ListT) = t + + substPred env (ClassP name ts) = ClassP name (map (subst' env) ts) + substPred env (EqualP t1 t2) = EqualP (subst' env t1) (subst' env t2) + +---------------------------------------- +-- Type expansion +---------------------------------------- + +-- | Expands all type synonyms in its argument. Also strips all kind +-- annotations since those might be incorrect once type synonyms are +-- applied to their arguments. +expandType :: (Quasi m) => Type -> m Type +expandType t = expandType' t [] + +-- most of these clauses can be written cleaner using [t| ... |] quotes +-- but then we couldn't use "Quasi m" and would only work on "Q". +-- +-- This code does not check arity and may produce unexpected results +-- in the presence of partially applied type synonyms. +expandType' :: (Quasi m) => Type -> [Type] -> m Type +expandType' (ForallT tyVarBndrs cxt ty) args = do + cxt' <- mapM doCxt cxt + ty' <- expandType' ty [] + let t' = ForallT tyVarBndrs cxt' ty' + return $ foldl AppT t' args + where doCxt (ClassP name tys) = liftM (ClassP name) (mapM (flip expandType' []) tys) + doCxt (EqualP t1 t2) = liftM2 EqualP (expandType' t1 []) (expandType' t2 []) +expandType' (VarT name) args = return $ foldl AppT (VarT name) args +expandType' (ConT name) args = do + t <- qReify name + let nonSynonym = return $ foldl AppT (ConT name) args + case t of + TyConI (TySynD _name tyVarBndrs ty) -> + expandType' (subst (zip tyVarBndrs args) ty) (drop (length tyVarBndrs) args) + TyConI (DataD {}) -> nonSynonym + TyConI (NewtypeD {}) -> nonSynonym + PrimTyConI {} -> nonSynonym +expandType' (TupleT n) args = return $ foldl AppT (TupleT n) args +expandType' (ArrowT) args = return $ foldl AppT (ArrowT) args +expandType' (ListT) args = return $ foldl AppT (ListT) args +expandType' (AppT t1 t2) args = do t2' <- expandType' t2 [] + expandType' t1 (t2' : args) +expandType' (SigT t _kind) args = expandType' t args + +---------------------------------------- +-- Common error messages +---------------------------------------- + +-- We don't yet implement tests for polymorphic and quantified types +-- for two reasons: +-- * First, testing the equivalence of Cxt on a "forall" requires a +-- class solver which is beyond the scope of this project +-- * Second, even with empty Cxt, it is hard to define exactly what +-- as equal "forall"s. For example, are "forall a b. (a, b)" and +-- "forall b a. (a, b)" equal? What about "forall a. a -> a" and +-- "forall a b. b -> b" or "forall a. Int" and "Int"? Or "forall +-- a. ([a], a -> a)" and "forall c d. ([c], d -> d)"? +-- SYB also does not have strong support for polymorphic and +-- quantified types, so this problem is not unique to this system. +{- +failForall :: (Monad m) => String -> Type -> m a +failForall functionName t = + fail $ functionName ++ + ": Comparing polymorphic or quantified types is not (yet) implemented." ++ + " Found `" ++ pprint t ++ "'." +-} + +---------------------------------------- +-- Function and monadic composition +---------------------------------------- + +-- | A helper function: @composeE f g = [| $(f) . $(g) |]@. +-- Though this works for any 'Quasi' monad and not just 'Q'. +composeE :: (Quasi m) => m Exp -> m Exp -> m Exp +composeE f1 f2 = do + f1' <- f1 + f2' <- f2 + x <- qNewName "x" + return (LamE [VarP x] (AppE f1' (AppE f2' (VarE x)))) + --[|\x -> f1 (f2 x)|] + +-- | A helper function: |@composeM f g = [| $(f) <=< $(g) |]@. +-- Though this works for any 'Quasi' monad and not just 'Q'. +composeM :: (Quasi m) => m Exp -> m Exp -> m Exp +composeM f1 f2 = do + f1' <- f1 + f2' <- f2 + x <- qNewName "x" + return (LamE [VarP x] (InfixE (Just (AppE f2' (VarE x))) (VarE '(>>=)) (Just f1'))) + --[|\x -> f2 x >>= f1|] + + +-------------------------------------------------------------------------------- +-- TODO +-------------------------------------------------------------------------------- + +{- + +- Support for GADTs +- (NOTE) the M of gmapMp becomes an object level monad, but the "p" is meta-level + +- version of "somewhere" that doesn't recur where useless + +- version of "somewhere" where (MonadPlus m) => m (Exp, Bool) (True means recur) + +- note that recurive calls to everything may not terminate + for that use "memoizeExp" directly + +-- TODO: memoizeDecIO :: (a -> b) -> IO (a -> IO b) +-- can't be done because of qNewName + +-- TODO: memoize via thunks + +-- TODO: explain implementation of memoize instead of just interface + +-- memoizeDec3, memoizeDec4, etc. +-- memoizeExp3, memoizeExp4, etc. +-- TODO: generate 2, 3, 4, 5, 6, 7, 8, and 9 via Template Haskell + +-- TODO: remove "T/M/Q" suffix and replace the "'" suffix with a letter +-- TODO: suffixes: by name vs by type predicate; passing type vs not (only for type pred version) + +-- extByName +-- extC +-- extWithType + +-} diff --git a/Data/Generics/TH/Instances.hs b/Data/Generics/TH/Instances.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/TH/Instances.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP, StandaloneDeriving #-} +{-# OPTIONS_GHC -W -Wall -fno-warn-orphans #-} +module Data.Generics.TH.Instances({- only class instances are exported -}) where + +import Control.Monad.Error +import Control.Monad.List +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Control.Monad.Trans.Maybe +import Language.Haskell.TH.Syntax hiding (lift) + +-------------------------------------------------------------------------------- +-- Instance of Ord that are useful but missing from Language.Haskell.TH +-------------------------------------------------------------------------------- + +deriving instance Ord Exp +deriving instance Ord Dec +deriving instance Ord Type +deriving instance Ord Pat + +deriving instance Ord Body +deriving instance Ord Callconv +deriving instance Ord Clause +deriving instance Ord Con +deriving instance Ord FamFlavour +deriving instance Ord Foreign +deriving instance Ord FunDep +deriving instance Ord Guard +deriving instance Ord InlineSpec +deriving instance Ord Kind +deriving instance Ord Lit +deriving instance Ord Match +deriving instance Ord Pragma +deriving instance Ord Pred +deriving instance Ord Range +deriving instance Ord Safety +deriving instance Ord Stmt +deriving instance Ord Strict +deriving instance Ord TyVarBndr + +-------------------------------------------------------------------------------- +-- Quasi instances for monad transformers +-------------------------------------------------------------------------------- +instance (Quasi m, Error e) => Quasi (ErrorT e m) where + qNewName s = lift $ qNewName s + qReport b s = lift $ qReport b s + qRecover m1 m2 = ErrorT $ runErrorT m1 `qRecover` runErrorT m2 + qReify n = lift $ qReify n +#if __GLASGOW_HASKELL__ >= 700 && __GLASGOW_HASKELL__ < 704 + qClassInstances n ts = lift $ qClassInstances n ts +#endif + qLocation = lift $ qLocation + qRunIO m = lift $ qRunIO m + +instance (Quasi m) => Quasi (ListT m) where + qNewName s = lift $ qNewName s + qReport b s = lift $ qReport b s + qRecover m1 m2 = Control.Monad.List.ListT $ runListT m1 `qRecover` runListT m2 + qReify n = lift $ qReify n +#if __GLASGOW_HASKELL__ >= 700 && __GLASGOW_HASKELL__ < 704 + qClassInstances n ts = lift $ qClassInstances n ts +#endif + qLocation = lift $ qLocation + qRunIO m = lift $ qRunIO m + +instance (Quasi m) => Quasi (ReaderT r m) where + qNewName s = lift $ qNewName s + qReport b s = lift $ qReport b s + qRecover m1 m2 = ReaderT $ \r -> runReaderT m1 r `qRecover` runReaderT m2 r + qReify n = lift $ qReify n +#if __GLASGOW_HASKELL__ >= 700 && __GLASGOW_HASKELL__ < 704 + qClassInstances n ts = lift $ qClassInstances n ts +#endif + qLocation = lift $ qLocation + qRunIO m = lift $ qRunIO m + +instance (Quasi m) => Quasi (StateT s m) where + qNewName s = lift $ qNewName s + qReport b s = lift $ qReport b s + qRecover m1 m2 = StateT $ \s -> runStateT m1 s `qRecover` runStateT m2 s + qReify n = lift $ qReify n +#if __GLASGOW_HASKELL__ >= 700 && __GLASGOW_HASKELL__ < 704 + qClassInstances n ts = lift $ qClassInstances n ts +#endif + qLocation = lift $ qLocation + qRunIO m = lift $ qRunIO m + +instance (Quasi m, Monoid w) => Quasi (WriterT w m) where + qNewName s = lift $ qNewName s + qReport b s = lift $ qReport b s + qRecover m1 m2 = WriterT $ runWriterT m1 `qRecover` runWriterT m2 + qReify n = lift $ qReify n +#if __GLASGOW_HASKELL__ >= 700 && __GLASGOW_HASKELL__ < 704 + qClassInstances n ts = lift $ qClassInstances n ts +#endif + qLocation = lift $ qLocation + qRunIO m = lift $ qRunIO m + +-- TODO: other possible monad instances +-- ((->) r) +-- Maybe +-- IO + +instance (Quasi m) => Quasi (MaybeT m) where + qNewName s = lift $ qNewName s + qReport b s = lift $ qReport b s + qRecover m1 m2 = MaybeT $ runMaybeT m1 `qRecover` runMaybeT m2 + qReify n = lift $ qReify n +#if __GLASGOW_HASKELL__ >= 700 && __GLASGOW_HASKELL__ < 704 + qClassInstances n ts = lift $ qClassInstances n ts +#endif + qLocation = lift $ qLocation + qRunIO m = lift $ qRunIO m diff --git a/Data/Generics/TH/VarSet.hs b/Data/Generics/TH/VarSet.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/TH/VarSet.hs @@ -0,0 +1,205 @@ +-- Do not edit. This file is generated by "util/makeVarSet.hs". +{-# OPTIONS_GHC -W -Wall #-} +module Data.Generics.TH.VarSet (varSet) where +import Language.Haskell.TH.Syntax +import GHC.Base +import qualified Data.Set as Set +import qualified Data.Maybe +accVarRef :: Exp -> Set.Set Name -> Set.Set Name +accVarRef (VarE n) set = Set.insert n set +accVarRef _ set = set +varSet :: Exp -> Set.Set Name +varSet e_0 = (let memoized_1 = \x_2 acc_3 -> accVarRef x_2 ((\_x_4 -> case _x_4 of + Language.Haskell.TH.Syntax.VarE arg_5 -> memoized_6 arg_5 acc_3 + Language.Haskell.TH.Syntax.ConE arg_7 -> memoized_6 arg_7 acc_3 + Language.Haskell.TH.Syntax.LitE arg_8 -> memoized_9 arg_8 acc_3 + Language.Haskell.TH.Syntax.AppE arg_10 + arg_11 -> memoized_1 arg_10 (memoized_1 arg_11 acc_3) + Language.Haskell.TH.Syntax.InfixE arg_12 + arg_13 + arg_14 -> memoized_15 arg_12 (memoized_1 arg_13 (memoized_15 arg_14 acc_3)) + Language.Haskell.TH.Syntax.LamE arg_16 + arg_17 -> memoized_18 arg_16 (memoized_1 arg_17 acc_3) + Language.Haskell.TH.Syntax.TupE arg_19 -> memoized_20 arg_19 acc_3 + Language.Haskell.TH.Syntax.CondE arg_21 + arg_22 + arg_23 -> memoized_1 arg_21 (memoized_1 arg_22 (memoized_1 arg_23 acc_3)) + Language.Haskell.TH.Syntax.LetE arg_24 + arg_25 -> memoized_26 arg_24 (memoized_1 arg_25 acc_3) + Language.Haskell.TH.Syntax.CaseE arg_27 + arg_28 -> memoized_1 arg_27 (memoized_29 arg_28 acc_3) + Language.Haskell.TH.Syntax.DoE arg_30 -> memoized_31 arg_30 acc_3 + Language.Haskell.TH.Syntax.CompE arg_32 -> memoized_31 arg_32 acc_3 + Language.Haskell.TH.Syntax.ArithSeqE arg_33 -> memoized_34 arg_33 acc_3 + Language.Haskell.TH.Syntax.ListE arg_35 -> memoized_20 arg_35 acc_3 + Language.Haskell.TH.Syntax.SigE arg_36 + arg_37 -> memoized_1 arg_36 (memoized_38 arg_37 acc_3) + Language.Haskell.TH.Syntax.RecConE arg_39 + arg_40 -> memoized_6 arg_39 (memoized_41 arg_40 acc_3) + Language.Haskell.TH.Syntax.RecUpdE arg_42 + arg_43 -> memoized_1 arg_42 (memoized_41 arg_43 acc_3)) x_2) + memoized_41 = \x_44 acc_45 -> GHC.Base.const GHC.Base.id x_44 ((\_x_46 -> case _x_46 of + [] -> acc_45 + (:) arg_47 + arg_48 -> memoized_49 arg_47 (memoized_41 arg_48 acc_45)) x_44) + memoized_49 = \x_50 acc_51 -> GHC.Base.const GHC.Base.id x_50 ((\_x_52 -> case _x_52 of + (,) arg_53 + arg_54 -> memoized_6 arg_53 (memoized_1 arg_54 acc_51)) x_50) + memoized_34 = \x_55 acc_56 -> GHC.Base.const GHC.Base.id x_55 ((\_x_57 -> case _x_57 of + Language.Haskell.TH.Syntax.FromR arg_58 -> memoized_1 arg_58 acc_56 + Language.Haskell.TH.Syntax.FromThenR arg_59 + arg_60 -> memoized_1 arg_59 (memoized_1 arg_60 acc_56) + Language.Haskell.TH.Syntax.FromToR arg_61 + arg_62 -> memoized_1 arg_61 (memoized_1 arg_62 acc_56) + Language.Haskell.TH.Syntax.FromThenToR arg_63 + arg_64 + arg_65 -> memoized_1 arg_63 (memoized_1 arg_64 (memoized_1 arg_65 acc_56))) x_55) + memoized_29 = \x_66 acc_67 -> GHC.Base.const GHC.Base.id x_66 ((\_x_68 -> case _x_68 of + [] -> acc_67 + (:) arg_69 + arg_70 -> memoized_71 arg_69 (memoized_29 arg_70 acc_67)) x_66) + memoized_71 = \x_72 acc_73 -> GHC.Base.const GHC.Base.id x_72 ((\_x_74 -> case _x_74 of + Language.Haskell.TH.Syntax.Match arg_75 + arg_76 + arg_77 -> memoized_78 arg_75 (memoized_79 arg_76 (memoized_26 arg_77 acc_73))) x_72) + memoized_26 = \x_80 acc_81 -> GHC.Base.const GHC.Base.id x_80 ((\_x_82 -> case _x_82 of + [] -> acc_81 + (:) arg_83 + arg_84 -> memoized_85 arg_83 (memoized_26 arg_84 acc_81)) x_80) + memoized_85 = \x_86 acc_87 -> GHC.Base.const GHC.Base.id x_86 ((\_x_88 -> case _x_88 of + Language.Haskell.TH.Syntax.FunD arg_89 + arg_90 -> memoized_6 arg_89 (memoized_91 arg_90 acc_87) + Language.Haskell.TH.Syntax.ValD arg_92 + arg_93 + arg_94 -> memoized_78 arg_92 (memoized_79 arg_93 (memoized_26 arg_94 acc_87)) + Language.Haskell.TH.Syntax.DataD arg_95 + arg_96 + arg_97 + arg_98 + arg_99 -> memoized_100 arg_95 (memoized_6 arg_96 (memoized_101 arg_97 (memoized_102 arg_98 (memoized_103 arg_99 acc_87)))) + Language.Haskell.TH.Syntax.NewtypeD arg_104 + arg_105 + arg_106 + arg_107 + arg_108 -> memoized_100 arg_104 (memoized_6 arg_105 (memoized_101 arg_106 (memoized_109 arg_107 (memoized_103 arg_108 acc_87)))) + Language.Haskell.TH.Syntax.TySynD arg_110 + arg_111 + arg_112 -> memoized_6 arg_110 (memoized_101 arg_111 (memoized_38 arg_112 acc_87)) + Language.Haskell.TH.Syntax.ClassD arg_113 + arg_114 + arg_115 + arg_116 + arg_117 -> memoized_100 arg_113 (memoized_6 arg_114 (memoized_101 arg_115 (memoized_118 arg_116 (memoized_26 arg_117 acc_87)))) + Language.Haskell.TH.Syntax.InstanceD arg_119 + arg_120 + arg_121 -> memoized_100 arg_119 (memoized_38 arg_120 (memoized_26 arg_121 acc_87)) + Language.Haskell.TH.Syntax.SigD arg_122 + arg_123 -> memoized_6 arg_122 (memoized_38 arg_123 acc_87) + Language.Haskell.TH.Syntax.ForeignD arg_124 -> memoized_125 arg_124 acc_87 + Language.Haskell.TH.Syntax.PragmaD arg_126 -> memoized_127 arg_126 acc_87 + Language.Haskell.TH.Syntax.FamilyD arg_128 + arg_129 + arg_130 + arg_131 -> memoized_132 arg_128 (memoized_6 arg_129 (memoized_101 arg_130 (memoized_133 arg_131 acc_87))) + Language.Haskell.TH.Syntax.DataInstD arg_134 + arg_135 + arg_136 + arg_137 + arg_138 -> memoized_100 arg_134 (memoized_6 arg_135 (memoized_139 arg_136 (memoized_102 arg_137 (memoized_103 arg_138 acc_87)))) + Language.Haskell.TH.Syntax.NewtypeInstD arg_140 + arg_141 + arg_142 + arg_143 + arg_144 -> memoized_100 arg_140 (memoized_6 arg_141 (memoized_139 arg_142 (memoized_109 arg_143 (memoized_103 arg_144 acc_87)))) + Language.Haskell.TH.Syntax.TySynInstD arg_145 + arg_146 + arg_147 -> memoized_6 arg_145 (memoized_139 arg_146 (memoized_38 arg_147 acc_87))) x_86) + memoized_139 = GHC.Base.const GHC.Base.id + memoized_133 = GHC.Base.const GHC.Base.id + memoized_132 = GHC.Base.const GHC.Base.id + memoized_127 = GHC.Base.const GHC.Base.id + memoized_125 = GHC.Base.const GHC.Base.id + memoized_118 = GHC.Base.const GHC.Base.id + memoized_109 = GHC.Base.const GHC.Base.id + memoized_103 = GHC.Base.const GHC.Base.id + memoized_102 = GHC.Base.const GHC.Base.id + memoized_101 = GHC.Base.const GHC.Base.id + memoized_100 = GHC.Base.const GHC.Base.id + memoized_91 = \x_148 acc_149 -> GHC.Base.const GHC.Base.id x_148 ((\_x_150 -> case _x_150 of + [] -> acc_149 + (:) arg_151 + arg_152 -> memoized_153 arg_151 (memoized_91 arg_152 acc_149)) x_148) + memoized_153 = \x_154 acc_155 -> GHC.Base.const GHC.Base.id x_154 ((\_x_156 -> case _x_156 of + Language.Haskell.TH.Syntax.Clause arg_157 + arg_158 + arg_159 -> memoized_18 arg_157 (memoized_79 arg_158 (memoized_26 arg_159 acc_155))) x_154) + memoized_79 = \x_160 acc_161 -> GHC.Base.const GHC.Base.id x_160 ((\_x_162 -> case _x_162 of + Language.Haskell.TH.Syntax.GuardedB arg_163 -> memoized_164 arg_163 acc_161 + Language.Haskell.TH.Syntax.NormalB arg_165 -> memoized_1 arg_165 acc_161) x_160) + memoized_164 = \x_166 acc_167 -> GHC.Base.const GHC.Base.id x_166 ((\_x_168 -> case _x_168 of + [] -> acc_167 + (:) arg_169 + arg_170 -> memoized_171 arg_169 (memoized_164 arg_170 acc_167)) x_166) + memoized_171 = \x_172 acc_173 -> GHC.Base.const GHC.Base.id x_172 ((\_x_174 -> case _x_174 of + (,) arg_175 + arg_176 -> memoized_177 arg_175 (memoized_1 arg_176 acc_173)) x_172) + memoized_177 = \x_178 acc_179 -> GHC.Base.const GHC.Base.id x_178 ((\_x_180 -> case _x_180 of + Language.Haskell.TH.Syntax.NormalG arg_181 -> memoized_1 arg_181 acc_179 + Language.Haskell.TH.Syntax.PatG arg_182 -> memoized_31 arg_182 acc_179) x_178) + memoized_31 = \x_183 acc_184 -> GHC.Base.const GHC.Base.id x_183 ((\_x_185 -> case _x_185 of + [] -> acc_184 + (:) arg_186 + arg_187 -> memoized_188 arg_186 (memoized_31 arg_187 acc_184)) x_183) + memoized_188 = \x_189 acc_190 -> GHC.Base.const GHC.Base.id x_189 ((\_x_191 -> case _x_191 of + Language.Haskell.TH.Syntax.BindS arg_192 + arg_193 -> memoized_78 arg_192 (memoized_1 arg_193 acc_190) + Language.Haskell.TH.Syntax.LetS arg_194 -> memoized_26 arg_194 acc_190 + Language.Haskell.TH.Syntax.NoBindS arg_195 -> memoized_1 arg_195 acc_190 + Language.Haskell.TH.Syntax.ParS arg_196 -> memoized_197 arg_196 acc_190) x_189) + memoized_197 = \x_198 acc_199 -> GHC.Base.const GHC.Base.id x_198 ((\_x_200 -> case _x_200 of + [] -> acc_199 + (:) arg_201 + arg_202 -> memoized_31 arg_201 (memoized_197 arg_202 acc_199)) x_198) + memoized_20 = \x_203 acc_204 -> GHC.Base.const GHC.Base.id x_203 ((\_x_205 -> case _x_205 of + [] -> acc_204 + (:) arg_206 + arg_207 -> memoized_1 arg_206 (memoized_20 arg_207 acc_204)) x_203) + memoized_18 = \x_208 acc_209 -> GHC.Base.const GHC.Base.id x_208 ((\_x_210 -> case _x_210 of + [] -> acc_209 + (:) arg_211 + arg_212 -> memoized_78 arg_211 (memoized_18 arg_212 acc_209)) x_208) + memoized_78 = \x_213 acc_214 -> GHC.Base.const GHC.Base.id x_213 ((\_x_215 -> case _x_215 of + Language.Haskell.TH.Syntax.LitP arg_216 -> memoized_9 arg_216 acc_214 + Language.Haskell.TH.Syntax.VarP arg_217 -> memoized_6 arg_217 acc_214 + Language.Haskell.TH.Syntax.TupP arg_218 -> memoized_18 arg_218 acc_214 + Language.Haskell.TH.Syntax.ConP arg_219 + arg_220 -> memoized_6 arg_219 (memoized_18 arg_220 acc_214) + Language.Haskell.TH.Syntax.InfixP arg_221 + arg_222 + arg_223 -> memoized_78 arg_221 (memoized_6 arg_222 (memoized_78 arg_223 acc_214)) + Language.Haskell.TH.Syntax.TildeP arg_224 -> memoized_78 arg_224 acc_214 + Language.Haskell.TH.Syntax.BangP arg_225 -> memoized_78 arg_225 acc_214 + Language.Haskell.TH.Syntax.AsP arg_226 + arg_227 -> memoized_6 arg_226 (memoized_78 arg_227 acc_214) + Language.Haskell.TH.Syntax.WildP -> acc_214 + Language.Haskell.TH.Syntax.RecP arg_228 + arg_229 -> memoized_6 arg_228 (memoized_230 arg_229 acc_214) + Language.Haskell.TH.Syntax.ListP arg_231 -> memoized_18 arg_231 acc_214 + Language.Haskell.TH.Syntax.SigP arg_232 + arg_233 -> memoized_78 arg_232 (memoized_38 arg_233 acc_214) + Language.Haskell.TH.Syntax.ViewP arg_234 + arg_235 -> memoized_1 arg_234 (memoized_78 arg_235 acc_214)) x_213) + memoized_38 = GHC.Base.const GHC.Base.id + memoized_230 = \x_236 acc_237 -> GHC.Base.const GHC.Base.id x_236 ((\_x_238 -> case _x_238 of + [] -> acc_237 + (:) arg_239 + arg_240 -> memoized_241 arg_239 (memoized_230 arg_240 acc_237)) x_236) + memoized_241 = \x_242 acc_243 -> GHC.Base.const GHC.Base.id x_242 ((\_x_244 -> case _x_244 of + (,) arg_245 + arg_246 -> memoized_6 arg_245 (memoized_78 arg_246 acc_243)) x_242) + memoized_15 = \x_247 acc_248 -> GHC.Base.const GHC.Base.id x_247 ((\_x_249 -> case _x_249 of + Data.Maybe.Nothing -> acc_248 + Data.Maybe.Just arg_250 -> memoized_1 arg_250 acc_248) x_247) + memoized_9 = GHC.Base.const GHC.Base.id + memoized_6 = GHC.Base.const GHC.Base.id + in memoized_1) e_0 Set.empty diff --git a/Debug/TH.hs b/Debug/TH.hs new file mode 100644 --- /dev/null +++ b/Debug/TH.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} +module Debug.TH where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-------------------------------------------------------------------------------- +-- Debugging Helpers +-------------------------------------------------------------------------------- + +{-| +Debugging Template Haskell stuff at the GHCi REPL is hard because everything +ends up in the "Q" monad and there is no way to print the "Q" monad. These functions +call pprint and show but return a "Q Exp" so that the following expressions work +to print a given value (e.g. "x"): + $(pprintQ x) + $(showQ x) + +NOTE: GHCi likes to run the contents of splices twice or more, so the results +may be printed multiple times. +-} + +pprintQ :: (Ppr a) => Q a -> Q Exp +pprintQ x = x >>= (qRunIO . putStrLn . pprint) >> [|return ()|] + +showQ :: (Show a) => Q a -> Q Exp +showQ x = x >>= (qRunIO . putStrLn . show) >> [|return ()|] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) Portland State University + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,16 @@ +This is the Template Your Boilerplate (TYB) library. + +The "Template Your Boilerplate" paper documents the design of this library +and is available at: http://cs.pdx.edu/~adamsmic/projects/tyb/TYB.pdf + +The TYB library is in the Data.Generics.TH module. + +The 'examples' folder contains examples of using TYB and is a good +place to start getting familiar with TYB. They can be built with: + +$ ghc --make examples/*.hs + +A couple of useful debugging helpers for Template Haskell are +included in the Debug.TH module. + +We welcome feedback on both the implementation and the interface. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TYB.cabal b/TYB.cabal new file mode 100644 --- /dev/null +++ b/TYB.cabal @@ -0,0 +1,29 @@ +Name: TYB +Version: 0.2.0 +Synopsis: Template Your Boilerplate - a Template Haskell version of SYB +Description: TYB is a generic-programming system that uses Template + Haskell to generate boiler-plate traversals at compile + time. This results in significantly improved + performance. The paper documenting it is available at: + +License: BSD3 +License-file: LICENSE +Author: Michael D. Adams, Thomas M. DuBuisson +Maintainer: Thomas M. DuBuisson +-- Copyright: +Category: Generics +Build-type: Simple +Extra-source-files: README examples/*.hs util/makeVarSet.hs +Cabal-version: >=1.8 + +Library + Exposed-modules: Data.Generics.TH + Build-depends: base >= 4 && < 5 + , template-haskell >= 2.5 && < 2.8 + , array >= 0.3 && < 0.5 + , containers >= 0.4 && < 0.5 + , mtl >= 2.0 && < 2.1 + , transformers >= 0.2 && < 0.3 + Other-modules: Data.Generics.TH.Instances, Data.Generics.TH.VarSet, + Debug.TH + -- Build-tools: diff --git a/examples/List.hs b/examples/List.hs new file mode 100644 --- /dev/null +++ b/examples/List.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -Wall #-} +{-# OPTIONS -fno-warn-type-defaults #-} -- See Note [Type defaults] in Syntax.hs + +module List where + +import Data.Generics.TH +import Control.Monad.State + +---------------------------------------- +-- List +---------------------------------------- + +-- This is slower than "Prelude.sum" because that uses accumulator +-- style due to the foldl in it. +sum :: [Int] -> Int +sum = $(everything [|(+)|] (mkQ [|0|] 'f) [t|[Int]|]) where + f :: Int -> Int + f = id + +-- As fast as sum +sum_acc :: [Int] -> Int +sum_acc xs = $(everythingAccR (mkQ [|id|] 'f) [t|[Int]|]) xs 0 where + f :: Int -> (Int -> Int) + f = (+) + +-- Or by reifying the types from the function name (and using a strict accumulator): +sum_for :: [Int] -> Int +sum_for xs = $(everythingForL' 'f [t|[Int]|]) xs 0 where + f :: Int -> Int -> Int + f = (+) + +map :: (Int -> Int) -> [Int] -> [Int] +map f = $(everywhere (mkT 'f) [t|[Int]|]) + +shift :: [Int] -> [Int] +shift xs = evalState ($(everywhereM (mkM 'go) [t|[Int]|]) xs) 0 + where + go :: Int -> State Int Int + go i = get >>= \v -> put i >> return v diff --git a/examples/Syntax.hs b/examples/Syntax.hs new file mode 100644 --- /dev/null +++ b/examples/Syntax.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -Wall #-} +{-# OPTIONS -fno-warn-type-defaults #-} -- See Note [Type defaults] + +-- Note that this file takes a little bit longer to compile than the +-- others (e.g. ~150 seconds vs <1 second). +-- +-- This file contains a large number transformations over a large +-- number of types (i.e. all the types in Language.Haskell.Syntax). +-- This seems to trigger poor compile-time performance. +-- +-- We are looking into fixing this. + +module Syntax where + +import Data.Generics.TH +import Control.Monad.Reader +import Language.Haskell.Syntax + +---------------------------------------- +-- Id +---------------------------------------- +id_All :: HsModule -> HsModule +id_All = $(everywhere (const [|id|]) [t|HsModule|]) + +id_HsName :: HsModule -> HsModule +id_HsName = $(everywhere (const [|id|] `extE` (eqType [t|HsName|], [|id|])) [t|HsModule|]) + +---------------------------------------- +-- Const +---------------------------------------- + +const_HsName :: HsName -> HsModule -> HsModule +const_HsName c = $(everywhere (const [|id|] `extE` (eqType [t|HsName|], [|const c|])) [t|HsModule|]) + +const_HsName_But :: HsName -> HsModule -> HsModule +const_HsName_But c = $(everywhereBut (liftM not . containsType [t|HsName|]) + (const [|id|] `extE` (eqType [t|HsName|], [|const c|])) [t|HsModule|]) + +---------------------------------------- +-- Counting +---------------------------------------- + +count_HsModule_All :: HsModule -> Int +count_HsModule_All = $(everything [|(+)|] (const [|const 1|]) [t|HsModule|]) + +count_HsName :: HsModule -> Int +count_HsName = $(everything [|(+)|] (mkQ [|0|] 'f) [t|HsModule|]) + where f :: HsName -> Int + f _ = 1 + +count_HsName_Acc :: HsModule -> Int +count_HsName_Acc x = $(everythingAccR (mkQ [|id|] 'f) [t|HsModule|]) x 0 + where f :: HsName -> Int -> Int + f _ = (+1) + +count_HsName_ForR :: HsModule -> Int +count_HsName_ForR x = $(everythingForR 'f [t|HsModule|]) x 0 + where f :: HsName -> Int -> Int + f _ = (+1) + +count_HsName_ForL :: HsModule -> Int +count_HsName_ForL x = $(everythingForL 'f [t|HsModule|]) x 0 + where f :: HsName -> Int -> Int + f _ = (+1) + +count_HsName_ForL' :: HsModule -> Int +count_HsName_ForL' x = $(everythingForL' 'f [t|HsModule|]) x 0 + where f :: HsName -> Int -> Int + f _ = (+1) + +-- 148us if we only check eqType, 117us if we check both eqType and containsType +count_HsName_But :: HsModule -> Int +count_HsName_But = $(let g t = do b <- eqType [t|HsName|] t + c <- containsType [t|HsName|] t + if b then do h <- [|const 1|] + return (h, True) + else do h <- [|const 0|] + return (h, not c) + in everythingBut [|(+)|] g [t|HsModule|]) + +count_HsName_But_Acc :: HsModule -> Int +count_HsName_But_Acc x = $(let g t = do b <- eqType [t|HsName|] t + c <- containsType [t|HsName|] t + if b then do h <- [|const (+1)|] + return (h, True) + else do h <- [|const id|] + return (h, not c) + in everythingButAccR g [t|HsModule|]) x 0 + +count_HsName_For :: HsModule -> Int +count_HsName_For x = let f = (\_ -> (+1)) :: HsName -> Int -> Int + in $(everythingForL' 'f [t|HsModule|]) x 0 + +---------------------------------------- +-- Listing +---------------------------------------- + +list_HsName_List :: HsModule -> [HsName] +list_HsName_List = $(everything [|(++)|] (mkQ [|[]|] 'f) [t|HsModule|]) + where f :: HsName -> [HsName] + f x = [x] + +list_HsName_But :: HsModule -> [HsName] +list_HsName_But = $(everythingBut [|(++)|] (\t -> do + e <- mkQ [|[]|] 'f t + b <- liftM not (containsType [t|HsName|] t) + return (e,b)) + [t|HsModule|]) + where f :: HsName -> [HsName] + f x = [x] + +list_HsName_Comp :: HsModule -> [HsName] +list_HsName_Comp x = $(everything [|(.)|] (mkQ [|id|] 'f) [t|HsModule|]) x [] + where f :: HsName -> [HsName] -> [HsName] + f = (:) + +list_HsName_Comp_But :: HsModule -> [HsName] +list_HsName_Comp_But x = $(let g t = do b <- eqType [t|HsName|] t + c <- containsType [t|HsName|] t + if b then do h <- [|(:)|] + return (h, True) + else do h <- [|const id|] + return (h, not c) + in everythingBut [|(.)|] g [t|HsModule|]) x [] + where f :: HsName -> [HsName] -> [HsName] + f = (:) + +list_HsName_AccR :: HsModule -> [HsName] +list_HsName_AccR x = $(everythingAccR (mkQ [|id|] 'f) [t|HsModule|]) x [] + where + f :: HsName -> [HsName] -> [HsName] + f = (:) + + +list_HsName_AccL :: HsModule -> [HsName] +list_HsName_AccL x = $(everythingAccL (mkQ [|id|] 'f) [t|HsModule|]) x [] + where + f :: HsName -> [HsName] -> [HsName] + f = (:) + +list_HsName_AccL' :: HsModule -> [HsName] +list_HsName_AccL' x = $(everythingAccL' (mkQ [|id|] 'f) [t|HsModule|]) x [] + where + f :: HsName -> [HsName] -> [HsName] + f = (:) + +list_HsName_Acc_But :: HsModule -> [HsName] +list_HsName_Acc_But x = $(let rec memoF t = do + is <- eqType [t|HsName|] t + contains <- containsType [t|HsName|] t + case (is, contains) of + (True, _) -> [|\acc name -> name : acc|] + (_, True) -> [|\acc -> $(thcase (g [|acc|]) (return t))|] + (_, _) -> [|\acc _ -> acc|] + where g acc _ctor [] = acc + g acc ctor ((t, v):vs) = [|$(memoF t) $(g acc ctor vs) $v|] + in [t|HsModule|] >>= memoizeExp rec) [] x + + +list_HsName_AccR_But :: HsModule -> [HsName] +list_HsName_AccR_But x = $(let h t = do b <- eqType [t|HsName|] t + c <- containsType [t|HsName|] t + if b then do h <- [|(:)|] + return (h, True) + else do h <- [|const id|] + return (h, not c) + in everythingButAccR h [t|HsModule|]) x [] + +list_HsName_ForR :: HsModule -> [HsName] +list_HsName_ForR x = $(everythingForR 'f [t|HsModule|]) x [] + where f :: HsName -> [HsName] -> [HsName] + f = (:) + +list_HsName_AccL_But :: HsModule -> [HsName] +list_HsName_AccL_But x = $(let h t = do b <- eqType [t|HsName|] t + c <- containsType [t|HsName|] t + if b then do h <- [|(:)|] + return (h, True) + else do h <- [|const id|] + return (h, not c) + in everythingButAccL h [t|HsModule|]) x [] + +list_HsName_ForL :: HsModule -> [HsName] +list_HsName_ForL x = $(everythingForL 'f [t|HsModule|]) x [] + where f :: HsName -> [HsName] -> [HsName] + f = (:) + +list_HsName_AccL'_But :: HsModule -> [HsName] +list_HsName_AccL'_But x = $(let h t = do b <- eqType [t|HsName|] t + c <- containsType [t|HsName|] t + if b then do h <- [|(:)|] + return (h, True) + else do h <- [|const id|] + return (h, not c) + in everythingButAccL' h [t|HsModule|]) x [] + +list_HsName_ForL' :: HsModule -> [HsName] +list_HsName_ForL' x = $(everythingForL' 'f [t|HsModule|]) x [] + where f :: HsName -> [HsName] -> [HsName] + f = (:) + +-- Slower than list_HsName_Comp +list_HsName_Comp2 :: HsModule -> [HsName] +list_HsName_Comp2 x = $(everything [|flip (.)|] (mkQ [|id|] 'f) [t|HsModule|]) x [] + where f :: HsName -> [HsName] -> [HsName] + f = (:) + +---------------------------------------- +-- Prefixing +---------------------------------------- + +prefix :: HsName -> HsName +prefix (HsIdent s) = HsIdent ('x' : s) +prefix x = x + +prefix_HsName :: HsModule -> HsModule +prefix_HsName = $(everywhere (const [|id|] `extN` 'prefix) [t|HsModule|]) + +prefix_HsName_But :: HsModule -> HsModule +prefix_HsName_But = $(everywhereBut (liftM not . containsType [t|HsName|]) (const [|id|] `extN` 'prefix) [t|HsModule|]) + +---------------------------------------- +-- A useful helper for benchmarking +---------------------------------------- + +deepseq_HsModule = + $(let --rec :: (TH.Type -> Q TH.Exp) -> TH.Type -> Q TH.Exp + rec k t = thcase f (return t) where + --f :: Q TH.Exp -> [(TH.Type, Q TH.Exp)] -> Q TH.Exp + f _ [] = [| () |] + f _ ((t, x) : xs) = [| $(k t) $x `seq` $(f undefined xs) |] + in [t|HsModule|] >>= memoizeExp rec) + +---------------------------------------- +-- Notes +---------------------------------------- + +{- +Note [Type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC 7.0.3 has (we think) a bug where it reports type default warnings +in Template Haskell code even though no type defaulting is actually +happening. Until it is fixed, we just have to tell GHC to be quiet +about it. +-} diff --git a/examples/WTree.hs b/examples/WTree.hs new file mode 100644 --- /dev/null +++ b/examples/WTree.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -Wall #-} +{-# OPTIONS -fno-warn-type-defaults #-} -- See Note [Type defaults] in Syntax.hs + +module WTree where + +import Data.Generics.TH +import Control.Monad.State + +data WTree a w = Leaf a + | Fork (WTree a w) (WTree a w) + | WithWeight (WTree a w) w + deriving (Show) + +---------------- + +rmWeight :: WTree Int Int -> WTree Int Int +rmWeight (WithWeight t _) = t +rmWeight t = t + +nrInt :: Int -> State Int Int +nrInt _ = do + i <- get + put (i+1) + return i + +---------------- + +id_WTree :: WTree a w -> WTree a w +id_WTree = $(everywhere (const [|id|]) [t|WTree Int Int|]) + +const_WTree :: Int -> WTree Int Int -> WTree Int Int +const_WTree c = $(everywhere (const [|id|] `extE` (eqType [t|Int|], [|const c|])) [t|WTree Int Int|]) + +rmWeights :: WTree Int Int -> WTree Int Int +rmWeights = $(everywhere (const [|id|] `extN` 'rmWeight) [t|WTree Int Int|]) + +count_WTree_All :: WTree Int Int -> Int +count_WTree_All = $(everything [|(+)|] (const [|const 1|]) [t|WTree Int Int|]) + +selectInt :: WTree Int Int -> [Int] +selectInt = $(everything [|(++)|] (mkQ [|[]|] 'f) [t|WTree Int Int|]) + where f :: Int -> [Int] + f i = [i] + +selectInt_Acc :: WTree Int Int -> [Int] +selectInt_Acc x = $(everything [|(.)|] (mkQ [|id|] 'f) [t|WTree Int Int|]) x [] + where f :: Int -> [Int] -> [Int] + f i = (i:) + +selectInt_Acc2 :: WTree Int Int -> [Int] +selectInt_Acc2 x = $(everythingAccL (mkQ [|id|] 'f) [t|WTree Int Int|]) x [] + where f :: Int -> [Int] -> [Int] + f i = (i:) + +selectInt_For :: WTree Int Int -> [Int] +selectInt_For x = $(everythingForR 'f [t|WTree Int Int|]) x [] + where + f :: Int -> [Int] -> [Int] + f = (:) + +number_WTree :: WTree Int Int -> WTree Int Int +number_WTree b = evalState ($(everywhereM (mkM 'nrInt) [t|(WTree Int Int)|]) b) 0 + +number_WTree_For :: WTree Int Int -> WTree Int Int +number_WTree_For b = evalState ($(everywhereForM 'nrInt [t|(WTree Int Int)|]) b) 0 diff --git a/util/makeVarSet.hs b/util/makeVarSet.hs new file mode 100644 --- /dev/null +++ b/util/makeVarSet.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} +import Data.Generics.TH +import Data.String.Utils +import Language.Haskell.TH +import System.Exit + +import qualified Data.Set as Set + +-- This program generates the Data.Generics.TH.VarSet module +-- when this module compiles. It is not intended to be run. + +-- The reason is that Template Haskell can't "reify" under the IO +-- monad. Thus we need to be running under GHC's typechecker monad. +-- That happens only at compile time. + +accVarRef :: Exp -> Set.Set Name -> Set.Set Name +accVarRef = undefined + +$(do e <- [d|varSet e = $(everythingForL 'accVarRef [t| Exp |]) e Set.empty|] + let fileName = "Data/Generics/TH/VarSet.hs" + runIO $ writeFile fileName $ + + "-- Do not edit. This file is generated by \"util/makeVarSet.hs\".\n" ++ + "{-# OPTIONS_GHC -W -Wall #-}\n" ++ + "module Data.Generics.TH.VarSet (varSet) where\n" ++ + "import Language.Haskell.TH.Syntax\n" ++ + "import GHC.Base\n" ++ + "import qualified Data.Set as Set\n" ++ + "import qualified Data.Maybe\n" ++ + + "accVarRef :: Exp -> Set.Set Name -> Set.Set Name\n" ++ + "accVarRef (VarE n) set = Set.insert n set\n" ++ + "accVarRef _ set = set\n" ++ + + "varSet :: Exp -> Set.Set Name\n" ++ + (replace "GHC.Tuple." "" $ + replace "GHC.Types." "" $ + replace "Main." "" $ + replace "Data.Set." "Set." $ + (pprint e)) ++ + "\n" + + runIO $ putStrLn $ "Generated " ++ fileName + return [] {- Return an empty set of declarations. -}) + +main = putStrLn "Error: this program is intended to be compiled but not run" >> exitFailure