derive 0.1.3 → 0.1.4
raw patch · 17 files changed
+155/−70 lines, 17 filessetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Data.Derive.Update: makeUpdate :: Derivation
+ Data.DeriveTH: deriveFromDec :: Derivation -> Dec -> Q [Dec]
+ Language.Haskell.TH.Helper: class (Eq nm) => NameLike nm
+ Language.Haskell.TH.Helper: instance NameLike Name
+ Language.Haskell.TH.Helper: instance NameLike String
+ Language.Haskell.TH.Helper: toName :: (NameLike nm) => nm -> Name
- Data.DeriveTraversal: TraveralType :: Int -> Bool -> String -> Trav -> Trav -> (String -> Trav -> Trav) -> (Trav -> Trav -> Trav) -> (Trav -> Trav -> Trav) -> ([Exp] -> Exp) -> (String -> [Exp] -> Exp) -> (Pat -> Exp -> Clause) -> TraveralType
+ Data.DeriveTraversal: TraveralType :: Int -> Bool -> nm -> Trav -> Trav -> (Name -> Trav -> Trav) -> (Trav -> Trav -> Trav) -> (Trav -> Trav -> Trav) -> ([Exp] -> Exp) -> (String -> [Exp] -> Exp) -> (Pat -> Exp -> Clause) -> TraveralType nm
- Data.DeriveTraversal: data TraveralType
+ Data.DeriveTraversal: data TraveralType nm
- Data.DeriveTraversal: deriveTraversal :: TraveralType -> DataDef -> WithInstances Dec
+ Data.DeriveTraversal: deriveTraversal :: (NameLike nm) => TraveralType nm -> DataDef -> WithInstances Dec
- Data.DeriveTraversal: traversalArg :: TraveralType -> Int
+ Data.DeriveTraversal: traversalArg :: TraveralType nm -> Int
- Data.DeriveTraversal: traversalCo :: TraveralType -> Bool
+ Data.DeriveTraversal: traversalCo :: TraveralType nm -> Bool
- Data.DeriveTraversal: traversalDerivation1 :: TraveralType -> String -> Derivation
+ Data.DeriveTraversal: traversalDerivation1 :: (NameLike nm) => TraveralType nm -> String -> Derivation
- Data.DeriveTraversal: traversalDirect :: TraveralType -> Trav
+ Data.DeriveTraversal: traversalDirect :: TraveralType nm -> Trav
- Data.DeriveTraversal: traversalFunc :: TraveralType -> String -> Trav -> Trav
+ Data.DeriveTraversal: traversalFunc :: TraveralType nm -> Name -> Trav -> Trav
- Data.DeriveTraversal: traversalId :: TraveralType -> Trav
+ Data.DeriveTraversal: traversalId :: TraveralType nm -> Trav
- Data.DeriveTraversal: traversalInstance :: TraveralType -> String -> DataDef -> [WithInstances Dec] -> [Dec]
+ Data.DeriveTraversal: traversalInstance :: (NameLike nm) => TraveralType nm -> String -> DataDef -> [WithInstances Dec] -> [Dec]
- Data.DeriveTraversal: traversalInstance1 :: TraveralType -> String -> DataDef -> [Dec]
+ Data.DeriveTraversal: traversalInstance1 :: (NameLike nm) => TraveralType nm -> String -> DataDef -> [Dec]
- Data.DeriveTraversal: traversalName :: TraveralType -> String
+ Data.DeriveTraversal: traversalName :: TraveralType nm -> nm
- Data.DeriveTraversal: traversalPlus :: TraveralType -> Trav -> Trav -> Trav
+ Data.DeriveTraversal: traversalPlus :: TraveralType nm -> Trav -> Trav -> Trav
- Data.DeriveTraversal: traverseArrow :: TraveralType -> Trav -> Trav -> Trav
+ Data.DeriveTraversal: traverseArrow :: TraveralType nm -> Trav -> Trav -> Trav
- Data.DeriveTraversal: traverseCtor :: TraveralType -> String -> [Exp] -> Exp
+ Data.DeriveTraversal: traverseCtor :: TraveralType nm -> String -> [Exp] -> Exp
- Data.DeriveTraversal: traverseFunc :: TraveralType -> Pat -> Exp -> Clause
+ Data.DeriveTraversal: traverseFunc :: TraveralType nm -> Pat -> Exp -> Clause
- Data.DeriveTraversal: traverseTuple :: TraveralType -> [Exp] -> Exp
+ Data.DeriveTraversal: traverseTuple :: TraveralType nm -> [Exp] -> Exp
- Language.Haskell.TH.Helper: l0 :: (Valcon a) => String -> a
+ Language.Haskell.TH.Helper: l0 :: (NameLike nm, Valcon a) => nm -> a
- Language.Haskell.TH.Helper: l1 :: (Valcon a) => String -> a -> a
+ Language.Haskell.TH.Helper: l1 :: (NameLike nm, Valcon a) => nm -> a -> a
- Language.Haskell.TH.Helper: l2 :: (Valcon a) => String -> a -> a -> a
+ Language.Haskell.TH.Helper: l2 :: (NameLike nm, Valcon a) => nm -> a -> a -> a
- Language.Haskell.TH.Helper: lK :: (Valcon a) => String -> [a] -> a
+ Language.Haskell.TH.Helper: lK :: (Valcon a, NameLike nm) => nm -> [a] -> a
- Language.Haskell.TH.Helper: vr :: (Valcon a) => String -> a
+ Language.Haskell.TH.Helper: vr :: (Valcon a, NameLike nm) => nm -> a
Files
- Data/Derive/All.hs +1/−0
- Data/Derive/Data.hs +0/−0
- Data/Derive/Eq.hs +7/−4
- Data/Derive/Foldable.hs +7/−2
- Data/Derive/Functor.hs +1/−1
- Data/Derive/Ord.hs +20/−13
- Data/Derive/Show.hs +4/−3
- Data/Derive/Traversable.hs +1/−1
- Data/Derive/Typeable.hs +1/−1
- Data/Derive/Update.hs +39/−0
- Data/DeriveTH.hs +9/−2
- Data/DeriveTraversal.hs +22/−16
- Derive.hs +9/−5
- Language/Haskell/TH/Helper.hs +26/−15
- Setup.hs +3/−3
- derive.cabal +4/−2
- derive.htm +1/−2
Data/Derive/All.hs view
@@ -32,3 +32,4 @@ import Data.Derive.TTypeable as D import Data.Derive.Typeable as D import Data.Derive.Uniplate as D+import Data.Derive.Update as D
Data/Derive/Data.hs view
Data/Derive/Eq.hs view
@@ -3,6 +3,8 @@ -- | Derive 'Eq', as specified in the Haskell 98 Language Report. module Data.Derive.Eq(makeEq) where +import Control.Monad(guard)+ import Language.Haskell.TH.All @@ -25,16 +27,17 @@ makeEq :: Derivation makeEq = derivation eq' "Eq"-eq' dat = [instance_context ["Eq"] "Eq" dat [FunD (mkName "==") ((map (\(ctorInd+eq' dat = [instance_context ["Eq"] "Eq" dat [FunD (mkName "==") ((map (\(_ ,ctor) -> (Clause [(ConP (mkName (ctorName ctor)) ((map (\field -> (VarP ( mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[])),(ConP (mkName (ctorName ctor)) ((map (\field -> (VarP (mkName ("y" ++ show field)))) (id [1..ctorArity ctor]))++[]))] (NormalB (foldl1With (VarE (mkName "&&")) (( map (\field -> (AppE (AppE (VarE (mkName "==")) (VarE (mkName ("x" ++ show field)))) (VarE (mkName ("y" ++ show field))))) (id [1..ctorArity ctor]))++- [(ConE (mkName "True"))]++[]))) [])) (id (zip [0..] (dataCtors dat))))++[(- Clause [WildP,WildP] (NormalB (ConE (mkName "False"))) [])]++[])]]-+ [(ConE (mkName "True"))]++[]))) [])) (id (zip [0..] (dataCtors dat))))+++ (guard (length (dataCtors dat) > 1) >> [(+ Clause [WildP,WildP] (NormalB (ConE (mkName "False"))) [])]+ )++[])]] {- -- HAND WRITTEN VERSION
Data/Derive/Foldable.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}++ {- This module is not written/maintained by the usual Data.Derive author. @@ -12,6 +15,8 @@ module Data.Derive.Foldable(makeFoldable, makeFoldableN) where +import qualified Data.Foldable ( foldr )+ import Language.Haskell.TH.All import Data.DeriveTraversal @@ -23,11 +28,11 @@ makeFoldableN n = traversalDerivation1 foldrTraversal{traversalArg = n} "Foldable" foldrTraversal = defaultTraversalType- { traversalName = "foldr"+ { traversalName = 'Data.Foldable.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"))+ , traverseFunc = \pat rhs -> sclause [vr "_f", vr "b", pat] (AppE rhs (vr "b")) }
Data/Derive/Functor.hs view
@@ -27,7 +27,7 @@ functorTraversal = defaultTraversalType { traversalName = "fmap" , traverseArrow = functorForArrowType- , traverseFunc = \pat rhs -> sclause [vr "f", pat] rhs+ , traverseFunc = \pat rhs -> sclause [vr "_f", pat] rhs } functorForArrowType :: Exp -> Exp -> Exp
Data/Derive/Ord.hs view
@@ -3,6 +3,7 @@ -- | Derive 'Ord', as specified in the Haskell 98 Language Report. module Data.Derive.Ord(makeOrd) where +import Control.Monad(guard) import Language.Haskell.TH.All #ifdef GUESS@@ -20,7 +21,7 @@ check (CtorOne x1) (CtorOne y1) = compare (tup1 x1) (tup1 y1) check (CtorTwo x1 x2) (CtorTwo y1 y2) = compare (x1,x2) (y1,y2) check (CtorTwo' x1 x2) (CtorTwo' y1 y2) = compare (x1,x2) (y1,y2)- check a b = compare (tag a) (tag b)+ check x y = compare (tag x) (tag y) tag (CtorZero{}) = 0 tag (CtorOne{}) = 1@@ -34,21 +35,27 @@ makeOrd :: Derivation makeOrd = derivation ord' "Ord" ord' dat = [instance_context ["Ord"] "Ord" dat [FunD (mkName "compare") [(Clause- [(VarP (mkName "a")),(VarP (mkName "b"))] (NormalB (applyWith (VarE (mkName- "check")) [(VarE (mkName "a")),(VarE (mkName "b"))])) [FunD (mkName "check"- ) ((map (\(ctorInd,ctor) -> (Clause [(ConP (mkName (ctorName ctor)) ((map (- \field -> (VarP (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[- ])),(ConP (mkName (ctorName ctor)) ((map (\field -> (VarP (mkName ("y" +++ [(VarP (lName "a")),(VarP (lName "b"))] (NormalB (applyWith (VarE (lName+ "check")) [(VarE (lName "a")),(VarE (lName "b"))])) (FunD (lName "check"+ ) ((map (\ (_,ctor) -> (Clause [(ConP (mkName (ctorName ctor)) ((map (+ \field -> (VarP (lName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[+ ])),(ConP (mkName (ctorName ctor)) ((map (\field -> (VarP (lName ("y" ++ show field)))) (id [1..ctorArity ctor]))++[]))] (NormalB (applyWith (VarE (- mkName "compare")) [(TupE ((map (\field -> (VarE (mkName ("x" ++ show field- )))) (id [1..ctorArity ctor]))++[])),(TupE ((map (\field -> (VarE (mkName (+ mkName "compare")) [(TupE ((map (\field -> (VarE (lName ("x" ++ show field+ )))) (id [1..ctorArity ctor]))++[])),(TupE ((map (\field -> (VarE (lName ( "y" ++ show field)))) (id [1..ctorArity ctor]))++[]))])) [])) (id (zip [0..- ] (dataCtors dat))))++[(Clause [(VarP (mkName "a")),(VarP (mkName "b"))] (- NormalB (applyWith (VarE (mkName "compare")) [(AppE (VarE (mkName "tag")) (- VarE (mkName "a"))),(AppE (VarE (mkName "tag")) (VarE (mkName "b")))])) [])- ]++[]),FunD (mkName "tag") ((map (\(ctorInd,ctor) -> (Clause [((flip RecP [+ ] (dataCtors dat))))+ ++ emptyIfOneCtor+ [(Clause [(VarP (lName "x")),(VarP (lName "y"))] (+ NormalB (applyWith (VarE (mkName "compare")) [(AppE (VarE (lName "tag")) (+ VarE (lName "x"))),(AppE (VarE (lName "tag")) (VarE (lName "y")))])) [])+ ])+ : emptyIfOneCtor+ [FunD (lName "tag") ((map (\ (ctorInd,ctor) -> (Clause [((flip RecP [ ]) (mkName (ctorName ctor)))] (NormalB (LitE (IntegerL ctorInd))) [])) (id- (zip [0..] (dataCtors dat))))++[])])]]]+ (zip [0..] (dataCtors dat)))))] ))]]]+ where lName = mkName . (++ "_Data_Derive_Ord__")+ emptyIfOneCtor = (guard (length (dataCtors dat) > 1) >>) {- -- HAND WRITTEN VERSION
Data/Derive/Show.hs view
@@ -14,10 +14,11 @@ show' dat = [instance_default "Show" dat [funN "showsPrec" body]] where- body = [ sclause [vr "p", ctp ctr 'x'] (showit ctr) | ctr <- dataCtors dat ]+ body = [ sclause [vr vname, ctp ctr 'x'] rhs+ | ctr <- dataCtors dat, let (vname, rhs) = showit ctr ] -showit ctr = case ctorFields ctr of [] -> norm- fl -> flds fl+showit ctr = case ctorFields ctr of [] -> ("p", norm)+ fl -> ("_", flds fl) where norm = l2 "showParen" (vr "p" >: lit (10::Integer)) ((.::) (intersperse (scl ' ')
Data/Derive/Traversable.hs view
@@ -28,7 +28,7 @@ , traversalPlus = fail "variable used in multiple positions in a data type" , traverseTuple = \args -> liftAN (ConE $ tupleDataName $ length args) args , traverseCtor = \ctor -> liftAN (l0 ctor)- , traverseFunc = \pat rhs -> sclause [vr "f", pat] rhs+ , traverseFunc = \pat rhs -> sclause [vr "_f", pat] rhs } liftAN :: Exp -> [Exp] -> Exp
Data/Derive/Typeable.hs view
@@ -59,5 +59,5 @@ where def = if n == 0 then l2 "mkTyConApp" (l0 nam) (lst []) else l0 ("typeOf" ++ sn ++ "Default")- vars = take n $ map (vr . return) ['a'..]+ vars = take n $ map (vr . (:"")) ['a'..] sn = let i = dataArity dat - n in if i == 0 then "" else show i
+ Data/Derive/Update.hs view
@@ -0,0 +1,39 @@+-- | A Pseudo derivation. For every label, creates a function+-- foo_u and foo_s which updates and sets the label respectively,+-- e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'+module Data.Derive.Update(makeUpdate) where++import Language.Haskell.TH.All+import Data.Char+import Data.List+{-+data Computer = Laptop {weight :: Int, memory :: Int}+ | Desktop {memory :: Int, processor :: Int}++==>++weight_u f r = r{weight = f (weight r)}+weight_s v = weight_u (const v)+memory_u f r = r{memory = f (memory r)}+memory_s v = memory_u (const v)+processor_u f r = r{processor = f (processor r)}+processor_s v = processor_u (const v)++-}++makeUpdate :: Derivation+makeUpdate = derivation update' "Update"++update' dat = concatMap f fields+ where+ ctors = dataCtors dat -- constructors of the data type+ fields = nub $ concatMap ctorFields ctors -- get all of the fields of every data type+ + f field = [ funN (field ++ "_u") $+ [sclause [vr "f",vr "r"] + $ RecUpdE (vr "r") [( mkName field+ , AppE (vr "f") $ AppE (vr field) (vr "r"))]]+ , funN (field ++ "_s") $+ [sclause [vr "v"] $ AppE (VarE (mkName $ field++"_u")) + (AppE (vr "const") $ vr "v")]+ ]
Data/DeriveTH.hs view
@@ -6,7 +6,7 @@ -- data Foo = Foo ; $( derive makeEq ''Foo ) -- @ module Data.DeriveTH- (derive,+ (derive, deriveFromDec, -- * Convienience re-exports Derivation, -- abstract! module Data.Derive.All,@@ -26,6 +26,11 @@ derive :: Derivation -> Name -> Q [Dec] derive (Derivation f _) nm = f =<< deriveOne nm +-- | Derive an instance of some class. @deriveFromDec@ only derives instances+-- for the type of the argument.+deriveFromDec :: Derivation -> Dec -> Q [Dec]+deriveFromDec (Derivation f _) dec = f =<< fromTyConDecl dec+ -- | Derive for a type and print the code to standard output. This is -- a internal hook for the use of the Derive executable. _derive_string_instance :: Derivation -> Name -> Q Exp@@ -41,5 +46,7 @@ deriveOne :: Name -> Q DataDef deriveOne x = extract =<< reify x -extract (TyConI decl) = liftM normData (expandData decl)+fromTyConDecl = liftM normData . expandData++extract (TyConI decl) = fromTyConDecl decl extract _ = error $ "Data.Derive.TH.deriveInternal: not a type!"
Data/DeriveTraversal.hs view
@@ -20,6 +20,7 @@ ) where import Language.Haskell.TH.All+import Language.Haskell.TH.Helper ( toName ) import Data.List import qualified Data.Set as S import Control.Monad.Writer@@ -39,13 +40,13 @@ type Trav = Exp -- | What kind of traversal are we deriving? -data TraveralType = TraveralType +data TraveralType nm = TraveralType { traversalArg :: Int -- ^ On what position are we traversing? , traversalCo :: Bool -- ^ covariant? - , traversalName :: String -- ^ name of the traversal function + , traversalName :: nm -- ^ name of the traversal function , traversalId :: Trav -- ^ Identity traversal , traversalDirect :: Trav -- ^ Traversal of 'a' - , traversalFunc :: String -> Trav -> Trav -- ^ Apply the sub-traversal function + , traversalFunc :: Name -> Trav -> Trav -- ^ Apply the sub-traversal function , traversalPlus :: Trav -> Trav -> Trav -- ^ Apply two non-identity traversals in sequence , traverseArrow :: Trav -> Trav -> Trav -- ^ Traverse a function type , traverseTuple :: [Exp] -> Exp -- ^ Construct a tuple from applied traversals @@ -58,7 +59,7 @@ , traversalCo = False , traversalName = undefined -- prevent warnings , traversalId = id'- , traversalDirect = l0 "f"+ , traversalDirect = l0 "_f" , traversalFunc = l1 , traversalPlus = (.:) , traverseArrow = fail "Cannot derive traversal over function types"@@ -82,17 +83,18 @@ -- | Derivation for a Traversable like class with just 1 method-traversalDerivation1 :: TraveralType -> String -> Derivation+traversalDerivation1 :: NameLike nm => TraveralType nm -> 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-traversalInstance1 :: TraveralType -> String -> DataDef -> [Dec]+traversalInstance1 :: NameLike nm => TraveralType nm -> String -> DataDef -> [Dec] traversalInstance1 tt nm dat = traversalInstance tt nm dat [deriveTraversal tt dat] -- | Instance for a Traversable like class-traversalInstance :: TraveralType -> String -> DataDef -> [WithInstances Dec] -> [Dec]+traversalInstance :: NameLike nm+ => TraveralType nm -> String -> DataDef -> [WithInstances Dec] -> [Dec] traversalInstance tt nameBase dat bodyM | dataArity dat == 0 = [] | otherwise = [InstanceD ctx head body]@@ -108,16 +110,17 @@ -- | Derive a 'traverse' like function-deriveTraversal :: TraveralType -> DataDef -> WithInstances Dec+deriveTraversal :: NameLike nm => TraveralType nm -> DataDef -> WithInstances Dec deriveTraversal tt dat = fun where- fun = funN (traversalNameN tt (traversalArg tt)) <$> body+ fun = funN (nameBase $ toName $ traversalNameN tt (traversalArg tt)) <$> body args = argPositions dat body = mapM (deriveTraversalCtor tt args) (dataCtors dat) -- | Derive a clause of a 'traverse' like function for a constructor-deriveTraversalCtor :: TraveralType -> ArgPositions -> CtorDef -> WithInstances Clause+deriveTraversalCtor :: NameLike nm+ => TraveralType nm -> ArgPositions -> CtorDef -> WithInstances Clause deriveTraversalCtor tt ap ctor = do tTypes <- mapM (deriveTraversalType tt ap) (ctorTypes ctor) return $ traverseFunc tt (ctp ctor 'a')@@ -125,7 +128,8 @@ -- | Derive a traversal for a type-deriveTraversalType :: TraveralType -> ArgPositions -> Type -> WithInstances Trav+deriveTraversalType :: NameLike nm+ => TraveralType nm -> ArgPositions -> Type -> WithInstances Trav deriveTraversalType tt ap (ForallT _ _ _) = fail "forall not supported in traversal deriving" deriveTraversalType tt ap (AppT (AppT ArrowT a) b) = traverseArrow tt <$> deriveTraversalType tt{traversalCo = not $ traversalCo tt} ap a@@ -140,7 +144,8 @@ -- | Find all arguments to a type application, then derive a traversal-deriveTraversalApp :: TraveralType -> ArgPositions -> Type -> [Type] -> WithInstances Trav+deriveTraversalApp :: NameLike nm+ => TraveralType nm -> ArgPositions -> Type -> [Type] -> WithInstances Trav deriveTraversalApp tt ap (AppT a b) args = deriveTraversalApp tt ap a (b : args) deriveTraversalApp tt ap tycon args | isTupleT tycon = do -- (a,b,c)@@ -174,12 +179,13 @@ -- | Lift a traversal to the argument of a type constructor-traverseArg :: TraveralType -> Int -> Trav -> Trav+traverseArg :: NameLike nm => TraveralType nm -> Int -> Trav -> Trav traverseArg tt n e = traversalFunc tt (traversalNameN tt n) e -traversalNameN :: TraveralType -> Int -> String-traversalNameN tt n = traversalName tt ++ (if n > 1 then show n else "")-+traversalNameN :: NameLike nm => TraveralType nm -> Int -> Name+traversalNameN tt n | n <= 1 = nm+ | otherwise = mkName (nameBase nm ++ (if n > 1 then show n else ""))+ where nm = toName (traversalName tt) -- | Information on argument positions type ArgPositions = Name -> Int
Derive.hs view
@@ -36,6 +36,8 @@ -import, should an import statement be added +-import-derivation, additional modules providing derivations+ -module name, should a module statement be added, and if so with what name -append, append the code to the current file (overrides all other flags)@@ -46,7 +48,7 @@ -data Flag = Version | Help | Output String | Import String | Module String+data Flag = Version | Help | Output String | Import String | Module String | Use String | Append | Derive [String] | KeepTemp | NoOpts deriving (Eq, Show) @@ -57,6 +59,7 @@ , Option "h?" ["help"] (NoArg Help) "show help message" , Option "o" ["output"] (ReqArg Output "FILE") "output FILE" , Option "i" ["import"] (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"+ , Option "u" ["use"] (ReqArg Use "MODULE") "use additional derivations" , Option "m" ["module"] (ReqArg Module "MODULE") "add a module MODULE where statement" , Option "a" ["append"] (NoArg Append) "append the result to the file" , Option "d" ["derive"] (ReqArg splt "DERIVES") "things to derive for all types"@@ -71,11 +74,11 @@ getOpts = do args <- getArgs case getOpt Permute options args of- (o,n,[] ) | Version `elem` o -> putStrLn "Derive 0.1.3, (C) Neil Mitchell & Stefan O'Rear 2006-2007" >> exitSuccess+ (o,n,[] ) | Version `elem` o -> putStrLn "Derive 0.1, (C) Neil Mitchell & Stefan O'Rear 2006-2008" >> exitSuccess | Help `elem` o -> putStr useage >> exitSuccess | null n -> putStr ("no files specified\n" ++ useage) >> exitSuccess | otherwise -> return (o, n)- (_,_,errs) -> putStr (concat errs ++ useage) >> exitFailure+ (_,_,errs) -> hPutStr stderr (concat errs ++ useage) >> exitFailure where useage = usageInfo "Usage: derive [OPTION...] files..." options exitSuccess = exitWith ExitSuccess@@ -91,7 +94,7 @@ pickFile :: FilePath -> IO (Maybe FilePath) pickFile orig = f [orig, orig <.> "hs", orig <.> "lhs"] where- f [] = putStrLn ("Error, file not found: " ++ orig) >> return Nothing+ f [] = hPutStrLn stderr ("Error, file not found: " ++ orig) >> return Nothing f (x:xs) = do b <- doesFileExist x if b then return $ Just x else f xs@@ -136,6 +139,7 @@ "module " ++ modname ++ " where\n" ++ "import Data.DeriveTH\n" ++ "import Data.Derive.All\n" +++ concat [ "import " ++ x ++ "\n" | Use x <- flags ] ++ datas ++ "\n" ++ "main = Prelude.writeFile " ++ show x ++ " $\n" ++ " Prelude.unlines [" ++ concat (intersperse ", " devs) ++ "]\n"@@ -154,7 +158,7 @@ let incdir = dropTrailingPathSeparator $ joinPath $ reverse $ drop (1 + length (filter (== '.') modname)) $ reverse $ splitPath file- cmd = "ghc -i. -i\"" ++ incdir ++ "\" -e " ++ modname ++ ".main " ++ hsfile+ cmd = "ghc -w -i. -i\"" ++ incdir ++ "\" -e " ++ modname ++ ".main " ++ hsfile code <- system cmd when (code /= ExitSuccess) $ do putStrLn "Failed to generate the code"
Language/Haskell/TH/Helper.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE TypeSynonymInstances #-}++ -- | These small short-named functions are intended to make the -- construction of abstranct syntax trees less tedious. module Language.Haskell.TH.Helper where@@ -79,6 +82,11 @@ -- * Pattern vs Value abstraction +class Eq nm => NameLike nm where+ toName :: nm -> Name+instance NameLike Name where toName = id+instance NameLike String where toName = mkName+ -- | The class used to overload lifting operations. To reduce code -- duplication, we overload the wrapped constructors (and everything -- else, but that's irrelevant) to work in patterns, expressions, and@@ -86,9 +94,9 @@ class Valcon a where -- | Build an application node, with a name for a head and a -- provided list of arguments.- lK :: String -> [a] -> a+ lK :: NameLike nm => nm -> [a] -> a -- | Reference a named variable.- vr :: String -> a+ vr :: NameLike nm => nm -> a -- | Lift a TH 'Lit' raw_lit :: Lit -> a -- | Tupling@@ -96,25 +104,28 @@ -- | Listing lst :: [a] -> a instance Valcon Exp where- lK "[]" [] = ConE (mkName "[]")- lK "[]" xs = lst xs- lK nm@(x:_) args | isUpper x || x == ':' = foldl AppE (ConE (mkName nm)) args- lK nm@(x:_) [a,b] | isOper x = InfixE (Just a) (VarE (mkName nm)) (Just b)+ lK nm ys = let name = toName nm in case (nameBase name, ys) of+ ("[]", []) -> ConE name+ ("[]", xs) -> lst xs+ ((x:_), args) | isUpper x || x == ':' -> foldl AppE (ConE name) args+ ((x:_), [a,b]) | isOper x -> InfixE (Just a) (VarE name) (Just b) where isOper x = not (isAlpha x || x == '_')- lK nm args = foldl AppE (VarE (mkName nm)) args- vr = VarE . mkName+ (nm, args) -> foldl AppE (VarE name) args++ vr = VarE . toName raw_lit = LitE tup = TupE lst = ListE instance Valcon Pat where- lK = ConP . mkName- vr = VarP . mkName+ lK = ConP . toName+ vr = VarP . toName raw_lit = LitP tup = TupP lst = ListP instance Valcon Type where- lK nm = foldl AppT (if nm == "[]" then ListT else ConT (mkName nm))- vr = VarT . mkName+ lK nm = foldl AppT (if bNm == "[]" then ListT else ConT (mkName bNm))+ where bNm = nameBase (toName nm)+ vr = VarT . toName raw_lit = error "raw_lit @ Type" tup l = foldl AppT (TupleT (length l)) l lst = error "lst @ Type"@@ -170,9 +181,9 @@ -- * Lift a constructor over a fixed number of arguments. -l0 :: Valcon a => String -> a-l1 :: Valcon a => String -> a -> a-l2 :: Valcon a => String -> a -> a -> a+l0 :: (NameLike nm, Valcon a) => nm -> a+l1 :: (NameLike nm, Valcon a) => nm -> a -> a+l2 :: (NameLike nm, Valcon a) => nm -> a -> a -> a l0 s = lK s [] l1 s a = lK s [a] l2 s a b = lK s [a,b]
Setup.hs view
@@ -8,7 +8,7 @@ import Control.Monad -main = defaultMainWithHooks defaultUserHooks{runTests=test}+main = defaultMainWithHooks simpleUserHooks{runTests=test} test :: CabalBreaksTheAPI_Grr grr => Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO grr@@ -19,11 +19,11 @@ b <- doesFileExist "Small.out.hs" when b $ removeFile "Small.out.hs"- i <- system $ "derive -mSmallInstancess -iSmall -iData.Generics -iData.Monoid " +++ i <- system $ "derive -mSmallInstances -iSmall -iData.Generics -iData.Monoid " ++ "-o Small.out.hs Small.hs" b <- doesFileExist "Small.out.hs"- if b then system "diff -u Small.expected.hs Small.out.hs" >> return ()+ if b then system "diff -u -b Small.expected.hs Small.out.hs" >> return () else putStrLn "Error: Failed to generate the output file" -- currently we turn off warnings when compiling
derive.cabal view
@@ -1,6 +1,7 @@ Cabal-Version: >= 1.2+Build-Type: Custom Name: derive-Version: 0.1.3+Version: 0.1.4 build-type: Simple Copyright: 2006-7, Neil Mitchell Maintainer: ndmitchell@gmail.com@@ -26,7 +27,7 @@ Extensions: CPP Build-Depends: template-haskell, filepath, mtl if impl(ghc >= 6.10)- build-depends: base >= 4 && < 5, syb+ build-depends: base == 4.*, syb if flag(small_base) Build-Depends: base >= 3, containers, pretty, packedstring, random, process, directory else@@ -68,6 +69,7 @@ Data.Derive.TTypeable Data.Derive.Typeable Data.Derive.Uniplate+ Data.Derive.Update Language.Haskell.TH.All Language.Haskell.TH.Data Language.Haskell.TH.ExpandSynonym
derive.htm view
@@ -72,8 +72,7 @@ <h3>Acknowledgements</h3> <p>- Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson.- Thanks also to Joel Raymont for being the first user of Data.Derive, and generally helping us feel like we weren't wasting our time.+ Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson, Joel Raymont, Benedikt Huber. </p>