derive (empty) → 0.1
raw patch · 39 files changed
+3797/−0 lines, 39 filesdep +basedep +filepathdep +mtlbuild-type:Customsetup-changed
Dependencies added: base, filepath, mtl, template-haskell
Files
- Data/Derive/All.hs +28/−0
- Data/Derive/Arbitrary.hs +69/−0
- Data/Derive/Arbitrary2.hs +52/−0
- Data/Derive/Binary.hs +34/−0
- Data/Derive/BinaryDefer.hs +48/−0
- Data/Derive/Bounded.hs +36/−0
- Data/Derive/Data.hs +42/−0
- Data/Derive/Enum.hs +46/−0
- Data/Derive/EnumCyclic.hs +66/−0
- Data/Derive/Eq.hs +48/−0
- Data/Derive/From.hs +36/−0
- Data/Derive/Functor.hs +69/−0
- Data/Derive/Has.hs +41/−0
- Data/Derive/Is.hs +31/−0
- Data/Derive/LazySet.hs +42/−0
- Data/Derive/Monoid.hs +32/−0
- Data/Derive/NFData.hs +33/−0
- Data/Derive/Ord.hs +68/−0
- Data/Derive/Play.hs +188/−0
- Data/Derive/PlayAll.hs +48/−0
- Data/Derive/Read.hs +45/−0
- Data/Derive/Serial.hs +57/−0
- Data/Derive/Set.hs +34/−0
- Data/Derive/Show.hs +35/−0
- Data/Derive/TTypeable.hs +26/−0
- Data/Derive/Typeable.hs +63/−0
- Data/DeriveGuess.hs +407/−0
- Data/DeriveTH.hs +43/−0
- Derive.hs +275/−0
- LICENSE +30/−0
- Language/Haskell/TH/All.hs +23/−0
- Language/Haskell/TH/Data.hs +158/−0
- Language/Haskell/TH/FixedPpr.hs +358/−0
- Language/Haskell/TH/Helper.hs +226/−0
- Language/Haskell/TH/Peephole.hs +179/−0
- Language/Haskell/TH/SYB.hs +368/−0
- Setup.hs +2/−0
- derive.cabal +58/−0
- derive.htm +353/−0
+ Data/Derive/All.hs view
@@ -0,0 +1,28 @@+-- | This module provides convenience re-exports of all the standard+-- Data.Derive derivations.+module Data.Derive.All (module D) where++import Data.Derive.Arbitrary as D+import Data.Derive.Binary as D+import Data.Derive.BinaryDefer as D+import Data.Derive.Bounded as D+import Data.Derive.Data as D+import Data.Derive.Enum as D+import Data.Derive.EnumCyclic as D+import Data.Derive.Eq as D+import Data.Derive.From as D+import Data.Derive.Functor as D+import Data.Derive.Has as D+import Data.Derive.Is as D+import Data.Derive.LazySet as D+import Data.Derive.Monoid as D+import Data.Derive.NFData as D+import Data.Derive.Ord as D+import Data.Derive.Play as D+import Data.Derive.PlayAll as D+import Data.Derive.Read as D+import Data.Derive.Serial as D+import Data.Derive.Set as D+import Data.Derive.Show as D+import Data.Derive.TTypeable as D+import Data.Derive.Typeable as D
+ Data/Derive/Arbitrary.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}++-- | Derivation for 'Test.QuickCheck.Arbitrary'.+--+-- Things to note:+--+-- * The resulting instances do not implement @coarbitrary@, only+-- @arbitrary@.+--+-- * 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.Arbitrary(makeArbitrary) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Test.QuickCheck+import Data.DeriveGuess++example = (,) "Arbitrary" [d|+++ instance Arbitrary a => Arbitrary (DataName a) where+ arbitrary = do+ x <- choose (0,3)+ case x of+ 0 -> do return CtorZero+ 1 -> do x1 <- arbitrary+ return (CtorOne x1)+ 2 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (CtorTwo x1 x2)+ 3 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (CtorTwo' x1 x2)++ coarbitrary CtorZero = variant 0+ coarbitrary (CtorOne x1) = variant 1 . coarbitrary x1+ coarbitrary (CtorTwo x1 x2) = variant 2 . coarbitrary x1 . coarbitrary x2+ coarbitrary (CtorTwo' x1 x2) = variant 3 . coarbitrary x1 . coarbitrary x2+ |]++#endif++makeArbitrary :: Derivation+makeArbitrary = Derivation arbitrary' "Arbitrary"+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 (+ 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+ "arbitrary")))) (id [1..ctorArity ctor]))++[(NoBindS (AppE (VarE (mkName+ "return")) (applyWith (ConE (mkName ("" ++ ctorName ctor))) ((map (\field+ -> (VarE (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[]))))]+ ++[]))) [])) (id (zip [0..] (dataCtors dat))))++[])))])) []),(FunD (mkName+ "coarbitrary") ((map (\(ctorInd,ctor) -> (Clause [(ConP (mkName ("" +++ ctorName ctor)) ((map (\field -> (VarP (mkName ("x" ++ show field)))) (id [+ 1..ctorArity ctor]))++[]))] (NormalB (foldl1With (VarE (mkName ".")) ([(+ AppE (VarE (mkName "variant")) (LitE (IntegerL ctorInd)))]++(map (\field ->+ (AppE (VarE (mkName "coarbitrary")) (VarE (mkName ("x" ++ show field))))) (+ id [1..ctorArity ctor]))++[]))) [])) (id (zip [0..] (dataCtors dat))))++[])+ )]]
+ Data/Derive/Arbitrary2.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}++-- | Derivation for 'Test.QuickCheck.Arbitrary'.+--+-- * 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++import Language.Haskell.TH.All+++#ifdef GUESS++import Test.QuickCheck+import Data.DeriveGuess++example = (,) "Arbitrary" [d|+++ instance Arbitrary a => Arbitrary (DataName a) where+ arbitrary = do+ x <- choose (0,3)+ case x of+ 0 -> do return CtorZero+ 1 -> do x1 <- arbitrary+ return (CtorOne x1)+ 2 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (CtorTwo x1 x2)+ 3 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (CtorTwo' x1 x2)+ |]++#endif++makeArbitrary :: Derivation+makeArbitrary = Derivation arbitrary' "Arbitrary"+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 (+ 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 + "arbitrary")))) (id [1..ctorArity ctor]))++[(NoBindS (AppE (VarE (mkName + "return")) (applyWith (ConE (mkName ("" ++ ctorName ctor))) ((map (\field + -> (VarE (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[]))))]+ ++[]))) [])) (id (zip [0..] (dataCtors dat))))++[])))])) [])]]
+ Data/Derive/Binary.hs view
@@ -0,0 +1,34 @@+-- NOTE: Cannot be guessed as is not inductive because of getWordN++-- | Derivation for Data.Binary's Binary class for serializing values.+-- The generated instances implement a very simple tagged data format.+-- First, the (0-based) constructor number is stored, in the smallest+-- of 0, 1, 2, or 4 bytes that can represent the entire range. Then,+-- the constructor's arguments are stored, in order, using the Binary+-- instances in scope.+module Data.Derive.Binary(makeBinary) where++import Language.Haskell.TH.All+import Data.List++makeBinary :: Derivation+makeBinary = Derivation derive "Binary"++derive dat =+ simple_instance "Binary" dat [funN "put" pbody, funN "get" gbody]+ where+ pbody = [ sclause [ctp ctor 'x'] (put_case nm ctor) | (nm,ctor) <- items ]+ put_case nm ctor = sequence__ (ptag (lit nm) : map (l1 "put") (ctv ctor 'x'))++ gbody = [sclause [] (gtag >>=: ("tag_" ->: case' (vr "tag_") (map get_case items)))]+ get_case (nm,ctor) = (lit nm, liftmk (ctc ctor) (replicate (ctorArity ctor) (vr "get")))++ ctors = dataCtors dat+ nctors = length ctors+ items :: [(Integer,CtorDef)]+ items = zip [0..] ctors++ (ptag, gtag) | nctors <= 1 = (\_ -> return' unit, return' (lit (0::Integer)))+ | nctors <= 256 = (l1 "putWord8", l0 "getWord8")+ | nctors <= 65536 = (l1 "putWord16", l0 "getWord16")+ | otherwise = (l1 "putWord32", l0 "getWord32")
+ Data/Derive/BinaryDefer.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -fth -cpp #-}++-- | Derivation for Neil Mitchell's BinaryDefer class. XXX: do research, write useful haddock+module Data.Derive.BinaryDefer(makeBinaryDefer) where++import Language.Haskell.TH.All hiding (unit)++#ifdef GUESS++import Data.DeriveGuess+import Data.Binary.Defer++instance Eq (DataName a) where++example = (,) "BinaryDefer" [d|++ instance BinaryDefer a => BinaryDefer (DataName a) where+ bothDefer = defer [\ ~(CtorZero) -> unit CtorZero+ ,\ ~(CtorOne x1) -> unit CtorOne << x1+ ,\ ~(CtorTwo x1 x2) -> unit CtorTwo << x1 << x2+ ,\ ~(CtorTwo' x1 x2) -> unit CtorTwo' << x1 << x2+ ]++ |]++#endif++makeBinaryDefer :: Derivation+makeBinaryDefer = Derivation binarydefer' "BinaryDefer"+binarydefer' dat = [instance_context ["BinaryDefer"] "BinaryDefer" dat [ValD (+ VarP (mkName "bothDefer")) (NormalB (AppE (VarE (mkName "defer")) (ListE ((+ map (\(ctorInd,ctor) -> (LamE [(TildeP (ConP (mkName (ctorName ctor)) ((map+ (\field -> (VarP (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))+++ [])))] (foldr1With (VarE (mkName "<<")) ((map (\field -> (VarE (mkName ("x"+ ++ show field)))) (reverse [1..ctorArity ctor]))++[(AppE (VarE (mkName+ "unit")) (ConE (mkName (ctorName ctor))))]++[])))) (id (zip [0..] (+ dataCtors dat))))++[])))) []]]+ ++{- ++derive dat = simple_instance "BinaryDefer" dat [funN "bothDefer" [ body ] ]+ where+ body = sclause [] (l1 "defer" (lst [ f ct | ct <- dataCtors dat ]))++ f ctor = LamE [TildeP (ctp ctor 'v')] $+ foldl (l2 "<<") (l1 "unit" (ctc ctor)) (ctv ctor 'v')+-}
+ Data/Derive/Bounded.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -fth -cpp #-}++-- | Derive @Bounded@, as specified in the Haskell 98 Language Report.+-- As an extension, we support deriving @Bounded@ for all data types.+-- If the first or last constructor has non-zero arity, we call+-- minBound (respectively, maxBound) recursively to fill in the+-- fields.+module Data.Derive.Bounded(makeBounded) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Data.DeriveGuess++example = (,) "Bounded" [d|++ instance Bounded a => Bounded (DataName a) where+ minBound = head [CtorZero, CtorOne minBound, CtorTwo minBound minBound, CtorTwo' minBound minBound]+ maxBound = head [CtorTwo' maxBound maxBound, CtorTwo maxBound maxBound, CtorOne maxBound, CtorZero]++ |]++#endif++makeBounded :: Derivation+makeBounded = Derivation bounded' "Bounded"+bounded' dat = [instance_context ["Bounded"] "Bounded" dat [(ValD (VarP (mkName+ "minBound")) (NormalB (AppE (VarE (mkName "head")) (ListE ((map (\(ctorInd,+ ctor) -> (applyWith (ConE (mkName ("" ++ ctorName ctor))) (replicate (+ ctorArity ctor) (VarE (mkName "minBound"))))) (id (zip [0..] (dataCtors dat+ ))))++[])))) []),(ValD (VarP (mkName "maxBound")) (NormalB (AppE (VarE (+ mkName "head")) (ListE ((map (\(ctorInd,ctor) -> (applyWith (ConE (mkName (+ "" ++ ctorName ctor))) (replicate (ctorArity ctor) (VarE (mkName "maxBound"+ ))))) (reverse (zip [0..] (dataCtors dat))))++[])))) [])]]
+ Data/Derive/Data.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}++-- | 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).++module Data.Derive.Data(makeData) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Data.Generics+import Data.DeriveGuess++instance Typeable (DataName a) where++example = (,) "Data" [d|++ instance (Data a, Typeable a) => Data (DataName a) where+ gfoldl k r CtorZero = r CtorZero+ 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++makeData :: Derivation+makeData = Derivation data' "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))))+++ [])]]
+ Data/Derive/Enum.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -fth -cpp #-}++-- | Derivation for 'Enum', as defined by the Haskell 98 Language+-- report, except that we support arbitrary types. toEnum (and+-- derived functions, notably succ and pred) use undefined to fill all+-- fields of nonzero arity constructors.+module Data.Derive.Enum(makeEnum) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Data.DeriveGuess++example = (,) "Enum" [d|++ instance Enum (DataName a) where+ toEnum 0 = CtorZero{}+ toEnum 1 = CtorOne {}+ toEnum 2 = CtorTwo {}+ toEnum 3 = CtorTwo'{}+ toEnum n = error $ "toEnum " ++ show n ++ ", not defined for " ++ "DataName"+ + fromEnum (CtorZero{}) = 0+ fromEnum (CtorOne {}) = 1+ fromEnum (CtorTwo {}) = 2+ fromEnum (CtorTwo'{}) = 3++ |]++#endif++makeEnum :: Derivation+makeEnum = Derivation enum' "Enum"+enum' dat = [instance_context [] "Enum" dat [FunD (mkName "toEnum") ((map (\(+ ctorInd,ctor) -> (Clause [(LitP (IntegerL ctorInd))] (NormalB ((flip+ RecConE []) (mkName (ctorName ctor)))) [])) (id (zip [0..] (dataCtors dat))+ ))++[(Clause [(VarP (mkName "n"))] (NormalB (applyWith (VarE (mkName "$"))+ [(VarE (mkName "error")),(applyWith (VarE (mkName "++")) [(LitE (StringL+ "toEnum ")),(applyWith (VarE (mkName "++")) [(AppE (VarE (mkName "show")) (+ VarE (mkName "n"))),(applyWith (VarE (mkName "++")) [(LitE (StringL+ ", not defined for ")),(LitE (StringL (dataName dat)))])])])])) [])]++[]),+ FunD (mkName "fromEnum") ((map (\(ctorInd,ctor) -> (Clause [((flip RecP [])+ (mkName (ctorName ctor)))] (NormalB (LitE (IntegerL ctorInd))) [])) (id (+ zip [0..] (dataCtors dat))))++[])]]
+ Data/Derive/EnumCyclic.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS_GHC -fth -cpp #-}++-- | @EnumCyclic@ defines the @Enum@ class, using the same+-- modifications as our @Enum@ derivation, but additionally @succ@+-- and @pred@ treat the data type as cyclic, wrapping between the+-- first and last constructors.++module Data.Derive.EnumCyclic(makeEnumCyclic) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Data.DeriveGuess++example = (,) "EnumCyclic" [d|++ instance Enum (DataName a) where+ toEnum 0 = CtorZero{}+ toEnum 1 = CtorOne {}+ toEnum 2 = CtorTwo {}+ toEnum 3 = CtorTwo'{}+ toEnum n = error $ "toEnum " ++ show n ++ ", not defined for " ++ "DataName"+ + fromEnum (CtorZero{}) = 0+ fromEnum (CtorOne {}) = 1+ fromEnum (CtorTwo {}) = 2+ fromEnum (CtorTwo'{}) = 3+ + + succ a = if b == 3 then toEnum 0 else toEnum (b+1)+ where b = fromEnum a++ pred a = if b == 0 then toEnum 3 else toEnum (b-1)+ where b = fromEnum a++ |]++#endif++makeEnumCyclic :: Derivation+makeEnumCyclic = Derivation enumCyclic' "EnumCyclic"+enumCyclic' dat = [instance_context [] "Enum" dat [(FunD (mkName "toEnum") ((+ map (\(ctorInd,ctor) -> (Clause [(LitP (IntegerL ctorInd))] (NormalB ((flip+ RecConE []) (mkName ("" ++ ctorName ctor)))) [])) (id (zip [0..] (dataCtors+ dat))))++[(Clause [(VarP (mkName "n"))] (NormalB (applyWith (VarE (mkName+ "$")) [(VarE (mkName "error")),(applyWith (VarE (mkName "++")) [(LitE (+ StringL "toEnum ")),(applyWith (VarE (mkName "++")) [(AppE (VarE (mkName+ "show")) (VarE (mkName "n"))),(applyWith (VarE (mkName "++")) [(LitE (+ StringL ", not defined for ")),(LitE (StringL (dataName dat)))])])])])) [])+ ]++[])),(FunD (mkName "fromEnum") ((map (\(ctorInd,ctor) -> (Clause [((flip+ RecP []) (mkName ("" ++ ctorName ctor)))] (NormalB (LitE (IntegerL ctorInd)+ )) [])) (id (zip [0..] (dataCtors dat))))++[])),(FunD (mkName "succ") [(+ Clause [(VarP (mkName "a"))] (NormalB (CondE (applyWith (VarE (mkName "==")+ ) [(VarE (mkName "b")),(LitE (IntegerL (toInteger (length (dataCtors dat)))+ ))]) (AppE (VarE (mkName "toEnum")) (LitE (IntegerL 0))) (AppE (VarE (+ mkName "toEnum")) (applyWith (VarE (mkName "+")) [(VarE (mkName "b")),(LitE+ (IntegerL 1))])))) [(ValD (VarP (mkName "b")) (NormalB (AppE (VarE (mkName+ "fromEnum")) (VarE (mkName "a")))) [])])]),(FunD (mkName "pred") [(Clause [+ (VarP (mkName "a"))] (NormalB (CondE (applyWith (VarE (mkName "==")) [(VarE+ (mkName "b")),(LitE (IntegerL 0))]) (AppE (VarE (mkName "toEnum")) (LitE (+ IntegerL (toInteger (length (dataCtors dat)))))) (AppE (VarE (mkName+ "toEnum")) (applyWith (VarE (mkName "-")) [(VarE (mkName "b")),(LitE (+ IntegerL 1))])))) [(ValD (VarP (mkName "b")) (NormalB (AppE (VarE (mkName+ "fromEnum")) (VarE (mkName "a")))) [])])])]]
+ Data/Derive/Eq.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -fth -cpp #-}++-- | Derive 'Eq', as specified in the Haskell 98 Language Report.+module Data.Derive.Eq(makeEq) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Data.DeriveGuess++example = (,) "Eq" [d|++ instance Eq a => Eq (DataName a) where+ CtorZero == CtorZero = True+ (CtorOne x1) == (CtorOne y1) = x1 == y1 && True+ (CtorTwo x1 x2) == (CtorTwo y1 y2) = x1 == y1 && x2 == y2 && True+ (CtorTwo' x1 x2) == (CtorTwo' y1 y2) = x1 == y1 && x2 == y2 && True+ _ == _ = False++ |]++#endif++makeEq :: Derivation+makeEq = Derivation eq' "Eq"+eq' dat = [instance_context ["Eq"] "Eq" dat [FunD (mkName "==") ((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" ++ 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"))) [])]++[])]]+++{-+-- HAND WRITTEN VERSION++eq' dat = simple_instance "Eq" dat [funN "==" body]+ where+ body = map rule (dataCtors dat) ++ [defclause 2 false]++rule ctor = sclause [ctp ctor 'a', ctp ctor 'b']+ (and_ (zipWith (==:) (ctv ctor 'a') (ctv ctor 'b')))+-}
+ Data/Derive/From.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -fth -cpp #-}++-- | A pseudo derivation. For each constructor in the data type,+-- deriving @From@ generates @from@/CtorName/ which extracts the+-- components if given the appropriate constructor, and crashes+-- otherwise. Unlike the DrIFT @\"From\"@ derivation, our version+-- works for all constructors - zero-arity constructors always return+-- @()@, arity-one constructors return the contained value, and all+-- others return a tuple with all the components.+module Data.Derive.From(makeFrom) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Data.DeriveGuess++example = (,) "From" [d|++ fromCtorZero (CtorZero) = ()+ fromCtorOne (CtorOne x1) = tup1 x1+ fromCtorTwo (CtorTwo x1 x2) = (x1,x2)+ fromCtorTwo' (CtorTwo' x1 x2) = (x1,x2)++ |]++#endif++makeFrom :: Derivation+makeFrom = Derivation from' "From"+from' dat = ((map (\(ctorInd,ctor) -> (FunD (mkName ("from" ++ ctorName ctor))+ [(Clause [(ConP (mkName ("" ++ ctorName ctor)) ((map (\field -> (VarP (+ mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[]))] (NormalB (+ TupE ((map (\field -> (VarE (mkName ("x" ++ show field)))) (id [1..+ ctorArity ctor]))++[]))) [])])) (id (zip [0..] (dataCtors dat))))++[])
+ Data/Derive/Functor.hs view
@@ -0,0 +1,69 @@+-- NOTE: Cannot be guessed as it relies on type information++-- | Derives 'Functor', as discussed on the Haskell-prime mailing list:+-- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.+module Data.Derive.Functor(makeFunctor) where++import Language.Haskell.TH.All+import Data.List+++makeFunctor :: Derivation+makeFunctor = Derivation derive "Functor"++derive dat+ | dataArity dat == 0 = []+ | otherwise = generic_instance (classFor arg) dat [] [funN (fmapFor arg) body]+ where+ arg = Arg False 1 -- TODO : make a parameter?+ body = map (deriveFunctorCtor dat arg) (dataCtors dat)++-- | Derive Functor over a given argument number for a type+-- return (derived function, required instances)+deriveFunctorCtor :: DataDef -> Arg -> CtorDef -> Clause+deriveFunctorCtor dat arg ctor = sclause lhs rhs+ where+ name = ctorName ctor+ types = ctorRTypes dat ctor+ arity = length types+ args = map return $ take arity ['a'..]+ lhs = [vr "fun", lK name (map vr args)]+ rhs = lK name $ zipWith AppE (map (deriveFunctorType arg) types) (map vr args)++-- | Derive Functor over a given argument number for a type+-- return (derived function, required instances)+deriveFunctorType :: Arg -> RType -> Exp+deriveFunctorType arg (RType (TypeCon "->") [a,b]) -- a -> b+ | isId af && isId bf = id'+ | isId af = InfixE Nothing (l0 ".") (Just bf)+ | isId bf = InfixE (Just af) (l0 ".") Nothing+ | otherwise = LamE [l0 "arg"] $ l2 "." af (l2 "." (l0 "arg") bf)+ where af = deriveFunctorType arg{co=not (co arg)} a+ bf = deriveFunctorType arg b+deriveFunctorType arg (RType tycon args)+ = foldl (.:) (deriveFunctorCon arg tycon)+ (zipWith fmapAp (map (Arg False) [0..])+ (map (deriveFunctorType arg) args))++-- | Derive Functor over a given argument number for a type constructor+deriveFunctorCon :: Arg -> TypeCon -> Exp+deriveFunctorCon (Arg False i) (TypeArg j) | i == j = l0 "fun"+deriveFunctorCon (Arg True i) (TypeArg j) | i == j = error "argument used in contravariant position"+deriveFunctorCon _ _ = id'+++-- | Is a function the identity function?+isId = (== id')+++-- | optimized fmap application+fmapAp arg b+ | isId b = id'+ | otherwise = l1 (fmapFor arg) b+++-- | Derive Functor or CoFunctor over an argument+data Arg = Arg { co :: Bool, position :: Int }++fmapFor (Arg co i) = (if co then "co" else "") ++ "fmap" ++ (if i > 1 then show i else "")+classFor (Arg co i) = (if co then "Co" else "") ++ "Functor" ++ (if i > 1 then show i else "")
+ Data/Derive/Has.hs view
@@ -0,0 +1,41 @@++-- | Has is a pseudo derivation. For each field of any constructor of+-- the data type, Has generates @has@/FieldName/ which returns 'True'+-- if given the the given field is a member of the constructor of the+-- passed object, and 'False' otherwise.+module Data.Derive.Has(makeHas) where++import Language.Haskell.TH.All+import Data.Char+import Data.List++{-+data Computer = Laptop {weight :: Int, memory :: Int}+ | Desktop {memory :: Int, processor :: Int}++==>++hasWeight (Laptop{}) = True+hasWeight _ = False++hasMemory (Laptop{}) = True+hasMemory (Desktop{}) = True++hasProcessor (Desktop{}) = True+hasProcessor _ = False++-}++makeHas :: Derivation+makeHas = Derivation has' "Has"++has' dat = map f fields+ where+ ctors = dataCtors dat+ fields = nub $ concatMap ctorFields ctors+ + f field = funN ("has" ++ toUpper (head field) : tail field) $+ [sclause [RecP (mkName $ ctorName c) []] true | (True,c) <- zip matches ctors] +++ [sclause [WildP] false | not $ and matches]+ where+ matches = map (\c -> field `elem` ctorFields c) ctors
+ Data/Derive/Is.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -fth -cpp #-}++-- | A pseudo derivation. For each constructor of the data type, @Is@+-- generates @is@/CtorName/ which returns 'True' if given an object+-- build using the appropriate constructor, and 'False' otherwise.+module Data.Derive.Is(makeIs) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Data.DeriveGuess++example = (,) "Is" [d|++ isCtorZero (CtorZero{}) = True; isCtorZero _ = False+ isCtorOne (CtorOne {}) = True; isCtorOne _ = False+ isCtorTwo (CtorTwo {}) = True; isCtorTwo _ = False+ isCtorTwo' (CtorTwo'{}) = True; isCtorTwo' _ = False++ |]++#endif++makeIs :: Derivation+makeIs = Derivation is' "Is"+is' dat = ((map (\(ctorInd,ctor) -> (FunD (mkName ("is" ++ ctorName ctor)) [(+ Clause [((flip RecP []) (mkName ("" ++ ctorName ctor)))] (NormalB (ConE (+ mkName "True"))) []),(Clause [WildP] (NormalB (ConE (mkName "False"))) [])]+ )) (id (zip [0..] (dataCtors dat))))++[])
+ Data/Derive/LazySet.hs view
@@ -0,0 +1,42 @@++-- | A pseudo derivation. For each field in the data type, deriving+-- @LazySet@ generates a function like a record updator, but lazy.+-- This is very useful in certain situations to improve laziness+-- properties. Example:+--+-- > data Foo = Foo { x :: Int, y :: Int, z :: Int }+--+-- becomes:+--+-- > setX v f = Foo v (y f) (z f)+-- > setY v f = Foo (x f) v (z f)+-- > setZ v f = Foo (x f) (y f) v++module Data.Derive.LazySet(makeLazySet) where++import Language.Haskell.TH.All+import Data.Char+import Data.List++{-+data State = State {x :: Int, y :: Int}++==>++setX a0 b0 = State a0 (y b0)+setY a0 b0 = State (x b0) a0++-}++makeLazySet :: Derivation+makeLazySet = Derivation lazyset' "LazySet"++lazyset' dat = map f fields+ where+ fields = nub $ concatMap (\f -> map ((,) f) (ctorFields f)) (dataCtors dat)++ f (ctor,field) = funN name [sclause [vr "a0", vr "b0"] (lK (ctorName ctor) body)]+ where+ name = "set" ++ toUpper (head field) : tail field+ body = [ if fld == field then vr "a0" else l1 fld (vr "b0")+ | fld <- ctorFields ctor ]
+ Data/Derive/Monoid.hs view
@@ -0,0 +1,32 @@++-- | Derives an instance of @Monoid@. This derivation is limited to+-- data types with only one constructor; it uses the product+-- construction of monoids.+module Data.Derive.Monoid(makeMonoid) where++import Language.Haskell.TH.All++{-+data Foo = Foo a String++==>++instance Monoid a => Monoid (Foo a) where+ mempty = Foo mempty mempty+ mappend (Foo x1 x2) (Foo y1 y2) = Foo (mappend x1 y1) (mappend x2 y2)++-}++makeMonoid :: Derivation+makeMonoid = Derivation monoid' "Monoid"++monoid' dat | length (dataCtors dat) == 1+ = [instance_default "Monoid" dat [funN "mempty" [empty],funN "mappend" [append]]]+ where+ ctor = head $ dataCtors dat++ empty = sclause [] $ lK (ctorName ctor) (replicate (ctorArity ctor) (l0 "mempty"))+ append = sclause [ctp ctor 'x',ctp ctor 'y'] $+ lK (ctorName ctor) (zipWith (l2 "mappend") (ctv ctor 'x') (ctv ctor 'y'))++monoid' dat = []
+ Data/Derive/NFData.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}++-- | Derive NFData, from Control.Parallel.Strategies.+module Data.Derive.NFData(makeNFData) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Control.Parallel.Strategies+import Data.DeriveGuess++example = (,) "NFData" [d|++ instance (NFData a) => NFData (DataName a) where+ rnf CtorZero = ()+ rnf (CtorOne x1) = rnf x1 `seq` ()+ rnf (CtorTwo x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (CtorTwo' x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ |]++#endif++makeNFData :: Derivation+makeNFData = Derivation nFData' "NFData"+nFData' dat = [instance_context ["NFData"] "NFData" dat [(FunD (mkName "rnf") (+ (map (\(ctorInd,ctor) -> (Clause [(ConP (mkName ("" ++ ctorName ctor)) ((+ map (\field -> (VarP (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]+ ))++[]))] (NormalB (foldl1With (VarE (mkName "seq")) ((map (\field -> (AppE+ (VarE (mkName "rnf")) (VarE (mkName ("x" ++ show field))))) (id [1..+ ctorArity ctor]))++[(TupE [])]++[]))) [])) (id (zip [0..] (dataCtors dat)))+ )++[]))]]
+ Data/Derive/Ord.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS_GHC -fth -cpp #-}++-- | Derive 'Ord', as specified in the Haskell 98 Language Report.+module Data.Derive.Ord(makeOrd) where++import Language.Haskell.TH.All++#ifdef GUESS++import Data.DeriveGuess++instance Eq (DataName a) where++example = (,) "Ord" [d|++ instance Ord a => Ord (DataName a) where+ compare a b = check a b+ where+ check CtorZero CtorZero = compare () ()+ 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)+ + tag (CtorZero{}) = 0+ tag (CtorOne{}) = 1+ tag (CtorTwo{}) = 2+ tag (CtorTwo'{}) = 3++ |]++#endif++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" +++ 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 (+ "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 [+ ]) (mkName (ctorName ctor)))] (NormalB (LitE (IntegerL ctorInd))) [])) (id+ (zip [0..] (dataCtors dat))))++[])])]]]++{-+-- HAND WRITTEN VERSION+-- requires O(n^2) page space (the automatic one is O(n))++ord' dat = simple_instance "Ord" dat [funN "compare" body]+ where+ obs = zip [0..] (dataCtors dat)+ body = [ sclause [ctp (snd x) 'a', ctp (snd y) 'b'] (rule x y)+ | x <- obs , y <- obs ]++rule (i1,c1) (i2,c2) | i1 < i2 = l0 "LT"+ | i1 > i2 = l0 "GT"+ | otherwise = l2 "compare" (tup2 c1 'a') (tup2 c2 'b')++tup2 c ch = foldr (l2 "(,)") (lit ()) (ctv c ch)+-}
+ Data/Derive/Play.hs view
@@ -0,0 +1,188 @@+-- NOTE: Cannot be guessed as it relies on type information++-- | Derive Play, implemented for tuples and lists.+module Data.Derive.Play(makePlay) where++import Language.Haskell.TH.All+import Data.List+import Data.Maybe+import Data.Generics+import qualified Data.Map as Map+import Control.Monad.State+import Debug.Trace++++makePlay :: Derivation+makePlay = Derivation play' "Play"+++data Container = None | Target+ | List Container | Tuple [Container]+ deriving (Eq, Show)+++-- convert a type to the appropriate container type+typeToContainer :: String -> Type -> Container+typeToContainer active t =+ if eqConT active name then Target+ else if all (== None) rest2 then None+ else if name == ListT then List (head rest2)+ else if isTupleT name then Tuple rest2+ else error $ "Play derivation on unknown type: " ++ show t+ where+ (name,rest) = typeApp t+ rest2 = map (typeToContainer active) rest+++-- the variable type+type Var x = State (Map.Map String Int) x++getVar :: String -> Var String+getVar x = do mp <- get+ let i = Map.findWithDefault 1 x mp+ put $ Map.insert x (i+1) mp+ return $ x ++ if i == 1 then "" else show i++runVar :: Var a -> a+runVar x = evalState x Map.empty++++play' dat =+ [instance_default "Play" dat [funN "getChildren" gbody, funN "replaceChildren" rbody]]+ where+ ctors :: [(CtorDef,[Container])]+ ctors = [(c, map (typeToContainer (dataName dat)) (ctorTypes c)) | c <- dataCtors dat]+++ gbody = [sclause [ctp (fst c) 'x'] (gitem c) | c <- ctors]++ gitem :: (CtorDef,[Container]) -> Exp+ gitem (c,ts) = (++::) [AppE (f t) v | (t,v) <- zip ts (ctv c 'x')]+ where+ f None = const' nil+ f Target = LamE [vr "x"] (box (vr "x"))+ f (List t) = l1 "concatMap" (f t)+ f (Tuple ts) = LamE [tup (map vr vars)] ((++::) [AppE (f t) (vr v) | (t,v) <- zip ts vars])+ where vars = ['x':show i | i <- [1..length ts]]+++ rbody = [Clause [vr "x"] (NormalB $ case' (vr "x")+ [(ctp (fst c) 'x', tup [gitem c, ritem c]) | c <- ctors]+ ) [funcList]]+ + + funcList = funN "list'"+ [sclause [vr "f",nil] (runVar $ const1_ nil)+ ,sclause [vr "f",lK ":" [vr "x",vr "xs"]]+ (runVar $ do+ a <- const1_ (l0 ":")+ lhs <- join_ a (l1 "f" (vr "x"))+ join_ lhs (lK "list'" [vr "f",vr "xs"])+ )]++ + wildcard :: Exp -> Exp+ wildcard x = everywhere (mkT f) x+ where+ vars = everything (++) ([] `mkQ` g) x+ + g (VarE x) = [x]+ g x = []+ + f (VarP x) | x `notElem` vars = WildP+ f x = x+ + + ritem :: (CtorDef,[Container]) -> Exp+ ritem (c,ts) = wildcard $ runVar (value_ $ joins_ (l0 (ctorName c)) items)+ where+ items = zip ts (ctv c 'x')+ + f None = const_+ f Target = id_+ f (List t) = list_ (f t)+ f (Tuple ts) = do+ vars1 <- replicateM (length ts) (getVar "x")+ vars2 <- replicateM (length ts) (getVar "y")+ bod <- joins_ (LamE (map vr vars1) (tup $ map vr vars1)) (zip ts (map vr vars2))+ return $ LamE [tup $ map vr vars2] bod++ joins_ root xs = do+ root2 <- const1_ root+ xs2 <- mapM (\(t,v) -> liftM (`appE` v) (f t)) xs+ foldM join_ root2 xs2+++ -- the replaceChildren combinators+ + const_ = do+ y <- getVar "y"+ ns <- getVar "ns"+ c <- getVar "c"+ return $ lamE [vr y,vr ns,vr c] (app (vr c) [vr y,vr ns])++ id_ = do+ n <- getVar "n"+ ns <- getVar "ns"+ c <- getVar "c"+ return $ lamE [WildP,lK ":" [vr n,vr ns],vr c] (app (vr c) [vr n,vr ns])+ + isId (LamE [WildP,ConP cons [VarP n, VarP ns],VarP c] (AppE (AppE (VarE c2) (VarE n2)) (VarE ns2)))+ | show cons == ":" && n == n2 && c == c2 && ns == ns2 = True+ isId _ = False+ + list_ x = liftM (l1 "list'") x+ + value_ inp = do+ inp <- inp+ ns <- getVar "ns"+ y <- getVar "y"+ return $ lamE [vr ns] $ appE2 inp (vr ns) $ lamE [vr y,WildP] (vr y)++ join_ ina inb = do+ ns1 <- getVar "ns"+ ns2 <- getVar "ns"+ ns3 <- getVar "ns"+ c <- getVar "c"+ a <- getVar "a"+ b <- getVar "b"+ return $ lamE [vr ns1,vr c]+ $ appE2 ina (vr ns1) $ lamE [vr a,vr ns2]+ $ appE2 inb (vr ns2) $ lamE [vr b,vr ns3]+ $ appE2 (vr c) (appE (vr a) (vr b)) (vr ns3)++ const1_ x = do c <- const_ ; return $ appE c x++++ -- can be a bit more fast and loose about variable clashes etc+ -- since we guarantee a limited set of generated values++ -- very special rule, only valid for play+ appE (AppE (AppE (AppE (VarE l) i) x) y) (LamE (b:WildP:bs) c)+ | show l == "list'" && isId i = appE (lamE (b:bs) c) y++ appE (LamE (VarP x:xs) y) z = lamE xs (rebuild $ replaceVar x z y)+ appE (LamE (WildP :xs) y) z = lamE xs y+ appE (AppE (LamE (x1:VarP x2:xs) xb) y) z =+ AppE (lamE (x1:xs) (rebuild $ replaceVar x2 z xb)) y+ appE x y = AppE x y+ + + + + appE2 x y z = appE (appE x y) z+ + lamE [] y = y+ lamE xs (LamE ys z) = lamE (xs++ys) z+ lamE xs (AppE y (VarE z)) | last xs == VarP z = lamE (init xs) y+ lamE x y = LamE x y++ rebuild :: Exp -> Exp+ rebuild = everywhere (mkT f)+ where+ f (AppE x y) = appE x y+ f (LamE x y) = lamE x y+ f x = x
+ Data/Derive/PlayAll.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -fth -cpp -fglasgow-exts -fallow-undecidable-instances #-}++module Data.Derive.PlayAll(makePlayAll) where++import Language.Haskell.TH.All+++#ifdef GUESS++import Data.Generics.PlayTypeable+import Data.DeriveGuess+import Data.Typeable++example = (,) "PlayAll" [d|++ instance (PlayAll a (DataName a), Typeable a) => Play (DataName a) where+ replaceChildren = replaceChildrenAll++ instance (Typeable t, Typeable a, Play t, PlayAll a t) => PlayAll (DataName a) t where+ playAll CtorZero = play CtorZero+ playAll (CtorOne x1) = play CtorOne |+ x1+ playAll (CtorTwo x1 x2) = play CtorTwo |+ x1 |+ x2+ playAll (CtorTwo' x1 x2) = play CtorTwo' |+ x1 |+ x2++ |]++#endif+++makePlayAll :: Derivation+makePlayAll = Derivation playAll' "PlayAll"+playAll' dat = [InstanceD (concat ([(map (\tdat -> (AppT (AppT (ConT (mkName+ "PlayAll")) tdat) (lK (dataName dat) (dataVars dat)))) (dataVars dat)),(map+ (\tdat -> (AppT (ConT (mkName "Typeable")) tdat)) (dataVars dat))])) (head+ [(AppT (ConT (mkName "Play")) (lK (dataName dat) (dataVars dat)))])[(ValD (+ VarP (mkName "replaceChildren")) (NormalB (VarE (mkName+ "replaceChildrenAll"))) [])],InstanceD (concat ([[(AppT (ConT (mkName+ "Typeable")) (VarT (mkName "t")))],(map (\tdat -> (AppT (ConT (mkName+ "Typeable")) tdat)) (dataVars dat)),[(AppT (ConT (mkName "Play")) (VarT (+ mkName "t")))],(map (\tdat -> (AppT (AppT (ConT (mkName "PlayAll")) tdat) (+ VarT (mkName "t")))) (dataVars dat))])) (head [(AppT (AppT (ConT (mkName+ "PlayAll")) (lK (dataName dat) (dataVars dat))) (VarT (mkName "t")))])[(+ FunD (mkName "playAll") ((map (\(ctorInd,ctor) -> (Clause [(ConP (mkName (+ "" ++ ctorName ctor)) ((map (\field -> (VarP (mkName ("x" ++ show field))))+ (id [1..ctorArity ctor]))++[]))] (NormalB (foldr1With (VarE (mkName "|+"))+ ((map (\field -> (VarE (mkName ("x" ++ show field)))) (reverse [1..+ ctorArity ctor]))++[(AppE (VarE (mkName "play")) (ConE (mkName ("" +++ ctorName ctor))))]++[]))) [])) (id (zip [0..] (dataCtors dat))))++[]))]]
+ Data/Derive/Read.hs view
@@ -0,0 +1,45 @@++-- | Derives @Read@. This is as defined by the Haskell report, except+-- there is no support for infix constructors. If you attempt to+-- derive @Read@ for a data type with infix constructors, the+-- constructors are handled as if they were prefix constructors, using+-- the @(@/consym/@)@ syntax.+module Data.Derive.Read(makeRead) where++import Language.Haskell.TH.All+import Data.List+import Data.Char++makeRead :: Derivation+makeRead = Derivation read' "Read"++read' dat = [instance_default "Read" dat [funN "readsPrec" [sclause [vr "p0", vr "r0"] body]]]+ where+ body = (++::) [ readit ctr | ctr <- dataCtors dat ]++readit ctr = case ctorFields ctr of [] -> norm+ fl -> flds fl+ where+ norm = l2 "readParen" (vr "p0" >: lit (10::Integer))+ (runComp (pName . foldr (.) id (map (pRead 11) (ctv ctr 'x'))) (ctp ctr 'x'))++ flds f = l2 "readParen" false+ (runComp (pName . pLex "{" .+ foldr (.) id (intersperse (pLex ",")+ (zipWith pField (ctv ctr 'x') f)) .+ pLex "}") (ctp ctr 'x'))++ runComp fn ex = CompE $ fn (\k -> [ NoBindS (tup [ex, vrn 'r' k]) ]) 0++ pArse pat fun ct k = BindS (tup [pat, vrn 'r' (k+1)]) (AppE fun (vrn 'r' k)) : ct (k+1)++ pLex pat = pArse (lit pat) (l0 "lex")++ name = ctorName ctr++ pName | isAlpha (head name) || head name == '_' = pLex name+ | otherwise = pLex "(" . pLex name . pLex ")"++ pRead pc pat = pArse pat (l1 "readsPrec" (lit (pc :: Integer)))++ pField pat fld = pLex fld . pLex "=" . pRead 0 pat
+ Data/Derive/Serial.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}++-- | Derivation for the @Serial@ class used by SmallCheck. Following+-- the guidelines in the SmallCheck README+-- <http://www.cs.york.ac.uk/fp/darcs/smallcheck/README>, we implement+-- both @series@ and @coseries@. The generated instances use the+-- SmallCheck instance combinators in the proscribed way.++module Data.Derive.Serial(makeSerial) where++import Language.Haskell.TH.All+++#ifdef GUESS++import SmallCheck+import Data.DeriveGuess++example = (,) "Serial" [d|++ instance Serial a => Serial (DataName a) where+ series = cons0 CtorZero \/+ cons1 CtorOne \/+ cons2 CtorTwo \/+ cons2 CtorTwo'++ coseries d = [ \t -> case t of+ CtorZero -> t0+ CtorOne x1 -> t1 x1+ CtorTwo x1 x2 -> t2 x1 x2+ CtorTwo' x1 x2 -> t3 x1 x2+ | t0 <- alts0 d+ , t1 <- alts1 d+ , t2 <- alts2 d+ , t3 <- alts2 d+ ]++ |]++#endif++makeSerial :: Derivation+makeSerial = Derivation serial' "Serial"+serial' dat = [instance_context ["Serial"] "Serial" dat [ValD (VarP (mkName+ "series")) (NormalB (foldl1With (VarE (mkName "\\/")) ((map (\(ctorInd,ctor+ ) -> (AppE (VarE (mkName ("cons" ++ show (ctorArity ctor)))) (ConE (mkName+ (ctorName ctor))))) (id (zip [0..] (dataCtors dat))))++[]))) [],FunD (+ mkName "coseries") [(Clause [(VarP (mkName "d"))] (NormalB (CompE ((map (\(+ ctorInd,ctor) -> (BindS (VarP (mkName ("t" ++ show ctorInd))) (AppE (VarE (+ mkName ("alts" ++ show (ctorArity ctor)))) (VarE (mkName "d"))))) (id (zip+ [0..] (dataCtors dat))))++[(NoBindS (LamE [(VarP (mkName "t"))] (CaseE (+ VarE (mkName "t")) ((map (\(ctorInd,ctor) -> (Match (ConP (mkName (ctorName+ ctor)) ((map (\field -> (VarP (mkName ("x" ++ show field)))) (id [1..+ ctorArity ctor]))++[])) (NormalB (applyWith (VarE (mkName ("t" ++ show+ ctorInd))) ((map (\field -> (VarE (mkName ("x" ++ show field)))) (id [1..+ ctorArity ctor]))++[]))) [])) (id (zip [0..] (dataCtors dat))))++[]))))]++[+ ]))) [])]]]
+ Data/Derive/Set.hs view
@@ -0,0 +1,34 @@++-- | A pseudo derivation. For each field in the data type, deriving+-- @Set@ generates @set@/FieldName/@ v x = x{@/fieldName/@ = v}@.+-- This derivation is intended to work around the fact that in Haskell+-- assigning to a field is not a first class object (although+-- extracting from a field is).+module Data.Derive.Set(makeSet) where++import Language.Haskell.TH.All+import Data.Char+import Data.List++{-+data Computer = Laptop {weight :: Int, memory :: Int}+ | Desktop {memory :: Int, processor :: Int}++==>++setWeight v x = x{weight=v}+setMemory v x = x{memory=v}+setProcessor v x = x{process=v}++-}++makeSet :: Derivation+makeSet = Derivation set' "Set"++set' dat = map f fields+ where+ ctors = dataCtors dat+ fields = nub $ concatMap ctorFields ctors+ + f field = funN ("set" ++ toUpper (head field) : tail field) $+ [sclause [vr "v",vr "x"] $ RecUpdE (vr "x") [(mkName field,vr "v")]]
+ Data/Derive/Show.hs view
@@ -0,0 +1,35 @@++-- | Derives @Show@. This is as defined by the Haskell report, except+-- there is no support for infix constructors. If you attempt to+-- derive @Show@ for a data type with infix constructors, the+-- constructors are handled as if they were prefix constructors, using+-- the @(@/consym/@)@ syntax.+module Data.Derive.Show(makeShow) where++import Language.Haskell.TH.All+import Data.List++makeShow :: Derivation+makeShow = Derivation show' "Show"++show' dat = [instance_default "Show" dat [funN "showsPrec" body]]+ where+ body = [ sclause [vr "p", ctp ctr 'x'] (showit ctr) | ctr <- dataCtors dat ]++showit ctr = case ctorFields ctr of [] -> norm+ fl -> flds fl+ where+ norm = l2 "showParen" (vr "p" >: lit (10::Integer))+ ((.::) (intersperse (scl ' ')+ (ssl pname : map (l2 "showsPrec" (lit (11::Integer))) (ctv ctr 'x'))))++ flds f = (.::) (ssl (pname ++ " {") : fields f ++ [scl '}'])++ fields [] = []+ fields fs = scl ' ' : concat (intersperse [ssl ", "] (map field (zip [0..] fs))) ++ [scl ' ']++ field (n,f) = [ ssl (f ++ " = ") , l2 "showsPrec" (lit (0::Integer)) (vrn 'x' n) ]++ ssl = l1 "showString" . lit ; scl = l1 "showChar" . lit++ pname = show (ppr (mkName (ctorName ctr)))
+ Data/Derive/TTypeable.hs view
@@ -0,0 +1,26 @@+-- NOTE: Cannot be guessed as it inducts on the data type (not its constructors)++-- | Type level typeable, as used by the undecidable-instances version+-- of the @TypeEq@ class from Oleg and Lammel's HList library. The+-- type numbers used are autmatically generated using a little-endian+-- @Enum@ representation of the type's name. Note that we truncate+-- characters above 255, and ignore the module name, though the+-- consequences are much less severe than in the @Typeable@ case since+-- no coercion is involved.+module Data.Derive.TTypeable(makeTTypeable) where++import Language.Haskell.TH.All+import Data.Char+import Data.Bits++makeTTypeable :: Derivation+makeTTypeable = Derivation ttypeable' "TTypeable"+ttypeable' dat = [InstanceD ctx hd []]+ where+ bits x = [ if x .&. mask /= 0 then hSucc' hZero' else hZero' | mask <- [1,2,4,8,16,32,64,128] ]+ bitnam = foldr hCons' hNil' (concatMap (bits . ord) (dataName dat))++ hd = l2 "TTypeable" (lK (dataName dat) (vrs 't')) (foldr hCons' hNil' (bitnam : vrs 'n'))+ ctx = zipWith (l2 "TTypeable") (vrs 't') (vrs 'n')++ vrs = flip vars (dataArity dat)
+ Data/Derive/Typeable.hs view
@@ -0,0 +1,63 @@+-- NOTE: Cannot be guessed as it inducts on the data type (not its constructors)++-- | Derivation for the 'Typeable' class, as described in the Scrap+-- Your Boilerplate papers. This derivation generates instances for+-- all kinds of TypeableK classes; as such we do NOT require the+-- GHC-specific generic downkinding instances to provide lower kind+-- instances.+--+-- The generated 'TypeRep' uses only the base name of the type, so+-- identically named types in different modules can be treated as the+-- same, with disasterous consequences.+--+-- Also creates a @typename_\<the type name\>@ value to hold the+-- 'TypeRep'.++module Data.Derive.Typeable(makeTypeable) where++import Language.Haskell.TH.All+import Data.Char++-- based on the macros in: http://darcs.haskell.org/packages/base/include/Typeable.h++{-+#define INSTANCE_TYPEABLE1(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE2(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable1 (tycon a) where { \+ typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \+ typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE3(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable2 (tycon a) where { \+ typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \+ typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \+ typeOf = typeOfDefault }+-}+++makeTypeable :: Derivation+makeTypeable = Derivation typeable' "Typeable"+typeable' dat = (funN nam [sclause [] (l1 "mkTyCon" $ lit $ dataName dat)])+ : map f [0..dataArity dat]+ where+ nam = [if x == '.' then '_' else x | x <- "typename_" ++ dataName dat]++ f n = InstanceD (map (l1 "Typeable") vars)+ (l1 ("Typeable"++sn) $ lK (dataName dat) vars)+ [funN ("typeOf"++sn) [sclause [WildP | n == 0] def]]+ where+ def = if n == 0 then l2 "mkTyConApp" (l0 nam) (lst [])+ else l0 ("typeOf" ++ sn ++ "Default")+ vars = take n $ map (vr . return) ['a'..]+ sn = let i = dataArity dat - n in if i == 0 then "" else show i
+ Data/DeriveGuess.hs view
@@ -0,0 +1,407 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}++module Data.DeriveGuess(DataName(..), tup1, guess) where++import Language.Haskell.TH.All+import Data.Generics+import Data.List+import Data.Char+import Data.Maybe+++data DataName a = CtorZero+ | CtorOne a+ | CtorTwo a a+ | CtorTwo' a a++ctorNames = ["CtorZero","CtorOne","CtorTwo","CtorTwo'"]++-- | Guess an instantiator from a sample instance.+guess :: (String, Q [Dec]) -> IO ()+guess (name,x) = runQ x >>= putStr . (++) line0. widthify . (++) line1 . guessStr . unQ+ where+ line0 = "make" ++ name ++ " :: Derivation\n" +++ "make" ++ name ++ " = Derivation " ++ lname ++ "' \"" ++ name ++ "\"\n"+ line1 = lname ++ "' dat = "+ lname = toLower (head name) : tail name++-- | A fake constructor for the unary tuple. Helps 'guess' to see+-- patterns in progressions of differently sized tuples.+tup1 = id++-- | Chop and mangle a String representing Haskell code so that it+-- fits in 80 columns, without regard for prettiness.+widthify :: String -> String+widthify xs = g 80 (f xs)+ where+ g n (x:xs) | n - length x <= 0 = "\n " ++ g 76 ([x|x/=" "] ++ xs)+ | otherwise = x ++ g (n - length x) xs+ g n [] = "\n"+++ f (x:xs) | isSpace x = " " : f (dropWhile isSpace xs)+ f x = case lex x of+ [("","")] -> []+ -- \\ must not occur at the end of a line (CPP restrictions)+ [("\\",y)] -> let a:b = f y in ('\\':a) : b+ [(x,y)] -> x : f y++-- | Process a tree produced by a quasiquote, stripping name+-- uniquifiers and changing applications and tuplings into a standard+-- form.+unQ :: [Dec] -> [Dec]+unQ x = everywhere (mkT g) $ everywhere (mkT f) $ map normData x+ where+ -- | Remove_0 evil_1 ghc_2 name_3 uniquifiers_4+ f :: Name -> Name+ f name = if match s then mkName $ dropUnder s else name+ where+ s = show name+ match = isPrefixOf "_" . dropWhile isDigit . reverse++ -- | Turn infix applications into prefix, and normalise+ -- tuples.+ g :: Exp -> Exp+ g (InfixE (Just x) y (Just z)) = AppE (AppE y x) z+ g (AppE (VarE tup) x) | show tup == "tup1" = TupE [x]+ g (ConE unit) | show unit == "()" = TupE []+ g x = x+++-- | Drop the first _ and everything after it; used to trim GHC name+-- uniques.+dropUnder = reverse . drop 1 . dropWhile (/= '_') . reverse++list x = "[" ++ concat (intersperse "," x) ++ "]"++unwordsb x = "(" ++ unwords x ++ ")"++fst3 (a,b,c) = a+snd3 (a,b,c) = b+thd3 (a,b,c) = c++snub x = nub $ sort x++arityToCtors x = x : [3 | x == 2]+ctorToArity x = if x == 3 then 2 else x++ctorArityEnv (Ctor i) = ctorToArity i++on op get a b = op (get a) (get b)+++-- imagine the following environment table:+{-+[("CtorZero",0,0,[])+,("CtorOne" ,1,1,[1])+,("CtorTwo" ,2,2,[1,2])+,("CtorTwo'",2,3,[1,2])+]+-}++data Env = None | Ctor Int | Field Int+ deriving (Show,Eq)++isField (Field _) = True; isField _ = False+isCtor (Ctor _) = True; isCtor _ = False++fromField (Field i) = i+fromCtor (Ctor i) = i++fromEnv (Field i) = i+fromEnv (Ctor i) = i++++-- Show t and Ppr t for better error messages+-- Eq t required for hypothesis testing+class (Ppr t, Eq t, Show t) => Guess t where+ -- invariant: all answers must be correct for this example+ -- will never be given a different type of environment+ guessEnv :: t -> [(Env, Env -> t, String)]+ +guessStr :: Guess t => t -> String+guessStr t = case [s | (None,_,s) <- guessEnv t] of+ [] -> error $ "\n\nNo hypothesis for:\n" ++ show t +++ "\n\nPretty version:\n" ++ show (ppr t)+ (x:xs) -> x+++checkGuess :: (Ppr t, Eq t, Show t) => t -> [(Env, Env -> t, String)] -> [(Env, Env -> t, String)]+checkGuess t xs = map f xs+ where+ f o@(env,gen,str) | t == gen env = o+ | otherwise = error $ unlines ["checkGuess failed:"+ ,"INPUT : " ++ show t+ ,"OUTPUT: " ++ show (gen env)+ ,"ENV : " ++ show env+ ,"HYP : " ++ str+ ]+++guessEnvStr :: Guess t => t -> [(Env, Env -> t, String)]+guessEnvStr t = [(None, const t, guessStr t)]+++guessPairStr :: (Guess a, Guess b) => String -> a -> b -> String+guessPairStr sjoin a b = sjoin ++ " " ++ guessStr a ++ " " ++ guessStr b++guessTripStr :: (Guess a, Guess b, Guess c) => String -> a -> b -> c -> String+guessTripStr sjoin a b c = unwords [sjoin, guessStr a, guessStr b, guessStr c]+++joinEnvs :: [Env] -> Maybe Env+joinEnvs xs = if length ys > 1 then Nothing else Just $ head (ys ++ [None])+ where ys = filter (/= None) $ nub xs++guessOneEnv :: Guess a => (a -> t) -> String -> a -> [(Env, Env -> t, String)]+guessOneEnv fjoin sjoin x1 =+ [ (e1, \e -> fjoin (f1 e), unwordsb [sjoin,s1])+ | (e1,f1,s1) <- guessEnv x1]++-- to join two elements either they are the same env, or one has None+guessPairEnv :: (Guess a, Guess b) => (a -> b -> t) -> String -> a -> b -> [(Env, Env -> t, String)]+guessPairEnv fjoin sjoin x1 x2 =+ [ (env, \e -> fjoin (f1 e) (f2 e), unwordsb [sjoin,s1,s2])+ | (e1,f1,s1) <- guessEnv x1+ , (e2,f2,s2) <- guessEnv x2+ , Just env <- [joinEnvs [e1,e2]]]++guessTripEnv :: (Guess a, Guess b, Guess c) => (a -> b -> c -> t) -> String -> a -> b -> c -> [(Env, Env -> t, String)]+guessTripEnv fjoin sjoin x1 x2 x3 =+ [ (env, \e -> fjoin (f1 e) (f2 e) (f3 e), unwordsb [sjoin,s1,s2,s3])+ | (e1,f1,s1) <- guessEnv x1+ , (e2,f2,s2) <- guessEnv x2+ , (e3,f3,s3) <- guessEnv x3+ , Just env <- [joinEnvs [e1,e2,e3]]]++++instance Guess a => Guess [a] where+ guessEnv os = concatMap f $ mapM guessEnv os+ where+ -- first try and induct based on the length of the list+ f xs | all (== None) (map fst3 xs) &&+ length xs == 2 &&+ length vals == 1+ = [(Ctor i, \e -> replicate (ctorArityEnv e) (head vals),+ "(replicate (ctorArity ctor) " ++ thd3 (head xs) ++ ")")+ | i <- [2,3]] +++ [(None, \e -> map ($ e) gens, list strs)]+ where+ (envs,gens,strs) = unzip3 xs+ vals = nub $ zipWith ($) gens envs++ + f xs | length es <= 1 = [(head (es ++ [None]), \e -> map ($ e) gens, list strs)]+ | otherwise = [(env,gen,"("++str++")")+ | env <- newEnvs, (gen,str) <- nubBy ((==) `on` snd) $ g xs]+ where+ (envs,gens,strs) = unzip3 xs+ es = nub $ filter (/= None) envs+ + ctors = snub [i | Ctor i <- envs]+ fields = snub [i | Field i <- envs]+ maxField = maximum fields+ + newEnvs = case ctors of+ [] -> map Ctor $ arityToCtors maxField+ _ | null fields -> [None]+ [x] | ctorToArity x == maxField -> [Ctor x]+ _ -> [] + + ctorEnv = head newEnvs == None+ varName = if ctorEnv then "(ctorInd,ctor)" else "field"+ + domain = if ctorEnv then [0..3] else [1..maxField]+ getDomain (Ctor i) = take 2 [1..i]+ getDomain None = [0..3]+ strDomain = if ctorEnv then "(zip [0..] (dataCtors dat))" else "[1..ctorArity ctor]"+ + construct = if ctorEnv then Ctor else Field+ + isNone x = x == None || (not ctorEnv && isCtor x)+ + g :: Eq t => [(Env, Env -> t, String)] -> [(Env -> [t], String)]+ g [] = [(\e -> [], "[]")]+ g ((none,gn,st):xs) | isNone none =+ [(\e -> gn e : gen e, "[" ++ st ++ "]++" ++ str) | (gen,str) <- g xs]+ + g xs = h id "id" xs ++ h reverse "reverse" xs++ h :: Eq t => ([Int] -> [Int]) -> String -> [(Env, Env -> t, String)] -> [(Env -> [t], String)]+ h fdir sdir xs+ | map construct (fdir domain) `isPrefixOf` map fst3 xs+ = [(\e -> map (fhyp . construct) (fdir $ getDomain e) ++ gen e+ ,"(map (\\" ++ varName ++ " -> " ++ shyp ++ ") (" ++ sdir ++ " " ++ strDomain ++ "))++" ++ str)+ | (fhyp,shyp) <- validHyp+ , (gen,str) <- g rest]+ where+ (now,rest) = splitAt (length domain) xs++ validHyp = filter (\hyp -> all (valid (fst hyp)) now) (map (\(a,b,c) -> (b,c)) now)+ valid hyp (e,gen,_) = hyp e == gen e++ h _ _ _ = []+++guessType :: Type -> Type -> String+guessType principle x =+ if hasPrinciple then "(map (\\tdat -> " ++ disp x ++ ") (dataVars dat))" else "[" ++ disp x ++ "]"+ where+ hasPrinciple = f x+ where+ f x | x == principle = True+ f (AppT (ConT x) y) | show x == "DataName" = False+ f (AppT a b) = f a || f b+ f _ = False++ disp x | x == principle = "tdat"+ disp (AppT (ConT x) y) | show x == "DataName" = "(lK (dataName dat) (dataVars dat))"+ disp (AppT a b) = "(AppT " ++ disp a ++ " " ++ disp b ++ ")"+ disp (VarT a) = "(VarT (mkName " ++ show (show a) ++ "))"+ disp (ConT a) = "(ConT (mkName " ++ show (show a) ++ "))"++++instance Guess Dec where+ guessEnv (InstanceD ctx typ inner) =+ [ (None, \e -> InstanceD ctx typ (gen e), prefix ++ str)+ | (None,gen,str) <- guessEnv inner]+ where+ principle = head (everything (++) ([] `mkQ` f) typ ++ [VarT $ mkName "?"])+ where+ f (AppT (ConT x) y) | show x == "DataName" = [y]+ f _ = []+ + prefix = "InstanceD " +++ "(concat (" ++ list (map (guessType principle) ctx) ++ ")) " +++ "(head " ++ guessType principle typ ++ ")"++ guessEnv (FunD name claus) = guessPairEnv FunD "FunD" name claus+ guessEnv (ValD pat bod whr) = guessTripEnv ValD "ValD" pat bod whr+ + guessEnv x = error $ show ("Guess Dec",x)+++instance Guess Name where+ guessEnv name = if null guessCtor then guessRest else guessCtor+ where+ sname = show name+ (pre,end) = (init sname, last sname)+ + guessCtor = [(Ctor i, \(Ctor e) -> mkName (pre ++ (ctorNames !! e))+ ,"(mkName (" ++ show pre ++ " ++ ctorName ctor))")+ | (i,nam) <- zip [0..] ctorNames, nam `isSuffixOf` sname+ , let pre = take (length sname - length nam) sname]++ guessRest = guessLast ++ guessDefault+ + guessLast | isDigit end = [(e, \e -> mkName $ pre ++ show (g e)+ ,"(mkName (" ++ show pre ++ " ++ show " ++ s ++ "))")+ | (e,g,s) <- guessNum $ read [end]]+ | otherwise = []++ guessDefault = [(None,const name, "(mkName " ++ show sname ++ ")")+ | not (isDigit end) || pre `notElem` ["x","y","z"]]+++guessNum :: Int -> [(Env, Env -> Int, String)]+guessNum i = [(Field i, fromField, "field") | i `elem` [1,2]] +++ [(None, const 3, "(toInteger (length (dataCtors dat) - 1))") | i == 3] +++ [(None, const 4, "(toInteger (length (dataCtors dat)))") | i == 4] +++ [(Ctor i, fromCtor, "ctorInd") | i `elem` [0..3]] +++ [(Ctor i, ctorArityEnv, "(ctorArity ctor)") | i `elem` [0..2]] +++ [(Ctor 3, ctorArityEnv, "(ctorArity ctor)") | i == 2]++++instance Guess Clause where+ guessEnv (Clause pat bod whr) = guessTripEnv Clause "Clause" pat bod whr+++instance Guess Stmt where+ guessEnv (BindS x y) = guessPairEnv BindS "BindS" x y+ guessEnv (NoBindS x) = guessOneEnv NoBindS "NoBindS" x+ guessEnv x = error $ show ("Guess Stmt",x)+++instance Guess Pat where+ guessEnv (VarP x) = guessOneEnv VarP "VarP" x+ guessEnv (ConP x xs) = guessPairEnv ConP "ConP" x xs+ guessEnv (WildP) = [(None, const WildP, "WildP")]+ guessEnv (TildeP x) = guessOneEnv TildeP "TildeP" x+ guessEnv (RecP x []) = guessOneEnv (flip RecP []) "(flip RecP [])" x+ guessEnv (LitP x) = guessOneEnv LitP "LitP" x+ guessEnv x = error $ show ("Guess Pat",x)+++instance Guess Body where+ guessEnv (NormalB x) = guessOneEnv NormalB "NormalB" x+ guessEnv x = error $ show ("Guess Body",x)+++instance Guess Exp where+ guessEnv (VarE x) = guessOneEnv VarE "VarE" x+ guessEnv (ConE x) = guessOneEnv ConE "ConE" x+ guessEnv (LitE x) = guessOneEnv LitE "LitE" x+ guessEnv (ListE x) = guessOneEnv ListE "ListE" x+ guessEnv (LamE x y) = guessPairEnv LamE "LamE" x y+ guessEnv (CompE x) = guessOneEnv CompE "CompE" x+ guessEnv (CaseE x y) = guessPairEnv CaseE "CaseE" x y+ guessEnv (TupE x) = guessOneEnv TupE "TupE" x+ guessEnv (RecConE x []) = guessOneEnv (flip RecConE []) "(flip RecConE [])" x+ guessEnv (CondE x y z) = guessTripEnv CondE "CondE" x y z+ guessEnv (DoE x) = guessOneEnv DoE "DoE" x++ guessEnv o@(AppE x y) = guessApply o ++ guessFold o ++ guessPairEnv AppE "AppE" x y+ + guessEnv x = error $ show ("Guess Exp",x)+++instance Guess Match where+ guessEnv (Match a b c) = guessTripEnv Match "Match" a b c+++instance Guess Lit where+ guessEnv o@(IntegerL i) =+ [ (env, \e -> IntegerL $ toInteger $ gen e, "(IntegerL " ++ str ++ ")")+ | (env,gen,str) <- guessNum $ fromInteger i] +++ [(None,const $ IntegerL i,"(IntegerL " ++ show i ++ ")")]+ + guessEnv o@(StringL s) | s == "DataName" = [(None, const o, "(StringL (dataName dat))")]+ | otherwise = [(None, const o, "(StringL " ++ show s ++ ")")]+ + guessEnv x = error $ show ("Guess Lit",x)+++-- for when an expression is just an application+guessApply :: Exp -> [(Env, Env -> Exp, String)]+guessApply o | length args <= 1 = []+ | otherwise = guessPairEnv applyWith "applyWith" fn args+ where+ (fn,args) = list o+ + list (AppE x y) = let (fn,args) = list x in (fn, args ++ [y])+ list x = (x, [])+++-- for when an expression comes from folding+guessFold :: Exp -> [(Env, Env -> Exp, String)]+guessFold o@(AppE (AppE fn x) y) =+ f (with foldl1With) "foldl1With" (list True o) +++ f (with foldr1With) "foldr1With" (list False o)+ where+ with fold join [] = VarE $ mkName "?"+ with fold join xs = fold join xs+ + list b (AppE (AppE fn2 x) y) | fn == fn2 =+ if b then x : list b y else y : list b x+ list b x = [x]++ f ffold sfold lst+ | length lst <= 2 = []+ | otherwise = guessPairEnv ffold sfold fn lst++guessFold _ = []+
+ Data/DeriveTH.hs view
@@ -0,0 +1,43 @@+-- | The main TH driver module. It is intended that this need be the+-- only module imported by user code; it takes care of all data+-- threading issues such that all one needs to do is:+--+-- @+-- data Foo = Foo ; $( derive 'Data.Derive.StdDerivations.eq' ''Foo )+-- @+module Data.DeriveTH+ (derive,+ -- * Convienience re-exports+ Derivation, -- abstract!+ -- * Internal+ _derive_string_instance+ ) where++import Data.List+import Control.Monad (liftM)++import Language.Haskell.TH.All+++-- | Derive an instance of some class. @derive@ only derives instances+-- for the type of the argument.+derive :: Derivation -> Name -> Q [Dec]+derive (Derivation f _) = liftM f . deriveOne++-- | 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+_derive_string_instance (Derivation f s) nm =+ return . LitE . StringL . blankLine . show . ppr . peephole . f =<< deriveOne nm+ where+ blankLine "" = "-- Cannot derive " ++ s ++ " for " ++ show nm+ blankLine xs = xs+ ++-- | Extract a 'DataDef' value from a type using the TH 'reify'+-- framework.+deriveOne :: Name -> Q DataDef+deriveOne x = liftM extract (reify x)++extract (TyConI decl) = normData decl+extract _ = error $ "Data.Derive.TH.deriveInternal: not a type!"
+ Derive.hs view
@@ -0,0 +1,275 @@++module Main(main) where++import System.Console.GetOpt+import System.Environment+import System.Directory+import System.Exit+import System.Cmd+import System.FilePath+import System.Random+import System.IO+import Control.Monad+import Data.Maybe+import Data.List+import Data.Char+import Data.Int+++{-+WHAT TO DERIVE:++To derive something we must write:++data Foo = Foo+ deriving (Eq, Ord {-! Functor, Binary !-} )++Or if we don't want to derive other stuff:++data Foo = Foo+ deriving ({-! Binary !-})++The (brackets) must be present, commas in derive list are required only to separate elements, but are permitted before or after.++CONSOLE OPTIONS:++-o file, which file should the code go in - no file defaults to the console++-import, should an import statement be added++-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)++And a list of files to execute upon++-}++++data Flag = Version | Help | Output String | Import String | Module String+ | Append | Derive [String] | KeepTemp | NoOpts+ deriving (Eq, Show)+++options :: [OptDescr Flag]+options =+ [ Option "v" ["version"] (NoArg Version) "show version number"+ , 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 "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 split "DERIVES") "things to derive for all types"+ , Option "k" ["keep"] (NoArg KeepTemp) "keep temporary file"+ , Option "n" ["no-opts"] (NoArg NoOpts) "ignore the file options"+ ]+ where+ split = Derive . words . map (\x -> if x == ',' then ' ' else x)+++getOpts :: IO ([Flag], [String])+getOpts = do+ args <- getArgs+ case getOpt Permute options args of+ (o,n,[] ) | Version `elem` o -> putStrLn "Derive 0.1, (C) Neil Mitchell & Stefan O'Rear 2006-2007" >> 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+ where+ useage = usageInfo "Usage: derive [OPTION...] files..." options+ exitSuccess = exitWith ExitSuccess+++main = do+ (flags,files) <- getOpts+ files <- mapM pickFile files+ mapM_ (mainFile flags) (catMaybes files)+ when (any isNothing files) exitFailure+++pickFile :: FilePath -> IO (Maybe FilePath)+pickFile orig = f [orig, orig <.> "hs", orig <.> "lhs"]+ where+ f [] = putStrLn ("Error, file not found: " ++ orig) >> return Nothing+ f (x:xs) = do+ b <- doesFileExist x+ if b then return $ Just x else f xs+++appendMsg = "--------------------------------------------------------\n" +++ "-- DERIVES GENERATED CODE\n" +++ "-- DO NOT MODIFY BELOW THIS LINE\n" +++ "-- CHECKSUM: "+++-- delete the end of a file with the appendMsg and a correct hash+-- make sure there are at least 4 blank lines at the end+-- return True for warning+dropAppend :: String -> (String,Bool)+dropAppend xs = f 0 xs+ where+ f i xs | appendMsg `isPrefixOf` xs =+ if hashString rest == chk+ then f i []+ else (xs ++ "\n\n\n\n", True)+ where (chk, rest) = span isDigit $ drop (length appendMsg) xs++ f i [] = (replicate (4 - i) '\n', False)+ f i ('\n':xs) = add '\n' (f (i+1) xs)+ f i (x:xs) = add x (f 0 xs)++ add c ~(cs,b) = (c:cs,b)++++mainFile flags file = do+ (fileflags,modname,datas,reqs) <- parseFile flags file+ let tmpfile = "Temp.hs"+ + devs = ["'\\n': $( _derive_string_instance make" ++ cls ++ " ''" ++ ctor ++ " )"+ | (ctor,cls) <- reqs]++ hscode x = "{-# OPTIONS_GHC -fth -fglasgow-exts -w #-}\n" +++ "module " ++ modname ++ " where\n" +++ "import Data.DeriveTH\n" +++ concat [ "import Data.Derive." ++ cls ++ "\n" | (_, cls) <- reqs ] +++ datas ++ "\n" +++ "main = writeFile " ++ show x ++ " $\n" +++ " unlines [" ++ concat (intersperse ", " devs) ++ "]\n"++ -- note: Wrong on Hugs on Windows+ tmpdir <- getTemporaryDirectory+ b <- doesDirectoryExist tmpdir+ tmpdir <- return $ if b then tmpdir else ""+ + (hsfile, hshndl) <- openTempFileLocal tmpdir "Temp.hs"+ (txfile, txhndl) <- openTempFileLocal tmpdir "Temp.txt"+ hClose txhndl+ + hPutStr hshndl $ hscode txfile+ hClose hshndl+ + system $ "ghc -e " ++ modname ++ ".main " ++ hsfile++ txhndl <- openFile txfile ReadMode+ res <- hGetContents txhndl+ length res `seq` return ()+ hClose txhndl+ + when (KeepTemp `notElem` flags) $ do+ removeFile hsfile+ removeFile txfile++ flags <- return $ fileflags ++ flags+ if Append `elem` flags then do+ src <- readFile file+ let (src2,b) = dropAppend src+ when b $ putStrLn "Warning, Checksum does not match, please edit the file manually"+ writeFile file $ src2 ++ (if null res then "" else appendMsg ++ hashString res ++ "\n" ++ res)+ else do+ let modline = concat $ take 1 ["module " ++ x ++ " where\n" | Module x <- flags]+ impline = unlines ["import " ++ if null i then modname else i | Import i <- flags]+ answer = modline ++ impline ++ res+ + case [x | Output x <- flags] of+ [] -> putStr answer+ (x:_) -> writeFile x answer+++-- return the flags, a string that is the data structures only (including Typeable, Data)+-- and a set of derivation names with types++-- first disguard blank lines and lines which are -- comments+-- next find all lines which start a section, i.e. have something in column 0+-- group lines so every line starts at column 1+-- look for newtype, data etc.+-- look for deriving+parseFile :: [Flag] -> FilePath -> IO ([Flag], String, String, [(String,String)])+parseFile flags file = do+ src <- liftM lines $ readFile file+ options <- if NoOpts `elem` flags then return [] else parseOptions src+ modname <- parseModname src+ let deriv = concat [x | Derive x <- flags ++ options]+ (decl,req) <- return $ unzip $ concatMap (checkData deriv) $ joinLines $+ map dropComments $ filter (not . isBlank) src+ return (options, modname, unlines decl, concat req)+ where+ parseOptions (x:xs)+ | "{-# OPTIONS_DERIVE " `isPrefixOf` x = do+ a <- readOptions $ takeWhile (/= '#') $ drop 19 x+ b <- parseOptions xs+ return $ a ++ b+ | "{-# OPTIONS" `isPrefixOf` x = parseOptions xs+ parseOptions _ = return []+ + readOptions x = case getOpt Permute options (words x) of+ (a,_,ns) -> mapM_ putStr ns >> return a+++ parseModname (x:xs) | "module " `isPrefixOf` x = return $ takeWhile f $ dropWhile isSpace $ drop 6 x+ where f x = not (isSpace x) && x `notElem` "("+ parseModname (x:xs) = parseModname xs+ parseModname [] = putStrLn "Error, module name not detected" >> return "Main"+++ isBlank x = null x2 || "--" `isPrefixOf` x2+ where x2 = dropWhile isSpace x+ + dropComments ('-':'-':xs) = []+ dropComments (x:xs) = x : dropComments xs+ dropComments [] = []++ joinLines (x1:x2:xs) | col1 x1 && not (col1 x2) = joinLines ((x1 ++ x2) : xs)+ where col1 = null . takeWhile isSpace+ joinLines (x:xs) = x : joinLines xs+ joinLines [] = []+ + checkData extra x+ | keyword `elem` ["data","newtype"] = [(x, map ((,) name) req)]+ | keyword `elem` ["type","import"] = [(x,[])]+ | otherwise = []+ where+ keyword = takeWhile (not . isSpace) x+ name = parseName $ drop (length keyword) x+ req = nub $ extra ++ parseDeriving x+++ -- which derivings have been requested+ -- find all things inside {-! !-} and 'words' them+ parseDeriving :: String -> [String]+ parseDeriving x = words $ f False x+ where+ f b ('{':'-':'!':xs) = ' ' : f True xs+ f b ('!':'-':'}':xs) = ' ' : f False xs+ f b (x:xs) = [if x == ',' then ' ' else x | b] ++ f b xs+ f b [] = []+++ -- if there is a =>, its just after that+ -- if there isn't, then its right now+ -- if the => is after =, then ignore+ parseName x = if "=>" `isPrefixOf` b+ then parseName (drop 2 b)+ else head (words a)+ where (a,b) = break (== '=') x+++hashString :: String -> String+hashString = show . abs . foldl f 0 . filter (not . isSpace)+ where+ f :: Int32 -> Char -> Int32+ f x y = x * 31 + fromIntegral (ord y)+++-- Note: openTempFile is not available on Hugs, which sucks+openTempFileLocal :: FilePath -> String -> IO (FilePath, Handle)+openTempFileLocal dir template = do+ i <- randomRIO (1000::Int,9999)+ let (file,ext) = splitExtension template+ s = dir </> (file ++ show i) <.> ext+ b <- doesFileExist s+ if b then openTempFileLocal dir template else do+ h <- openFile s ReadWriteMode+ return (s, h)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2006-2007.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Neil Mitchell nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER 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.
+ Language/Haskell/TH/All.hs view
@@ -0,0 +1,23 @@++module Language.Haskell.TH.All (+ 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.SYB+ ) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Peephole+import Language.Haskell.TH.Helper+import Language.Haskell.TH.FixedPpr+import Language.Haskell.TH.Data+import Language.Haskell.TH.SYB++++-- | The type of ways to derive classes.+-- Should not really be in this module!+data Derivation = Derivation {+ derivationDeriver :: DataDef -> [Dec], -- ^ The derivation function proper+ derivationName :: String -- ^ The name of the derivation+ }
+ Language/Haskell/TH/Data.hs view
@@ -0,0 +1,158 @@+-- | The core module of the Data.Derive system. This module contains+-- the data types used for communication between the extractors and+-- the derivors.+module Language.Haskell.TH.Data where++import Data.List+import Data.Char+import Data.Generics++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.SYB+++-- must be one of DataD or NewtypeD+type DataDef = Dec++type CtorDef = Con+++dataName :: DataDef -> String+dataName (DataD _ name _ _ _) = show name+dataName (NewtypeD _ name _ _ _) = show name+++dataArity :: DataDef -> Int+dataArity (DataD _ _ xs _ _) = length xs+dataArity (NewtypeD _ _ xs _ _) = length xs+++dataCtors :: DataDef -> [CtorDef]+dataCtors (DataD _ _ _ xs _) = xs+dataCtors (NewtypeD _ _ _ x _) = [x]+++ctorName :: CtorDef -> String+ctorName (NormalC name _ ) = show name+ctorName (RecC name _ ) = show name+ctorName (InfixC _ name _) = show name+ctorName (ForallC _ _ c ) = ctorName c+++ctorArity :: CtorDef -> Int+ctorArity (NormalC _ xs ) = length xs+ctorArity (RecC _ xs ) = length xs+ctorArity (InfixC _ _ _ ) = 2+ctorArity (ForallC _ _ c) = ctorArity c+++ctorStrictTypes :: CtorDef -> [StrictType]+ctorStrictTypes (NormalC _ xs ) = xs+ctorStrictTypes (RecC _ xs ) = [(b,c) | (a,b,c) <- xs]+ctorStrictTypes (InfixC x _ y ) = [x,y]+ctorStrictTypes (ForallC _ _ c) = ctorStrictTypes c+++ctorTypes :: CtorDef -> [Type]+ctorTypes = map snd . ctorStrictTypes+++ctorFields :: CtorDef -> [String]+ctorFields (RecC name xs) = [show a | (a,b,c) <- xs]+ctorFields _ = []+++-- normalisation++-- make sure you deal with "GHC.Base.."+dropModule :: String -> String+dropModule xs = case reverse xs of+ ('.':xs) -> takeWhile (== '.') xs+ xs -> reverse $ takeWhile (/= '.') xs+++normData :: DataDef -> DataDef+normData = everywhere (mkT normType) . everywhere (mkT normName)+ where+ normName :: Name -> Name+ normName = mkName . dropModule . show++ normType :: Type -> Type+ normType (ConT x) | show x == "[]" = ListT+ normType x = x++++-- convert AppT chains back to a proper list+typeApp :: Type -> (Type, [Type])+typeApp (AppT l r) = (a, b++[r])+ where (a,b) = typeApp l+typeApp t = (t, [])++++eqConT :: String -> Type -> Bool+eqConT name (ConT x) = name == show x+eqConT _ _ = False++isTupleT :: Type -> Bool+isTupleT (TupleT _) = True+isTupleT (ConT x) = head sx == '(' && last sx == ')' &&+ all (== ',') (take (length sx - 2) (tail sx))+ where sx = show x+isTupleT _ = False+++++-- * Depreciated, old type stuff++data RType = RType {typeCon :: TypeCon, typeArgs :: [RType] }+ deriving (Eq, Ord)++-- | A referencing type which is not itself an application.+data TypeCon = TypeCon String -- ^ A type defined elsewhere, free in+ -- the data declaration.+ | TypeArg Int -- ^ A reference to a type bound by the+ -- type constructor; the argument to+ -- @TypeArg@ is the index of the type+ -- argument, counting from zero at the+ -- left.+ deriving (Eq, Ord)+++instance Show RType where+ show (RType con []) = show con+ show (RType con args) = "(" ++ show con ++ concatMap ((" "++) . show) args ++ ")"++instance Show TypeCon where+ show (TypeCon n) = n+ show (TypeArg i) = [chr (ord 'a' + i)]+++++ctorRTypes :: DataDef -> CtorDef -> [RType]+ctorRTypes dat (NormalC nm tys) = map (ex_type dat . snd) tys+ctorRTypes dat (RecC name tys) = map (ex_type dat . (\ (x,y,z) -> z)) tys+ctorRTypes dat (InfixC t0 n t1) = map (ex_type dat . snd) [t0, t1]+ctorRTypes dat ForallC{} = error "Existential types not yet handled"++++ex_type :: DataDef -> Type -> RType+ex_type dat ForallT{} = error "Polymorphic components not supported"+ex_type dat (VarT nm) = case elemIndex nm (ex_args dat) of+ Nothing -> error "impossible: tyvar not in scope"+ Just k -> RType (TypeArg k) []+ex_type dat (ConT nm) = RType (TypeCon (show nm)) []+ex_type dat (TupleT k) = RType (TypeCon ("(" ++ replicate (k-1) ',' ++ ")")) []+ex_type dat (ArrowT) = RType (TypeCon "(->)") []+ex_type dat (ListT) = RType (TypeCon "[]") []+ex_type dat (AppT a b) = let (RType tc ar) = ex_type dat a ; arg = ex_type dat b+ in RType tc (ar ++ [arg])+++ex_args :: DataDef -> [Name]+ex_args (DataD _cx name args cons _derv) = args+ex_args (NewtypeD cx name args con derv) = args
+ Language/Haskell/TH/FixedPpr.hs view
@@ -0,0 +1,358 @@+-- TH.Ppr contains a prettyprinter for the+-- Template Haskell datatypes++module Language.Haskell.TH.FixedPpr where+ -- All of the exports from this module should+ -- be "public" functions. The main module TH+ -- re-exports them all.++import Text.PrettyPrint.HughesPJ (render)+import Language.Haskell.TH.PprLib+import Language.Haskell.TH.Syntax+import Data.Char ( toLower, isAlpha )++nestDepth :: Int+nestDepth = 4++type Precedence = Int+appPrec, opPrec, noPrec :: Precedence+appPrec = 2 -- Argument of a function application+opPrec = 1 -- Argument of an infix operator+noPrec = 0 -- Others++parensIf :: Bool -> Doc -> Doc+parensIf True d = parens d+parensIf False d = d++------------------------------++-- Show name with `` and () stripped, so that behaviour is the same+-- with fixed and broken syntax-libs+showNameRaw :: Name -> String+showNameRaw = clean . show+ where+ clean ('(':xs) = init xs+ clean ('`':xs) = init xs+ clean xs = xs++isPrefixName :: Name -> Bool+isPrefixName = classify . showNameRaw+ where+ classify xs = case break (=='.') xs of+ (_,(_:xs')) -> classify xs'+ ((x:xs),[]) -> isAlpha x || x == '_'+ _ -> False -- operators ending with .++pprName_ :: Bool -> Name -> Doc+pprName_ True nm | isPrefixName nm = text (showNameRaw nm)+ | otherwise = text ("(" ++ showNameRaw nm ++ ")")+pprName_ False nm | isPrefixName nm = text ("`" ++ showNameRaw nm ++ "`")+ | otherwise = text (showNameRaw nm)++------------------------------++pprint :: Ppr a => a -> String+pprint x = render $ to_HPJ_Doc $ ppr x++class Ppr a where+ ppr :: a -> Doc+ ppr_list :: [a] -> Doc+ ppr_list = vcat . map ppr++instance Ppr a => Ppr [a] where+ ppr x = ppr_list x++------------------------------+instance Ppr Name where+ ppr v = pprName_ True v -- text (show v)++------------------------------+instance Ppr Info where+ ppr (ClassI d) = ppr d+ ppr (TyConI d) = ppr d+ ppr (PrimTyConI name arity is_unlifted) + = text "Primitive"+ <+> (if is_unlifted then text "unlifted" else empty)+ <+> text "type construtor" <+> quotes (ppr name)+ <+> parens (text "arity" <+> int arity)+ ppr (ClassOpI v ty cls fix) + = text "Class op from" <+> ppr cls <> colon <+>+ vcat [ppr_sig v ty, pprFixity v fix]+ ppr (DataConI v ty tc fix) + = text "Constructor from" <+> ppr tc <> colon <+>+ vcat [ppr_sig v ty, pprFixity v fix]+ ppr (TyVarI v ty)+ = text "Type variable" <+> ppr v <+> equals <+> ppr ty+ ppr (VarI v ty mb_d fix) + = vcat [ppr_sig v ty, pprFixity v fix, + case mb_d of { Nothing -> empty; Just d -> ppr d }]++ppr_sig v ty = ppr v <+> text "::" <+> ppr ty++pprFixity :: Name -> Fixity -> Doc+pprFixity v f | f == defaultFixity = empty+pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v+ where ppr_fix InfixR = text "infixr"+ ppr_fix InfixL = text "infixl"+ ppr_fix InfixN = text "infix"+++------------------------------+instance Ppr Exp where+ ppr = pprExp noPrec++pprExpInfix :: Exp -> Doc+pprExpInfix (VarE v) = pprName_ False v+pprExpInfix (ConE c) = pprName_ False c++pprExp :: Precedence -> Exp -> Doc+pprExp _ (VarE v) = ppr v+pprExp _ (ConE c) = ppr c+pprExp i (LitE l) = pprLit i l+pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1+ <+> pprExp appPrec e2+pprExp i (InfixE (Just e1) op (Just e2))+ = parensIf (i >= opPrec) $ pprExp opPrec e1+ <+> pprExpInfix op+ <+> pprExp opPrec e2+pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1+ <+> pprExpInfix op+ <+> pprMaybeExp noPrec me2+pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)+ <+> text "->" <+> ppr e+pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es+-- Nesting in Cond is to avoid potential problems in do statments+pprExp i (CondE guard true false)+ = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard,+ nest 1 $ text "then" <+> ppr true,+ nest 1 $ text "else" <+> ppr false]+pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds+ $$ text " in" <+> ppr e+pprExp i (CaseE e ms)+ = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"+ $$ nest nestDepth (ppr ms)+pprExp i (DoE ss) = parensIf (i > noPrec) $ text "do" <+> ppr ss+pprExp _ (CompE []) = error "Can't happen: pprExp (CompExp [])"+-- This will probably break with fixity declarations - would need a ';'+pprExp _ (CompE ss) = text "[" <> ppr s+ <+> text "|"+ <+> (sep $ punctuate comma $ map ppr ss')+ <> text "]"+ where s = last ss+ ss' = init ss+pprExp _ (ArithSeqE d) = ppr d+pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es+pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t+pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)+pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)++pprFields :: [(Name,Exp)] -> Doc+pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)++pprMaybeExp :: Precedence -> Maybe Exp -> Doc+pprMaybeExp _ Nothing = empty+pprMaybeExp i (Just e) = pprExp i e++------------------------------+instance Ppr Stmt where+ ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e+ ppr (LetS ds) = text "let" <+> ppr ds+ ppr (NoBindS e) = ppr e+ ppr (ParS sss) = sep $ punctuate (text "|")+ $ map (sep . punctuate comma . map ppr) sss++------------------------------+instance Ppr Match where+ ppr (Match p rhs ds) = ppr p <+> pprBody False rhs+ $$ where_clause ds++------------------------------+pprBody :: Bool -> Body -> Doc+pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs+ where eqd = if eq then text "=" else text "->"+ do_guard (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e+ do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss)+ $$ nest nestDepth (eqd <+> ppr e)+pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e+++instance Ppr Body where+ ppr = pprBody True++------------------------------+pprLit :: Precedence -> Lit -> Doc+pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0)+ (integer x <> char '#')+pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0)+ (float (fromRational x) <> char '#')+pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)+ (double (fromRational x) <> text "##")+pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x)+pprLit _ (CharL c) = text (show c)+pprLit _ (StringL s) = text (show s)+pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat++instance Ppr Lit where+ ppr = pprLit 10++------------------------------+instance Ppr Pat where+ ppr = pprPat noPrec++pprPat :: Precedence -> Pat -> Doc+pprPat i (LitP l) = pprLit i l+pprPat _ (VarP v) = ppr v+pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps+pprPat i (ConP s ps) = parensIf (i > noPrec) $ ppr s+ <+> sep (map (pprPat appPrec) ps)+pprPat i (InfixP p1 n p2)+ = parensIf (i > noPrec)+ $ pprPat opPrec p1 <+> pprName_ False n <+> pprPat opPrec p2+pprPat i (TildeP p) = parensIf (i > noPrec) $ text "~" <> pprPat appPrec p+pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@"+ <> pprPat appPrec p+pprPat _ WildP = text "_"+pprPat _ (RecP nm fs)+ = parens $ ppr nm+ <+> braces (sep $ punctuate comma $+ map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)+pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps+pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t++------------------------------+instance Ppr Dec where+ ppr (FunD f cs) = vcat $ map (\c -> ppr f <+> ppr c) cs+ ppr (ValD p r ds) = ppr p <+> pprBody True r+ $$ where_clause ds+ ppr (TySynD t xs rhs) = text "type" <+> ppr t <+> hsep (map ppr xs) + <+> text "=" <+> ppr rhs+ ppr (DataD ctxt t xs cs decs)+ = text "data"+ <+> pprCxt ctxt+ <+> ppr t <+> hsep (map ppr xs)+ <+> sep (pref $ map ppr cs)+ $$ if null decs+ then empty+ else nest nestDepth+ $ text "deriving"+ <+> parens (hsep $ punctuate comma $ map ppr decs)+ where pref :: [Doc] -> [Doc]+ pref [] = [char '='] -- Can't happen in H98+ pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds+ ppr (NewtypeD ctxt t xs c decs)+ = text "newtype"+ <+> pprCxt ctxt+ <+> ppr t <+> hsep (map ppr xs)+ <+> char '=' <+> ppr c+ $$ if null decs+ then empty+ else nest nestDepth+ $ text "deriving"+ <+> parens (hsep $ punctuate comma $ map ppr decs)+ ppr (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt+ <+> ppr c <+> hsep (map ppr xs) <+> ppr fds+ $$ where_clause ds+ ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i+ $$ where_clause ds+ ppr (SigD f t) = ppr f <+> text "::" <+> ppr t+ ppr (ForeignD f) = ppr f++------------------------------+instance Ppr FunDep where+ ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)+ ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))++------------------------------+instance Ppr Foreign where+ ppr (ImportF callconv safety impent as typ)+ = text "foreign import"+ <+> showtextl callconv+ <+> showtextl safety+ <+> text (show impent)+ <+> ppr as+ <+> text "::" <+> ppr typ+ ppr (ExportF callconv expent as typ)+ = text "foreign export"+ <+> showtextl callconv+ <+> text (show expent)+ <+> ppr as+ <+> text "::" <+> ppr typ++------------------------------+instance Ppr Clause where+ ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs+ $$ where_clause ds++------------------------------+instance Ppr Con where+ ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)+ ppr (RecC c vsts)+ = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))+ ppr (InfixC st1 c st2) = pprStrictType st1 <+> pprName_ False c <+> pprStrictType st2+ ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)+ <+> char '.' <+> pprCxt ctxt <+> ppr con++------------------------------+pprVarStrictType :: (Name, Strict, Type) -> Doc+-- Slight infelicity: with print non-atomic type with parens+pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t)++------------------------------+pprStrictType :: (Strict, Type) -> Doc+-- Prints with parens if not already atomic+pprStrictType (IsStrict, t) = char '!' <> pprParendType t+pprStrictType (NotStrict, t) = pprParendType t++------------------------------+pprParendType :: Type -> Doc+pprParendType (VarT v) = ppr v+pprParendType (ConT c) = ppr c+pprParendType (TupleT 0) = text "()"+pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))+pprParendType ArrowT = parens (text "->")+pprParendType ListT = text "[]"+pprParendType other = parens (ppr other)++instance Ppr Type where+ ppr (ForallT tvars ctxt ty) = + text "forall" <+> hsep (map ppr tvars) <+> text "."+ <+> pprCxt ctxt <+> ppr ty+ ppr ty = pprTyApp (split ty)++pprTyApp :: (Type, [Type]) -> Doc+pprTyApp (ArrowT, [arg1,arg2]) = sep [ppr arg1 <+> text "->", ppr arg2]+pprTyApp (ListT, [arg]) = brackets (ppr arg)+pprTyApp (TupleT n, args)+ | length args == n = parens (sep (punctuate comma (map ppr args)))+pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)++split :: Type -> (Type, [Type]) -- Split into function and args+split t = go t []+ where go (AppT t1 t2) args = go t1 (t2:args)+ go ty args = (ty, args)++------------------------------+pprCxt :: Cxt -> Doc+pprCxt [] = empty+pprCxt [t] = ppr t <+> text "=>"+pprCxt ts = parens (hsep $ punctuate comma $ map ppr ts) <+> text "=>"++------------------------------+instance Ppr Range where+ ppr = brackets . pprRange+ where pprRange :: Range -> Doc+ pprRange (FromR e) = ppr e <> text ".."+ pprRange (FromThenR e1 e2) = ppr e1 <> text ","+ <> ppr e2 <> text ".."+ pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2+ pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","+ <> ppr e2 <> text ".."+ <> ppr e3++------------------------------+where_clause :: [Dec] -> Doc+where_clause [] = empty+where_clause ds = nest nestDepth $ text "where" <+> vcat (map ppr ds)++showtextl :: Show a => a -> Doc+showtextl = text . map toLower . show
+ Language/Haskell/TH/Helper.hs view
@@ -0,0 +1,226 @@+-- | These small short-named functions are intended to make the+-- construction of abstranct syntax trees less tedious.+module Language.Haskell.TH.Helper where++import Data.List+import Data.Char++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Data++++-- * Special folds for the guessing+++applyWith, foldl1With, foldr1With :: Exp -> [Exp] -> Exp+applyWith join xs = foldl AppE join xs+foldl1With join xs = foldr1 (\y x -> AppE (AppE join y) x) xs+foldr1With join xs = foldr1 (\y x -> AppE (AppE join x) y) xs++++-- * Syntax elements+--++-- | A simple clause, without where or guards.+sclause :: [Pat] -> Exp -> Clause+sclause pats body = Clause pats (NormalB body) []++-- | A default clause with N arguments.+defclause :: Int -> Exp -> Clause+defclause num = sclause (replicate num WildP)++-- | A simple Val clause+sval :: Pat -> Exp -> Dec+sval pat body = ValD pat (NormalB body) []+++case' :: Exp -> [(Pat, Exp)] -> Exp+case' exp alts = CaseE exp [ Match x (NormalB y) [] | (x,y) <- alts ]++(->:) :: String -> Exp -> Exp+(->:) nm bdy = LamE [vr nm] bdy++-- | We provide 3 standard instance constructors+-- instance_default requires C for each free type variable+-- instance_none requires no context+-- instance_context requires a given context+instance_none :: String -> DataDef -> [Dec] -> Dec+instance_none = instance_context []++instance_default :: String -> DataDef -> [Dec] -> Dec+instance_default n = instance_context [n] n++instance_context :: [String] -> String -> DataDef -> [Dec] -> Dec+instance_context req cls dat defs = InstanceD ctx hed defs+ where+ vrs = vars 't' (dataArity dat)+ hed = l1 cls (lK (dataName dat) vrs)+ ctx = [l1 r v | r <- req, v <- vrs]+++-- | Build an instance of a class for a data type, using the heuristic+-- that the type is itself required on all type arguments.+simple_instance :: String -> DataDef -> [Dec] -> [Dec]+simple_instance cls dat defs = [instance_default cls dat defs]++-- | Build an instance of a class for a data type, using the class at the given types+generic_instance :: String -> DataDef -> [Type] -> [Dec] -> [Dec]+generic_instance cls dat ctxTypes defs = [InstanceD ctx hed defs]+ where+ vrs = vars 't' (dataArity dat)+ hed = l1 cls (lK (dataName dat) vrs)+ ctx = map (l1 cls) ctxTypes++-- | Build a fundecl with a string name+funN :: String -> [Clause] -> Dec+funN nam claus = FunD (mkName nam) claus++-- * Pattern vs Value abstraction++-- | 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+-- types.+class Valcon a where+ -- | Build an application node, with a name for a head and a+ -- provided list of arguments.+ lK :: String -> [a] -> a+ -- | Reference a named variable.+ vr :: String -> a+ -- | Lift a TH 'Lit'+ raw_lit :: Lit -> a+ -- | Tupling+ tup :: [a] -> a+ -- | Listing+ lst :: [a] -> a+instance Valcon Exp where+ 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)+ where isOper x = not (isAlpha x || x == '_')+ lK nm args = foldl AppE (VarE (mkName nm)) args+ vr = VarE . mkName+ raw_lit = LitE+ tup = TupE+ lst = ListE+instance Valcon Pat where+ lK = ConP . mkName+ vr = VarP . mkName+ 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+ raw_lit = error "raw_lit @ Type"+ tup l = foldl AppT (TupleT (length l)) l+ lst = error "lst @ Type"++-- | Build an application node without a given head+app :: Exp -> [Exp] -> Exp+app root args = foldl AppE root args+++-- | This class is used to overload literal construction based on the+-- type of the literal.+class LitC a where+ lit :: Valcon p => a -> p+instance LitC Integer where+ lit = raw_lit . IntegerL+instance LitC Char where+ lit = raw_lit . CharL+instance LitC a => LitC [a] where+ lit = lst . map lit+instance (LitC a, LitC b) => LitC (a,b) where+ lit (x,y) = tup [lit x, lit y]+instance (LitC a, LitC b, LitC c) => LitC (a,b,c) where+ lit (x,y,z) = tup [lit x, lit y, lit z]+instance LitC () where+ lit () = tup []+++-- * Constructor abstraction++dataVars :: DataDef -> [Type]+dataVars dat = take (dataArity dat) $ map (VarT . mkName . return) ['a'..]++-- | Common pattern: list of a familiy of variables+vars :: Valcon a => Char -> Int -> [a]+vars c n = map (vrn c) [1 .. n]++-- | Variable based on a letter + number+vrn :: Valcon a => Char -> Int -> a+vrn c n = vr (c : show n)++-- | Make a list of variables, one for each argument to a constructor+ctv :: Valcon a => CtorDef -> Char -> [a]+ctv ctor c = vars c (ctorArity ctor)++-- | Make a simple pattern to bind a constructor+ctp :: Valcon a => CtorDef -> Char -> a+ctp ctor c = lK (ctorName ctor) (ctv ctor c)++-- | Reference the constructor itself+ctc :: Valcon a => CtorDef -> a+ctc = l0 . ctorName+++-- * 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 s = lK s []+l1 s a = lK s [a]+l2 s a b = lK s [a,b]++-- * Pre-lifted versions of common operations+true, false, nil :: Valcon a => a+hNil', hZero' :: Type+true = l0 "True"+false = l0 "False"+nil = l0 "[]"+unit = lit ()+hNil' = l0 "HNil"+hZero' = l0 "HZero"+id' = l0 "id"++cons :: Valcon a => a -> a -> a+cons = l2 ":"++box :: Valcon a => a -> a+return', const' :: Exp -> Exp+hSucc' :: Type -> Type+box x = cons x nil+return' = l1 "return"+const' = l1 "const"+hSucc' = l1 "HSucc"++(==:), (&&:), (++:), (>>=:), (>>:), (.:), ap', (>:) :: Exp -> Exp -> Exp+hCons' :: Type -> Type -> Type+(==:) = l2 "=="+(&&:) = l2 "&&"+(++:) = l2 "++"+(>>=:) = l2 ">>="+(>>:) = l2 ">>"+(.:) = l2 "."+(>:) = l2 ">"+ap' = l2 "ap"+hCons' = l2 "HCons"++-- | Build a chain of expressions, with an appropriate terminal+-- sequence__ does not require a unit at the end (all others are optimised automatically)+(&&::), (++::), (>>::), sequence__, (.::) :: [Exp] -> Exp+(&&::) = foldr (&&:) true+(++::) = foldr (++:) nil+(>>::) = foldr (>>:) (return' unit)+(.::) = foldr (.:) id'++sequence__ [] = return' unit+sequence__ xs = foldr1 (>>:) xs+++-- | K-way liftM+liftmk :: Exp -> [Exp] -> Exp+liftmk hd args = foldl ap' (return' hd) args
+ Language/Haskell/TH/Peephole.hs view
@@ -0,0 +1,179 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-- pattern bindings only++module Language.Haskell.TH.Peephole(peephole, replaceVar, replaceVars) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Helper+import Language.Haskell.TH.SYB+import Data.Generics+import Data.Maybe+import Data.List+import Debug.Trace++traceMode = False+++peephole :: Data a => a -> a+peephole = everywhere (mkT peep) . everywhere (mkT peepPat)++++-- find a given string, and replace it with a particular expression+-- must succeed, so crashes readily (deliberately!)+replaceVars :: [(Name,Exp)] -> Exp -> Exp+replaceVars rep orig = fExp orig+ where+ fExp x = case x of+ VarE y -> fromMaybe x $ lookup y rep+ ConE _ -> x+ LitE _ -> x+ AppE x y -> AppE (fExp x) (fExp y)+ CaseE x y -> CaseE (fExp x) (map fMatch y)+ TupE xs -> TupE (map fExp xs)+ ListE xs -> ListE (map fExp xs)+ LamE x y -> LamE x (fPat x y)+ _ | null $ map fst rep `intersect` getNames x -> x+ _ -> error $ "replaceVar: " ++ show x++ getNames x = everything (++) ([] `mkQ` f) x+ where+ f :: Name -> [Name]+ f x = [x]++ fMatch o@(Match pat (NormalB bod) []) =+ Match pat (NormalB $ fPat [pat] bod) []++ -- given these pattern have come into scope+ -- continue matching on the rest+ fPat :: [Pat] -> Exp -> Exp+ fPat pat = replaceVars (filter ((`notElem` used) . fst) rep)+ where used = concatMap usedPats pat++ usedPats x = everything (++) ([] `mkQ` f) x+ where+ f (VarP x) = [x]+ f _ = []+++replaceVar :: Name -> Exp -> Exp -> Exp+replaceVar name with = replaceVars [(name,with)]++++-- based on the rewrite combinator in Play+peep :: Exp -> Exp+peep (ListE xs)+ | not (null xs) && all (isJust . fromLitChar) xs =+ peep $ LitE $ StringL $ map (fromJust . fromLitChar) xs+ where+ fromLitChar (LitE (CharL x)) = Just x+ fromLitChar _ = Nothing++peep (AppE x y)+ | x ~= "id" = y++peep (AppE (AppE op x) y)+ | Just res <- peepBin op x y = res++peep (InfixE (Just x) op (Just y))+ | Just res <- peepBin op x y = res++peep (LamE [] x) = x++peep (LamE [VarP x] (VarE y))+ | x == y = l0 "id"++peep (DoE [NoBindS x]) = x++peep x@(ConE _)+ | x ~= "[]" = ListE []++peep (AppE (AppE cons x) nil)+ | cons ~= ":" && nil ~= "[]" = ListE [x]++peep (DoE [BindS (VarP p) (AppE ret (LitE val)),NoBindS e])+ | ret ~= "return" = peep $ replaceVar p (LitE val) e++peep (LamE [TupP [VarP x, VarP y]] (VarE z))+ | x == z = l0 "fst"+ | y == z = l0 "snd"++peep (AppE (LamE (VarP x:xs) y) z)+ | simple z+ = peep $ LamE xs (replaceVar x z y)++peep (AppE (AppE bind (AppE ret x)) y)+ | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x++peep (InfixE (Just (AppE ret x)) bind (Just y))+ | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x++peep (AppE append (ListE [x]))+ | append ~= "++" = peep $ AppE (l0 ":") x++peep (InfixE (Just (ListE [x])) append y)+ | append ~= "++" = peep $ InfixE (Just x) (l0 ":") y++peep (InfixE (Just x) cons (Just (ListE xs)))+ | cons ~= ":" = peep $ ListE (x:xs)++peep (AppE f (LamE x (ListE [y])))+ | f ~= "concatMap" = peep $ AppE (l0 "map") (peep $ LamE x y)++peep (AppE f (ListE xs))+ | f ~= "head" && not (null xs) = head xs+ | f ~= "reverse" = ListE $ reverse xs++peep (AppE f (TupE [x,y]))+ | f ~= "choose" && x == y = peep $ AppE (VarE (mkName "return")) x++peep (AppE (AppE sq o@(AppE rnf x)) (TupE []))+ | sq ~= "seq" && rnf ~= "rnf" = o++peep (CaseE (LitE x) (Match (LitP y) (NormalB z) [] : _))+ | x == y = z++peep (TupE [x]) = x++-- allow easy flip to tracing mode+peep x | traceMode = trace (show x) x+peep x = x+++peepPat :: Pat -> Pat+peepPat (ListP xs)+ | all (\x -> case x of LitP (CharL _) -> True+ _ -> False) xs =+ LitP $ StringL $ map (\(LitP (CharL x)) -> x) xs++peepPat x = x++peepBin :: Exp -> Exp -> Exp -> Maybe Exp+peepBin op x y+ | op ~= "." && x ~= "id" = Just y+ | op ~= "." && y ~= "id" = Just x+ | op ~= "&&" && y ~= "True" = Just x+ | op ~= "const" = Just x+ | op ~= "map" && x ~= "id" = Just y+ | op ~= "++" && x ~= "[]" = Just y+ | op ~= "++" && y ~= "[]" = Just x+ | op ~= "." && y ~= "id" = Just x+ | op ~= ">>" && x ~= "return" && y == TupE [] = Just $ l0 "id"+ | op ~= "$" = Just $ peep $ AppE x y++peepBin op (LitE (StringL x)) (LitE (StringL y))+ | op ~= "++" = Just $ LitE $ StringL (x++y)++peepBin _ _ _ = Nothing+++(VarE f) ~= x = show f == x+(ConE f) ~= x = show f == x+(ListE []) ~= "[]" = True+_ ~= _ = False+++simple (VarE _) = True+simple (LitE _) = True+simple _ = False
+ Language/Haskell/TH/SYB.hs view
@@ -0,0 +1,368 @@+{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-deprecations #-}++module Language.Haskell.TH.SYB where++import Data.Generics hiding (Fixity)+import Language.Haskell.TH.Syntax+import Data.PackedString+++instance Data PackedString where gfoldl k z x = z x++++typename_Name = mkTyCon "Name"+instance Typeable Name+ where typeOf _ = mkTyConApp typename_Name ([])++++instance Data Name+ where gfoldl k z (Name x1 x2) = k (k (z Name) x1) x2++++typename_NameFlavour = mkTyCon "NameFlavour"+instance Typeable NameFlavour+ where typeOf _ = mkTyConApp typename_NameFlavour ([])++++instance Data NameFlavour+ where gfoldl k z x = z x++++typename_NameSpace = mkTyCon "NameSpace"+instance Typeable NameSpace+ where typeOf _ = mkTyConApp typename_NameSpace ([])++++instance Data NameSpace+ where gfoldl k z (VarName) = z VarName+ gfoldl k z (DataName) = z DataName+ gfoldl k z (TcClsName) = z TcClsName++++typename_Info = mkTyCon "Info"+instance Typeable Info+ where typeOf _ = mkTyConApp typename_Info ([])++++instance Data Info+ where gfoldl k z (ClassI x1) = k (z ClassI) x1+ gfoldl k z (ClassOpI x1+ x2+ x3+ x4) = k (k (k (k (z ClassOpI) x1) x2) x3) x4+ gfoldl k z (TyConI x1) = k (z TyConI) x1+ gfoldl k z (PrimTyConI x1+ x2+ x3) = k (k (k (z PrimTyConI) x1) x2) x3+ gfoldl k z (DataConI x1+ x2+ x3+ x4) = k (k (k (k (z DataConI) x1) x2) x3) x4+ gfoldl k z (VarI x1 x2 x3 x4) = k (k (k (k (z VarI) x1) x2) x3) x4+ gfoldl k z (TyVarI x1 x2) = k (k (z TyVarI) x1) x2++++typename_Fixity = mkTyCon "Fixity"+instance Typeable Fixity+ where typeOf _ = mkTyConApp typename_Fixity ([])++++instance Data Fixity+ where gfoldl k z (Fixity x1 x2) = k (k (z Fixity) x1) x2++++typename_FixityDirection = mkTyCon "FixityDirection"+instance Typeable FixityDirection+ where typeOf _ = mkTyConApp typename_FixityDirection ([])++++instance Data FixityDirection+ where gfoldl k z (InfixL) = z InfixL+ gfoldl k z (InfixR) = z InfixR+ gfoldl k z (InfixN) = z InfixN++++typename_Lit = mkTyCon "Lit"+instance Typeable Lit+ where typeOf _ = mkTyConApp typename_Lit ([])++++instance Data Lit+ where gfoldl k z (CharL x1) = k (z CharL) x1+ gfoldl k z (StringL x1) = k (z StringL) x1+ gfoldl k z (IntegerL x1) = k (z IntegerL) x1+ gfoldl k z (RationalL x1) = k (z RationalL) x1+ gfoldl k z (IntPrimL x1) = k (z IntPrimL) x1+ gfoldl k z (FloatPrimL x1) = k (z FloatPrimL) x1+ gfoldl k z (DoublePrimL x1) = k (z DoublePrimL) x1++++typename_Pat = mkTyCon "Pat"+instance Typeable Pat+ where typeOf _ = mkTyConApp typename_Pat ([])++++instance Data Pat+ where gfoldl k z (LitP x1) = k (z LitP) x1+ gfoldl k z (VarP x1) = k (z VarP) x1+ gfoldl k z (TupP x1) = k (z TupP) x1+ gfoldl k z (ConP x1 x2) = k (k (z ConP) x1) x2+ gfoldl k z (InfixP x1 x2 x3) = k (k (k (z InfixP) x1) x2) x3+ gfoldl k z (TildeP x1) = k (z TildeP) x1+ gfoldl k z (AsP x1 x2) = k (k (z AsP) x1) x2+ gfoldl k z (WildP) = z WildP+ gfoldl k z (RecP x1 x2) = k (k (z RecP) x1) x2+ gfoldl k z (ListP x1) = k (z ListP) x1+ gfoldl k z (SigP x1 x2) = k (k (z SigP) x1) x2++++typename_Match = mkTyCon "Match"+instance Typeable Match+ where typeOf _ = mkTyConApp typename_Match ([])++++instance Data Match+ where gfoldl k z (Match x1 x2 x3) = k (k (k (z Match) x1) x2) x3++++typename_Clause = mkTyCon "Clause"+instance Typeable Clause+ where typeOf _ = mkTyConApp typename_Clause ([])++++instance Data Clause+ where gfoldl k z (Clause x1 x2 x3) = k (k (k (z Clause) x1) x2) x3++++typename_Exp = mkTyCon "Exp"+instance Typeable Exp+ where typeOf _ = mkTyConApp typename_Exp ([])++++instance Data Exp+ where gfoldl k z (VarE x1) = k (z VarE) x1+ gfoldl k z (ConE x1) = k (z ConE) x1+ gfoldl k z (LitE x1) = k (z LitE) x1+ gfoldl k z (AppE x1 x2) = k (k (z AppE) x1) x2+ gfoldl k z (InfixE x1 x2 x3) = k (k (k (z InfixE) x1) x2) x3+ gfoldl k z (LamE x1 x2) = k (k (z LamE) x1) x2+ gfoldl k z (TupE x1) = k (z TupE) x1+ gfoldl k z (CondE x1 x2 x3) = k (k (k (z CondE) x1) x2) x3+ gfoldl k z (LetE x1 x2) = k (k (z LetE) x1) x2+ gfoldl k z (CaseE x1 x2) = k (k (z CaseE) x1) x2+ gfoldl k z (DoE x1) = k (z DoE) x1+ gfoldl k z (CompE x1) = k (z CompE) x1+ gfoldl k z (ArithSeqE x1) = k (z ArithSeqE) x1+ gfoldl k z (ListE x1) = k (z ListE) x1+ gfoldl k z (SigE x1 x2) = k (k (z SigE) x1) x2+ gfoldl k z (RecConE x1 x2) = k (k (z RecConE) x1) x2+ gfoldl k z (RecUpdE x1 x2) = k (k (z RecUpdE) x1) x2++++typename_Body = mkTyCon "Body"+instance Typeable Body+ where typeOf _ = mkTyConApp typename_Body ([])++++instance Data Body+ where gfoldl k z (GuardedB x1) = k (z GuardedB) x1+ gfoldl k z (NormalB x1) = k (z NormalB) x1++++typename_Guard = mkTyCon "Guard"+instance Typeable Guard+ where typeOf _ = mkTyConApp typename_Guard ([])++++instance Data Guard+ where gfoldl k z (NormalG x1) = k (z NormalG) x1+ gfoldl k z (PatG x1) = k (z PatG) x1++++typename_Stmt = mkTyCon "Stmt"+instance Typeable Stmt+ where typeOf _ = mkTyConApp typename_Stmt ([])++++instance Data Stmt+ where gfoldl k z (BindS x1 x2) = k (k (z BindS) x1) x2+ gfoldl k z (LetS x1) = k (z LetS) x1+ gfoldl k z (NoBindS x1) = k (z NoBindS) x1+ gfoldl k z (ParS x1) = k (z ParS) x1++++typename_Range = mkTyCon "Range"+instance Typeable Range+ where typeOf _ = mkTyConApp typename_Range ([])++++instance Data Range+ where gfoldl k z (FromR x1) = k (z FromR) x1+ gfoldl k z (FromThenR x1 x2) = k (k (z FromThenR) x1) x2+ gfoldl k z (FromToR x1 x2) = k (k (z FromToR) x1) x2+ gfoldl k z (FromThenToR x1+ x2+ x3) = k (k (k (z FromThenToR) x1) x2) x3++++typename_Dec = mkTyCon "Dec"+instance Typeable Dec+ where typeOf _ = mkTyConApp typename_Dec ([])++++instance Data Dec+ where gfoldl k z (FunD x1 x2) = k (k (z FunD) x1) x2+ gfoldl k z (ValD x1 x2 x3) = k (k (k (z ValD) x1) x2) x3+ gfoldl k z (DataD x1+ x2+ x3+ x4+ x5) = k (k (k (k (k (z DataD) x1) x2) x3) x4) x5+ gfoldl k z (NewtypeD x1+ x2+ x3+ x4+ x5) = k (k (k (k (k (z NewtypeD) x1) x2) x3) x4) x5+ gfoldl k z (TySynD x1 x2 x3) = k (k (k (z TySynD) x1) x2) x3+ gfoldl k z (ClassD x1+ x2+ x3+ x4+ x5) = k (k (k (k (k (z ClassD) x1) x2) x3) x4) x5+ gfoldl k z (InstanceD x1 x2 x3) = k (k (k (z InstanceD) x1) x2) x3+ gfoldl k z (SigD x1 x2) = k (k (z SigD) x1) x2+ gfoldl k z (ForeignD x1) = k (z ForeignD) x1++++typename_FunDep = mkTyCon "FunDep"+instance Typeable FunDep+ where typeOf _ = mkTyConApp typename_FunDep ([])++++instance Data FunDep+ where gfoldl k z (FunDep x1 x2) = k (k (z FunDep) x1) x2++++typename_Foreign = mkTyCon "Foreign"+instance Typeable Foreign+ where typeOf _ = mkTyConApp typename_Foreign ([])++++instance Data Foreign+ where gfoldl k z (ImportF x1+ x2+ x3+ x4+ x5) = k (k (k (k (k (z ImportF) x1) x2) x3) x4) x5+ gfoldl k z (ExportF x1+ x2+ x3+ x4) = k (k (k (k (z ExportF) x1) x2) x3) x4++++typename_Callconv = mkTyCon "Callconv"+instance Typeable Callconv+ where typeOf _ = mkTyConApp typename_Callconv ([])++++instance Data Callconv+ where gfoldl k z (CCall) = z CCall+ gfoldl k z (StdCall) = z StdCall++++typename_Safety = mkTyCon "Safety"+instance Typeable Safety+ where typeOf _ = mkTyConApp typename_Safety ([])++++instance Data Safety+ where gfoldl k z (Unsafe) = z Unsafe+ gfoldl k z (Safe) = z Safe+ gfoldl k z (Threadsafe) = z Threadsafe++++typename_Strict = mkTyCon "Strict"+instance Typeable Strict+ where typeOf _ = mkTyConApp typename_Strict ([])++++instance Data Strict+ where gfoldl k z (IsStrict) = z IsStrict+ gfoldl k z (NotStrict) = z NotStrict++++typename_Con = mkTyCon "Con"+instance Typeable Con+ where typeOf _ = mkTyConApp typename_Con ([])++++instance Data Con+ where gfoldl k z (NormalC x1 x2) = k (k (z NormalC) x1) x2+ gfoldl k z (RecC x1 x2) = k (k (z RecC) x1) x2+ gfoldl k z (InfixC x1 x2 x3) = k (k (k (z InfixC) x1) x2) x3+ gfoldl k z (ForallC x1 x2 x3) = k (k (k (z ForallC) x1) x2) x3++++typename_Type = mkTyCon "Type"+instance Typeable Type+ where typeOf _ = mkTyConApp typename_Type ([])++++instance Data Type+ where gfoldl k z (ForallT x1+ x2+ x3) = k (k (k (z ForallT) x1) x2) x3+ gfoldl k z (VarT x1) = k (z VarT) x1+ gfoldl k z (ConT x1) = k (z ConT) x1+ gfoldl k z (TupleT x1) = k (z TupleT) x1+ gfoldl k z (ArrowT) = z ArrowT+ gfoldl k z (ListT) = z ListT+ gfoldl k z (AppT x1 x2) = k (k (z AppT) x1) x2++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ derive.cabal view
@@ -0,0 +1,58 @@+Name: derive+Version: 0.1+Copyright: 2006-7, Neil Mitchell+Maintainer: ndmitchell@gmail.com+Homepage: http://www-users.cs.york.ac.uk/~ndm/derive/+Build-Depends: base, template-haskell, filepath, mtl+License: BSD3+License-File: LICENSE+Author: Neil Mitchell & Stefan O'Rear+Synopsis: A program and library to derive instances for data types+Description:+ Data.Derive is a library and a tool for deriving instances for Haskell programs.+ It is designed to work with custom derivations, SYB and Template Haskell mechanisms.+ The tool requires GHC, but the generated code is portable to all compilers.+ We see this tool as a competitor to DrIFT.+Category: Development+Extensions: CPP+Extra-Source-Files:+ derive.htm+Exposed-Modules:+ Data.DeriveGuess+ Data.DeriveTH+ Data.Derive.All+ Data.Derive.Arbitrary+ Data.Derive.Arbitrary2+ Data.Derive.Binary+ Data.Derive.BinaryDefer+ Data.Derive.Bounded+ Data.Derive.Data+ Data.Derive.Enum+ Data.Derive.EnumCyclic+ Data.Derive.Eq+ Data.Derive.From+ Data.Derive.Functor+ Data.Derive.Has+ Data.Derive.Is+ Data.Derive.LazySet+ Data.Derive.Monoid+ Data.Derive.NFData+ Data.Derive.Ord+ Data.Derive.Play+ Data.Derive.PlayAll+ Data.Derive.Read+ Data.Derive.Serial+ Data.Derive.Set+ Data.Derive.Show+ Data.Derive.TTypeable+ Data.Derive.Typeable+ Language.Haskell.TH.All+ Language.Haskell.TH.Data+ Language.Haskell.TH.FixedPpr+ Language.Haskell.TH.Helper+ Language.Haskell.TH.Peephole+ Language.Haskell.TH.SYB+++Executable: derive+Main-Is: Derive.hs
+ derive.htm view
@@ -0,0 +1,353 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html>+ <head>+ <meta http-equiv="Content-Type" content="text/html;charset=utf-8" />+ <title>Data.Derive: A User Manual</title>+ <style type="text/css">+pre {+ border: 2px solid gray;+ padding: 1px;+ padding-left: 5px;+ margin-left: 10px;+ background-color: #eee;+}++pre.define {+ background-color: #ffb;+ border-color: #cc0;+}++body {+ font-family: sans-serif;+}++h1, h2, h3 {+ font-family: serif;+}++h1 {+ color: rgb(23,54,93);+ border-bottom: 1px solid rgb(79,129,189);+ padding-bottom: 2px;+ font-variant: small-caps;+ text-align: center;+}++a {+ color: rgb(54,95,145);+}++h2 {+ color: rgb(54,95,145);+}++h3 {+ color: rgb(79,129,189);+}+ </style>+ </head>+ <body>++<h1>Data.Derive: A User Manual</h1>++<p style="text-align:right;margin-bottom:25px;">+ by <a href="http://www.cs.york.ac.uk/~ndm/">Neil Mitchell</a> & Stefan O'Rear+</p>++<p>+ Data.Derive is a library and a tool for deriving instances for Haskell programs. It is designed to work with custom derivations, SYB and Template Haskell mechanisms. The tool requires GHC, but the generated code is portable to all compilers. We see this tool as a competitor to <a href="http://repetae.net/~john/computer/haskell/DrIFT/">DrIFT</a>.+</p>+<p>+ This document proceeds as follows:+</p>+<ol>+ <li>Obtaining and Installing Data.Derive</li>+ <li>Supported Derivations</li>+ <li>Using the Derive Program</li>+ <li>Using Template Haskell Derivations</li>+ <li>Writing a New Derivation</li>+</ol>++<h3>Acknowledgements</h3>++<p>+ Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi.+ 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.+</p>+++<h2>Obtaining and Installing Data.Derive</h2>++<p>+ Data.Derive is available using <a href="http://darcs.net/">darcs</a>:+</p>+<pre>+darcs get --partial <a href="http://www.cs.york.ac.uk/fp/darcs/derive">http://www.cs.york.ac.uk/fp/darcs/derive</a>+</pre>+<p>+ Install the program using the standard sequence of Cabal magic:+</p>+<pre>+runhaskell Setup configure+runhaskell Setup build+runhaskell Setup install+</pre>+++<h2>Supported Derivations</h2>++<p>+ Data.Derive is not limited to any prebuild set of derivations, see later for how to add your own. Out of the box, we provide instances for the following libraries.+</p>++<h3>Prelude</h3>++<p>+ These are the standard classes defined in the <a href="http://haskell.org/onlinereport/derived.html">Haskell Report</a>, some of which the existing <tt>deriving</tt> works upon.+</p>+<ul>+ <li><b>Eq</b></li>+ <li><b>Ord</b></li>+ <li><b>Bounded</b></li>+ <li><b>Enum</b></li>+ <li><b>EnumCyclic</b></li>+ <li><b>Functor</b></li>+ <li><b>Read</b></li>+ <li><b>Show</b></li>+</ul>++<h3>Base</h3>++<p>+ These are instances from the base libraries, but which aren't in the Haskell 98 report.+</p>+<ul>+ <li><b>Monoid</b></li>+ <li><b>NFData</b></li>+</ul>++<h3>Query</h3>++<p>+ DrIFT defines a number of useful query functions, which are technically not instances, but can be derived in a similar manner. We support some of these as from DrIFT, some with modifications, and some which are brand new:+</p>+<ul>+ <li><b>From</b></li>+ <li><b>Has</b></li>+ <li><b>Is</b></li>+ <li><b>Set</b></li>+ <li><b>LazySet</b></li>+</ul>++<h3>Generics</h3>++<p>+ We support the two classes from the first <a href="http://www.cs.vu.nl/boilerplate/">Scrap Your Boilerplate</a> paper, and the classes from the <a href="http://www-users.cs.york.ac.uk/~ndm/play/">Play library</a>:+</p>+<ul>+ <li><b>Typeable</b></li>+ <li><b>Data</b></li>+ <li><b>Play</b></li>+</ul>++<h3>Binary</h3>++<p>+ We support the new <a href="http://www.cse.unsw.edu.au/~dons/binary.html">Binary library</a>, and the <a href="http://www-users.cs.york.ac.uk/~ndm/binarydefer/">BinaryDefer library</a>.+</p>+<ul>+ <li><b>Binary</b></li>+ <li><b>BinaryDefer</b></li>+</ul>++<h3>Testing</h3>++<p>+ We support both <a href="http://www.cs.chalmers.se/~rjmh/QuickCheck/">QuickCheck</a> and the <a href="http://www.cs.york.ac.uk/fp/darcs/smallcheck/">SmallCheck library</a>:+</p>+<ul>+ <li><b>Arbitrary</b></li>+ <li><b>Serial</b></li>+</ul>++<h3>Classhacking</h3>++<p>+ From the <a href="http://homepages.cwi.nl/~ralf/HList">HList library</a>:+</p>+<ul>+ <li><b>TTypeable</b></li>+</ul>++<h3>Missing</h3>++<p>+ These derivations are in DrIFT, but not in Derive. If you need them, let us know and we'll implement them.+</p>+<ul>+ <li><b>ATermConvertible</b> - encode terms in the ATerm format.</li>+ <li><b>BitsBinary</b> - efficient binary encoding of terms.</li>+ <li><b>FunctorM</b> - derive reasonable fmapM implementation.</li>+ <li><b>GhcBinary</b> - byte sized binary encoding of terms.</li>+ <li><b>HFoldable</b> - Strafunski hfoldr.</li>+ <li><b>Haskell2Xml</b> - encode terms as XML (HaXml<=1.13).</li>+ <li><b>Observable</b> - HOOD observable.</li>+ <li><b>RMapM</b> - derive reasonable rmapM implementation.</li>+ <li><b>Term</b> - Strafunski representation via Dynamic.</li>+ <li><b>XmlContent</b> - encode terms as XML (HaXml>=1.14).</li>+</ul>++<h2>Using the Derive program</h2>++<p>+ Let's imagine we've defined a data type:+</p>+<pre>+data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Eq, Show)+</pre>+<p>+ Now we wish to extend this to derive <tt>Binary</tt> and change to defining <tt>Eq</tt> using our library. To do this we simply add to the <tt>deriving</tt> clause.+</p>+<pre>+data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Show {-! Eq, Binary !-})+</pre>+<p>+ Now running <tt>derive</tt> on the program containing this code will generate appropriate instances. How do you combine these instances back into the code? There are various mechanisms supported.+</p>++<h3>Appending to the module</h3>++<p>+ One way is to append the text to the bottom of the module, this can be done by passing the <tt>--append</tt> flag. If this is done, Derive will generate the required instances and place them at the bottom of the file, along with a checksum. Do not modify these instances.+</p>++<h3>Using CPP</h3>++<p>+ One way is to use CPP. Ensure your compiler is set up for compiling with the C Pre Processor. For example:+</p>+<pre>+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_DERIVE --output=file.h #-}++module ModuleName where++#include "file.h"+</pre>++<h3>Side-by-side Modules</h3>++<p>+ If you had Colour.Type, and wished to place the Binary instance in Colour.Binary, this can be done with:+</p>+<pre>+{-# OPTIONS_DERIVE --output=Binary.hs --module=Colour.Binary --import #-}+</pre>+<p>+ Here you ask for the output to go to a particular file, give a specific module name and import this module. This will only work if the data structure is exported non-abstractly.+</p>++<h2>Using Template Haskell Derivations</h2>++<p>+ One of Derive's major advantages over DrIFT is support for the <a href="http://www.haskell.org/th/">Template Haskell</a> (henceforth abbreviated "TH") system. This allows Derive to be invoked automatically during the compilation process, and (because it occurs with full access to the renamer tables) transparently supports deriving across module boundaries. The main disadvantage of TH-based deriving is that it is only portable to compilers that support TH; currently that is GHC only.+</p>++<p>+ To use the TH deriving system, with the same example as before:+</p>++<pre>+import Data.Derive.TH+import Data.Derive.Eq+import Data.Derive.Binary++data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Show)++$( derive makeEq ''Color )+$( derive makeBinary ''Color )+</pre>++<p>+ Note two things. First, we need to import the derivations. By convention, a derivation for a class <tt>FooBar</tt> is located in module <tt>Data.Derive.FooBar</tt> (nota bene: this need not be in package "derive") and is exported with the name <tt>makeFooBar</tt>. Secondly, we need to tell the compiler to insert the instance using the TH <em>splice</em> construct, <tt>$( ... )</tt> (the spaces are optional). The splice causes the compiler to run the function <tt>derive</tt> (exported from <tt>Data.Derive.TH</tt>), passing arguments <tt>makeFooBar</tt> and <tt>''Color</tt>. The second argument deserves more explanation; it is a quoted symbol, somewhat like a quoted symbol in Lisp and with deliberately similar syntax. (Two apostrophes are used to specify that this name is to be resolved as a type constructor; just <tt>'Color</tt> would look for a <i>data</i> constructor named <tt>Color</tt>.)+</p>++<h2>Writing a New Derivation</h2>++<p>+ There are two methods for writing a new derivation, guessing or coding. The guessing method is substantially easier if it will work for you, but is limited to derivations with the following properties:+</p>+<ul>+ <li>Inductive - each derivation must be similar to the previous one. <tt>Binary</tt> does not have this property as a 1 item derivation does not have a tag, but a 2 item derivation does.</li>+ <li>Not inductive on the type - it must be an instance for the constructors, not for the type. <tt>Typeable</tt> violates this property by inducting on the free variables in the data type.</li>+ <li>Not type based - the derivation must not change based on the types of the fields. <tt>Play</tt> and <tt>Functor</tt> both behave differently given differently typed fields.</li>+ <li>Not record based - the derivation must not change on record fields. <tt>Show</tt> outputs the fields, so this is not allowed.</li>+</ul>+<p>+ If however your instance does meet these properties, you can use derivation by guess. Many instances do meet these conditions: <tt>Eq</tt>, <tt>Ord</tt>, <tt>Data</tt>, <tt>Serial</tt> etc.+</p>++<h3>Derivation by Guess</h3>++<p>+ This is a unique feature of this library. You simply give an instance, and the program guesses what your instance derivation code should look like, and returns it. You paste the code in, and you have written an instance without learning any of the types or functions required to construct the abstract syntax. For example, lets take the <tt>Data</tt> instance. I recommend reading through the source in <tt>Data.Derive.Data</tt> first, then matching it to this description.+</p>+<p>+ First copy the Data file, changing all the obvious bits (<tt>makeData</tt> etc) to whatever name you want. Next change the example to match your requirements. You basically define an instance for <tt>DataName</tt> which is defined as:+</p>+<pre>+data DataName a = CtorZero+ | CtorOne a+ | CtorTwo a a+ | CtorTwo' a a+</pre>+<p>+ Try and make your declaration as inductive as possible. Use <tt>x1</tt> etc for variable names within a constructor match. Place all the constructors in the correct order. If you would be unable to see an obvious pattern, then the guesser won't either. Once we have written our sample instance:+</p>+<pre>+> <b>ghci Data.Derive.Data -DGUESS</b>+ ___ ___ _+ / _ \ /\ /\/ __(_)+ / /_\// /_/ / / | | GHC Interactive, version 6.6, for Haskell 98.+/ /_\\/ __ / /___| | http://www.haskell.org/ghc/+\____/\/ /_/\____/|_| Type :? for help.++Loading package base ... linking ... done.+Ok, modules loaded: Data.Derive.Data, Data.DeriveGuess, Language.Haskell.TH.All,+ Language.Haskell.TH.SYB, Language.Haskell.TH.Data, Language.Haskell.TH.FixedPpr+, Language.Haskell.TH.Helper, Language.Haskell.TH.Peephole.+*Data.Derive.Data> <b>guess example</b>++makeData = Derivation data' "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+ ))))++[]))]]+</pre>+<p>+ And thats it. The block of code spewed out will generate <tt>Data</tt> instances, we just paste it back into the file.+</p>+<p>+ There is lots of clever stuff, induction hypotheses etc going on behind all this. If you have an instance which you think should be inferable, but isn't, then <a href="http://www-users.cs.york.ac.uk/~ndm/contact/">let me know</a>.+</p>++<h3>Derivation by Coding</h3>++<p>+ We use the Template Haskell data types extensively, for examples take a look at <tt>Binary</tt> and <tt>Functor</tt>. Its not particularly hard, but it is harder than just having them guessed.+</p>+++ </body>+</html>