packages feed

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 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>