diff --git a/Data/Derive/All.hs b/Data/Derive/All.hs --- a/Data/Derive/All.hs +++ b/Data/Derive/All.hs @@ -3,6 +3,7 @@ module Data.Derive.All (module D) where import Data.Derive.Arbitrary as D +import Data.Derive.Arbitrary2 as D import Data.Derive.Binary as D import Data.Derive.BinaryDefer as D import Data.Derive.BinaryOld as D diff --git a/Data/Derive/Arbitrary.hs b/Data/Derive/Arbitrary.hs --- a/Data/Derive/Arbitrary.hs +++ b/Data/Derive/Arbitrary.hs @@ -51,7 +51,15 @@ "Arbitrary")) tdat)) (dataVars dat))])) (head [(AppT (ConT (mkName "Arbitrary")) (lK (dataName dat) (dataVars dat)))])[(ValD (VarP (mkName "arbitrary")) (NormalB (DoE [(BindS (VarP (mkName "x")) (AppE (VarE (mkName - "choose")) (TupE [(LitE (IntegerL 0)),(LitE (IntegerL (toInteger (length ( + "choose")) (TupE [ +-- NOTE BIG TIME: + (SigE (LitE (IntegerL 0)) (ConT (mkName "Int"))) +-- The above was generated by the 'guess' function to just be +-- (LitE (IntegerL 0)) ... +-- but we must annotate it with an Int type so that auto-generated +-- instances actually work since otherwise we get an ambiguous type +-- freak-out + ,(LitE (IntegerL (toInteger (length ( dataCtors dat) - 1))))]))),(NoBindS (CaseE (VarE (mkName "x")) ((map (\( ctorInd,ctor) -> (Match (LitP (IntegerL ctorInd)) (NormalB (DoE ((map ( \field -> (BindS (VarP (mkName ("x" ++ show field))) (VarE (mkName diff --git a/Data/Derive/Arbitrary2.hs b/Data/Derive/Arbitrary2.hs --- a/Data/Derive/Arbitrary2.hs +++ b/Data/Derive/Arbitrary2.hs @@ -1,12 +1,12 @@ {-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-} --- | Derivation for 'Test.QuickCheck.Arbitrary'. +-- | Derivation for 'Test.QuickCheck.Arbitrary' (version 2 of quickcheck.) -- -- * The resulting instances of @arbitrary@ generate each constructor -- of the data type with equal probability. -- -- * No form of size control is used. -module Data.Derive.Arbitrary2(makeArbitrary) where +module Data.Derive.Arbitrary2(makeArbitrary2) where import Language.Haskell.TH.All @@ -16,7 +16,7 @@ import Test.QuickCheck import Data.DeriveGuess -example = (,) "Arbitrary" [d| +example = (,) "Arbitrary2" [d| instance Arbitrary a => Arbitrary (DataName a) where arbitrary = do @@ -35,13 +35,21 @@ #endif -makeArbitrary :: Derivation -makeArbitrary = derivation arbitrary' "Arbitrary" +makeArbitrary2 :: Derivation +makeArbitrary2 = derivation arbitrary' "Arbitrary2" arbitrary' dat = [InstanceD (concat ([(map (\tdat -> (AppT (ConT (mkName "Arbitrary")) tdat)) (dataVars dat))])) (head [(AppT (ConT (mkName "Arbitrary")) (lK (dataName dat) (dataVars dat)))])[(ValD (VarP (mkName "arbitrary")) (NormalB (DoE [(BindS (VarP (mkName "x")) (AppE (VarE (mkName - "choose")) (TupE [(LitE (IntegerL 0)),(LitE (IntegerL (toInteger (length ( + "choose")) (TupE [ +-- NOTE BIG TIME: + (SigE (LitE (IntegerL 0)) (ConT (mkName "Int"))) +-- The above was generated by the 'guess' function to just be +-- (LitE (IntegerL 0)) ... +-- but we must annotate it with an Int type so that auto-generated +-- instances actually work since otherwise we get an ambiguous type +-- freak-out + ,(LitE (IntegerL (toInteger (length ( dataCtors dat) - 1))))]))),(NoBindS (CaseE (VarE (mkName "x")) ((map (\( ctorInd,ctor) -> (Match (LitP (IntegerL ctorInd)) (NormalB (DoE ((map ( \field -> (BindS (VarP (mkName ("x" ++ show field))) (VarE (mkName diff --git a/Data/Derive/Data.hs b/Data/Derive/Data.hs --- a/Data/Derive/Data.hs +++ b/Data/Derive/Data.hs @@ -2,8 +2,7 @@ -- | Derivation for the 'Data.Generics.Basics.Data' class, as -- described in the Scrap Your Boilerplate paper. No type structure --- is abstracted; only gfoldl is implemented (notably, gunfold is --- not). +-- is abstracted module Data.Derive.Data(makeData) where @@ -24,19 +23,78 @@ gfoldl k r (CtorOne x1) = r CtorOne `k` x1 gfoldl k r (CtorTwo x1 x2) = r CtorTwo `k` x1 `k` x2 gfoldl k r (CtorTwo' x1 x2) = r CtorTwo' `k` x1 `k` x2 - |] #endif +{- GHC autogenerated instance: +instance (Data a, Data b) => Data (T a b) where + gfoldl k z (C1 a b) = z C1 `k` a `k` b + gfoldl k z C2 = z C2 + + gunfold k z c = case constrIndex c of + 1 -> k (k (z C1)) + 2 -> z C2 + + toConstr (C1 _ _) = con_C1 + toConstr C2 = con_C2 + + dataTypeOf _ = ty_T + + con_C1 = mkConstr ty_T "C1" [] Prefix + con_C2 = mkConstr ty_T "C2" [] Prefix + ty_T = mkDataType "Module.T" [con_C1, con_C2] +-} + makeData :: Derivation -makeData = derivation data' "Data" +makeData = derivation genDataInst "Data" -data' dat = [instance_context ["Data","Typeable"] "Data" dat [FunD (mkName - "gfoldl") ((map (\(ctorInd,ctor) -> (Clause [(VarP (mkName "k")),(VarP ( - mkName "r")),(ConP (mkName (ctorName ctor)) ((map (\field -> (VarP (mkName - ("x" ++ show field)))) (id [1..ctorArity ctor]))++[]))] (NormalB ( - foldr1With (VarE (mkName "k")) ((map (\field -> (VarE (mkName ("x" ++ show - field)))) (reverse [1..ctorArity ctor]))++[(AppE (VarE (mkName "r")) (ConE - (mkName (ctorName ctor))))]++[]))) [])) (id (zip [0..] (dataCtors dat))))++ - [])]] +genDataInst :: DataDef -> [Dec] +genDataInst dat = [ + instance_context ["Data","Typeable"] "Data" dat + [ FunD (mkName "gfoldl") (gfoldlDefs dat), + FunD (mkName "gunfold") (gunfoldDefs dat), + FunD (mkName "toConstr") (toConstrDefs dat), + FunD (mkName "dataTypeOf") (dataTypeOfDefs dat) ] + ] +toConstrDefs :: DataDef -> [Clause] +toConstrDefs dat = map toConstrImpl (zip [(1::Integer)..] (dataCtors dat)) where + toConstrImpl (ctorInd,ctor) = Clause [toConstrParams ctor] (toConstrDef ctorInd ctor) [] + toConstrParams ctor = AsP (mkName "ctor") (matchConstructor ctor) + toConstrDef ind _ctor = NormalB $ + app (varExpr "indexConstr") + [ AppE (varExpr "dataTypeOf") (varExpr "ctor"), lit ind ] +dataTypeOfDefs :: DataDef -> [Clause] +dataTypeOfDefs dat = [Clause dtOfParams dtOfDef dtOfClauses] where + dtOfParams = [WildP] + dtOfDef = NormalB $ varExpr "ty_T" + dtOfClauses = (mkDt (dataCtors dat)) : map mkCon (zip [(1::Integer)..] (dataCtors dat)) + mkCon (ix,ctor) = FunD (mkName $ "con_C"++show ix) [Clause [] (NormalB (mkConImpl ix ctor)) []] + mkConImpl _ix ctor = app (varExpr "mkConstr") + [varExpr "ty_T", lit (ctorName ctor), ListE (fields ctor), ConE (mkName "Prefix") ] + fields = map lit . ctorFields + mkDt ctors = FunD (mkName "ty_T") [Clause [] (NormalB (mkDtImpl ctors)) []] + mkDtImpl ctors = app (varExpr "mkDataType") [lit (show$ qualifiedDataName dat) , mkConVars ctors] + mkConVars ctors = ListE $ map (\ix -> varExpr ("con_C"++show ix)) [(1::Int)..(length ctors)] +gfoldlDefs :: DataDef -> [Clause] +gfoldlDefs dat = map gfoldlImpl (zip [(1::Integer)..] (dataCtors dat)) where + gfoldlImpl (_ctorInd,ctor) = Clause (gfoldlParams ctor) (gfoldlDef ctor) [] + gfoldlParams ctor = [ VarP (mkName "k"), VarP (mkName "r"), matchConstructor ctor ] + gfoldlDef ctor = NormalB $ foldr1With (varExpr "k") foldFields where + foldFields = map (\field -> (varExpr ("x" ++ show field))) (reverse [1..ctorArity ctor]) + ++ [ (AppE (varExpr "r") (ConE (mkName (ctorName ctor)))) ] +gunfoldDefs :: DataDef -> [Clause] +gunfoldDefs dat = [Clause guParams (NormalB guDef) []] where + guParams = map (VarP . mkName) ["k","z","c"] + guDef = CaseE (AppE (varExpr "constrIndex") (varExpr "c")) $ + map (guCase) (zip [(1::Integer)..] (dataCtors dat)) + guCase (ix,ctor) = Match (LitP (IntegerL ix)) (NormalB$ guCaseBody ctor) [] + guCaseBody ctor = foldr (\_ e -> AppE (varExpr "k") e) + (AppE (varExpr "z") (ConE . mkName . ctorName $ ctor)) + [1..ctorArity ctor] +varExpr :: String -> Exp +varExpr = VarE . mkName +matchConstructor :: CtorDef -> Pat +matchConstructor ctor = ConP (mkName (ctorName ctor)) (fields++[]) where + fields = map (\field -> (VarP (mkName ("x" ++ show field)))) + (id [1..ctorArity ctor]) diff --git a/Data/Derive/Foldable.hs b/Data/Derive/Foldable.hs --- a/Data/Derive/Foldable.hs +++ b/Data/Derive/Foldable.hs @@ -10,21 +10,23 @@ -- NOTE: Cannot be guessed as it relies on type information -module Data.Derive.Foldable(makeFoldable) where +module Data.Derive.Foldable(makeFoldable, makeFoldableN) where import Language.Haskell.TH.All import Data.DeriveTraversal makeFoldable :: Derivation -makeFoldable = derivation derive "Foldable" +makeFoldable = makeFoldableN 1 -derive dat = traversalInstance1 foldrTraversal "Foldable" dat +makeFoldableN :: Int -> Derivation +makeFoldableN n = traversalDerivation1 foldrTraversal{traversalArg = n} "Foldable" foldrTraversal = defaultTraversalType { traversalName = "foldr" , traversalFunc = \n a -> l1 "flip" (l1 n a) , traversalPlus = fail "variable used in multiple positions in a data type" + , traversalId = l1 "flip" (l0 "const") , traverseTuple = foldr (.:) id' , traverseCtor = const $ foldr (.:) id' , traverseFunc = \pat rhs -> sclause [vr "f", vr "b", pat] (AppE rhs (vr "b")) diff --git a/Data/Derive/Functor.hs b/Data/Derive/Functor.hs --- a/Data/Derive/Functor.hs +++ b/Data/Derive/Functor.hs @@ -12,16 +12,17 @@ -- | Derives 'Functor', as discussed on the Haskell-prime mailing list: -- . -module Data.Derive.Functor(makeFunctor) where +module Data.Derive.Functor(makeFunctor,makeFunctorN) where import Language.Haskell.TH.All import Data.DeriveTraversal makeFunctor :: Derivation -makeFunctor = derivation derive "Functor" +makeFunctor = makeFunctorN 1 -derive dat = traversalInstance1 functorTraversal "Functor" dat +makeFunctorN :: Int -> Derivation +makeFunctorN n = traversalDerivation1 functorTraversal{traversalArg = n} "Functor" functorTraversal = defaultTraversalType { traversalName = "fmap" @@ -32,7 +33,7 @@ functorForArrowType :: Exp -> Exp -> Exp functorForArrowType a b | isId a && isId b = id' - | isId a = InfixE Nothing (l0 ".") (Just b) - | isId b = InfixE (Just a) (l0 ".") Nothing - | otherwise = LamE [l0 "arg"] $ a .: l0 "arg" .: b + | isId a = InfixE (Just b) (l0 ".") Nothing + | isId b = InfixE Nothing (l0 ".") (Just a) + | otherwise = LamE [l0 "arg"] $ b .: l0 "arg" .: a where isId = (id'==) diff --git a/Data/Derive/Traversable.hs b/Data/Derive/Traversable.hs --- a/Data/Derive/Traversable.hs +++ b/Data/Derive/Traversable.hs @@ -10,22 +10,23 @@ -- NOTE: Cannot be guessed as it relies on type information -module Data.Derive.Traversable(makeTraversable) where +module Data.Derive.Traversable(makeTraversable, makeTraversableN) where import Language.Haskell.TH.All import Data.DeriveTraversal makeTraversable :: Derivation -makeTraversable = derivation derive "Traversable" +makeTraversable = makeTraversableN 1 -derive dat = traversalInstance1 traverseTraversal "Traversable" dat +makeTraversableN :: Int -> Derivation +makeTraversableN n = traversalDerivation1 traverseTraversal{traversalArg = n} "Traversable" traverseTraversal = defaultTraversalType { traversalName = "traverse" , traversalId = l0 "pure" , traversalPlus = fail "variable used in multiple positions in a data type" - , traverseTuple = \args -> liftAN (VarE $ tupleDataName $ length args) args + , traverseTuple = \args -> liftAN (ConE $ tupleDataName $ length args) args , traverseCtor = \ctor -> liftAN (l0 ctor) , traverseFunc = \pat rhs -> sclause [vr "f", pat] rhs } diff --git a/Data/Derive/Typeable.hs b/Data/Derive/Typeable.hs --- a/Data/Derive/Typeable.hs +++ b/Data/Derive/Typeable.hs @@ -48,7 +48,7 @@ makeTypeable :: Derivation makeTypeable = derivation typeable' "Typeable" -typeable' dat = (funN nam [sclause [] (l1 "mkTyCon" $ lit $ dataName dat)]) +typeable' dat = (funN nam [sclause [] (l1 "mkTyCon" $ lit . show $ qualifiedDataName dat)]) : map f [0..dataArity dat] where nam = [if x == '.' then '_' else x | x <- "typename_" ++ dataName dat] diff --git a/Data/DeriveTH.hs b/Data/DeriveTH.hs --- a/Data/DeriveTH.hs +++ b/Data/DeriveTH.hs @@ -3,12 +3,13 @@ -- threading issues such that all one needs to do is: -- -- @ --- data Foo = Foo ; $( derive 'Data.Derive.StdDerivations.eq' ''Foo ) +-- data Foo = Foo ; $( derive makeEq ''Foo ) -- @ module Data.DeriveTH (derive, -- * Convienience re-exports Derivation, -- abstract! + module Data.Derive.All, -- * Internal _derive_string_instance ) where @@ -16,6 +17,7 @@ import Data.List import Control.Monad (liftM) +import Data.Derive.All import Language.Haskell.TH.All @@ -37,7 +39,7 @@ -- | Extract a 'DataDef' value from a type using the TH 'reify' -- framework. deriveOne :: Name -> Q DataDef -deriveOne x = liftM extract (reify x) +deriveOne x = extract =<< reify x -extract (TyConI decl) = normData decl +extract (TyConI decl) = liftM normData (expandData decl) extract _ = error $ "Data.Derive.TH.deriveInternal: not a type!" diff --git a/Data/DeriveTraversal.hs b/Data/DeriveTraversal.hs --- a/Data/DeriveTraversal.hs +++ b/Data/DeriveTraversal.hs @@ -14,6 +14,7 @@ -- . module Data.DeriveTraversal( TraveralType(..), defaultTraversalType, + traversalDerivation1, traversalInstance, traversalInstance1, deriveTraversal ) where @@ -78,6 +79,12 @@ --------------------------------------------------------------------------------- -- Deriving traversals + + +-- | Derivation for a Traversable like class with just 1 method +traversalDerivation1 :: TraveralType -> String -> Derivation +traversalDerivation1 tt nm = derivation (traversalInstance1 tt nm) (className (traversalArg tt)) + where className n = nm ++ (if n > 1 then show n else "") -- | Instance for a Traversable like class with just 1 method diff --git a/Derive.hs b/Derive.hs --- a/Derive.hs +++ b/Derive.hs @@ -110,7 +110,7 @@ dropAppend xs = f 0 xs where f i ys | appendMsg `isPrefixOf` ys = - if hashString rest == chk + if hashString (filter (/= '\r') rest) == chk then f i [] else (ys ++ "\n\n\n\n", True) where (chk, rest) = span isDigit $ drop (length appendMsg) ys @@ -122,8 +122,11 @@ add c ~(cs,b) = (c:cs,b) +-- note: need to be careful that on Windows we don't convert \n files into +-- \r\n files mainFile :: [Flag] -> FilePath -> IO () mainFile flags file = do + file <- canonicalizePath file (fileflags,pragmas,modname,datas,reqs) <- parseFile flags file let devs = ["'\\n': $( _derive_string_instance make" ++ cls ++ " ''" ++ ctor ++ " )" | (ctor,cls) <- reqs] @@ -134,8 +137,8 @@ "import Data.DeriveTH\n" ++ "import Data.Derive.All\n" ++ datas ++ "\n" ++ - "main = writeFile " ++ show x ++ " $\n" ++ - " unlines [" ++ concat (intersperse ", " devs) ++ "]\n" + "main = Prelude.writeFile " ++ show x ++ " $\n" ++ + " Prelude.unlines [" ++ concat (intersperse ", " devs) ++ "]\n" -- note: Wrong on Hugs on Windows tmpdir <- getTemporaryDirectory @@ -149,23 +152,27 @@ hPutStr hshndl $ hscode txfile hClose hshndl - system $ "ghc -e " ++ modname ++ ".main " ++ hsfile - - txhandl <- openFile txfile ReadMode - res <- hGetContents txhandl - length res `seq` return () - hClose txhandl + let incdir = dropTrailingPathSeparator $ joinPath $ reverse $ + drop (1 + length (filter (== '.') modname)) $ reverse $ splitPath file + cmd = "ghc -i. -i\"" ++ incdir ++ "\" -e " ++ modname ++ ".main " ++ hsfile + code <- system cmd + when (code /= ExitSuccess) $ do + putStrLn "Failed to generate the code" + exitWith code + res <- readFile' txfile when (KeepTemp `notElem` flags) $ do removeFile hsfile removeFile txfile flgs <- return $ fileflags ++ flags if Append `elem` flgs then do - src <- readFile file + src <- readFileBinary file let (src2,c) = dropAppend src + ans = (if '\r' `elem` src then windowsNewLine else id) + (src2 ++ if null res then "" else appendMsg ++ hashString res ++ "\n" ++ res) when c $ putStrLn "Warning, Checksum does not match, please edit the file manually" - writeFile file $ src2 ++ (if null res then "" else appendMsg ++ hashString res ++ "\n" ++ res) + writeFileBinary file ans else do let modline = concat $ take 1 ["module " ++ x ++ " where\n" | Module x <- flgs] impline = unlines ["import " ++ if null i then modname else i | Import i <- flgs] @@ -278,3 +285,33 @@ if b then openTempFileLocal dir template else do h <- openFile s ReadWriteMode return (s, h) + + +readFile' :: FilePath -> IO String +readFile' file = do + h <- openFile file ReadMode + res <- hGetContents h + length res `seq` return () + hClose h + return res + + +readFileBinary :: FilePath -> IO String +readFileBinary file = do + h <- openBinaryFile file ReadMode + hGetContents h + + +writeFileBinary :: FilePath -> String -> IO () +writeFileBinary file s = do + h <- openBinaryFile file WriteMode + hPutStr h s + hClose h + + +windowsNewLine :: String -> String +windowsNewLine ('\r':'\n':xs) = '\r':'\n': windowsNewLine xs +windowsNewLine ('\n':xs) = '\r':'\n': windowsNewLine xs +windowsNewLine (x:xs) = x : windowsNewLine xs +windowsNewLine [] = [] + diff --git a/Language/Haskell/TH/All.hs b/Language/Haskell/TH/All.hs --- a/Language/Haskell/TH/All.hs +++ b/Language/Haskell/TH/All.hs @@ -4,7 +4,7 @@ module Language.Haskell.TH.All, module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Peephole, module Language.Haskell.TH.Helper, module Language.Haskell.TH.FixedPpr, - module Language.Haskell.TH.Data, + module Language.Haskell.TH.Data, module Language.Haskell.TH.ExpandSynonym, module Language.Haskell.TH.SYB ) where @@ -12,6 +12,7 @@ import Language.Haskell.TH.Peephole import Language.Haskell.TH.Helper import Language.Haskell.TH.FixedPpr +import Language.Haskell.TH.ExpandSynonym import Language.Haskell.TH.Data import Language.Haskell.TH.SYB diff --git a/Language/Haskell/TH/Data.hs b/Language/Haskell/TH/Data.hs --- a/Language/Haskell/TH/Data.hs +++ b/Language/Haskell/TH/Data.hs @@ -18,9 +18,12 @@ dataName :: DataDef -> String -dataName (DataD _ name _ _ _) = show name -dataName (NewtypeD _ name _ _ _) = show name +dataName (DataD _ name _ _ _) = show (unqualifiedName name) +dataName (NewtypeD _ name _ _ _) = show (unqualifiedName name) +qualifiedDataName :: DataDef -> Name +qualifiedDataName (DataD _ name _ _ _) = name +qualifiedDataName (NewtypeD _ name _ _ _) = name dataArity :: DataDef -> Int dataArity (DataD _ _ xs _ _) = length xs @@ -33,12 +36,18 @@ ctorName :: CtorDef -> String -ctorName (NormalC name _ ) = show name -ctorName (RecC name _ ) = show name -ctorName (InfixC _ name _) = show name +ctorName (NormalC name _ ) = show (unqualifiedName name) +ctorName (RecC name _ ) = show (unqualifiedName name) +ctorName (InfixC _ name _) = show (unqualifiedName name) ctorName (ForallC _ _ c ) = ctorName c +qualifiedCtorName :: CtorDef -> Name +qualifiedCtorName (NormalC name _ ) = name +qualifiedCtorName (RecC name _ ) = name +qualifiedCtorName (InfixC _ name _) = name +qualifiedCtorName (ForallC _ _ c ) = qualifiedCtorName c + ctorArity :: CtorDef -> Int ctorArity (NormalC _ xs ) = length xs ctorArity (RecC _ xs ) = length xs @@ -58,7 +67,7 @@ ctorFields :: CtorDef -> [String] -ctorFields (RecC name xs) = [show a | (a,b,c) <- xs] +ctorFields (RecC name varStrictType) = [show (unqualifiedName name) | (name,strict,typ) <- varStrictType] ctorFields _ = [] @@ -72,15 +81,14 @@ normData :: DataDef -> DataDef -normData = everywhere (mkT normType) . everywhere (mkT normName) +normData = everywhere (mkT normType) where - normName :: Name -> Name - normName = mkName . dropModule . show - normType :: Type -> Type normType (ConT x) | show x == "[]" = ListT normType x = x +unqualifiedName :: Name -> Name +unqualifiedName = mkName . dropModule . show -- convert AppT chains back to a proper list diff --git a/Language/Haskell/TH/ExpandSynonym.hs b/Language/Haskell/TH/ExpandSynonym.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/ExpandSynonym.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE PatternGuards #-} + +-- | Expand type synonyms in data declarations. +-- +-- This is needed for some type based derivations. +module Language.Haskell.TH.ExpandSynonym (expandData) where + +import Language.Haskell.TH +import Language.Haskell.TH.Data +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.SYB +import Data.Generics + +-- | Expand type synonyms in a data declaration +expandData :: DataDef -> Q DataDef +expandData = everywhereM (mkM expandType) + +expandType :: Type -> Q Type +expandType t = expandType' t [] + +-- Walk over a type, collecting applied arguments +expandType' :: Type -> [Type] -> Q Type +expandType' (AppT t arg) args = expandType' t (arg:args) +expandType' t@(ConT name) args = do result <- expandSyn name args + case result of + Just (t',args') -> everywhereM (mkM expandType) $ foldl AppT t' args' + _ -> return $ foldl AppT t args +expandType' t args = return $ foldl AppT t args + +-- Is the name a type synonym and are there enough arguments? if so, apply it +expandSyn :: Name -> [Type] -> Q (Maybe (Type, [Type])) +expandSyn name args = recover (return Nothing) $ do + info <- reify name + case info of + TyConI (TySynD _ synArgs t) | length args >= length synArgs + -> return $ Just (substitute synArgs argsInst t, argsMore) -- instantiate type synonym + where (argsInst,argsMore) = splitAt (length synArgs) args + _ -> return Nothing + -- `recover` return Nothing + +-- Substitute names for types in a type +substitute :: [Name] -> [Type] -> Type -> Type +substitute ns ts = subst (zip ns ts) + where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` ns) . fst) s) t) + subst s (VarT n) + | Just t' <- lookup n s = t' + subst s (AppT a b) = AppT (subst s a) (subst s b) + subst _ t = t diff --git a/Language/Haskell/TH/SYB.hs b/Language/Haskell/TH/SYB.hs --- a/Language/Haskell/TH/SYB.hs +++ b/Language/Haskell/TH/SYB.hs @@ -6,7 +6,7 @@ import Language.Haskell.TH.Syntax import Data.PackedString -#ifndef NO_SYB +#ifdef TH_SYB instance Data PackedString where gfoldl k z x = z x diff --git a/derive.cabal b/derive.cabal --- a/derive.cabal +++ b/derive.cabal @@ -1,6 +1,7 @@ Cabal-Version: >= 1.2 Name: derive -Version: 0.1.1 +Version: 0.1.2 +build-type: Simple Copyright: 2006-7, Neil Mitchell Maintainer: ndmitchell@gmail.com Homepage: http://www-users.cs.york.ac.uk/~ndm/derive/ @@ -24,11 +25,13 @@ Library Extensions: CPP Build-Depends: template-haskell, filepath, mtl + if impl(ghc >= 6.10) + build-depends: base == 4.*, syb if flag(small_base) Build-Depends: base >= 3, containers, pretty, packedstring, random, process, directory - CPP-Options: "-DNO_SYB" else Build-Depends: base < 3 + CPP-Options: "-DTH_SYB" Exposed-Modules: Data.DeriveGuess @@ -67,6 +70,7 @@ Data.Derive.Uniplate Language.Haskell.TH.All Language.Haskell.TH.Data + Language.Haskell.TH.ExpandSynonym Language.Haskell.TH.FixedPpr Language.Haskell.TH.Helper Language.Haskell.TH.Peephole