derive 0.1.1 → 2.6.5
raw patch · 102 files changed
Files
- CHANGES.txt +77/−0
- Data/Derive/All.hs +0/−33
- Data/Derive/Arbitrary.hs +0/−68
- Data/Derive/Arbitrary2.hs +0/−51
- Data/Derive/Binary.hs +0/−34
- Data/Derive/BinaryDefer.hs +0/−48
- Data/Derive/BinaryOld.hs +0/−93
- Data/Derive/Bounded.hs +0/−36
- Data/Derive/Data.hs +0/−42
- Data/Derive/Enum.hs +0/−46
- Data/Derive/EnumCyclic.hs +0/−66
- Data/Derive/Eq.hs +0/−48
- Data/Derive/Foldable.hs +0/−31
- Data/Derive/From.hs +0/−36
- Data/Derive/Functor.hs +0/−38
- Data/Derive/Has.hs +0/−41
- Data/Derive/Is.hs +0/−32
- Data/Derive/LazySet.hs +0/−42
- Data/Derive/Monoid.hs +0/−32
- Data/Derive/NFData.hs +0/−33
- Data/Derive/Ord.hs +0/−68
- Data/Derive/PlateDirect.hs +0/−57
- Data/Derive/PlateTypeable.hs +0/−48
- Data/Derive/Read.hs +0/−49
- Data/Derive/Ref.hs +0/−25
- Data/Derive/Serial.hs +0/−57
- Data/Derive/Set.hs +0/−34
- Data/Derive/Show.hs +0/−35
- Data/Derive/TTypeable.hs +0/−26
- Data/Derive/Traversable.hs +0/−34
- Data/Derive/Typeable.hs +0/−63
- Data/Derive/Uniplate.hs +0/−232
- Data/DeriveGuess.hs +0/−413
- Data/DeriveTH.hs +0/−43
- Data/DeriveTraversal.hs +0/−187
- Derive.hs +0/−280
- LICENSE +1/−1
- Language/Haskell/TH/All.hs +0/−36
- Language/Haskell/TH/Data.hs +0/−113
- Language/Haskell/TH/FixedPpr.hs +0/−358
- Language/Haskell/TH/Helper.hs +0/−228
- Language/Haskell/TH/Peephole.hs +0/−204
- Language/Haskell/TH/SYB.hs +0/−366
- Main.hs +9/−0
- README.md +168/−0
- Setup.hs +1/−42
- derive.cabal +79/−51
- derive.htm +0/−353
- src/Data/Derive/All.hs +35/−0
- src/Data/Derive/Arbitrary.hs +106/−0
- src/Data/Derive/ArbitraryOld.hs +89/−0
- src/Data/Derive/Arities.hs +48/−0
- src/Data/Derive/Binary.hs +181/−0
- src/Data/Derive/BinaryDefer.hs +83/−0
- src/Data/Derive/Bounded.hs +56/−0
- src/Data/Derive/Class/Arities.hs +5/−0
- src/Data/Derive/Class/Default.hs +5/−0
- src/Data/Derive/DSL/Apply.hs +76/−0
- src/Data/Derive/DSL/DSL.hs +112/−0
- src/Data/Derive/DSL/Derive.hs +157/−0
- src/Data/Derive/DSL/HSE.hs +115/−0
- src/Data/Derive/DSL/SYB.hs +114/−0
- src/Data/Derive/DataAbstract.hs +79/−0
- src/Data/Derive/Default.hs +38/−0
- src/Data/Derive/EnumCyclic.hs +152/−0
- src/Data/Derive/Fold.hs +67/−0
- src/Data/Derive/From.hs +65/−0
- src/Data/Derive/Has.hs +40/−0
- src/Data/Derive/Instance/Arities.hs +14/−0
- src/Data/Derive/Internal/Derivation.hs +46/−0
- src/Data/Derive/Internal/Instance.hs +34/−0
- src/Data/Derive/Internal/Traversal.hs +219/−0
- src/Data/Derive/Is.hs +33/−0
- src/Data/Derive/JSON.hs +178/−0
- src/Data/Derive/LazySet.hs +39/−0
- src/Data/Derive/Lens.hs +41/−0
- src/Data/Derive/Monoid.hs +93/−0
- src/Data/Derive/NFData.hs +42/−0
- src/Data/Derive/Ref.hs +42/−0
- src/Data/Derive/Serial.hs +84/−0
- src/Data/Derive/Serialize.hs +182/−0
- src/Data/Derive/Set.hs +41/−0
- src/Data/Derive/UniplateDirect.hs +233/−0
- src/Data/Derive/UniplateTypeable.hs +102/−0
- src/Data/Derive/Update.hs +47/−0
- src/Data/DeriveDSL.hs +21/−0
- src/Data/DeriveMain.hs +19/−0
- src/Data/DeriveTH.hs +44/−0
- src/Derive/Derivation.hs +103/−0
- src/Derive/Flags.hs +65/−0
- src/Derive/Generate.hs +115/−0
- src/Derive/Main.hs +67/−0
- src/Derive/Test.hs +100/−0
- src/Derive/Utils.hs +86/−0
- src/Language/Haskell.hs +315/−0
- src/Language/Haskell/Convert.hs +332/−0
- src/Language/Haskell/TH/All.hs +34/−0
- src/Language/Haskell/TH/Compat.hs +55/−0
- src/Language/Haskell/TH/Data.hs +142/−0
- src/Language/Haskell/TH/ExpandSynonym.hs +47/−0
- src/Language/Haskell/TH/Helper.hs +248/−0
- src/Language/Haskell/TH/Peephole.hs +216/−0
+ CHANGES.txt view
@@ -0,0 +1,77 @@+2.6.4+ Rewrite for haskell-src-exts == 1.20.*+ #27, disable a few more extensions by default (sync with the HLint list)+2.6.3+ #24, support GHC 8.2+2.6.2+ #19, more upgrade bug fixes+2.6.1+ #19, allow haskell-src-exts-1.19+2.6+ Remove lots of derivations that didn't seem useful (Eq, Show etc)+ Change to use annotated Haskell syntax trees+ Require haskell-src-exts-1.18+2.5.26+ #17, fix incomplete pattern matches for certain types of data+2.5.25+ #14, further GHC 8.0.1 updates+2.5.24+ #14, update to GHC 8.0.1+ #15, move all the source files under src to speed up building+ Delete the FixedPpr module, was unused+2.5.23+ Require haskell-src-exts-1.17+2.5.22+ #7, #8 convert more types from TemplateHaskell+2.5.21+ Fix the homepage link+2.5.20+ #5, fix regression with higher-kinded constructors becoming context+2.5.19+ Support GHC 7.10+2.5.18+ #4, fix the read instance for nullary constructors+2.5.17+ Upgrade to haskell-src-exts-1.16+ Remove GHC 7.2 support+2.5.16+ Allow transformers-0.4 and above+2.5.15+ Allow haskell-src-exts-1.15.*+2.5.14+ #3, support GHC 7.9+2.5.13+ #622, turn on more Haskell extensions+2.5.12+ Upgrade to haskell-src-exts-1.14.*+2.5.11+ Support GHC 7.6+2.5.10+ Add derivation for Lens+ Modify the Typeable derivation to use mkTyCon3+2.5.9+ Support the Template Haskell Unpacked constructor+2.5.8+ Allow haskell-src-exts-1.13.*+2.5.7+ Allow haskell-src-exts-1.12.*+2.5.6+ Update the copyright year+ Allow transformers-0.3.*+2.5.5+ #513, allow derive to be run as a preprocessor+ Improve the documentation for UniplateDirect+2.5.4+ #394, allow tuple names in more places+ Fix error when deriving Binary on "data A = B"+2.5.3+ GHC 7.2 compatibility+2.5.2+ Relax the dependency on haskell-src-exts to < 1.12+2.5.1+ Improve documentation for deriveMain+2.5+ #257, add Data.DeriveMain.deriveMain, to allow user derivations+2.4.2+ Relax the dependency on haskell-src-exts to < 1.11+ Start of changelog
− Data/Derive/All.hs
@@ -1,33 +0,0 @@--- | 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.BinaryOld 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.Foldable 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.PlateDirect as D-import Data.Derive.PlateTypeable as D-import Data.Derive.Read as D-import Data.Derive.Ref as D-import Data.Derive.Serial as D-import Data.Derive.Set as D-import Data.Derive.Show as D-import Data.Derive.Traversable as D-import Data.Derive.TTypeable as D-import Data.Derive.Typeable as D-import Data.Derive.Uniplate as D
− Data/Derive/Arbitrary.hs
@@ -1,68 +0,0 @@-{-# 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
@@ -1,51 +0,0 @@-{-# 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
@@ -1,34 +0,0 @@--- 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
@@ -1,48 +0,0 @@-{-# 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/BinaryOld.hs
@@ -1,93 +0,0 @@--- 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.-{-# OPTIONS_GHC -fth -cpp #-}--module Data.Derive.BinaryOld(makeBinaryOld) where--import Language.Haskell.TH.All-import Data.List--#ifdef GUESS--import Data.DeriveGuess-import Yhc.Core.Internal.Binary--example = (,) "BinaryOld" [d|-- instance Binary a => Binary (DataName a) where- put_ bh x = - case x of- CtorZero -> do- if useTag then putByte bh 0 else return ()- CtorOne x1 -> do- if useTag then putByte bh 1 else return ()- put_ bh x1- CtorTwo x1 x2 -> do- if useTag then putByte bh 2 else return ()- put_ bh x1- put_ bh x2- CtorTwo' x1 x2 -> do- if useTag then putByte bh 3 else return ()- put_ bh x1- put_ bh x2- where- useTag = length [CtorZero{}, CtorOne{}, CtorTwo{}, CtorTwo'{}] > 1-- get bh = do- h <- if useTag then getByte bh else return 0- case h of- 0 -> do- return CtorZero- 1 -> do- x1 <- get bh- return (CtorOne x1)- 2 -> do- x1 <- get bh- x2 <- get bh- return (CtorTwo x1 x2)- 3 -> do- x1 <- get bh- x2 <- get bh- return (CtorTwo' x1 x2)- _ -> fail "invalid binary data found"- where- useTag = length [CtorZero{}, CtorOne{}, CtorTwo{}, CtorTwo'{}] > 1- |]--#endif---makeBinaryOld :: Derivation-makeBinaryOld = derivation binaryOld' "BinaryOld"-binaryOld' dat = [InstanceD (concat ([(map (\tdat -> (AppT (ConT (mkName- "Binary")) tdat)) (dataVars dat))])) (head [(AppT (ConT (mkName "Binary"))- (lK (dataName dat) (dataVars dat)))])[(FunD (mkName "put_") [(Clause [(VarP- (mkName "bh")),(VarP (mkName "x"))] (NormalB (CaseE (VarE (mkName "x")) ((- map (\(ctorInd,ctor) -> (Match (ConP (mkName ("" ++ ctorName ctor)) ((map (- \field -> (VarP (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[- ])) (NormalB (DoE ([(NoBindS (CondE (VarE (mkName "useTag")) (applyWith (- VarE (mkName "putByte")) [(VarE (mkName "bh")),(LitE (IntegerL ctorInd))])- (AppE (VarE (mkName "return")) (TupE []))))]++(map (\field -> (NoBindS (- applyWith (VarE (mkName "put_")) [(VarE (mkName "bh")),(VarE (mkName ("x"- ++ show field)))]))) (id [1..ctorArity ctor]))++[]))) [])) (id (zip [0..] (- dataCtors dat))))++[]))) [(ValD (VarP (mkName "useTag")) (NormalB (- applyWith (VarE (mkName ">")) [(AppE (VarE (mkName "length")) (ListE ((map- (\(ctorInd,ctor) -> ((flip RecConE []) (mkName ("" ++ ctorName ctor)))) (id- (zip [0..] (dataCtors dat))))++[]))),(LitE (IntegerL 1))])) [])])]),(FunD (- mkName "get") [(Clause [(VarP (mkName "bh"))] (NormalB (DoE [(BindS (VarP (- mkName "h")) (CondE (VarE (mkName "useTag")) (AppE (VarE (mkName "getByte")- ) (VarE (mkName "bh"))) (AppE (VarE (mkName "return")) (LitE (IntegerL 0)))- )),(NoBindS (CaseE (VarE (mkName "h")) ((map (\(ctorInd,ctor) -> (Match (- LitP (IntegerL ctorInd)) (NormalB (DoE ((map (\field -> (BindS (VarP (- mkName ("x" ++ show field))) (AppE (VarE (mkName "get")) (VarE (mkName "bh"- ))))) (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))))++[(Match WildP (NormalB (AppE (VarE (- mkName "fail")) (LitE (StringL "invalid binary data found")))) [])]++[])))]- )) [(ValD (VarP (mkName "useTag")) (NormalB (applyWith (VarE (mkName ">"))- [(AppE (VarE (mkName "length")) (ListE ((map (\(ctorInd,ctor) -> ((flip- RecConE []) (mkName ("" ++ ctorName ctor)))) (id (zip [0..] (dataCtors dat)- )))++[]))),(LitE (IntegerL 1))])) [])])])]]
− Data/Derive/Bounded.hs
@@ -1,36 +0,0 @@-{-# 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
@@ -1,42 +0,0 @@-{-# 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
@@ -1,46 +0,0 @@-{-# 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
@@ -1,66 +0,0 @@-{-# 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
@@ -1,48 +0,0 @@-{-# 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/Foldable.hs
@@ -1,31 +0,0 @@-{-- This module is not written/maintained by the usual Data.Derive author.-- MAINTAINER: Twan van Laarhoven - EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"-- Please send all patches to this module to Neil (ndmitchell -at- gmail),- and CC Twan.--}---- NOTE: Cannot be guessed as it relies on type information--module Data.Derive.Foldable(makeFoldable) where--import Language.Haskell.TH.All-import Data.DeriveTraversal---makeFoldable :: Derivation-makeFoldable = derivation derive "Foldable"--derive dat = traversalInstance1 foldrTraversal "Foldable" dat--foldrTraversal = defaultTraversalType- { traversalName = "foldr"- , traversalFunc = \n a -> l1 "flip" (l1 n a)- , traversalPlus = fail "variable used in multiple positions in a data type"- , traverseTuple = foldr (.:) id'- , traverseCtor = const $ foldr (.:) id'- , traverseFunc = \pat rhs -> sclause [vr "f", vr "b", pat] (AppE rhs (vr "b"))- }
− Data/Derive/From.hs
@@ -1,36 +0,0 @@-{-# 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
@@ -1,38 +0,0 @@-{-- This module is not written/maintained by the usual Data.Derive author.-- MAINTAINER: Twan van Laarhoven - EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"-- Please send all patches to this module to Neil (ndmitchell -at- gmail),- and CC Twan.--}---- 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.DeriveTraversal---makeFunctor :: Derivation-makeFunctor = derivation derive "Functor"--derive dat = traversalInstance1 functorTraversal "Functor" dat--functorTraversal = defaultTraversalType- { traversalName = "fmap"- , traverseArrow = functorForArrowType- , traverseFunc = \pat rhs -> sclause [vr "f", pat] rhs- }--functorForArrowType :: Exp -> Exp -> Exp-functorForArrowType a b- | isId a && isId b = id'- | isId a = InfixE Nothing (l0 ".") (Just b)- | isId b = InfixE (Just a) (l0 ".") Nothing- | otherwise = LamE [l0 "arg"] $ a .: l0 "arg" .: b- where isId = (id'==)
− Data/Derive/Has.hs
@@ -1,41 +0,0 @@---- | 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
@@ -1,32 +0,0 @@--{-# 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
@@ -1,42 +0,0 @@---- | 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
@@ -1,32 +0,0 @@---- | 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
@@ -1,33 +0,0 @@-{-# 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
@@ -1,68 +0,0 @@-{-# 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/PlateDirect.hs
@@ -1,57 +0,0 @@--- NOTE: Cannot be guessed as it relies on type information---- | Derive Play, implemented for tuples and lists.-module Data.Derive.PlateDirect(makePlateDirect) where--import Language.Haskell.TH.All---makePlateDirect :: Derivation-makePlateDirect = derivation plateDirect' "PlateDirect"---plateDirect' :: Dec -> [Dec]-plateDirect' (DataD _ typ [] cs _) =- [InstanceD [] (l2 "PlateAll" t t) [funN "plateAll" [sclause [] (l0 "plateSelf")]]- ,InstanceD [] (l1 "PlateOne" t) [funN "plateOne" (map f cs)]- ]- where- t = l0 $ show typ- - f x = sclause [ctp x 'x'] $ foldl1 AppE args- where args = l1 "plate" (l0 $ ctorName x) : zipWith g (ctv x 'x') (ctorTypes x)- - g s (AppT (ConT c) t) | show c == "[]" = g s (AppT ListT t)- g s (AppT ListT (ConT t)) | t == typ = l1 "||*" s- g s (AppT ListT _) = l1 "||+" s- g s (ConT t) | t == typ = l1 "|*" s- g s _ = l1 "|+" s--plateDirect' (NewtypeD a b c d e) = plateDirect' (DataD a b c [d] e)-plateDirect' _ = []--{---- an attempt at something better which doesn't really work--getTypes :: Type -> Q [Type]-getTypes t = do- let (ConT c, cs) = typeApp t- TyConI dat <- reify c- return $ concatMap ctorTypes $ dataCtors dat---reaches :: Type -> Q [Type]-reaches t = f [] [t]- where- f done [] = return done- f done (t:odo)- | t `elem` done = f done odo- | otherwise = do- ts <- getTypes t- f (t:done) (odo ++ ts)---against :: Type -> Type -> Type-against = error "here"---}
− Data/Derive/PlateTypeable.hs
@@ -1,48 +0,0 @@-{-# OPTIONS_GHC -fth -cpp -fglasgow-exts -fallow-undecidable-instances #-}--module Data.Derive.PlateTypeable(makePlateTypeable) where--import Language.Haskell.TH.All---#ifdef GUESS--import Data.Generics.PlateTypeable-import Data.DeriveGuess-import Data.Typeable--example = (,) "PlateTypeable" [d|-- instance (PlateAll a (DataName a), Typeable a) => Uniplate (DataName a) where- uniplate = uniplateAll-- instance (Typeable t, Typeable a, Uniplate t, PlateAll a t) => PlateAll (DataName a) t where- plateAll CtorZero = plate CtorZero- plateAll (CtorOne x1) = plate CtorOne |+ x1- plateAll (CtorTwo x1 x2) = plate CtorTwo |+ x1 |+ x2- plateAll (CtorTwo' x1 x2) = plate CtorTwo' |+ x1 |+ x2-- |]--#endif---makePlateTypeable :: Derivation-makePlateTypeable = derivation plateTypeable' "PlateTypeable"-plateTypeable' dat = [InstanceD (concat ([(map (\tdat -> (AppT (AppT (ConT (- mkName "PlateAll")) tdat) (lK (dataName dat) (dataVars dat)))) (dataVars- dat)),(map (\tdat -> (AppT (ConT (mkName "Typeable")) tdat)) (dataVars dat)- )])) (head [(AppT (ConT (mkName "Uniplate")) (lK (dataName dat) (dataVars- dat)))])[(ValD (VarP (mkName "uniplate")) (NormalB (VarE (mkName- "uniplateAll"))) [])],InstanceD (concat ([[(AppT (ConT (mkName "Typeable"))- (VarT (mkName "t")))],(map (\tdat -> (AppT (ConT (mkName "Typeable")) tdat)- ) (dataVars dat)),[(AppT (ConT (mkName "Uniplate")) (VarT (mkName "t")))],(- map (\tdat -> (AppT (AppT (ConT (mkName "PlateAll")) tdat) (VarT (mkName- "t")))) (dataVars dat))])) (head [(AppT (AppT (ConT (mkName "PlateAll")) (- lK (dataName dat) (dataVars dat))) (VarT (mkName "t")))])[(FunD (mkName- "plateAll") ((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 "plate")) (ConE (mkName ("" ++ ctorName ctor))))]- ++[]))) [])) (id (zip [0..] (dataCtors dat))))++[]))]]
− Data/Derive/Read.hs
@@ -1,49 +0,0 @@---- | 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 "r"] body]]]- where- body = (++::) [ readit ctr | ctr <- dataCtors dat ]--readit ctr = case ctorFields ctr of [] -> norm- fl -> flds fl- where- norm = lK "readParen"- [vr "p0" >: lit (10::Integer),- "r0" ->: runComp (pName . foldr (.) id (map (pRead 11) (ctv ctr 'x'))) (ctp ctr 'x'),- l0 "r"]-- flds f = lK "readParen" - [false,- "r0" ->: runComp (pName . pLex "{" .- foldr (.) id (intersperse (pLex ",")- (zipWith pField (ctv ctr 'x') f)) .- pLex "}") (ctp ctr 'x'),- l0 "r"]-- 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/Ref.hs
@@ -1,25 +0,0 @@---- | A pseudo derivation. For each field in the data type, deriving--- @Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =--- \ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@.------ This is intended for use with the compositional functional references--- described in--- <http://www.haskell.org/pipermail/haskell-cafe/2007-June/026477.html>.-module Data.Derive.Ref(makeRef) where--import Language.Haskell.TH.All-import Data.Char-import Data.List--makeRef :: Derivation-makeRef = derivation ref' "Ref"--ref' dat = map f fields- where- ctors = dataCtors dat- fields = nub $ concatMap ctorFields ctors- - f field = funN ("ref" ++ toUpper (head field) : tail field) $- [sclause [] $ l2 "Ref" (vr field)- (LamE [vr "f",vr "v"] (RecUpdE (vr "v") [(mkName field, l1 "f" (l1 field (vr "v")))]))]
− Data/Derive/Serial.hs
@@ -1,57 +0,0 @@-{-# 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
@@ -1,34 +0,0 @@---- | 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
@@ -1,35 +0,0 @@---- | 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 (ctv ctr 'x') fs))) ++ [scl ' ']-- field (v,f) = [ ssl (f ++ " = ") , l2 "showsPrec" (lit (0::Integer)) v ]-- ssl = l1 "showString" . lit ; scl = l1 "showChar" . lit-- pname = show (ppr (mkName (ctorName ctr)))
− Data/Derive/TTypeable.hs
@@ -1,26 +0,0 @@--- 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/Traversable.hs
@@ -1,34 +0,0 @@-{-- This module is not written/maintained by the usual Data.Derive author.-- MAINTAINER: Twan van Laarhoven - EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"-- Please send all patches to this module to Neil (ndmitchell -at- gmail),- and CC Twan.--}---- NOTE: Cannot be guessed as it relies on type information--module Data.Derive.Traversable(makeTraversable) where--import Language.Haskell.TH.All-import Data.DeriveTraversal---makeTraversable :: Derivation-makeTraversable = derivation derive "Traversable"--derive dat = traversalInstance1 traverseTraversal "Traversable" dat--traverseTraversal = defaultTraversalType- { traversalName = "traverse"- , traversalId = l0 "pure"- , traversalPlus = fail "variable used in multiple positions in a data type"- , traverseTuple = \args -> liftAN (VarE $ tupleDataName $ length args) args- , traverseCtor = \ctor -> liftAN (l0 ctor)- , traverseFunc = \pat rhs -> sclause [vr "f", pat] rhs- }--liftAN :: Exp -> [Exp] -> Exp-liftAN base args = foldl (l2 "<*>") (l1 "pure" base) args
− Data/Derive/Typeable.hs
@@ -1,63 +0,0 @@--- 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/Derive/Uniplate.hs
@@ -1,232 +0,0 @@--- NOTE: Cannot be guessed as it relies on type information---- | Derive Play, implemented for tuples and lists.-module Data.Derive.Uniplate(makeUniplate) 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----makeUniplate :: Derivation-makeUniplate = derivation uniplate' "Uniplate"---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 $ "Uniplate 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----uniplate' dat =- [instance_default "Uniplate" dat [funN "uniplate" 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---{---- ATTEMPT BASED ON THE RULES IN THE PAPER--- GOT BORED TOO QUICKLY...---data Env = Env {prefix :: String, unit_ :: Exp, target_ :: Type -> Maybe Exp, join_ :: [Exp] -> Exp}---- RULES FROM THE PAPER-d_ :: Env -> Dec -> Dec-d_ e (NewtypeD x1 x2 x3 x4 x5) = d_ e (DataD x1 x2 x3 [x4] x5)-d_ e (DataD _ name targs cs _) =- FunD (mkName $ prefix e ++ show name) (map (c_ e (map VarP targs)) cs)--c_ :: Env -> [Pat] -> Con -> Clause-c_ e ps (NormalC name fields) = Clause (ps ++ [ConP name $ map (VarP . mkName) vs])- (NormalB $ join_ e (AppE (unit_ e) (ConE name) : fs))- []- where- vs = map (('v':) . show) [1..length fields]- fs = zipWith AppE (map (t_ e . snd) fields) (map (VarE . mkName) vs)--t_ :: Env -> Type -> Exp-t_ e (VarT x) = VarE x---test = do- i <- runQ dec- putStrLn $ pprint $ uniplate' $ head i--env = Env "prefix_" (VarE $ mkName "unit") (const Nothing) ListE--dec = [d| data Foo a = FooM a | FooN |]---uniplate' dat = [instance_default "Uniplate" dat- [FunD (mkName "replaceChildren") bod]]- where- bod = [Clause [vr "x"] (NormalB $ tup [l0 "getChildren", l0 "setChildren"]) [getC,setC]]- - getC = funN "getChildren" [sclause [] (vr "x")]- setC = funN "setChildren" [sclause [] (vr "x")]--}
− Data/DeriveGuess.hs
@@ -1,413 +0,0 @@-{-# 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 fAny $ map normData x- where- fAny :: (Typeable a, Data a) => a -> a- fAny = mkT fE `extT` fP- fE (VarE x) = VarE (f x); fE x = x- fP (VarP x) = VarP (f x); fP x = x-- -- | Remove_0 evil_1 ghc_2 name_3 uniquifiers_4- f :: Name -> Name- f name = if not ("_" `isSuffixOf` s) && 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]- getDomain _ = []- 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
@@ -1,43 +0,0 @@--- | 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 _) nm = f =<< deriveOne nm---- | 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!"
− Data/DeriveTraversal.hs
@@ -1,187 +0,0 @@-{-- This module is not written/maintained by the usual Data.Derive author.-- MAINTAINER: Twan van Laarhoven - EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"-- Please send all patches to this module to Neil (ndmitchell -at- gmail),- and CC Twan.--}---- NOTE: Cannot be guessed as it relies on type information---- | Derives 'Functor' and similair classes, as discussed on the Haskell-prime mailing list:--- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>. -module Data.DeriveTraversal(- TraveralType(..), defaultTraversalType,- traversalInstance, traversalInstance1,- deriveTraversal- ) where--import Language.Haskell.TH.All-import Data.List-import qualified Data.Set as S-import Control.Monad.Writer-import Control.Applicative-------------------------------------------------------------------------------------- Stuff that should be in a library --instance Monoid w => Applicative (Writer w) where- pure = return- (<*>) = ap----------------------------------------------------------------------------------- --- Information datatype, public interface - --- | An expression representing a traversal of a subpart of the data -type Trav = Exp - --- | What kind of traversal are we deriving? -data TraveralType = TraveralType - { traversalArg :: Int -- ^ On what position are we traversing? - , traversalCo :: Bool -- ^ covariant? - , traversalName :: String -- ^ name of the traversal function - , traversalId :: Trav -- ^ Identity traversal - , traversalDirect :: Trav -- ^ Traversal of 'a' - , traversalFunc :: String -> Trav -> Trav -- ^ Apply the sub-traversal function - , traversalPlus :: Trav -> Trav -> Trav -- ^ Apply two non-identity traversals in sequence - , traverseArrow :: Trav -> Trav -> Trav -- ^ Traverse a function type - , traverseTuple :: [Exp] -> Exp -- ^ Construct a tuple from applied traversals - , traverseCtor :: String -> [Exp] -> Exp -- ^ Construct a data type from applied traversals - , traverseFunc :: Pat -> Exp -> Clause -- ^ Construct a clause of the traversal function - } --defaultTraversalType = TraveralType- { traversalArg = 1- , traversalCo = False- , traversalName = undefined -- prevent warnings- , traversalId = id'- , traversalDirect = l0 "f"- , traversalFunc = l1- , traversalPlus = (.:)- , traverseArrow = fail "Cannot derive traversal over function types"- , traverseTuple = TupE- , traverseCtor = lK- , traverseFunc = undefined- }--data RequiredInstance = RequiredInstance- { requiredDataArg :: Name -- ^ What argument of the current data type?- , requiredPosition :: Int -- ^ What argument position of that type?- }- deriving (Eq, Ord)---- | Monad that collects required instances-type WithInstances a = Writer (S.Set RequiredInstance) a--------------------------------------------------------------------------------------- Deriving traversals ----- | Instance for a Traversable like class with just 1 method-traversalInstance1 :: TraveralType -> String -> DataDef -> [Dec]-traversalInstance1 tt nm dat = traversalInstance tt nm dat [deriveTraversal tt dat]---- | Instance for a Traversable like class-traversalInstance :: TraveralType -> String -> DataDef -> [WithInstances Dec] -> [Dec]-traversalInstance tt nameBase dat bodyM- | dataArity dat == 0 = []- | otherwise = [InstanceD ctx head body]- where- (body, required) = runWriter (sequence bodyM)- ctx = [ lK (className p) (VarT n : vars 's' (p - 1))- | RequiredInstance n p <- S.toList required- ]- vrs = vars 't' (dataArity dat)- (vrsBefore,(_:vrsAfter)) = splitAt (length vrs - traversalArg tt) vrs- className n = nameBase ++ (if n > 1 then show n else "")- head = lK (className (traversalArg tt)) (lK (dataName dat) vrsBefore : vrsAfter)----- | Derive a 'traverse' like function-deriveTraversal :: TraveralType -> DataDef -> WithInstances Dec-deriveTraversal tt dat = fun- where- fun = funN (traversalNameN tt (traversalArg tt)) <$> body- args = argPositions dat- body = mapM (deriveTraversalCtor tt args) (dataCtors dat)----- | Derive a clause of a 'traverse' like function for a constructor-deriveTraversalCtor :: TraveralType -> ArgPositions -> CtorDef -> WithInstances Clause-deriveTraversalCtor tt ap ctor = do- tTypes <- mapM (deriveTraversalType tt ap) (ctorTypes ctor)- return $ traverseFunc tt (ctp ctor 'a')- $ traverseCtor tt (ctorName ctor) (zipWith AppE tTypes (ctv ctor 'a'))----- | Derive a traversal for a type-deriveTraversalType :: TraveralType -> ArgPositions -> Type -> WithInstances Trav-deriveTraversalType tt ap (ForallT _ _ _) = fail "forall not supported in traversal deriving"-deriveTraversalType tt ap (AppT (AppT ArrowT a) b)- = traverseArrow tt <$> deriveTraversalType tt{traversalCo = not $ traversalCo tt} ap a- <*> deriveTraversalType tt ap b-deriveTraversalType tt ap (AppT a b) = deriveTraversalApp tt ap a [b] -- T a b c ...-deriveTraversalType tt ap ListT = return $ traversalId tt -- []-deriveTraversalType tt ap (ConT n) = return $ traversalId tt -- T-deriveTraversalType tt ap (VarT n) -- a- | ap n /= traversalArg tt = return $ traversalId tt- | traversalCo tt = fail "tyvar used in covariant position"- | otherwise = return $ traversalDirect tt----- | Find all arguments to a type application, then derive a traversal-deriveTraversalApp :: TraveralType -> ArgPositions -> Type -> [Type] -> WithInstances Trav-deriveTraversalApp tt ap (AppT a b) args = deriveTraversalApp tt ap a (b : args)-deriveTraversalApp tt ap tycon args- | isTupleT tycon = do -- (a,b,c)- tArgs <- mapM (deriveTraversalType tt ap) args- return $- if (all (== traversalId tt) tArgs) then- traversalId tt- else- LamE [TupP (vars 't' (length args))]- (traverseTuple tt $ zipWith AppE tArgs (vars 't' (length args)))- | otherwise = do -- T a b c- tCon <- deriveTraversalType tt ap tycon- tArgs <- mapM (deriveTraversalType tt ap) args- -- need instances?- case tycon of- VarT n | ap n == traversalArg tt -> fail "kind error: type used type constructor"- | otherwise -> tell $ S.fromList- [ RequiredInstance n i- | (t,i) <- zip (reverse tArgs) [1..]- , t /= traversalId tt- ]- _ -> return ()- -- combine non-id traversals- let nonId = [ traverseArg tt i t- | (t,i) <- zip (reverse tArgs) [1..]- , t /= traversalId tt- ]- return $ case nonId of- [] -> traversalId tt -- no interesting arguments to type con- _ -> foldl1 (traversalPlus tt) nonId----- | Lift a traversal to the argument of a type constructor-traverseArg :: TraveralType -> Int -> Trav -> Trav-traverseArg tt n e = traversalFunc tt (traversalNameN tt n) e--traversalNameN :: TraveralType -> Int -> String-traversalNameN tt n = traversalName tt ++ (if n > 1 then show n else "")----- | Information on argument positions-type ArgPositions = Name -> Int---- | Position of an argument in the data type--- In the type "data X a b c"--- positions are: a -> 3, b -> 2, c -> 1-argPositions :: DataDef -> Name -> Int-argPositions dat = \nm -> case elemIndex nm args of- Nothing -> error "impossible: tyvar not in scope"- Just k -> length args - k- where args = ex_args dat
− Derive.hs
@@ -1,280 +0,0 @@-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 splt "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- splt = 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 :: IO ()-main = do- (flags,files) <- getOpts- fles <- mapM pickFile files- mapM_ (mainFile flags) (catMaybes fles)- when (any isNothing fles) 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 :: String-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 ys | appendMsg `isPrefixOf` ys =- if hashString rest == chk- then f i []- else (ys ++ "\n\n\n\n", True)- where (chk, rest) = span isDigit $ drop (length appendMsg) ys-- f i [] = (replicate (4 - i) '\n', False)- f i ('\n':ys) = add '\n' (f (i+1) ys)- f _ (y:ys) = add y (f 0 ys)-- add c ~(cs,b) = (c:cs,b)---mainFile :: [Flag] -> FilePath -> IO ()-mainFile flags file = do- (fileflags,pragmas,modname,datas,reqs) <- parseFile flags file- let devs = ["'\\n': $( _derive_string_instance make" ++ cls ++ " ''" ++ ctor ++ " )"- | (ctor,cls) <- reqs]-- let hscode x = "{-# OPTIONS_GHC -fth -fglasgow-exts -w #-}\n" ++- unlines pragmas ++- "module " ++ modname ++ " where\n" ++- "import Data.DeriveTH\n" ++- "import Data.Derive.All\n" ++- datas ++ "\n" ++- "main = writeFile " ++ show x ++ " $\n" ++- " unlines [" ++ concat (intersperse ", " devs) ++ "]\n"-- -- note: Wrong on Hugs on Windows- tmpdir <- getTemporaryDirectory- b <- doesDirectoryExist tmpdir- tmpdr <- return $ if b && KeepTemp `notElem` flags then tmpdir else ""-- (hsfile, hshndl) <- openTempFileLocal tmpdr "Temp.hs"- (txfile, txhndl) <- openTempFileLocal tmpdr "Temp.txt"- hClose txhndl-- hPutStr hshndl $ hscode txfile- hClose hshndl-- system $ "ghc -e " ++ modname ++ ".main " ++ hsfile-- txhandl <- openFile txfile ReadMode- res <- hGetContents txhandl- length res `seq` return ()- hClose txhandl-- when (KeepTemp `notElem` flags) $ do- removeFile hsfile- removeFile txfile-- flgs <- return $ fileflags ++ flags- if Append `elem` flgs then do- src <- readFile file- let (src2,c) = dropAppend src- when c $ putStrLn "Warning, Checksum does not match, please edit the file manually"- writeFile file $ src2 ++ (if null res then "" else appendMsg ++ hashString res ++ "\n" ++ res)- else do- let modline = concat $ take 1 ["module " ++ x ++ " where\n" | Module x <- flgs]- impline = unlines ["import " ++ if null i then modname else i | Import i <- flgs]- answer = modline ++ impline ++ res-- case [x | Output x <- flgs] 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,String)])-parseFile flags file = do- src <- liftM lines $ readFile file- optns <- if NoOpts `elem` flags then return [] else parseOptions src- pragmas <- return $ parsePragmas src- modname <- parseModname src- let deriv = concat [x | Derive x <- flags ++ optns]- (decl,req) <- return $ unzip $ concatMap (checkData deriv) $ joinLines $- map dropComments $ filter (not . isBlank) src- return (optns, pragmas, modname, unlines decl, concat req)- where- parsePragmas (x:xs)- | "{-#" `isPrefixOf` x2 && "#-}" `isSuffixOf` x2 = x2 : parsePragmas xs- | null x2 = parsePragmas xs- where x2 = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace x- parsePragmas _ = []-- 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:_) | "module " `isPrefixOf` x = return $ takeWhile f $ dropWhile isSpace $ drop 6 x- where f y = not (isSpace y) && y `notElem` "("- parseModname (_:ys) = parseModname ys- parseModname [] = putStrLn "Error, module name not detected" >> return "Main"--- isBlank x = null x2 || "--" `isPrefixOf` x2- where x2 = dropWhile isSpace x-- dropComments ('-':'-':_) = []- 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 _ ('{':'-':'!':xs) = ' ' : f True xs- f _ ('!':'-':'}':xs) = ' ' : f False xs- f b (y:ys) = [if y == ',' then ' ' else y | b] ++ f b ys- f _ [] = []--- -- 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
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2006-2007.+Copyright Neil Mitchell 2006-2017. All rights reserved. Redistribution and use in source and binary forms, with or without
− Language/Haskell/TH/All.hs
@@ -1,36 +0,0 @@-{-# OPTIONS_GHC -w #-}--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--import Control.Monad------ | The type of ways to derive classes.--- Should not really be in this module!-data Derivation = Derivation {- derivationDeriver :: DataDef -> Q [Dec], -- ^ The derivation function proper- derivationName :: String -- ^ The name of the derivation- }----- create a new derivation more abstractly-derivation :: (DataDef -> [Dec]) -> String -> Derivation-derivation f = Derivation (return . f)---derivationQ :: (DataDef -> Q [Dec]) -> String -> Derivation-derivationQ = Derivation
− Language/Haskell/TH/Data.hs
@@ -1,113 +0,0 @@--- | 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---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
@@ -1,358 +0,0 @@--- 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
@@ -1,228 +0,0 @@--- | 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 "[]" [] = ConE (mkName "[]")- lK "[]" xs = lst xs- lK nm@(x:_) args | isUpper x || x == ':' = foldl AppE (ConE (mkName nm)) args- lK nm@(x:_) [a,b] | isOper x = InfixE (Just a) (VarE (mkName nm)) (Just b)- 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
@@ -1,204 +0,0 @@-{-# 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 (InfixE (Just (AppE pure x)) ap y)- | ap ~= "<*>" && pure ~= "pure" = peep $ InfixE (Just x) (l0 "<$>") y--peep (InfixE (Just x) fmap (Just (AppE pure y)))- | fmap ~= "<$>" && pure ~= "pure" = peep $ AppE pure (peep $ AppE x y)--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 (AppE (AppE comp f) g) x)- | comp ~= "." = peep $ AppE f (peep $ AppE g x)-peep (AppE (InfixE (Just f) comp (Just g)) x)- | comp ~= "." = peep $ AppE f (peep $ AppE g x)--peep (AppE (AppE (AppE flip f) x) y)- | flip ~= "flip" = peep $ AppE (AppE f y) x--peep (AppE (InfixE (Just x) op Nothing) y) = peep $ InfixE (Just x) op (Just y)-peep (AppE (InfixE Nothing op (Just y)) x) = peep $ InfixE (Just x) op (Just y)--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 (AppE len (ListE xs))- | len ~= "length" = LitE $ IntegerL $ toInteger $ length xs--peep (TupE [x]) = x--peep (AppE (LamE [pat] x) e) = CaseE e [Match pat (NormalB x) []]--peep (AppE (CaseE e [Match p (NormalB x) []]) y)- = CaseE e [Match p (NormalB $ peep $ AppE x y) []]---- 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
@@ -1,366 +0,0 @@-{-# OPTIONS_GHC -cpp -fno-warn-missing-methods -fno-warn-deprecations -fno-warn-unused-imports #-}--module Language.Haskell.TH.SYB where--import Data.Generics hiding (Fixity)-import Language.Haskell.TH.Syntax-import Data.PackedString--#ifndef NO_SYB -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-#endif
+ Main.hs view
@@ -0,0 +1,9 @@++module Main(main) where++import Data.Derive.All+import Data.DeriveMain+++main :: IO ()+main = deriveMain derivations
+ README.md view
@@ -0,0 +1,168 @@+# Derive [](https://hackage.haskell.org/package/derive) [](https://travis-ci.org/ndmitchell/derive)++**Warning: This package has no official maintainer anymore. Use at your own risk. You may wish to consider the built-in mechanism [`GHC.Generics`](https://hackage.haskell.org/package/base-4.11.1.0/docs/GHC-Generics.html) or libraries such as [`generic-deriving`](https://hackage.haskell.org/package/generic-deriving).**++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/computer/haskell/DrIFT/">DrIFT</a>.++This document proceeds as follows:++* Obtaining and Installing Data.Derive+* Supported Derivations+* Using the Derive Program+* Using Template Haskell Derivations+* Writing a New Derivation++### Acknowledgements++Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson, Joel Raymont, Benedikt Huber, Stefan O'Rear, Robin Green, Bertram Felgenhauer.+++## Obtaining and Installing Data.Derive++Installation follows the standard pattern of any Haskell library or program, type <tt>cabal update</tt> to update your local hackage database, then <tt>cabal install derive</tt> to install Derive.+++## Supported Derivations++Data.Derive is not limited to any prebuild set of derivations, see later for howto add your own. Out of the box, we provide instances for the following libraries.++<!--+-- GENERATED START+-->++* **[Arbitrary](http://hackage.haskell.org/packages/archive/QuickCheck/latest/doc/html/Test-QuickCheck.html#t%3AArbitrary)** - from the library [QuickCheck](http://hackage.haskell.org/package/QuickCheck)+* **[ArbitraryOld](http://hackage.haskell.org/packages/archive/QuickCheck/1.2.0.0/doc/html/Test-QuickCheck.html#t%3AArbitraryOld)** - from the library [QuickCheck-1.2.0.0](http://hackage.haskell.org/package/QuickCheck-1.2.0.0)+* **[Arities](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Arities.html#t%3AArities)** - from the library [derive](http://hackage.haskell.org/package/derive)+* **[Binary](http://hackage.haskell.org/packages/archive/binary/latest/doc/html/Data-Binary.html#t%3ABinary)** - from the library [binary](http://hackage.haskell.org/package/binary)+* **[BinaryDefer](http://hackage.haskell.org/packages/archive/binarydefer/latest/doc/html/Data-Binary-Defer.html#t%3ABinaryDefer)** - from the library [binarydefer](http://hackage.haskell.org/package/binarydefer)+* **[Bounded](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ABounded)** - from the library [base](http://hackage.haskell.org/package/base)+* **[DataAbstract](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3ADataAbstract)** - from the library [base](http://hackage.haskell.org/package/base)+* **[Default](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Default.html#t%3ADefault)** - from the library [derive](http://hackage.haskell.org/package/derive)+* **[EnumCyclic](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum)** - from the library [base](http://hackage.haskell.org/package/base)+* **[Fold](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Fold.html)**+* **[From](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-From.html)**+* **[Has](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Has.html)**+* **[Is](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Is.html)**+* **[JSON](http://hackage.haskell.org/packages/archive/json/latest/doc/html/Text-JSON.html#t%3AJSON)** - from the library [json](http://hackage.haskell.org/package/json)+* **[LazySet](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-LazySet.html)**+* **[Lens](http://hackage.haskell.org/packages/archive/data/lens/doc/html/Data-Lens-Common.html#t%3ALens)** - from the library [data-lens](http://hackage.haskell.org/package/data-lens)+* **[Monoid](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t%3AMonoid)** - from the library [base](http://hackage.haskell.org/package/base)+* **[NFData](http://hackage.haskell.org/packages/archive/deepseq/latest/doc/html/Control-DeepSeq.html#t%3ANFData)** - from the library [deepseq](http://hackage.haskell.org/package/deepseq)+* **[Ref](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Ref.html)**+* **[Serial](http://hackage.haskell.org/packages/archive/smallcheck/latest/doc/html/Test-SmallCheck.html#t%3ASerial)** - from the library [smallcheck](http://hackage.haskell.org/package/smallcheck)+* **[Serialize](http://hackage.haskell.org/packages/archive/cereal/latest/doc/html/Data-Serialize.html#t%3ASerialize)** - from the library [cereal](http://hackage.haskell.org/package/cereal)+* **[Set](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Set.html)**+* **[UniplateDirect](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Direct.html#t%3AUniplateDirect)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate)+* **[UniplateTypeable](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Typeable.html#t%3AUniplateTypeable)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate)+* **[Update](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Update.html)**++<!--+-- GENERATED STOP+-->++## Using the Derive program++Let's imagine we've defined a data type:++ data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Eq, Show)++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.++ data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Show {-! Eq, Binary !-})++Or alternatively write:++ {-!+ deriving instance Eq Color+ deriving instance Binary Color+ !-}++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.++### Appending to the module++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.++### As a GHC preprocessor++To use Derive as a GHC preprocessor, add the following line at the top of the source file:++ {-# OPTIONS_GHC -F -pgmFderive -optF-F #-}++This instructs GHC to apply a preprocessor (<tt>-F</tt>), and to use the preprocessor <tt>derive -F</tt>.++### Using CPP++One way is to use CPP. Ensure your compiler is set up for compiling with the C Pre Processor. For example:++ {-# LANGUAGE CPP #-}+ {-# OPTIONS_DERIVE --output=file.h #-}++ module ModuleName where+ + #include "file.h"++### Side-by-side Modules++If you had Colour.Type, and wished to place the Binary instance in Colour.Binary, this can be done with:++ {-# OPTIONS_DERIVE --output=Binary.hs --module=Colour.Binary --import #-}++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.++## Using Template Haskell Derivations</h2>++One of Derive's advantages over DrIFT is support for <a href="http://www.haskell.org/th/">Template Haskell</a> (abbreviated TH). Derive can be invoked automatically during the compilation process, and 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.++To use the TH deriving system, with the same example as before:++ {-# LANGUAGE TemplateHaskell #-}+ import Data.DeriveTH+ import Data.Binary+ + data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Show)+ + $( derive makeEq ''Color )+ $( derive makeBinary ''Color )++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.DeriveTH</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>.)++## Writing a New Derivation++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:++* 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.+* 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.+* 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.+* Not record based - the derivation must not change on record fields. <tt>Show</tt> outputs the fields, so this is not allowed.++If however your instance does meet these properties, you can use derivation by guess. Many instances do meet these conditions, for examples see: <tt>Eq</tt>, <tt>Ord</tt>, <tt>Data</tt>, <tt>Serial</tt> etc. If however you need to code the derivation manually see examples such as <tt>Update</tt> and <tt>Functor</tt>.++### Modifying Derive++The standard sequence for testing Derive is:++ $ ghci Main.hs+ :main --generate+ :reload+ :main --test++The `--generate` option will automatically generate DSL's for derivations derived by example. The `--test` option runs all test comparisons and then loads the file with Template Haskell.++### Coding a new derivation++My best suggestion, start with a similar instance, i.e. to make `Eq2` from `Eq` do:++* Copy `Data/Derive/Eq.hs` to `Data/Derive/Eq2.hs`+* Rename some of the bits in `Eq2.hs` from `Eq`+* `ghci` -- load derive+* `:main` --generate -- this adds Eq2.hs to the .cabal/All.hs files etc+* `:reload` -- reload with Eq2.hs++Now fix up `Eq2.hs` appropriately.
Setup.hs view
@@ -1,43 +1,2 @@ import Distribution.Simple-import Distribution.PackageDescription-import Distribution.Simple.LocalBuildInfo--import System.Directory-import System.Cmd-import System.Exit-import Control.Monad---main = defaultMainWithHooks defaultUserHooks{runTests=test}---test :: CabalBreaksTheAPI_Grr grr => Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO grr-test args bool pd lbi = do- putStrLn "Make sure you have installed the derive you wish to test!"- cur <- getCurrentDirectory- setCurrentDirectory "tests"- - b <- doesFileExist "Small.out.hs"- when b $ removeFile "Small.out.hs"- i <- system $ "derive -mSmallInstancess -iSmall -iData.Generics -iData.Monoid " ++- "-o Small.out.hs Small.hs"-- b <- doesFileExist "Small.out.hs"- if b then system "diff -u Small.expected.hs Small.out.hs" >> return ()- else putStrLn "Error: Failed to generate the output file"- - -- currently we turn off warnings when compiling- -- it would be nice if we made the generated code compile without warnings- system "ghc --make -c -w Small.out.hs"- setCurrentDirectory cur- return grr---class CabalBreaksTheAPI_Grr a where- grr :: a--instance CabalBreaksTheAPI_Grr () where- grr = ()--instance CabalBreaksTheAPI_Grr ExitCode where- grr = ExitSuccess+main = defaultMain
derive.cabal view
@@ -1,76 +1,104 @@-Cabal-Version: >= 1.2-Name: derive-Version: 0.1.1-Copyright: 2006-7, Neil Mitchell-Maintainer: ndmitchell@gmail.com-Homepage: http://www-users.cs.york.ac.uk/~ndm/derive/-License: BSD3-License-File: LICENSE-Author: Neil Mitchell & Stefan O'Rear-Synopsis: A program and library to derive instances for data types-Category: Development-Description:+cabal-version: 1.18+build-type: Simple+name: derive+version: 2.6.5+copyright: Neil Mitchell 2006-2017+author: Neil Mitchell <ndmitchell@gmail.com> and others+maintainer: None+homepage: https://github.com/ndmitchell/derive#readme+bug-reports: https://github.com/ndmitchell/derive/issues+license: BSD3+license-file: LICENSE+synopsis: A program and library to derive instances for data types+category: Development+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.+extra-doc-files:+ README.md+ CHANGES.txt+tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 -Extra-Source-Files:- derive.htm+source-repository head+ type: git+ location: https://github.com/ndmitchell/derive.git -Flag small_base- Description: Choose the new smaller, split-up base package.+executable derive+ default-language: Haskell2010+ build-depends: base==4.* , derive+ main-is: Main.hs -Library- Extensions: CPP- Build-Depends: template-haskell, filepath, mtl- if flag(small_base)- Build-Depends: base >= 3, containers, pretty, packedstring, random, process, directory- CPP-Options: "-DNO_SYB"- else- Build-Depends: base < 3+library+ default-language: Haskell2010+ hs-source-dirs: src+ build-depends:+ base == 4.*,+ filepath, syb, template-haskell, containers, pretty,+ directory, process, bytestring,+ haskell-src-exts == 1.20.*,+ transformers >= 0.2,+ uniplate >= 1.5 && < 1.7 - Exposed-Modules:- Data.DeriveGuess+ exposed-modules:+ Data.DeriveMain Data.DeriveTH- Data.DeriveTraversal+ Data.DeriveDSL Data.Derive.All+ Data.Derive.DSL.Apply+ Data.Derive.DSL.Derive+ Data.Derive.DSL.DSL+ Data.Derive.DSL.HSE+ Data.Derive.DSL.SYB+ Data.Derive.Instance.Arities+ Data.Derive.Class.Arities+ Data.Derive.Class.Default+ Language.Haskell+ Language.Haskell.Convert+ Language.Haskell.TH.All+ Language.Haskell.TH.Compat+ Language.Haskell.TH.Data+ Language.Haskell.TH.ExpandSynonym+ Language.Haskell.TH.Helper+ Language.Haskell.TH.Peephole+-- GENERATED START Data.Derive.Arbitrary- Data.Derive.Arbitrary2+ Data.Derive.ArbitraryOld+ Data.Derive.Arities Data.Derive.Binary Data.Derive.BinaryDefer- Data.Derive.BinaryOld Data.Derive.Bounded- Data.Derive.Data- Data.Derive.Enum+ Data.Derive.DataAbstract+ Data.Derive.Default Data.Derive.EnumCyclic- Data.Derive.Eq+ Data.Derive.Fold Data.Derive.From- Data.Derive.Foldable- Data.Derive.Functor Data.Derive.Has Data.Derive.Is+ Data.Derive.JSON Data.Derive.LazySet+ Data.Derive.Lens Data.Derive.Monoid Data.Derive.NFData- Data.Derive.Ord- Data.Derive.PlateDirect- Data.Derive.PlateTypeable- Data.Derive.Read Data.Derive.Ref Data.Derive.Serial+ Data.Derive.Serialize Data.Derive.Set- Data.Derive.Show- Data.Derive.Traversable- Data.Derive.TTypeable- Data.Derive.Typeable- Data.Derive.Uniplate- Language.Haskell.TH.All- Language.Haskell.TH.Data- Language.Haskell.TH.FixedPpr- Language.Haskell.TH.Helper- Language.Haskell.TH.Peephole- Language.Haskell.TH.SYB+ Data.Derive.UniplateDirect+ Data.Derive.UniplateTypeable+ Data.Derive.Update+-- GENERATED STOP -Executable derive- Main-Is: Derive.hs+ -- Mainly internal but some still people use them+ -- to implement derivations outside+ Data.Derive.Internal.Derivation+ other-modules:+ Data.Derive.Internal.Instance+ Data.Derive.Internal.Traversal+ Derive.Main+ Derive.Derivation+ Derive.Flags+ Derive.Generate+ Derive.Test+ Derive.Utils
− derive.htm
@@ -1,353 +0,0 @@-<!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, Samuel Bronson.- Thanks also to Joel Raymont for being the first user of Data.Derive, and generally helping us feel like we weren't wasting our time.-</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.DeriveTH-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.DeriveTH</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>
+ src/Data/Derive/All.hs view
@@ -0,0 +1,35 @@+-- | This module provides convenience re-exports of all the standard+-- Data.Derive derivations.+module Data.Derive.All (Derivation, derivations, module D) where++import Data.Derive.Internal.Derivation++-- GENERATED START+import Data.Derive.Arbitrary as D+import Data.Derive.ArbitraryOld as D+import Data.Derive.Arities as D+import Data.Derive.Binary as D+import Data.Derive.BinaryDefer as D+import Data.Derive.Bounded as D+import Data.Derive.DataAbstract as D+import Data.Derive.Default as D+import Data.Derive.EnumCyclic as D+import Data.Derive.Fold as D+import Data.Derive.From as D+import Data.Derive.Has as D+import Data.Derive.Is as D+import Data.Derive.JSON as D+import Data.Derive.LazySet as D+import Data.Derive.Lens as D+import Data.Derive.Monoid as D+import Data.Derive.NFData as D+import Data.Derive.Ref as D+import Data.Derive.Serial as D+import Data.Derive.Serialize as D+import Data.Derive.Set as D+import Data.Derive.UniplateDirect as D+import Data.Derive.UniplateTypeable as D+import Data.Derive.Update as D+derivations :: [Derivation]+derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeDataAbstract,makeDefault,makeEnumCyclic,makeFold,makeFrom,makeHas,makeIs,makeJSON,makeLazySet,makeLens,makeMonoid,makeNFData,makeRef,makeSerial,makeSerialize,makeSet,makeUniplateDirect,makeUniplateTypeable,makeUpdate]+-- GENERATED STOP
+ src/Data/Derive/Arbitrary.hs view
@@ -0,0 +1,106 @@+module Data.Derive.Arbitrary(makeArbitrary) where+{-+import "QuickCheck" Test.QuickCheck++example :: Custom++instance Arbitrary (Sample a) where+ arbitrary = do+ x <- choose (0::Int,length [First{},Second{},Third{}] - 1)+ case x of+ 0 -> do return (First)+ 1 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (Second x1 x2)+ 2 -> do x1 <- arbitrary+ return (Third x1)+ _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++test :: State+instance (CoArbitrary s, Arbitrary s, Arbitrary a) => Arbitrary (State s a) where+ arbitrary = do x1 <- arbitrary+ return (StateT x1)+-}++import Data.Derive.DSL.HSE+import Data.List+import Data.Generics.Uniplate.DataOnly++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeArbitrary :: Derivation+makeArbitrary = derivationCustomDSL "Arbitrary" custom $+ List [Instance [] "Arbitrary" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "arbitrary"])]),App "UnGuardedRhs" (List+ [App "()" (List []),App "Do" (List [App "()" (List []),List [App+ "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "x"])]),App+ "App" (List [App "()" (List []),App "Var" (List [App "()" (List []+ ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "choose"])])]),App "Tuple" (List [App "()" (+ List []),App "Boxed" (List []),List [App "ExpTypeSig" (List [App+ "()" (List []),App "Lit" (List [App "()" (List []),App "Int" (List+ [App "()" (List []),Int 0,ShowInt (Int 0)])]),App "TyCon" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "Int"])])])]),App+ "InfixApp" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "length"])])]),App "List" (List [App "()" (List []),MapCtor (App+ "RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])]),List+ []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Symbol" (List [App "()" (List []),+ String "-"])])]),App "Lit" (List [App "()" (List []),App "Int" (+ List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]])])]),App+ "Qualifier" (List [App "()" (List []),App "Case" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "x"])])]),Concat (List [MapCtor (App "Alt" (List [App "()" (List [+ ]),App "PLit" (List [App "()" (List []),App "Signless" (List [App+ "()" (List [])]),App "Int" (List [App "()" (List []),CtorIndex,+ ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()" (List [])+ ,App "Do" (List [App "()" (List []),Concat (List [MapField (App+ "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),Concat (List [+ String "x",ShowInt FieldIndex])])]),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "arbitrary"])])])])),List [App+ "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "return"])])]),App "Paren" (List [App "()" (List []),Application (+ Concat (List [List [App "Con" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),CtorName])])])],MapField (App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+ )]))])])])]])])]),App "Nothing" (List [])])),List [App "Alt" (List+ [App "()" (List []),App "PWildCard" (List [App "()" (List [])]),+ App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "error"])])]),App "Lit" (List [App "()" (List []),App+ "String" (List [App "()" (List []),String+ "FATAL ERROR: Arbitrary instance, logic bug",String+ "FATAL ERROR: Arbitrary instance, logic bug"])])])]),App "Nothing"+ (List [])])]])])])]])]),App "Nothing" (List [])])])]]))]+-- GENERATED STOP++custom = customContext context++-- Fix the context+-- C a b => Arbitrary a, Arbitrary b+-- a -> b => CoArbitrary a, Arbitrary b+context :: FullDataDecl -> Context () -> Context ()+context (_,d) _ = CxTuple () $ nub $ concatMap (f True . snd) $ concatMap ctorDeclFields $ dataDeclCtors d+ where+ f b (TyVar _ x) = [ClassA () (qname $ b ? "Arbitrary" $ "CoArbitrary") [TyVar () x]]+ f b (TyFun _ x y) = f (not b) x ++ f b y+ f b x = concatMap (f b) (children x)+
+ src/Data/Derive/ArbitraryOld.hs view
@@ -0,0 +1,89 @@+module Data.Derive.ArbitraryOld where+{-+import "QuickCheck-1.2.0.0" Test.QuickCheck(Arbitrary(..), choose,variant)++example :: Sample++instance Arbitrary a => Arbitrary (Sample a) where+ arbitrary = do+ x <- choose (0,length [First{},Second{},Third{}]-1)+ case x of+ 0 -> do return (First)+ 1 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (Second x1 x2)+ 2 -> do x1 <- arbitrary+ return (Third x1)++ coarbitrary (First) = ()+ coarbitrary (Second x1 x2) = ()+ coarbitrary (Third x1) = ()++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeArbitraryOld :: Derivation+makeArbitraryOld = derivationDSL "ArbitraryOld" dslArbitraryOld++dslArbitraryOld =+ List [Instance ["Arbitrary"] "Arbitrary" (App "Just" (List [List [+ App "InsDecl" (List [App "()" (List []),App "PatBind" (List [App+ "()" (List []),App "PVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),String "arbitrary"])]),App "UnGuardedRhs"+ (List [App "()" (List []),App "Do" (List [App "()" (List []),List+ [App "Generator" (List [App "()" (List []),App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "x"])]+ ),App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "choose"])])]),App "Tuple" (List [App+ "()" (List []),App "Boxed" (List []),List [App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 0,ShowInt (+ Int 0)])]),App "InfixApp" (List [App "()" (List []),App "App" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "length"])])]),App "List" (List [App "()" (List []+ ),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])]),List []]))])]),App "QVarOp" (List [App "()" (List [])+ ,App "UnQual" (List [App "()" (List []),App "Symbol" (List [App+ "()" (List []),String "-"])])]),App "Lit" (List [App "()" (List []+ ),App "Int" (List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]+ ])])]),App "Qualifier" (List [App "()" (List []),App "Case" (List+ [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "x"])])]),MapCtor (App "Alt" (List [App "()" (List+ []),App "PLit" (List [App "()" (List []),App "Signless" (List [App+ "()" (List [])]),App "Int" (List [App "()" (List []),CtorIndex,+ ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()" (List [])+ ,App "Do" (List [App "()" (List []),Concat (List [MapField (App+ "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),Concat (List [+ String "x",ShowInt FieldIndex])])]),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "arbitrary"])])])])),List [App+ "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "return"])])]),App "Paren" (List [App "()" (List []),Application (+ Concat (List [List [App "Con" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),CtorName])])])],MapField (App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+ )]))])])])]])])]),App "Nothing" (List [])]))])])]])]),App+ "Nothing" (List [])])]),App "InsDecl" (List [App "()" (List []),+ App "FunBind" (List [App "()" (List []),MapCtor (App "Match" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "coarbitrary"]),List [App "PParen" (List [App "()" (List []),App+ "PApp" (List [App "()" (List []),App "UnQual" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),CtorName])]),+ MapField (App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])+ ]))])])],App "UnGuardedRhs" (List [App "()" (List []),App "Con" (+ List [App "()" (List []),App "Special" (List [App "()" (List []),+ App "UnitCon" (List [App "()" (List [])])])])]),App "Nothing" (+ List [])]))])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Arities.hs view
@@ -0,0 +1,48 @@+module Data.Derive.Arities where+{-+import "derive" Data.Derive.Class.Arities++example :: Sample++instance Arities (Sample a) where+ arities _ = [const 0 First{}, const 2 Second{}, const 1 Third{}]++test :: []++instance Arities [a] where+ arities _ = [0,2]++test :: Bool++instance Arities Bool where+ arities _ = [0,0]++test :: Either++instance Arities (Either a b) where+ arities _ = [1,1]+-}++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeArities :: Derivation+makeArities = derivationDSL "Arities" dslArities++dslArities =+ List [Instance [] "Arities" (App "Just" (List [List [App "InsDecl"+ (List [App "()" (List []),App "FunBind" (List [App "()" (List []),+ List [App "Match" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "arities"]),List [App "PWildCard" (List [App+ "()" (List [])])],App "UnGuardedRhs" (List [App "()" (List []),App+ "List" (List [App "()" (List []),MapCtor (Application (List [App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "const"])])]),App+ "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []+ ),CtorArity,ShowInt CtorArity])]),App "RecConstr" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),List []])]))])]),App "Nothing" (+ List [])])]])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Binary.hs view
@@ -0,0 +1,181 @@+module Data.Derive.Binary where+{-+import "binary" Data.Binary++example :: Sample++instance Binary alpha => Binary (Sample alpha) where+ put x = case x of+ First -> do putTag 0+ Second x1 x2 -> do putTag 1 ; put x1 ; put x2+ Third x1 -> do putTag 2 ; put x1+ where+ useTag = length [First{}, Second{}, Third{}] > 1+ putTag x = when useTag (putWord8 x)++ get = do+ i <- getTag+ case i of+ 0 -> do return (First)+ 1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)+ 2 -> do x1 <- get ; return (Third x1)+ _ -> error "Corrupted binary data for Sample"+ where+ useTag = length [First{}, Second{}, Third{}] > 1+ getTag = if useTag then getWord8 else return 0+++test :: List++instance Binary a => Binary (List a) where+ put x = case x of+ Nil -> putWord8 0+ Cons x1 x2 -> do putWord8 1; put x1; put x2++ get = do+ i <- getWord8+ case i of+ 0 -> return Nil+ 1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)+ _ -> error "Corrupted binary data for List"++test :: Assoced++instance Binary typ => Binary (Assoced typ) where+ put (Assoced x1 x2) = do put x1; put x2+ get = do x1 <- get; x2 <- get; return (Assoced x1 x2)+++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeBinary :: Derivation+makeBinary = derivationDSL "Binary" dslBinary++dslBinary =+ List [Instance ["Binary"] "Binary" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),List [App "Match" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "put"]),List [App "PVar" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "x"])])],App "UnGuardedRhs" (List [App "()" (List []),App "Case" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "x"])])]),MapCtor (App "Alt" (List [App "()" (List+ []),App "PApp" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),CtorName])]),+ MapField (App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])+ ]))]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (List+ [App "()" (List []),Concat (List [List [App "Qualifier" (List [App+ "()" (List []),App "App" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "putTag"])])]),App "Lit"+ (List [App "()" (List []),App "Int" (List [App "()" (List []),+ CtorIndex,ShowInt CtorIndex])])])])],MapField (App "Qualifier" (+ List [App "()" (List []),App "App" (List [App "()" (List []),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "put"])])]),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),Concat (List [String "x"+ ,ShowInt FieldIndex])])])])])]))])])]),App "Nothing" (List [])]))]+ )]),App "Just" (List [App "BDecls" (List [App "()" (List []),List+ [App "PatBind" (List [App "()" (List []),App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "useTag"])]),App "UnGuardedRhs" (List [App "()" (List []),App+ "InfixApp" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "length"])])]),App "List" (List [App "()" (List []),MapCtor (App+ "RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])]),List+ []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Symbol" (List [App "()" (List []),+ String ">"])])]),App "Lit" (List [App "()" (List []),App "Int" (+ List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]),App+ "Nothing" (List [])]),App "FunBind" (List [App "()" (List []),List+ [App "Match" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "putTag"]),List [App "PVar" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "x"])])],App+ "UnGuardedRhs" (List [App "()" (List []),Application (List [App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "when"])])]),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "useTag"])])]),+ App "Paren" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),Concat (+ List [String "putWord",ShowInt (Int 8)])])])]),App "Var" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "x"])])])])])])]),App+ "Nothing" (List [])])]])]])])])]])]),App "InsDecl" (List [App "()"+ (List []),App "PatBind" (List [App "()" (List []),App "PVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "get"])]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (+ List [App "()" (List []),List [App "Generator" (List [App "()" (+ List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "i"])]),App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "getTag"])])])]),App "Qualifier" (List [App+ "()" (List []),App "Case" (List [App "()" (List []),App "Var" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "i"])])]),Concat (+ List [MapCtor (App "Alt" (List [App "()" (List []),App "PLit" (+ List [App "()" (List []),App "Signless" (List [App "()" (List [])]+ ),App "Int" (List [App "()" (List []),CtorIndex,ShowInt CtorIndex]+ )]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (List [+ App "()" (List []),Concat (List [MapField (App "Generator" (List [+ App "()" (List []),App "PVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),Concat (List [String "x",ShowInt+ FieldIndex])])]),App "Var" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "get"])])])])),List [App "Qualifier" (List [App "()" (List+ []),App "App" (List [App "()" (List []),App "Var" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "return"])])]),App "Paren" (List [App+ "()" (List []),Application (Concat (List [List [App "Con" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),CtorName])])])],MapField (App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),Concat (List [String "x"+ ,ShowInt FieldIndex])])])]))]))])])])]])])]),App "Nothing" (List [+ ])])),List [App "Alt" (List [App "()" (List []),App "PWildCard" (+ List [App "()" (List [])]),App "UnGuardedRhs" (List [App "()" (+ List []),App "App" (List [App "()" (List []),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "error"])])]),App "Lit" (List [+ App "()" (List []),App "String" (List [App "()" (List []),Concat (+ List [String "Corrupted binary data for ",DataName]),Concat (List+ [String "Corrupted binary data for ",DataName])])])])]),App+ "Nothing" (List [])])]])])])]])]),App "Just" (List [App "BDecls" (+ List [App "()" (List []),List [App "PatBind" (List [App "()" (List+ []),App "PVar" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "useTag"])]),App "UnGuardedRhs" (List [App+ "()" (List []),App "InfixApp" (List [App "()" (List []),App "App"+ (List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "length"])])]),App "List" (List [App "()" (List []+ ),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])]),List []]))])]),App "QVarOp" (List [App "()" (List [])+ ,App "UnQual" (List [App "()" (List []),App "Symbol" (List [App+ "()" (List []),String ">"])])]),App "Lit" (List [App "()" (List []+ ),App "Int" (List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]+ ),App "Nothing" (List [])]),App "PatBind" (List [App "()" (List []+ ),App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "getTag"])]),App "UnGuardedRhs" (List [App "()" (+ List []),App "If" (List [App "()" (List []),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "useTag"])])]),App "Var" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),Concat (List [String "getWord",+ ShowInt (Int 8)])])])]),App "App" (List [App "()" (List []),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "return"])])]),+ App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (+ List []),Int 0,ShowInt (Int 0)])])])])]),App "Nothing" (List [])])+ ]])])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/BinaryDefer.hs view
@@ -0,0 +1,83 @@+module Data.Derive.BinaryDefer where+{-+import "binarydefer" Data.Binary.Defer++example :: Sample++instance BinaryDefer a => BinaryDefer (Sample a) where+ bothDefer = defer [\ ~(o@(First)) -> if null [] then unit (First) <<! o else unit First+ ,\ ~(o@(Second x1 x2)) -> if null [const () x1, const () x2] then unit (Second x1 x2) <<! o else unit Second << x1 << x2+ ,\ ~(o@(Third x1)) -> if null [const () x1] then unit (Third x1) <<! o else unit Third << x1+ ]++test :: FailList++instance (BinaryDefer e, BinaryDefer a) => BinaryDefer (FailList e a) where+ bothDefer = defer [\ ~(o@Zoro) -> unit Zoro <<! o+ ,\ ~(Fial x1) -> unit Fial << x1+ ,\ ~(Const x1 x2) -> unit Const << x1 << x2+ ]++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeBinaryDefer :: Derivation+makeBinaryDefer = derivationDSL "BinaryDefer" dslBinaryDefer++dslBinaryDefer =+ List [Instance ["BinaryDefer"] "BinaryDefer" (App "Just" (List [+ List [App "InsDecl" (List [App "()" (List []),App "PatBind" (List+ [App "()" (List []),App "PVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "bothDefer"])]),App+ "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App "()"+ (List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "defer"])])]),App "List" (List [App "()" (List []),MapCtor (App+ "Lambda" (List [App "()" (List []),List [App "PIrrPat" (List [App+ "()" (List []),App "PParen" (List [App "()" (List []),App "PAsPat"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "o"]),App "PParen" (List [App "()" (List []),App "PApp" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),CtorName])]),MapField (App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),Concat (List [String "x",ShowInt FieldIndex])])]))])])])])])],+ App "If" (List [App "()" (List []),App "App" (List [App "()" (List+ []),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "null"+ ])])]),App "List" (List [App "()" (List []),MapField (Application+ (List [App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "const"])])]),App "Con" (List [App "()" (List []),App "Special" (+ List [App "()" (List []),App "UnitCon" (List [App "()" (List [])])+ ])]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])])])]))])]),App "InfixApp" (List+ [App "()" (List []),App "App" (List [App "()" (List []),App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "unit"])])]),App+ "Paren" (List [App "()" (List []),Application (Concat (List [List+ [App "Con" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])])])],+ MapField (App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),Concat (+ List [String "x",ShowInt FieldIndex])])])]))]))])]),App "QVarOp" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Symbol" (List [App "()" (List []),String "<<!"])])]),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "o"])])])]),Fold+ (App "InfixApp" (List [App "()" (List []),Tail,App "QVarOp" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Symbol" (List [App "()" (List []),String "<<"])])]),Head])) (+ Concat (List [Reverse (MapField (App "Var" (List [App "()" (List [+ ]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+ )),List [App "App" (List [App "()" (List []),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "unit"])])]),App "Con" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),CtorName])])])])]]))])]))])])]),App+ "Nothing" (List [])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Bounded.hs view
@@ -0,0 +1,56 @@+module Data.Derive.Bounded where+{-+import Prelude++example :: Sample++instance Bounded a => Bounded (Sample a) where+ minBound = head [First, Second (const minBound 1) (const minBound 2), Third (const minBound 1)]+ maxBound = head [Third (const maxBound 1), Second (const maxBound 1) (const maxBound 2), First]++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeBounded :: Derivation+makeBounded = derivationDSL "Bounded" dslBounded++dslBounded =+ List [Instance ["Bounded"] "Bounded" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "minBound"])]),App "UnGuardedRhs" (List+ [App "()" (List []),App "App" (List [App "()" (List []),App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "head"])])]),App+ "List" (List [App "()" (List []),MapCtor (Application (Concat (+ List [List [App "Con" (List [App "()" (List []),App "UnQual" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),CtorName+ ])])])],MapField (App "Paren" (List [App "()" (List []),+ Application (List [App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "const"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "minBound"])])]),App "Lit" (List [App "()" (List+ []),App "Int" (List [App "()" (List []),FieldIndex,ShowInt+ FieldIndex])])])]))])))])])]),App "Nothing" (List [])])]),App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "maxBound"])]),App "UnGuardedRhs" (List+ [App "()" (List []),App "App" (List [App "()" (List []),App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "head"])])]),App+ "List" (List [App "()" (List []),Reverse (MapCtor (Application (+ Concat (List [List [App "Con" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),CtorName])])])],MapField (App "Paren" (List [App "()" (+ List []),Application (List [App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "const"])])]),App "Var" (List [App "()" (List [])+ ,App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "maxBound"])])]),App "Lit" (List [App "()" (+ List []),App "Int" (List [App "()" (List []),FieldIndex,ShowInt+ FieldIndex])])])]))]))))])])]),App "Nothing" (List [])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Class/Arities.hs view
@@ -0,0 +1,5 @@++module Data.Derive.Class.Arities where++class Arities a where+ arities :: a -> [Int]
+ src/Data/Derive/Class/Default.hs view
@@ -0,0 +1,5 @@++module Data.Derive.Class.Default where++class Default a where+ def :: a
+ src/Data/Derive/DSL/Apply.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}++module Data.Derive.DSL.Apply(apply, applyEnv, env, Env(..)) where++import Data.Derive.DSL.HSE+import Data.Derive.DSL.DSL+import Data.List+import Data.Generics.Uniplate.DataOnly+++apply :: DSL -> Input -> Out+apply dsl input = fromOutput $ applyEnv dsl env{envInput=input}+++env = Env+ (error "Env.envInput: uninitialised")+ (error "Env.envCtor: uninitialised")+ (error "Env.envField: uninitialised")+ (error "Env.envFold: uninitialised")+++data Env = Env {envInput :: Input+ ,envCtor :: Ctor+ ,envField :: Integer+ ,envFold :: (Output,Output) }++applyEnv :: DSL -> Env -> Output+applyEnv dsl env@(Env input ctor field fold) = f dsl+ where+ f (Instance ctx hd body) =+ OApp "InstDecl"+ [out ()+ ,out (Nothing :: Maybe (Overlap ()))+ ,out (IRule () Nothing context insthead :: InstRule ())+ ,f body]+ where+ context = Just $ CxTuple ()+ [ClassA () (UnQual () $ Ident () c) [TyVar () $ Ident () v]+ | let seen = [x | TyVar () (Ident () x) <- universeBi $ concatMap ctorDeclFields $ dataCtors input]+ , v <- dataDeclVarsStar input `intersect` seen+ , c <- ctx]+ ty = TyParen () $ foldl (TyApp ())+ (TyCon () $ UnQual () $ Ident () $ dataName input)+ (map tyVar $ dataDeclVars input)+ insthead = IHApp () (IHCon () $ UnQual () $ Ident () hd) ty++ f (Application (f -> OList xs)) =+ foldl1 (\a b -> OApp "App" [OApp "()" [],a,b]) xs++ f (MapCtor dsl) = OList [applyEnv dsl env{envCtor=c}+ | c <- dataCtors input]+ f (MapField dsl) = OList [applyEnv dsl env{envField=i}+ | i <- [1.. fromIntegral $ ctorArity ctor]]++ f DataName = OString $ dataName input+ f CtorName = OString $ ctorName ctor+ f CtorArity = OInt $ ctorArity ctor+ f CtorIndex = OInt $ ctorIndex input ctor+ f FieldIndex = OInt $ field++ f Head = fst fold+ f Tail = snd fold+ f (Fold cons (f -> OList xs)) =+ foldr1 (\a b -> applyEnv cons env{envFold=(a,b)}) xs++ f (List xs) = OList $ map f xs+ f (Reverse (f -> OList xs)) = OList $ reverse xs+ f (Concat (f -> OList [])) = OList []+ f (Concat (f -> OList xs)) = foldr1 g xs+ where g (OList x) (OList y) = OList (x++y)+ g (OString x) (OString y) = OString (x++y)+ f (String x) = OString x+ f (Int x) = OInt x+ f (ShowInt (f -> OInt x)) = OString $ show x+ f (App x (f -> OList ys)) = OApp x ys
+ src/Data/Derive/DSL/DSL.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.Derive.DSL.DSL where++import Data.Derive.DSL.HSE+import Data.List+import Data.Data+import Data.Generics.Uniplate.DataOnly++data DSL = App String DSL{-List-}+ | Concat DSL+ | Reverse DSL+ | String String+ | ShowInt DSL+ | Int Integer+ | List [DSL]+ + | MapField DSL+ | MapCtor DSL+ | DataName+ | CtorName+ | CtorIndex+ | CtorArity+ | FieldIndex+ + | Fold DSL DSL+ | Head+ | Tail+ + | Instance [String] String DSL{-[InstDecl]-}+ | Application DSL{-List-}+ deriving (Data,Typeable,Show)++box x = List [x]+nil = List []+append x y = Concat $ List [x,y]+++fromOut :: Output -> DSL+fromOut (OApp x y) = App x (List $ map fromOut y)+fromOut (OList x) = List (map fromOut x)+fromOut (OString x) = String x+fromOut x = error $ show ("fromOut",x)+++{-+_1 s x1 = App s $ List [x1]+_2 s x1 x2 = App s $ List [x1,x2]+_3 s x1 x2 x3 = App s $ List [x1,x2,x3]+_5 s x1 x2 x3 x4 x5 = App s $ List [x1,x2,x3,x4,x5]++o x = fromOut $ out x++dslEq :: DSL+dslEq = box $ Instance ["Eq"] "Eq" $ box $ _1 "InsDecl" $ _1 "FunBind" $ match `append` dull+ where+ match = MapCtor $ _5 "Match" (o $ Symbol "==") (List [vars "x",vars "y"]) (o (Nothing :: Maybe Type)) (_1 "UnGuardedRhs" bod) (o $ BDecls [])+ vars x = _2 "PApp" (_1 "UnQual" $ _1 "Ident" CtorName) (MapField (_1 "PVar" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)))+ bod = Fold (_3 "InfixApp" Head (o $ QVarOp $ UnQual $ Symbol "&&") Tail) $ MapField pair `append` o [Con $ UnQual $ Ident "True"]+ pair = _3 "InfixApp" (var "x") (o $ QVarOp $ UnQual $ Symbol "==") (var "y")+ var x = _1 "Var" $ _1 "UnQual" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)++ dull = o [Match sl (Symbol "==") [PWildCard,PWildCard] Nothing (UnGuardedRhs $ Con $ UnQual $ Ident "False") (BDecls [])]+-}+++simplifyDSL :: DSL -> DSL+simplifyDSL = transform f+ where+ f (Concat (List xs)) = case g xs of+ [x] -> x+ [] -> List []+ xs -> Concat $ List xs+ f x = x++ g (List x:List y:zs) = g $ List (x++y):zs+ g (List []:xs) = g xs+ g (String "":xs) = g xs+ g (x:xs) = x : g xs+ g [] = []+++prettyTex :: DSL -> String+prettyTex = f id . transform g+ where+ bracket x = "(" ++ x ++ ")"+ + f b (App x (List [])) = x+ f b (App x (List xs)) = b $ unwords $ x : map (f bracket) xs+ f b (App x y) = b $ x ++ " " ++ f bracket y+ f b (Concat x) = b $ "concat " ++ f bracket x+ f b (Reverse x) = b $ "reverse " ++ f bracket x+ f b (String x) = show x+ f b (ShowInt x) = b $ "showInt " ++ f bracket x+ f b (Int x) = show x+ f b (List []) = "nil"+ f b (List x) = b $ "list (" ++ concat (intersperse "," $ map (f id) x) ++ ")"+ f b (MapField x) = b $ "mapField " ++ f bracket x+ f b (MapCtor x) = b $ "mapCtor " ++ f bracket x+ f b DataName = "dataName"+ f b CtorName = "ctorName"+ f b CtorIndex = "ctorIndex"+ f b CtorArity = "ctorArity"+ f b FieldIndex = "fieldIndex"+ f b (Fold x y) = b $ "fold " ++ f bracket x ++ " " ++ f bracket y+ f b Head = "head"+ f b Tail = "tail"+ f b (Instance x y z) = b $ "instance_ " ++ show x ++ " " ++ show y ++ " " ++ f bracket z+ f b (Application x) = b $ "application " ++ f bracket x++ g (App x (List [y])) | x `elem` words "Ident UnGuardedRhs UnQual Lit" = y+ g x = x
+ src/Data/Derive/DSL/Derive.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE PatternGuards #-}++module Data.Derive.DSL.Derive(derive) where++import Control.Arrow+import Data.Derive.DSL.HSE+import Data.Derive.DSL.DSL+import Data.Derive.DSL.Apply+import Data.List+import Data.Char+import Data.Maybe+++data Guess = Guess DSL+ | GuessFld Int DSL+ | GuessCtr Int Bool DSL -- 0 based index, does it mention CtorName+ deriving Show+++ctrNames = map ctorName $ dataCtors sample+++derive :: Out -> [DSL]+derive x = [simplifyDSL y | Guess y <- guess $ toOutput x]+++guess :: Output -> [Guess]+guess (OApp "InstDecl" [_,OApp "Nothing" [],rule,decls])+ | OApp "IRule" [_, OApp "Nothing" [], ctx, ihead] <- unparen rule+ , (name, types) <- unInstHead ihead+ , OApp "UnQual" [_, OApp "Ident" [_, OString name]] <- name+ , [OApp "TyParen" [_,OApp "TyApp"+ [_,OApp "TyCon" [_,OApp "UnQual" [_,OApp "Ident" [_,OString nam]]]+ ,OApp "TyVar" [_,OApp "Ident" [_,OString var]]]]] <- types+ , nam == dataName sample+ = [Guess $ Instance (unContext ctx) name y | Guess y <- guess decls]+ where+ unContext (OApp "Just" [x])+ | OApp "CxSingle" [_,x] <- x = unClass x+ | OApp "CxTuple" [_,OList xs] <- x = concatMap unClass xs+ unContext x = []++ unClass (OApp "ClassA" [_,OApp "UnQual" [_,OApp "Ident" [_,OString x]],_]) = [x]+ unClass _ = []++ unInstHead (OApp "IHCon" [_, name]) = (name, [])+ unInstHead (OApp "IHInfix" [_, ty, name]) = (name, [ty])+ unInstHead (OApp "IHParen" [_, x]) = unInstHead x+ unInstHead (OApp "IHApp" [_, hd, ty]) = second (++[ty]) $ unInstHead hd++ unparen (OApp p [_, x]) | "Paren" `isInfixOf` p = unparen x+ unparen x = x++guess (OList xs) = guessList xs+guess o@(OApp op xs) = gssFold o ++ gssApp o ++ map (lift (App op)) (guessList xs)+ +guess (OString x) + | Just i <- findIndex (`isSuffixOf` x) ctrNames = [GuessCtr i True $ String (take (length x - length (ctrNames !! i)) x) `append` CtorName]+ | "Sample" `isSuffixOf` x = [Guess $ String (take (length x - 6) x) `append` DataName]+ | otherwise =+ [lift (\d -> append (String $ init x) (ShowInt d)) g | x /= "", isDigit (last x), g <- guess $ OInt $ read [last x]] +++ [Guess $ String x]++guess (OInt i) =+ [GuessFld (fromInteger i) FieldIndex | i `elem` [1,2]] +++ [GuessCtr 1 False CtorIndex | i == 1] +++ [GuessCtr 1 False CtorArity | i == 2] +++ [Guess $ Int i]++guess x = error $ show ("fallthrough",x)+++{-+First try and figure out runs to put them in to one possible option+Then try and figure out similarities to give them the same type+-}+guessList :: [Output] -> [Guess]+guessList xs = mapMaybe sames $ map diffs $ sequence $ map guess xs+ where+ -- Given a list of guesses, try and collapse them into one coherent guess+ -- Each input Guess will guess at a List, so compose with Concat+ sames :: [Guess] -> Maybe Guess+ sames xs = do+ let (is,fs) = unzip $ map fromGuess xs+ i <- maxim is+ return $ toGuess i $ Concat $ List fs++ -- Promote each Guess to be a list+ diffs :: [Guess] -> [Guess]++ diffs (GuessCtr 0 True x0:GuessCtr 1 True x1:GuessCtr 2 True x2:xs)+ | f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (MapCtor x1) : diffs xs+ where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}+ + diffs (GuessCtr 2 True x2:GuessCtr 1 True x1:GuessCtr 0 True x0:xs)+ | f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (Reverse $ MapCtor x1) : diffs xs+ where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}+ + diffs (GuessFld 1 x1:GuessFld 2 x2:xs)+ | f 1 x1 == f 1 x2 = GuessCtr 1 False (MapField x2) : diffs xs+ where f i x = applyEnv x env{envInput=sample, envField=i}+ + diffs (GuessFld 2 x2:GuessFld 1 x1:xs)+ | f 1 x1 == f 1 x2 = GuessCtr 1 False (Reverse $ MapField x2) : diffs xs+ where f i x = applyEnv x env{envInput=sample, envField=i}++ diffs (x:xs) = lift box x : diffs xs+ diffs [] = []+++gssFold o@(OApp op [pre,x,m,y]) = f True (x : follow True y) ++ f False (y : follow False x)+ where+ follow dir (OApp op2 [pre2,a,m2,b]) | op == op2 && pre == pre2 && m == m2 = a2 : follow dir b2+ where (a2,b2) = if dir then (a,b) else (b,a)+ follow dir x = [x]++ f dir xs | length xs <= 2 = []+ f dir xs | pre:_ <- [d | Guess d <- guess pre] = map (lift $ g pre) $ guess $ OList xs+ where g pre = Fold (App op $ List [pre,h,fromOut m,t])+ (h,t) = if dir then (Head,Tail) else (Tail,Head)++gssFold _ = []+++gssApp (OApp "App" [_,OApp "App" [_,x,y],z]) = map (lift Application) $ guess $ OList $ fromApp x ++ [y,z]+ where fromApp (OApp "App" [_,x,y]) = fromApp x ++ [y]+ fromApp x = [x]+gssApp _ = []+ ++lift :: (DSL -> DSL) -> Guess -> Guess+lift f x = toGuess a (f b)+ where (a,b) = fromGuess x+++type GuessState = Maybe (Either Int (Int,Bool))++fromGuess :: Guess -> (GuessState, DSL)+fromGuess (Guess x) = (Nothing, x)+fromGuess (GuessFld i x) = (Just (Left i), x)+fromGuess (GuessCtr i b x) = (Just (Right (i,b)), x)++toGuess :: GuessState -> DSL -> Guess+toGuess Nothing = Guess+toGuess (Just (Left i)) = GuessFld i+toGuess (Just (Right (i,b))) = GuessCtr i b+++-- return the maximum element, if one exists+maxim :: [GuessState] -> Maybe GuessState+maxim [] = Just Nothing+maxim [x] = Just x+maxim (Nothing:xs) = maxim xs+maxim (x:Nothing:xs) = maxim $ x:xs+maxim (x1:x2:xs) | x1 == x2 = maxim $ x1:xs+maxim (Just (Right (i1,b1)):Just (Right (i2,b2)):xs) | i1 == i2 = maxim $ Just (Right (i1,max b1 b2)) : xs+maxim _ = Nothing
+ src/Data/Derive/DSL/HSE.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.Derive.DSL.HSE(module Data.Derive.DSL.HSE, module Language.Haskell) where++import Language.Haskell hiding (List, App, String, Int)+import Data.Data+import Data.Generics.Uniplate.DataOnly+import Data.Maybe+import Data.List+import Data.Function+import Control.Monad.Trans.State+++---------------------------------------------------------------------+-- EXAMPLES++{-+-- data List a = Nil | Cons a (List a)+list :: Input+list = Input "List" 1 [Ctor "Nil" 0 0, Ctor "Cons" 1 2]+-}+++-- data Sample a = First | Second a a | Third a+sample :: Input+sample = DataDecl () (DataType ()) Nothing (DHApp () (DHead () $ name "Sample") (tyVarBind "a")) ctrs []+ where+ ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1]+ ctr s i = QualConDecl () Nothing Nothing $ ConDecl () (name s) $ replicate i $ tyVar "a"+++---------------------------------------------------------------------+-- UTILITIES++outEq :: Out -> Out -> Bool+outEq = (==) `on` transformBi (const sl)++---------------------------------------------------------------------++showOut x = unlines $ map prettyPrint x+++type Input = DataDecl+type Ctor = CtorDecl++dataName = dataDeclName+dataVars = length . dataDeclVars+dataCtors = dataDeclCtors+ctorName = ctorDeclName+ctorArity = fromIntegral . ctorDeclArity++ctorIndex :: Input -> Ctor -> Integer+ctorIndex dat ctor = fromIntegral $ fromMaybe (error "fromJust: ctorIndex") $ findIndex (== ctor) $ dataCtors dat+++toInput :: DataDecl -> Input+toInput x = x+++type Out = [Decl ()]++++data Output = OString String+ | OInt Integer+ | OApp String [Output]+ | OList [Output]+ | OIgnore+ | OCustom String+ deriving (Eq,Show,Data,Typeable)+++toOutput :: Data a => a -> Output+toOutput x+ | t == typeOf "" = OString $ coerce x+ | c == "[]" = OList $ fList x+ | t == typeOf sl = OIgnore+ | t == typeOf (1 :: Integer) = OInt $ coerce x+ | otherwise = OApp (showConstr $ toConstr x) (filter (/= OIgnore) $ gmapQ toOutput x)+ where+ t = typeOf x+ c = show $ fst $ splitTyConApp t++ fList :: Data a => a -> [Output]+ fList = gmapQl (++) [] $ \x -> if typeOf x == t then fList x else [toOutput x]++fromOutput :: Data a => Output -> a+fromOutput (OList xs) = res+ where res = f xs+ f [] = fromConstr $ readCon dat "[]"+ f (x:xs) = fromConstrB (g x (f xs `asTypeOf` res)) $ readCon dat "(:)"+ dat = dataTypeOf res++ g :: (Data a, Data b) => Output -> a -> b+ g x xs = r2 where r2 = if typeOf r2 == typeOf xs then coerce xs else fromOutput x++fromOutput (OApp str args) = res+ where dat = dataTypeOf res+ res = evalState (fromConstrM f $ readCon dat str) args+ f :: Data a => State [Output] a+ f = res where res = if typeOf (fromState res) == typeOf sl then return $ coerce sl else+ do l <- get+ case l of+ x:xs -> do put xs; return $ fromOutput x+ [] -> error "fromOutput: null"++fromOutput (OString x) = coerce x+fromOutput (OInt x) = coerce x+++coerce x = fromMaybe (error "Error in coerce") $ cast x+readCon dat x = fromMaybe (error $ "Error in readCon, " ++ x) $ readConstr dat x+out x = toOutput x+fromState :: State a x -> x+fromState = undefined
+ src/Data/Derive/DSL/SYB.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE RelaxedPolyRec, RankNTypes, ScopedTypeVariables #-}+{- OPTIONS_GHC -fglasgow-exts -}++module Data.Derive.DSL.SYB(dslSYB) where++import Data.Derive.DSL.HSE+import qualified Language.Haskell.Exts as H+import Data.Derive.DSL.DSL+import Control.Monad.Trans.State+import Control.Monad+import Data.Generics+import Data.Maybe+++dslSYB :: DSL -> Maybe Out+dslSYB = syb+++syb :: Data a => DSL -> Maybe a+syb = dsimple & dlistAny & dapp -- & (\x -> error $ "Failed to generate for SYB, " ++ show x)++lift :: (Data a, Data b) => (DSL -> Maybe b) -> (DSL -> Maybe a)+lift f = maybe Nothing id . cast . f++(&) a b x = a x `mplus` b x+++dlistAny :: forall a . Data a => DSL -> Maybe a+dlistAny x | isNothing con = Nothing+ | otherwise = res+ where+ con = readConstr dat "(:)"+ val = fromConstr (fromJust con) :: a++ dat = dataTypeOf (undefined :: a)++ res = gmapQi 0 f val++ f :: Data d => d -> Maybe a+ f y = fromJust $ cast $ dlist x `asTypeOf` Just [y]+++dlist :: Data a => DSL -> Maybe [a]+dlist x = do+ List xs <- return x+ mapM syb xs+++dapp :: forall a . Data a => DSL -> Maybe a+dapp x = do+ App name (List args) <- return x+ let dat = dataTypeOf (undefined :: a)+ (res,s) = runState (fromConstrM f $ readCon dat name) (True,args)+ if fst s then Just res else Nothing+ where+ f :: forall b . Data b => State (Bool,[DSL]) b+ f = if typeOf (undefined :: b) == typeOf sl then return $ coerce sl+ else do+ (b,l) <- get+ case l of+ x:xs ->+ case syb x of+ Nothing -> do put (False,xs) ; return undefined+ Just y -> do put (b,xs) ; return y+ [] ->+ error "dapp: null"+++dsimple :: Data a => DSL -> Maybe a+dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle+++dinstance :: DSL -> Maybe (Decl ())+dinstance x = do+ Instance _ name bod <- return x+ bod <- syb bod+ let ctx = ClassA () (UnQual () $ Ident () "Data") [TyVar () $ Ident () "d_type"]+ let rule = IRule () Nothing (Just (CxSingle () ctx))+ (IHApp () (IHCon () (UnQual () $ Ident () name)) (TyVar () $ Ident () "d_type"))+ return $ InstDecl () Nothing rule bod+++dstring :: DSL -> Maybe String+dstring x = do+ String x <- return x+ return x+++dmapctor :: DSL -> Maybe (Exp ())+dmapctor x = do+ App "List" (List [_, MapCtor x]) <- return x+ x <- syb x+ return $ ListComp () x [QualStmt () $ Generator () (PVar () $ Ident () "d_ctor")+ (H.App () (v "d_dataCtors") (Paren () $ ExpTypeSig () (v "undefined") (TyVar () $ Ident () "d_type")))]+++dsingle :: DSL -> Maybe (Exp ())+dsingle (App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []),CtorArity,ShowInt CtorArity])])) = Just $ Paren () $ H.App () (v "d_ctorArity") (v "d_ctor")+dsingle (App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []),CtorIndex,ShowInt CtorIndex])])) = Just $ Paren () $ H.App () (v "d_ctorIndex") (v "d_ctor")+dsingle (App "RecConstr" (List [_, App "UnQual" (List [_, App "Ident" (List [_, CtorName])]),List []])) = Just $ Paren () $+ ExpTypeSig () (H.App () (v "d_ctorValue") (v "d_ctor")) (TyVar () $ Ident () "d_type")+dsingle _ = Nothing+++dapplication :: DSL -> Maybe (Exp ())+dapplication x = do+ Application (List xs) <- return x+ syb $ f xs+ where+ f (x:y:z) = f (App "App" (List [App "()" $ List [],x,y]) : z)+ f [x] = x+++v = Var () . UnQual () . Ident ()
+ src/Data/Derive/DataAbstract.hs view
@@ -0,0 +1,79 @@+{-|+ For deriving Data on abstract data types.+-}+module Data.Derive.DataAbstract(makeDataAbstract) where+{-+import Data.Data(Data(..))++example :: Custom++instance Typeable a => Data (Sample a) where+ gfoldl k r x = r x+ gunfold = error "Data.gunfold not implemented on abstract data type: Sample"+ toConstr = error "Data.gunfold not implemented on abstract data type: Sample"+ dataTypeOf = error "Data.gunfold not implemented on abstract data type: Sample"++-}++import Data.Derive.DSL.HSE++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeDataAbstract :: Derivation+makeDataAbstract = derivationCustomDSL "DataAbstract" custom $+ List [Instance ["Typeable"] "Data" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),List [App "Match" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "gfoldl"]),List [App "PVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "k"])]),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "r"])]),App "PVar" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "x"])])],App+ "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App "()"+ (List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "r"])])]),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "x"])])])])]),App "Nothing" (List [])])]])]),App "InsDecl" (List [+ App "()" (List []),App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "gunfold"])]),App "UnGuardedRhs" (List [App "()" (List+ []),App "App" (List [App "()" (List []),App "Var" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "error"])])]),App "Lit" (List [App "()"+ (List []),App "String" (List [App "()" (List []),Concat (List [+ String "Data.gunfold not implemented on abstract data type: ",+ DataName]),Concat (List [String+ "Data.gunfold not implemented on abstract data type: ",DataName])]+ )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App "()"+ (List []),App "PatBind" (List [App "()" (List []),App "PVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "toConstr"])]),App "UnGuardedRhs" (List [App "()" (List []),App+ "App" (List [App "()" (List []),App "Var" (List [App "()" (List []+ ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "error"])])]),App "Lit" (List [App "()" (+ List []),App "String" (List [App "()" (List []),Concat (List [+ String "Data.gunfold not implemented on abstract data type: ",+ DataName]),Concat (List [String+ "Data.gunfold not implemented on abstract data type: ",DataName])]+ )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App "()"+ (List []),App "PatBind" (List [App "()" (List []),App "PVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "dataTypeOf"])]),App "UnGuardedRhs" (List [App "()" (List []),App+ "App" (List [App "()" (List []),App "Var" (List [App "()" (List []+ ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "error"])])]),App "Lit" (List [App "()" (+ List []),App "String" (List [App "()" (List []),Concat (List [+ String "Data.gunfold not implemented on abstract data type: ",+ DataName]),Concat (List [String+ "Data.gunfold not implemented on abstract data type: ",DataName])]+ )])])]),App "Nothing" (List [])])])]]))]+-- GENERATED STOP++custom = customContext context++context :: FullDataDecl -> Context () -> Context ()+context d _ = CxTuple () [ClassA () (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
+ src/Data/Derive/Default.hs view
@@ -0,0 +1,38 @@+module Data.Derive.Default where+{-+import "derive" Data.Derive.Class.Default++example :: Sample++instance Default a => Default (Sample a) where+ def = head [First, Second (const def 1) (const def 2), Third (const def 1)]+-}++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeDefault :: Derivation+makeDefault = derivationDSL "Default" dslDefault++dslDefault =+ List [Instance ["Default"] "Default" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "def"])]),App "UnGuardedRhs" (List [App+ "()" (List []),App "App" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "head"])])]),App "List" (+ List [App "()" (List []),MapCtor (Application (Concat (List [List+ [App "Con" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])])])],+ MapField (App "Paren" (List [App "()" (List []),Application (List+ [App "Var" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),String "const"])])+ ]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "def"]+ )])]),App "Lit" (List [App "()" (List []),App "Int" (List [App+ "()" (List []),FieldIndex,ShowInt FieldIndex])])])]))])))])])]),+ App "Nothing" (List [])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/EnumCyclic.hs view
@@ -0,0 +1,152 @@+module Data.Derive.EnumCyclic where+{-+import Prelude(Enum)++example :: Sample++instance Enum (Sample a) where+ toEnum 0 = First{}+ toEnum 1 = Second{}+ toEnum 2 = Third{}+ toEnum n = error $ "toEnum " ++ show n ++ ", not defined for Sample"++ fromEnum (First{}) = 0+ fromEnum (Second{}) = 1+ fromEnum (Third{}) = 2+++ succ a = if b == length [First{},Second{},Third{}] then toEnum 0 else toEnum (b+1)+ where b = fromEnum a++ pred a = if b == 0 then toEnum (length [First{},Second{},Third{}]) else toEnum (b-1)+ where b = fromEnum a++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeEnumCyclic :: Derivation+makeEnumCyclic = derivationDSL "EnumCyclic" dslEnumCyclic++dslEnumCyclic =+ List [Instance [] "Enum" (App "Just" (List [List [App "InsDecl" (+ List [App "()" (List []),App "FunBind" (List [App "()" (List []),+ Concat (List [MapCtor (App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "toEnum"]),List [App+ "PLit" (List [App "()" (List []),App "Signless" (List [App "()" (+ List [])]),App "Int" (List [App "()" (List []),CtorIndex,ShowInt+ CtorIndex])])],App "UnGuardedRhs" (List [App "()" (List []),App+ "RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])]),List+ []])]),App "Nothing" (List [])])),List [App "Match" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "toEnum"]),List [App "PVar" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "n"])])],App "UnGuardedRhs" (List+ [App "()" (List []),App "InfixApp" (List [App "()" (List []),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "error"])])]),App+ "QVarOp" (List [App "()" (List []),App "UnQual" (List [App "()" (+ List []),App "Symbol" (List [App "()" (List []),String "$"])])]),+ Fold (App "InfixApp" (List [App "()" (List []),Head,App "QVarOp" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Symbol" (List [App "()" (List []),String "++"])])]),Tail])) (+ List [App "Lit" (List [App "()" (List []),App "String" (List [App+ "()" (List []),String "toEnum ",String "toEnum "])]),App "App" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "show"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "n"])])])]),App "Lit" (List [App "()" (List []),+ App "String" (List [App "()" (List []),Concat (List [String+ ", not defined for ",DataName]),Concat (List [String+ ", not defined for ",DataName])])])])])]),App "Nothing" (List [])]+ )]])])]),App "InsDecl" (List [App "()" (List []),App "FunBind" (+ List [App "()" (List []),MapCtor (App "Match" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "fromEnum"])+ ,List [App "PParen" (List [App "()" (List []),App "PRec" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),CtorName])]),List []])])],App+ "UnGuardedRhs" (List [App "()" (List []),App "Lit" (List [App "()"+ (List []),App "Int" (List [App "()" (List []),CtorIndex,ShowInt+ CtorIndex])])]),App "Nothing" (List [])]))])]),App "InsDecl" (List+ [App "()" (List []),App "FunBind" (List [App "()" (List []),List [+ App "Match" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "succ"]),List [App "PVar" (List [App "()" (List [+ ]),App "Ident" (List [App "()" (List []),String "a"])])],App+ "UnGuardedRhs" (List [App "()" (List []),App "If" (List [App "()"+ (List []),App "InfixApp" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "b"])])]),App "QVarOp" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Symbol" (List [App "()" (List []),String "=="])])]),App "App"+ (List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "length"])])]),App "List" (List [App "()" (List []+ ),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])]),List []]))])])]),App "App" (List [App "()" (List []),+ App "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "toEnum"])])+ ]),App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (+ List []),Int 0,ShowInt (Int 0)])])]),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "toEnum"])])]),App "Paren" (List [App "()" (List []),App+ "InfixApp" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "b"])])]),App "QVarOp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Symbol" (+ List [App "()" (List []),String "+"])])]),App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+ Int 1)])])])])])])]),App "Just" (List [App "BDecls" (List [App+ "()" (List []),List [App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "b"])]),App "UnGuardedRhs" (List [App "()" (List []),+ App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "fromEnum"])])]),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "a"])])])])]),App "Nothing" (List+ [])])]])])])]])]),App "InsDecl" (List [App "()" (List []),App+ "FunBind" (List [App "()" (List []),List [App "Match" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "pred"+ ]),List [App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "a"])])],App "UnGuardedRhs" (List [App+ "()" (List []),App "If" (List [App "()" (List []),App "InfixApp" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "b"])])]),App "QVarOp" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Symbol" (List [App+ "()" (List []),String "=="])])]),App "Lit" (List [App "()" (List [+ ]),App "Int" (List [App "()" (List []),Int 0,ShowInt (Int 0)])])])+ ,App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "toEnum"])])]),App "Paren" (List [App+ "()" (List []),App "App" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "length"])])]),App "List"+ (List [App "()" (List []),MapCtor (App "RecConstr" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),List []]))])])])]),App "App" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "toEnum"])])]),App "Paren" (List [App "()" (List [+ ]),App "InfixApp" (List [App "()" (List []),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "b"])])]),App "QVarOp" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Symbol"+ (List [App "()" (List []),String "-"])])]),App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+ Int 1)])])])])])])]),App "Just" (List [App "BDecls" (List [App+ "()" (List []),List [App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "b"])]),App "UnGuardedRhs" (List [App "()" (List []),+ App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "fromEnum"])])]),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "a"])])])])]),App "Nothing" (List+ [])])]])])])]])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Fold.hs view
@@ -0,0 +1,67 @@+-- Contributed by Tim Newsham <newsham -AT- lava -DOT- net>++{-|+ A pseudo derivation. Derive a (non-recursive) fold function for + the type which takes one function per alternative constructor. Each+ function takes the same arguments as the constructor and returns+ a value. When applied to a value the fold function applies the+ function for the matching constructor to the constructor fields.+ This provides a first-class alternative to pattern matching to+ deconstruct the data type.+-}+module Data.Derive.Fold(makeFold) where+{-+test :: Computer++foldComputer :: (Double -> Int -> a) -> (Int -> a) -> Computer -> a+foldComputer f _ (Laptop x1 x2) = f x1 x2+foldComputer _ f (Desktop x1) = f x1++test :: Assoced++foldAssoced :: (typ -> String -> a) -> Assoced typ -> a+foldAssoced f (Assoced x1 x2) = f x1 x2++test :: Either++foldEither :: (a -> c) -> (b -> c) -> Either a b -> c+foldEither f _ (Left x1) = f x1+foldEither _ f (Right x1) = f x1++test :: Bool++foldBool :: a -> a -> Bool -> a+foldBool f _ False = f+foldBool _ f True = f++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.List+import Data.Generics.Uniplate.DataOnly+++makeFold :: Derivation+makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d+++mkFold :: DataDecl -> [Decl ()]+mkFold d | isIdent $ dataDeclName d = [TypeSig () [name n] (foldType d), FunBind () $ zipWith f [0..] $ dataDeclCtors d]+ | otherwise = []+ where+ n = "fold" ++ title (dataDeclName d)+ f i c = Match () (name n) pat (UnGuardedRhs () bod) Nothing+ where pat = replicate i (PWildCard ()) ++ [pVar "f"] ++ replicate (length (dataDeclCtors d) - i - 1) (PWildCard ()) +++ [PParen () $ PApp () (qname $ ctorDeclName c) (map pVar vars)]+ bod = apps (var "f") (map var vars)+ vars = ['x' : show i | i <- [1..length (ctorDeclFields c)]]+++foldType :: DataDecl -> Type ()+foldType d = tyFun $ map f (dataDeclCtors d) ++ [dt, v]+ where+ dt = dataDeclType d+ v = head $ map (tyVar . return) ['a'..] \\ universe dt+ f c = TyParen () $ tyFun $ map snd (ctorDeclFields c) ++ [v]+
+ src/Data/Derive/From.hs view
@@ -0,0 +1,65 @@+{-|+ 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++{-++test :: Sample++fromFirst :: Sample a -> ()+fromFirst First = ()+fromFirst _ = error "fromFirst failed, not a First"++fromSecond :: Sample a -> (a, a)+fromSecond (Second x1 x2) = (x1,x2)+fromSecond _ = error "fromSecond failed, not a Second"++fromThird :: Sample a -> a+fromThird (Third x1) = x1+fromThird _ = error "fromThird failed, not a Third"++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeFrom :: Derivation+makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d+++makeFromCtor :: DataDecl -> CtorDecl -> [Decl ()]+makeFromCtor d c | isIdent n = [TypeSig () [name from] typ, FunBind () $ match : [defMatch | length (dataDeclCtors d) > 1]]+ | otherwise = []+ where+ n = ctorDeclName c+ from = "from" ++ n++ typ = TyFun () (dataDeclType d)+ (tyTuple $ map snd $ ctorDeclFields c)++ match = Match () (name from) [pat] (UnGuardedRhs () rhs) Nothing+ pat = (length vars == 0 ? id $ PParen ()) $ PApp () (qname n) (map pVar vars)+ vars = take (length $ ctorDeclFields c) $ map ((:) 'x' . show) [1..]+ rhs = valTuple $ map var vars++ defMatch = Match () (name from) [PWildCard ()] (UnGuardedRhs () err) Nothing+ err = App () (var "error") $ Lit () $ let s = from ++ " failed, not a " ++ n in String () s (show s)+++tyTuple [] = TyCon () $ Special () $ UnitCon ()+tyTuple [x] = x+tyTuple xs = TyTuple () Boxed xs+++valTuple [] = Con () $ Special () $ UnitCon ()+valTuple [x] = x+valTuple xs = Tuple () Boxed xs
+ src/Data/Derive/Has.hs view
@@ -0,0 +1,40 @@+{-|+ 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++{-+test :: Computer++hasSpeed :: Computer -> Bool+hasSpeed _ = True++hasWeight :: Computer -> Bool+hasWeight Laptop{} = True+hasWeight _ = False++test :: Sample+-}++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.List+++makeHas :: Derivation+makeHas = derivationCustom "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d+++makeHasField :: DataDecl -> String -> [Decl ()]+makeHasField d field = if isIdent field then [TypeSig () [name has] typ, binds has ms] else []+ where+ has = "has" ++ title field+ typ = TyFun () (dataDeclType d) (tyCon "Bool")+ (yes,no) = partition (elem field . map fst . ctorDeclFields) $ dataDeclCtors d+ match pat val = ([pat], con val)++ ms | null no = [match (PWildCard ()) "True"]+ | otherwise = [match (PRec () (qname $ ctorDeclName c) []) "True" | c <- yes] ++ [match (PWildCard ()) "False"]
+ src/Data/Derive/Instance/Arities.hs view
@@ -0,0 +1,14 @@+-- GENERATED START+{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}++module Data.Derive.Instance.Arities where++import Data.Derive.Class.Arities+import Data.Derive.Internal.Instance++instance Data d_type => Arities d_type where+ arities _+ = [const (d_ctorArity d_ctor) (d_ctorValue d_ctor :: d_type) |+ d_ctor <- d_dataCtors (undefined :: d_type)]++-- GENERATED STOP
+ src/Data/Derive/Internal/Derivation.hs view
@@ -0,0 +1,46 @@++module Data.Derive.Internal.Derivation(+ Derivation(..),+ derivationParams, derivationCustom, derivationDSL, derivationCustomDSL,+ customSplice, customContext+ ) where++import Data.DeriveDSL+import Data.Derive.DSL.HSE+import Data.Generics.Uniplate.DataOnly+++data Derivation = Derivation+ {derivationName :: String+ ,derivationOp :: Type () -> (String -> Decl ()) -> FullDataDecl -> Either String [Decl ()]+ }+++derivationParams :: String -> ([Type ()] -> (String -> Decl ()) -> FullDataDecl -> Either String [Decl ()]) -> Derivation+derivationParams name op = Derivation name $ \ty grab decs -> op (snd $ fromTyApps $ fromTyParen ty) grab decs+++derivationCustom :: String -> (FullDataDecl -> Either String [Decl ()]) -> Derivation+derivationCustom name op = derivationParams name $ \ty grab decs -> op decs+++derivationDSL :: String -> DSL -> Derivation+derivationDSL name dsl = derivationCustomDSL name (const id) dsl+++derivationCustomDSL :: String -> (FullDataDecl -> [Decl ()] -> [Decl ()]) -> DSL -> Derivation+derivationCustomDSL name custom dsl = derivationCustom name $+ \d -> case applyDSL dsl $ snd d of+ Left x -> Left x+ Right x -> Right $ simplify $ custom d x+++customSplice :: (FullDataDecl -> Exp () -> Exp ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()])+customSplice custom d = transformBi f+ where+ f (SpliceExp () (ParenSplice () x)) = custom d x+ f x = x+++customContext :: (FullDataDecl -> Context () -> Context ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()])+customContext custom ds = transformBi (custom ds)
+ src/Data/Derive/Internal/Instance.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE ExistentialQuantification #-}++module Data.Derive.Internal.Instance(+ Data, d_ctorArity, d_ctorValue, d_dataCtors+ ) where++import Data.Data+import Control.Monad+import Control.Monad.Trans.State+++data Ctor = Ctor+ {ctorType :: Box+ ,ctorRep :: Constr}+++data Box = forall a . Data a => Box a+++d_ctorArity :: Ctor -> Int+d_ctorArity Ctor{ctorType=Box t, ctorRep=rep} = flip execState 0 $+ liftM (`asTypeOf` t) $+ fromConstrM (modify (+1) >> return undefined) rep+++d_ctorValue :: Data a => Ctor -> a+d_ctorValue = error "TODO: d_ctorValue"+++d_dataCtors :: Data a => a -> [Ctor]+d_dataCtors x+ | not $ isAlgType t = error "d_dataCtors only works on algebraic data types"+ | otherwise = map (Ctor $ Box x) $ dataTypeConstrs t+ where t = dataTypeOf x
+ src/Data/Derive/Internal/Traversal.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE CPP #-}+{-+ This module is not written/maintained by the usual Data.Derive author.++ MAINTAINER: Twan van Laarhoven+ EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"++ Please send all patches to this module to Neil (ndmitchell -at- gmail),+ and CC Twan.+-}++-- NOTE: Cannot be guessed as it relies on type information++-- | Derives 'Functor' and similair classes, as discussed on the Haskell-prime mailing list:+-- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.+module Data.Derive.Internal.Traversal(+ TraveralType(..), defaultTraversalType,+ traversalDerivation1,+ traversalInstance, traversalInstance1,+ deriveTraversal+ ) where++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.List+import qualified Data.Set as S+import Control.Monad.Trans.Writer+import Control.Applicative+import Data.Generics.Uniplate.DataOnly+import Data.Maybe+import Prelude++---------------------------------------------------------------------------------+-- Information datatype, public interface++-- | An expression representing a traversal of a subpart of the data+type Trav = Exp ()++-- | What kind of traversal are we deriving?+data TraveralType = TraveralType+ { traversalArg :: Int -- ^ On what position are we traversing?+ , traversalCo :: Bool -- ^ covariant?+ , traversalName :: QName () -- ^ name of the traversal function+ , traversalId :: Trav -- ^ Identity traversal+ , traversalDirect :: Trav -- ^ Traversal of 'a'+ , traversalFunc :: QName () -> Trav -> Trav -- ^ Apply the sub-traversal function+ , traversalPlus :: Trav -> Trav -> Trav -- ^ Apply two non-identity traversals in sequence+ , traverseArrow :: Maybe (Trav -> Trav -> Trav) -- ^ Traverse a function type+ , traverseTuple :: [Exp ()] -> Exp () -- ^ Construct a tuple from applied traversals+ , traverseCtor :: String -> [Exp ()] -> Exp () -- ^ Construct a data type from applied traversals+ , traverseFunc :: Pat () -> Exp () -> Match () -- ^ Construct a clause of the traversal function+ }++defaultTraversalType = TraveralType+ { traversalArg = 1+ , traversalCo = False+ , traversalName = undefined -- prevent warnings+ , traversalId = var "id"+ , traversalDirect = var "_f"+ , traversalFunc = \x y -> appP (Var () x) y+ , traversalPlus = \x y -> apps (Con () $ Special () (Cons ())) [paren x, paren y]+ , traverseArrow = Nothing+ , traverseTuple = Tuple () Boxed+ , traverseCtor = \x y -> apps (con x) (map paren y)+ , traverseFunc = undefined+ }++data RequiredInstance = RequiredInstance+ { _requiredDataArg :: String -- ^ What argument of the current data type?+ , _requiredPosition :: Int -- ^ What argument position of that type?+ }+ deriving (Eq, Ord)++-- | Monad that collects required instances+type WithInstances a = Writer (S.Set RequiredInstance) a+++vars f c n = [f $ c : show i | i <- [1..n]]+++---------------------------------------------------------------------------------+-- Deriving traversals+++-- | Derivation for a Traversable like class with just 1 method+traversalDerivation1 :: TraveralType -> String -> Derivation+traversalDerivation1 tt nm = derivationCustom (className $ traversalArg tt) (traversalInstance1 tt nm)+ where className n = nm ++ (if n > 1 then show n else "")+++-- | Instance for a Traversable like class with just 1 method+traversalInstance1 :: TraveralType -> String -> FullDataDecl -> Either String [Decl ()]+traversalInstance1 tt nm (_,dat)+ | isNothing (traverseArrow tt) && any isTyFun (universeBi dat) = Left $ "Can't derive " ++ prettyPrint (traversalName tt) ++ " for types with arrow"+ | dataDeclArity dat == 0 = Left "Cannot derive class for data type arity == 0"+ | otherwise = Right $ traversalInstance tt nm dat [deriveTraversal tt dat]+++-- InstDecl SrcLoc (Maybe Overlap) [TyVarBind] Context QName [Type] [InstDecl]+-- InstDecl l (Maybe (Overlap l)) (InstRule l) (Maybe [InstDecl l])++-- | Instance for a Traversable like class+traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances (Decl ())] -> [Decl ()]+traversalInstance tt nameBase dat bodyM = -- [simplify $ InstDecl () Nothing [] ctx nam args (map InsDecl body)]+ [ simplify $ InstDecl () Nothing instRule (Just $ map (InsDecl ()) body) ]+ where+ instRule = IRule () Nothing (Just ctx) instHead+ instHead = foldr (flip (IHApp ())) (IHCon () nam) args+ (body, required) = runWriter (sequence bodyM)+ ctx = CxTuple ()+ [ ClassA () (qname $ className p) (tyVar n : vars tyVar 's' (p - 1))+ | RequiredInstance n p <- S.toList required+ ]+ vrs = vars tyVar 't' (dataDeclArity dat)+ (vrsBefore,_:vrsAfter) = splitAt (length vrs - traversalArg tt) vrs+ className n = nameBase ++ (if n > 1 then show n else "")+ nam = qname (className (traversalArg tt))+ args = TyParen () (tyApps (tyCon $ dataDeclName dat) vrsBefore) : vrsAfter++-- Match SrcLoc Name [Pat] (Maybe Type) Rhs (Maybe Binds)+-- Match l (Name l) [Pat l] (Rhs l) (Maybe (Binds l))+-- | Derive a 'traverse' like function+deriveTraversal :: TraveralType -> DataDecl -> WithInstances (Decl ())+deriveTraversal tt dat = fun+ where+ fun = (\xs -> FunBind () [Match () nam a b c | Match () _ a b c <- xs]) <$> body+ args = argPositions dat+ nam = unqual $ traversalNameN tt $ traversalArg tt+ body = mapM (deriveTraversalCtor tt args) (dataDeclCtors dat)++ unqual (Qual () _ x) = x+ unqual (UnQual () x) = x+++-- | Derive a clause of a 'traverse' like function for a constructor+deriveTraversalCtor :: TraveralType -> ArgPositions -> CtorDecl -> WithInstances (Match ())+deriveTraversalCtor tt ap ctor = do+ let nam = ctorDeclName ctor+ arity = ctorDeclArity ctor+ tTypes <- mapM (deriveTraversalType tt ap) (map snd $ ctorDeclFields ctor)+ return $ traverseFunc tt (PParen () $ PApp () (qname nam) (vars pVar 'a' arity))+ $ traverseCtor tt nam (zipWith (App ()) tTypes (vars var 'a' arity))++++-- | Derive a traversal for a type+deriveTraversalType :: TraveralType -> ArgPositions -> Type () -> WithInstances Trav+deriveTraversalType tt ap (TyParen () x) = deriveTraversalType tt ap x+deriveTraversalType tt ap TyForall{} = fail "forall not supported in traversal deriving"+deriveTraversalType tt ap (TyFun () a b)+ = fromJust (traverseArrow tt)+ <$> deriveTraversalType tt{traversalCo = not $ traversalCo tt} ap a+ <*> deriveTraversalType tt ap b+deriveTraversalType tt ap (TyApp () a b) = deriveTraversalApp tt ap a [b] -- T a b c ...+deriveTraversalType tt ap (TyList () a) = deriveTraversalType tt ap $ TyApp () (TyCon () $ Special () $ ListCon ()) a+deriveTraversalType tt ap (TyTuple () b a) = deriveTraversalType tt ap $ tyApps (TyCon () $ Special () $ TupleCon () b $ length a) a+deriveTraversalType tt ap (TyCon () n) = return $ traversalId tt -- T+deriveTraversalType tt ap (TyVar () (Ident () n)) -- a+ | ap n /= traversalArg tt = return $ traversalId tt+ | traversalCo tt = fail "tyvar used in covariant position"+ | otherwise = return $ traversalDirect tt+++-- | Find all arguments to a type application, then derive a traversal+deriveTraversalApp :: TraveralType -> ArgPositions -> Type () -> [Type ()] -> WithInstances Trav+deriveTraversalApp tt ap (TyApp () a b) args = deriveTraversalApp tt ap a (b : args)+deriveTraversalApp tt ap tycon@TyTuple{} args = do -- (a,b,c)+ tArgs <- mapM (deriveTraversalType tt ap) args+ return $+ if (all (== traversalId tt) tArgs) then+ traversalId tt+ else+ Lambda () [PTuple () Boxed (vars pVar 't' (length args))]+ (traverseTuple tt $ zipWith (App ()) tArgs (vars var 't' (length args)))+deriveTraversalApp tt ap tycon args = do -- T a b c+ tCon <- deriveTraversalType tt ap tycon+ tArgs <- mapM (deriveTraversalType tt ap) args+ -- need instances?+ case tycon of+ TyVar () (Ident () n) | ap n == traversalArg tt -> fail "kind error: type used type constructor"+ | otherwise -> tell $ S.fromList+ [ RequiredInstance n i+ | (t,i) <- zip (reverse tArgs) [1..]+ , t /= traversalId tt+ ]+ _ -> return ()+ -- combine non-id traversals+ let nonId = [ traverseArg tt i t+ | (t,i) <- zip (reverse tArgs) [1..]+ , t /= traversalId tt+ ]+ return $ case nonId of+ [] -> traversalId tt -- no interesting arguments to type con+ _ -> foldl1 (traversalPlus tt) nonId+++-- | Lift a traversal to the argument of a type constructor+traverseArg :: TraveralType -> Int -> Trav -> Trav+traverseArg tt n e = traversalFunc tt (traversalNameN tt n) e++traversalNameN :: TraveralType -> Int -> QName ()+traversalNameN tt n | n <= 1 = nm+ | otherwise = nm `f` (if n > 1 then show n else "")+ where nm = traversalName tt+ f (Qual () m x) y = Qual () m $ x `g` y+ f (UnQual () x) y = UnQual () $ x `g` y+ g (Ident () x) y = Ident () $ x ++ y++-- | Information on argument positions+type ArgPositions = String -> Int++-- | Position of an argument in the data type+-- In the type "data X a b c"+-- positions are: a -> 3, b -> 2, c -> 1+argPositions :: DataDecl -> String -> Int+argPositions dat = \nm -> case elemIndex nm args of+ Nothing -> error "impossible: tyvar not in scope"+ Just k -> length args - k+ where args = dataDeclVars dat
+ src/Data/Derive/Is.hs view
@@ -0,0 +1,33 @@+module Data.Derive.Is(makeIs) where+{-++test :: Sample++isFirst :: Sample a -> Bool+isFirst (First{}) = True ; isFirst _ = False++isSecond :: Sample a -> Bool+isSecond (Second{}) = True ; isSecond _ = False++isThird :: Sample a -> Bool+isThird (Third{}) = True ; isThird _ = False++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeIs :: Derivation+makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d+++makeIsCtor :: DataDecl -> CtorDecl -> [Decl ()]+makeIsCtor d c = if not $ isIdent $ ctorDeclName c then [] else+ [TypeSig () [name nam] (TyFun () (dataDeclType d) (tyCon "Bool"))+ ,FunBind () $ match : [defMatch | length (dataDeclCtors d) > 1]]+ where+ nam = "is" ++ ctorDeclName c+ + match = Match () (name nam) [PParen () $ PRec () (qname $ ctorDeclName c) []] (UnGuardedRhs () $ con "True") Nothing+ defMatch = Match () (name nam) [PWildCard ()] (UnGuardedRhs () $ con "False") Nothing
+ src/Data/Derive/JSON.hs view
@@ -0,0 +1,178 @@+-- |+-- Copyright: (c) Bertram Felgenhauer 2009+-- License: BSD3+-- Stability: experimental+-- Portability: portable+--+-- Derive 'Text.JSON' instances.+--+-- Unlike Text.JSON.Generics, single constructor types are /not/ handled+-- specially. Every value is encoded as an object with a single field,+-- with the constructor name as key and the values as its contents.+--+-- If the constructor is a record, the contents is an Object with the+-- field names as keys. Otherwise, the contents is an array.++module Data.Derive.JSON (makeJSON) where++import qualified Language.Haskell as H+import Language.Haskell (+ Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, Type, Stmt,+ (~=), var, pVar, con, strE, strP, apps, qname,+ ctorDeclFields, ctorDeclName, dataDeclCtors)++{-+import "json" Text.JSON+import Text.JSON.Types++example :: Custom+instance JSON a => JSON (Sample a) where+ readJSON (JSObject x) = $(readJSON)+ readJSON _ = Error "..."+ showJSON (First) = $(showJSON 0)+ showJSON (Second x1 x2) = $(showJSON 1)+ showJSON (Third x1) = $(showJSON 2)+-}++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeJSON :: Derivation+makeJSON = derivationCustomDSL "JSON" custom $+ List [Instance ["JSON"] "JSON" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),List [App "Match" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "readJSON"]),List [App "PParen" (+ List [App "()" (List []),App "PApp" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "JSObject"])]),List [App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "x"])])]])])+ ],App "UnGuardedRhs" (List [App "()" (List []),App "SpliceExp" (+ List [App "()" (List []),App "ParenSplice" (List [App "()" (List [+ ]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "readJSON"])])])])])]),App "Nothing" (List [])]),App "Match" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "readJSON"]),List [App "PWildCard" (List [App "()" (List [])])],+ App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Con" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "Error"])])]),App "Lit" (List [App "()" (List []),App+ "String" (List [App "()" (List []),String "...",String "..."])])])+ ]),App "Nothing" (List [])])]])]),App "InsDecl" (List [App "()" (+ List []),App "FunBind" (List [App "()" (List []),MapCtor (App+ "Match" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "showJSON"]),List [App "PParen" (List [App "()" (+ List []),App "PApp" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),CtorName]+ )]),MapField (App "PVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),Concat (List [String "x",ShowInt+ FieldIndex])])]))])])],App "UnGuardedRhs" (List [App "()" (List []+ ),App "SpliceExp" (List [App "()" (List []),App "ParenSplice" (+ List [App "()" (List []),App "App" (List [App "()" (List []),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "showJSON"])])]),+ App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (+ List []),CtorIndex,ShowInt CtorIndex])])])])])]),App "Nothing" (+ List [])]))])])]]))]+-- GENERATED STOP++-- ^ 'Derivation' for 'JSON'++custom :: FullDataDecl -> [Decl ()] -> [Decl ()]+custom = customSplice splice++splice :: FullDataDecl -> Exp () -> Exp ()+splice d x | x ~= "readJSON" = mkRead d+splice d (H.App _ x (H.Lit _ (H.Int _ y _))) | x~= "showJSON" = mkShow d y+splice _ e = error $ "makeJSON: unrecognized splice: " ++ show e++------------------------------------------------------------------------------+-- showJSON++mkShow :: FullDataDecl -> Integer -> Exp ()+mkShow d y = let+ hasFields = any (not . null . fst) (ctorDeclFields c)+ c = dataDeclCtors (snd d) !! fromInteger y+ mkFields = if hasFields then mkShowRecordFields else mkShowPlainFields+ in+ mkJSObject $ H.List ()+ [H.Tuple () H.Boxed [strE (ctorDeclName c), mkFields (ctorDeclFields c)]]++mkShowPlainFields :: FieldDecl -> Exp ()+mkShowPlainFields fs = mkJSArray $ H.List ()+ [H.App () (var "showJSON") xi | xi <- vars "x" fs]++mkShowRecordFields :: FieldDecl -> Exp ()+mkShowRecordFields fs = mkJSObject $ H.List ()+ [ H.Tuple () H.Boxed [strE fn, H.App () (var "showJSON") xi]+ | ((fn, _), xi) <- zip fs (vars "x" fs)]++------------------------------------------------------------------------------+-- readJSON++mkRead :: FullDataDecl -> Exp ()+mkRead (_, d) = let+ readError = H.App () (con "Error") $ strE "malformed JSON for type ...: ..."+ in+ H.Case () (H.App () (var "fromJSObject") $ var "x") $+ map mkReadCtor (dataDeclCtors d) +++ [H.Alt () (H.PWildCard ()) (H.UnGuardedRhs () readError) Nothing]++mkReadCtor :: CtorDecl -> Alt ()+mkReadCtor c = let+ cn = ctorDeclName c+ fs = ctorDeclFields c+ hasFields = any (not . null . fst) fs+ body | hasFields = mkReadRecord cn fs+ | otherwise = mkReadPlain cn fs+ in+ H.Alt () (H.PList () [H.PTuple () H.Boxed [strP cn, pVar "y"]])+ (H.UnGuardedRhs () body) Nothing++mkReadRecord :: String -> FieldDecl -> Exp ()+mkReadRecord cn fs = H.Do () $+ [H.Generator () (H.PApp () (qname "JSObject") [pVar "z"])+ (H.App () (var "return") $ var "y")] +++ [H.LetStmt () $ H.BDecls () [H.PatBind () (pVar "d")+ (H.UnGuardedRhs () $ H.App () (var "fromJSObject") $ var "z")+ Nothing]] +++ zipWith (mkReadRecordField cn) (pVars "x" fs) fs +++ mkReadTrailer cn fs++mkReadRecordField :: String -> Pat () -> (String, Type ()) -> Stmt ()+mkReadRecordField cn xi (fn, _) = H.Generator () xi $+ apps (var "maybe") [+ H.App () (var "fail") $ strE (unwords ["readJSON: missing field", fn,+ "while decoding a", cn]),+ var "return",+ apps (var "lookup") [strE fn, var "d"]]++mkReadPlain :: String -> FieldDecl -> Exp ()+mkReadPlain cn fs = H.Do () $+ [H.Generator () (H.PApp () (qname "JSArray") [H.PList () (pVars "x" fs)])+ (H.App () (var "return") $ var "y")] +++ mkReadTrailer cn fs++mkReadTrailer :: String -> FieldDecl -> [Stmt ()]+mkReadTrailer cn fs =+ [ H.Generator () yi (H.App () (var "readJSON") xi)+ | (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] +++ [H.Qualifier () $ H.App () (var "return") $ apps (con cn) (vars "y" fs)]++------------------------------------------------------------------------------+-- utilites++mkJSObject :: Exp () -> Exp ()+mkJSObject e = H.App () (con "JSObject") (H.App () (var "toJSObject") e)++mkJSArray :: Exp () -> Exp ()+mkJSArray e = H.App () (con "JSArray") e++vars :: String -> FieldDecl -> [Exp ()]+vars pre fs = [var (pre ++ show i) | i <- [1..length fs]]++pVars :: String -> FieldDecl -> [Pat ()]+pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]]
+ src/Data/Derive/LazySet.hs view
@@ -0,0 +1,39 @@+{-|+ A pseudo derivation. For each field in the data type, deriving+ @LazySet@ generates a function like a record updator, but lazy where possible.+ This is very useful in certain situations to improve laziness+ properties. A setter is only lazy if that field is present in one constructor.+-}+module Data.Derive.LazySet(makeLazySet) where+{-++test :: Computer++setSpeed :: Int -> Computer -> Computer+setSpeed v x = x{speed=v}++setWeight :: Double -> Computer -> Computer+setWeight v x = Laptop v (speed x)++test :: Sample++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeLazySet :: Derivation+makeLazySet = derivationCustom "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d+++makeLazySetField :: DataDecl -> String -> [Decl ()]+makeLazySetField d field = if isIdent field then [TypeSig () [name fun] typ, bind fun [pVar "v",pVar "x"] bod] else []+ where+ fun = "set" ++ title field+ tyFun = TyFun ()+ typ = t `tyFun` (dataDeclType d `tyFun` dataDeclType d)+ (t,c):tc = [(t,c) | c <- dataDeclCtors d, (n,t) <- ctorDeclFields c, n == field]++ bod | null tc = apps (con $ ctorDeclName c) [n == field ? var "v" $ Paren () $ App () (var n) (var "x") | (n,t) <- ctorDeclFields c]+ | otherwise = RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")]
+ src/Data/Derive/Lens.hs view
@@ -0,0 +1,41 @@+{-|+ A pseudo derivation. For each field in the data type, deriving+ @Lens@ generates @lens@/FieldName/@ = lens @/fieldName/@+ (\ x v -> v { @/fieldName/@ = x })@.++ This works with the @data-lens@ package.+-}+module Data.Derive.Lens(makeLens) where++{-+import "data-lens" Data.Lens.Common++test :: Sample++test :: Computer++lensSpeed :: Lens Computer Int+lensSpeed = lens speed (\x v -> v{speed = x})++lensWeight :: Lens Computer Double+lensWeight = lens weight (\x v -> v{weight = x})+-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeLens :: Derivation+makeLens = derivationCustom "Lens" $ \(_,d) -> Right $ concatMap (makeLensField d) $ dataDeclFields d+++makeLensField :: DataDecl -> String -> [Decl ()]+makeLensField d field = if isIdent field then [TypeSig () [name ref] typ, bind ref [] bod] else []+ where+ ref = "lens" ++ title field+ typ = tyApps (tyCon "Lens") [dataDeclType d, t]+ Just t = lookup field $ concatMap ctorDeclFields $ dataDeclCtors d++ bod = apps (var "lens")+ [var field+ ,Paren () $ Lambda () [pVar "x",pVar "v"] $ RecUpdate () (var "v") [FieldUpdate () (qname field) (var "x")]]
+ src/Data/Derive/Monoid.hs view
@@ -0,0 +1,93 @@+{-|+ Derives an instance of @Monoid@. It uses the product+ construction of monoids. @mappend@ on two different constructors+ is undefined.+-}+module Data.Derive.Monoid(makeMonoid) where+{-+import Data.Monoid hiding (First)++example :: Sample+instance Monoid a => Monoid (Sample a) where+ mempty = head [First, Second (const mempty 1) (const mempty 2), Third (const mempty 1)]+ mappend (First) (First) = First+ mappend (Second x1 x2) (Second y1 y2) = Second (mappend x1 y1) (mappend x2 y2)+ mappend (Third x1) (Third y1) = Third (mappend x1 y1)+ mappend _ _ | length [First{},Second{},Third{}] > 1 = error "Monoid.mappend: Different constructors for Sample"++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeMonoid :: Derivation+makeMonoid = derivationDSL "Monoid" dslMonoid++dslMonoid =+ List [Instance ["Monoid"] "Monoid" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "mempty"])]),App "UnGuardedRhs" (List [+ App "()" (List []),App "App" (List [App "()" (List []),App "Var" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "head"])])]),App+ "List" (List [App "()" (List []),MapCtor (Application (Concat (+ List [List [App "Con" (List [App "()" (List []),App "UnQual" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),CtorName+ ])])])],MapField (App "Paren" (List [App "()" (List []),+ Application (List [App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "const"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "mempty"])])]),App "Lit" (List [App "()" (List []+ ),App "Int" (List [App "()" (List []),FieldIndex,ShowInt+ FieldIndex])])])]))])))])])]),App "Nothing" (List [])])]),App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),Concat (List [MapCtor (App "Match" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "mappend"]),List+ [App "PParen" (List [App "()" (List []),App "PApp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])]))])]),App "PParen" (List [App+ "()" (List []),App "PApp" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])]),MapField (App "PVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),Concat (List [String "y",ShowInt+ FieldIndex])])]))])])],App "UnGuardedRhs" (List [App "()" (List []+ ),Application (Concat (List [List [App "Con" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),CtorName])])])],MapField (App "Paren" (List [App+ "()" (List []),Application (List [App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "mappend"])])]),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])]+ )])]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "y",ShowInt FieldIndex])])])])])]))]))]),App "Nothing" (+ List [])])),List [App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "mappend"]),List [App+ "PWildCard" (List [App "()" (List [])]),App "PWildCard" (List [App+ "()" (List [])])],App "GuardedRhss" (List [App "()" (List []),List+ [App "GuardedRhs" (List [App "()" (List []),List [App "Qualifier"+ (List [App "()" (List []),App "InfixApp" (List [App "()" (List [])+ ,App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "length"])])]),App "List" (List [App+ "()" (List []),MapCtor (App "RecConstr" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),CtorName])]),List []]))])]),App "QVarOp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Symbol" (+ List [App "()" (List []),String ">"])])]),App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+ Int 1)])])])])],App "App" (List [App "()" (List []),App "Var" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "error"])])]),App+ "Lit" (List [App "()" (List []),App "String" (List [App "()" (List+ []),Concat (List [String+ "Monoid.mappend: Different constructors for ",DataName]),Concat (+ List [String "Monoid.mappend: Different constructors for ",+ DataName])])])])])]]),App "Nothing" (List [])])]])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/NFData.hs view
@@ -0,0 +1,42 @@+module Data.Derive.NFData where+{-+import "deepseq" Control.DeepSeq(NFData, rnf)++example :: Sample+instance NFData a => NFData (Sample a) where+ rnf (First) = ()+ rnf (Second x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (Third x1) = rnf x1 `seq` ()++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeNFData :: Derivation+makeNFData = derivationDSL "NFData" dslNFData++dslNFData =+ List [Instance ["NFData"] "NFData" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),MapCtor (App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "rnf"]),List [App+ "PParen" (List [App "()" (List []),App "PApp" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])]))])])],App "UnGuardedRhs" (+ List [App "()" (List []),Fold (App "InfixApp" (List [App "()" (+ List []),Head,App "QVarOp" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "seq"])])]),Tail])) (Concat (List [MapField (App "App" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "rnf"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),Concat (List [String "x",ShowInt FieldIndex])])])])])),+ List [App "Con" (List [App "()" (List []),App "Special" (List [App+ "()" (List []),App "UnitCon" (List [App "()" (List [])])])])]]))])+ ,App "Nothing" (List [])]))])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Ref.hs view
@@ -0,0 +1,42 @@+{-|+ A pseudo derivation. For each field in the data type, deriving+ @Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =+ \ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@.++ This is intended for use with the compositional functional references+ described in+ <http://www.haskell.org/pipermail/haskell-cafe/2007-June/026477.html>.+-}+module Data.Derive.Ref(makeRef) where++{-+test :: Sample++test :: Computer++refSpeed :: Ref Computer+refSpeed = Ref {select = speed, update = \f v -> v{speed = f (speed v)}}++refWeight :: Ref Computer+refWeight = Ref {select = weight, update = \f v -> v{weight = f (weight v)}}+-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeRef :: Derivation+makeRef = derivationCustom "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d+++makeRefField :: DataDecl -> String -> [Decl ()]+makeRefField d field = if isIdent field then [TypeSig () [name ref] typ, bind ref [] bod] else []+ where+ ref = "ref" ++ title field+ typ = TyApp () (tyCon "Ref") (dataDeclType d)++ bod = RecConstr () (qname "Ref")+ [FieldUpdate () (qname "select") (var field)+ ,FieldUpdate () (qname "update") $ Lambda () [pVar "f",pVar "v"] $+ RecUpdate () (var "v") [FieldUpdate () (qname field) $ App () (var "f") $ Paren () $ App () (var field) (var "v")]+ ]
+ src/Data/Derive/Serial.hs view
@@ -0,0 +1,84 @@+module Data.Derive.Serial where+{-+import "smallcheck" Test.SmallCheck++example :: Sample++instance Serial a => Serial (Sample a) where+ series = cons0 First \/+ cons2 Second \/+ cons1 Third++ coseries rs d = [ \t -> case t of+ First -> t0+ Second x1 x2 -> t1 x1 x2+ Third x1 -> t2 x1+ | t0 <- alts0 rs d `const` First{}+ , t1 <- alts2 rs d `const` Second{}+ , t2 <- alts1 rs d `const` Third{}+ ]++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeSerial :: Derivation+makeSerial = derivationDSL "Serial" dslSerial++dslSerial =+ List [Instance ["Serial"] "Serial" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "series"])]),App "UnGuardedRhs" (List [+ App "()" (List []),Fold (App "InfixApp" (List [App "()" (List []),+ Tail,App "QVarOp" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Symbol" (List [App "()" (List []),String+ "\\/"])])]),Head])) (Reverse (MapCtor (App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),Concat (+ List [String "cons",ShowInt CtorArity])])])]),App "Con" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),CtorName])])])]))))]),App "Nothing" (+ List [])])]),App "InsDecl" (List [App "()" (List []),App "FunBind"+ (List [App "()" (List []),List [App "Match" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "coseries"]),List+ [App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "rs"])]),App "PVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "d"])])],App+ "UnGuardedRhs" (List [App "()" (List []),App "ListComp" (List [App+ "()" (List []),App "Lambda" (List [App "()" (List []),List [App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "t"])])],App "Case" (List [App "()" (List []),App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "t"])])]),MapCtor (+ App "Alt" (List [App "()" (List []),App "PApp" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])]))]),App "UnGuardedRhs" (List [+ App "()" (List []),Application (Concat (List [List [App "Var" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),Concat (List [String "t",+ ShowInt CtorIndex])])])])],MapField (App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])]+ )])]))]))]),App "Nothing" (List [])]))])]),MapCtor (App "QualStmt"+ (List [App "()" (List []),App "Generator" (List [App "()" (List []+ ),App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),Concat (List [String "t",ShowInt CtorIndex])])]),App+ "InfixApp" (List [App "()" (List []),Application (List [App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),Concat (List [String "alts",+ ShowInt CtorArity])])])]),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "rs"])])]),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "d"])])])]),App "QVarOp" (List [App "()" (List [])+ ,App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "const"])])]),App "RecConstr" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),CtorName])]),List []])])])]))])]),App+ "Nothing" (List [])])]])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Serialize.hs view
@@ -0,0 +1,182 @@+module Data.Derive.Serialize where+{-+import "cereal" Data.Serialize++example :: Sample++instance Serialize alpha => Serialize (Sample alpha) where+ put x = case x of+ First -> do putTag 0+ Second x1 x2 -> do putTag 1 ; put x1 ; put x2+ Third x1 -> do putTag 2 ; put x1+ where+ useTag = length [First{}, Second{}, Third{}] > 1+ putTag x = when useTag (putWord8 x)++ get = do+ i <- getTag+ case i of+ 0 -> do return (First)+ 1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)+ 2 -> do x1 <- get ; return (Third x1)+ _ -> error "Corrupted binary data for Sample"+ where+ useTag = length [First{}, Second{}, Third{}] > 1+ getTag = if useTag then getWord8 else return 0+++test :: List++instance Serialize a => Serialize (List a) where+ put x = case x of+ Nil -> putWord8 0+ Cons x1 x2 -> do putWord8 1; put x1; put x2++ get = do+ i <- getWord8+ case i of+ 0 -> return Nil+ 1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)+ _ -> error "Corrupted binary data for List"++test :: Assoced++instance Serialize typ => Serialize (Assoced typ) where+ put (Assoced x1 x2) = do put x1; put x2+ get = do x1 <- get; x2 <- get; return (Assoced x1 x2)+++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeSerialize :: Derivation+makeSerialize = derivationDSL "Serialize" dslSerialize++dslSerialize =+ List [Instance ["Serialize"] "Serialize" (App "Just" (List [List [+ App "InsDecl" (List [App "()" (List []),App "FunBind" (List [App+ "()" (List []),List [App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "put"]),List [App "PVar"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "x"])])],App "UnGuardedRhs" (List [App "()" (List []),App+ "Case" (List [App "()" (List []),App "Var" (List [App "()" (List [+ ]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "x"])])]),MapCtor (App "Alt" (List [App "()"+ (List []),App "PApp" (List [App "()" (List []),App "UnQual" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),CtorName+ ])]),MapField (App "PVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),Concat (List [String "x",ShowInt+ FieldIndex])])]))]),App "UnGuardedRhs" (List [App "()" (List []),+ App "Do" (List [App "()" (List []),Concat (List [List [App+ "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "putTag"])])]),App "Lit" (List [App "()" (List []),App "Int" (List+ [App "()" (List []),CtorIndex,ShowInt CtorIndex])])])])],MapField+ (App "Qualifier" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "put"])])]),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),Concat (List [String "x",ShowInt FieldIndex])])])])])]))]+ )])]),App "Nothing" (List [])]))])]),App "Just" (List [App+ "BDecls" (List [App "()" (List []),List [App "PatBind" (List [App+ "()" (List []),App "PVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),String "useTag"])]),App "UnGuardedRhs" (+ List [App "()" (List []),App "InfixApp" (List [App "()" (List []),+ App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "length"])])]),App "List" (List [App+ "()" (List []),MapCtor (App "RecConstr" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),CtorName])]),List []]))])]),App "QVarOp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Symbol" (+ List [App "()" (List []),String ">"])])]),App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+ Int 1)])])])]),App "Nothing" (List [])]),App "FunBind" (List [App+ "()" (List []),List [App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "putTag"]),List [App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "x"])])],App "UnGuardedRhs" (List [App "()" (List []),+ Application (List [App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "when"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "useTag"])])]),App "Paren" (List [App "()" (List+ []),App "App" (List [App "()" (List []),App "Var" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),Concat (List [String "putWord",ShowInt (Int 8)+ ])])])]),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "x"])])])])])])]),App "Nothing" (List [])])]])]])])])]])]),App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "get"])]),App "UnGuardedRhs" (List [App+ "()" (List []),App "Do" (List [App "()" (List []),List [App+ "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "i"])]),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "getTag"])])])]),+ App "Qualifier" (List [App "()" (List []),App "Case" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "i"])])]),Concat (List [MapCtor (App "Alt" (List [App "()"+ (List []),App "PLit" (List [App "()" (List []),App "Signless" (+ List [App "()" (List [])]),App "Int" (List [App "()" (List []),+ CtorIndex,ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()"+ (List []),App "Do" (List [App "()" (List []),Concat (List [+ MapField (App "Generator" (List [App "()" (List []),App "PVar" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ Concat (List [String "x",ShowInt FieldIndex])])]),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "get"])])])])),List [App+ "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "return"])])]),App "Paren" (List [App "()" (List []),Application (+ Concat (List [List [App "Con" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),CtorName])])])],MapField (App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+ )]))])])])]])])]),App "Nothing" (List [])])),List [App "Alt" (List+ [App "()" (List []),App "PWildCard" (List [App "()" (List [])]),+ App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "error"])])]),App "Lit" (List [App "()" (List []),App+ "String" (List [App "()" (List []),Concat (List [String+ "Corrupted binary data for ",DataName]),Concat (List [String+ "Corrupted binary data for ",DataName])])])])]),App "Nothing" (+ List [])])]])])])]])]),App "Just" (List [App "BDecls" (List [App+ "()" (List []),List [App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "useTag"])]),App "UnGuardedRhs" (List [App "()" (List [+ ]),App "InfixApp" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "length"])])]),App "List" (List [App "()" (List []),MapCtor+ (App "RecConstr" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),CtorName])]),+ List []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Symbol" (List [App "()" (List []),+ String ">"])])]),App "Lit" (List [App "()" (List []),App "Int" (+ List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]),App+ "Nothing" (List [])]),App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "getTag"])]),App "UnGuardedRhs" (List [App "()" (List [+ ]),App "If" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "useTag"])])]),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),Concat (List [String "getWord",ShowInt (+ Int 8)])])])]),App "App" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "return"])])]),App "Lit"+ (List [App "()" (List []),App "Int" (List [App "()" (List []),Int+ 0,ShowInt (Int 0)])])])])]),App "Nothing" (List [])])]])])])])]]))+ ]+-- GENERATED STOP
+ src/Data/Derive/Set.hs view
@@ -0,0 +1,41 @@+{-|+ 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++{-++test :: Computer++setSpeed :: Int -> Computer -> Computer+setSpeed v x = x{speed=v}++setWeight :: Double -> Computer -> Computer+setWeight v x = x{weight=v}++test :: Sample++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.Maybe+++makeSet :: Derivation+makeSet = derivationCustom "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d+++makeSetField :: DataDecl -> String -> [Decl ()]+makeSetField d field = [TypeSig () [name set] typ, bind set [pVar "v",pVar "x"] bod]+ where+ set = "set" ++ title field+ tyFun = TyFun ()+ typ = typField `tyFun` (dataDeclType d `tyFun` dataDeclType d)+ typField = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d++ bod = RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")]
+ src/Data/Derive/UniplateDirect.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE PatternGuards #-}+-- NOTE: Cannot be guessed as it relies on type information++-- | Derive Uniplate and Biplate using the Direct combinators.+-- You must request monomorphic instances, i.e:+--+-- > data Foo a = Foo a (Bool, a)+-- >+-- > {-!+-- > deriving instance UniplateDirect (Foo Int)+-- > deriving instance UniplateDirect (Bool, Int) Int+-- > deriving instance UniplateDirect (Foo Int) Int+-- > !-}+--+-- This will generate the instances @Uniplate (Foo Int)@,+-- @Biplate (Bool, Int) Int@ and @Biplate (Foo Int) Int@.+-- Generally, start with the instance you are after (e.g. @UniplateDirect (Foo Int)@),+-- try to compile and add further instances as necessary. @UniplateDirect@ with+-- one argument derives Uniplate, and with two arguments derives Biplate.+--+-- @deriving UniplateDirect@ on a data type with no arguments derives Uniplate+-- with all type parameters defaulting to @()@.+module Data.Derive.UniplateDirect(makeUniplateDirect) where+++{-+import "uniplate" Data.Generics.Uniplate.Direct+++-- test tuples+test :: UniplateDirect ((), Maybe ()) ()+instance Biplate ((), Maybe ()) () where+ {-# INLINE biplate #-}+ biplate (x1, x2) = plate (,) |* x1 |+ x2++test :: UniplateDirect (Sample Int)+instance Uniplate (Sample Int) where+ {-# INLINE uniplate #-}+ uniplate x = plate x++test :: UniplateDirect (Sample Int) Int+instance Biplate (Sample Int) Int where+ {-# INLINE biplate #-}+ biplate (Second x1 x2) = plate Second |* x1 |* x2+ biplate (Third x1) = plate Third |* x1+ biplate x = plate x++test :: UniplateDirect Computer+instance Uniplate Computer where+ {-# INLINE uniplate #-}+ uniplate x = plate x++test :: UniplateDirect Computer Computer+instance Biplate Computer Computer where+ {-# INLINE biplate #-}+ biplate = plateSelf++test :: UniplateDirect Computer Double+instance Biplate Computer Double where+ {-# INLINE biplate #-}+ biplate (Laptop x1 x2) = plate Laptop |* x1 |- x2+ biplate x = plate x++test :: UniplateDirect (Assoced (Maybe Bool)) Char+instance Biplate (Assoced (Maybe Bool)) Char where+ {-# INLINE biplate #-}+ biplate (Assoced x1 x2) = plate (Assoced x1) ||* x2++-- test following external declarations+test :: UniplateDirect (Either Bool Computer) Int+instance Biplate (Either Bool Computer) Int where+ {-# INLINE biplate #-}+ biplate (Right x1) = plate Right |+ x1+ biplate x = plate x++-- test recursive bits+test :: UniplateDirect (List Int) Bool+instance Biplate (List Int) Bool where+ {-# INLINE biplate #-}+ biplate x = plate x+-}++import Language.Haskell+import Data.Generics.Uniplate.DataOnly+import Data.Derive.Internal.Derivation+import Data.Maybe+import qualified Data.Map as Map+import Control.Arrow+import Control.Monad.Trans.State+++makeUniplateDirect :: Derivation+makeUniplateDirect = derivationParams "UniplateDirect" $ \args grab (_,ty) -> simplify $+ let known = map (declName &&& id) knownCtors+ grab2 x = fromMaybe (grab x) $ lookup x known+ in case args of+ _ | not $ null [() | TyVar () _ <- universeBi args] -> error "UniplateDirect only accepts monomorphic types"+ [] -> make True grab2 x x+ where x = tyApps (tyCon $ dataDeclName ty) $ replicate (dataDeclArity ty) $ TyCon () $ Special () (UnitCon ())+ [x] -> make True grab2 x x+ [x,y] -> make False grab2 x y+ _ -> error $ "UniplateDirect requires exactly one or two arguments, got " ++ show (length args)++-- alwaysActive :: Activation ()+-- alwaysActive = ActiveFrom () 0++make :: Bool -> (String -> DataDecl) -> Type () -> Type () -> Either String [Decl ()]+make uni grab from to =+ Right [InstDecl () Nothing instRule+ (Just [InsDecl () $ InlineSig () True Nothing (qname $ if uni then "uniplate" else "biplate"), InsDecl () ms])]+ where+ headName = (UnQual () $ Ident () $ if uni then "Uniplate" else "Biplate")+ instRule = IRule () Nothing Nothing (foldr (flip (IHApp ())) (IHCon () headName) (from : [to | not uni]))+ ty = grab $ tyRoot from+ match pat bod = Match () (Ident () $ if uni then "uniplate" else "biplate") [pat] (UnGuardedRhs () bod) Nothing+ ms = if uni || from /= to+ then FunBind () $ map (uncurry match) (catMaybes bods) ++ [match (pVar "x") (App () (var "plate") (var "x")) | any isNothing bods]+ else PatBind () (pVar "biplate") (UnGuardedRhs () $ var "plateSelf") Nothing+ bods = run (fromTyParens to) $ mapM (make1 grab) $ substData from ty+++make1 :: (String -> DataDecl) -> (String,[Type ()]) -> S (Maybe (Pat (), Exp ()))+make1 grab (name,tys) = do+ ops <- mapM (fmap show . operator grab) tys+ let vars = ['x':show i | i <- [1..length tys]]+ pat = PParen () $ PApp () (qname name) $ map pVar vars+ (good,bad) = span ((==) "|-" . fst) $ zip ops $ map var vars+ bod = foldl (\x (y,z) -> InfixApp () x (QVarOp () $ UnQual () $ Symbol () y) z) (App () (var "plate") $ paren $ apps (con name) (map snd good)) bad+ return $ if all (== "|-") ops then Nothing else Just (pat,bod)+++data Ans = Hit | Miss | Try | ListHit | ListTry deriving Eq++instance Show Ans where+ show Hit = "|*"+ show Miss = "|-"+ show Try = "|+"+ show ListHit = "||*"+ show ListTry = "||+"++ansList Hit = ListHit+ansList Miss = Miss+ansList _ = ListTry+++ansJoin (Miss:xs) = ansJoin xs+ansJoin [] = Miss+ansJoin _ = Try+++type S a = State (Map.Map (Type ()) Ans) a++run :: Type () -> S a -> a+run to act = evalState act (Map.singleton to Hit)++operator :: (String -> DataDecl) -> Type () -> S Ans+operator grab from = do+ mp <- get+ case Map.lookup from mp of+ Just y -> return y+ Nothing -> do+ fix Miss+ where+ fix ans = do+ s <- get+ modify $ Map.insert from ans+ ans2 <- operator2 grab from+ if ans == ans2+ then return ans+ else put s >> fix ans2+++operator2 :: (String -> DataDecl) -> Type () -> S Ans+operator2 grab from+ | isTyFun from = return Try+ | Just from2 <- fromTyList from = fmap ansList $ operator grab from2+ | otherwise = case subst from $ grab $ tyRoot from of+ Left from2 -> operator grab from2+ Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs+++subst :: Type () -> Decl () -> Either (Type ()) [(String,[Type ()])]+subst ty x@TypeDecl{} = Left $ substType ty x+subst ty x = Right $ substData ty x++substData :: Type () -> Decl () -> [(String,[Type ()])]+substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat]+ where+ rep = zip (dataDeclVars dat) (snd $ fromTyApps $ fromTyParen ty)+ f (TyVar () x) = fromMaybe (TyVar () x) $ lookup (prettyPrint x) rep+ f x = x++substType :: Type () -> Decl () -> Type ()+substType ty (TypeDecl () dhead d) = fromTyParens $ transform f d+ where+ vars = collect dhead+ rep = zip (map prettyPrint vars) (snd $ fromTyApps ty)+ f (TyVar () x) = fromMaybe (TyVar () x) $ lookup (prettyPrint x) rep+ f x = x+ collect (DHead () _) = []+ collect (DHInfix () bind _) = [bind]+ collect (DHParen () h) = collect h+ collect (DHApp () h bind) = bind : collect h++clearAnn :: Functor f => f a -> f ()+clearAnn = fmap (const ())++knownCtors :: [Decl ()]+knownCtors = map (fromParseResult . fmap clearAnn . parseDecl)+ ["data Int = Int"+ ,"data Bool = Bool"+ ,"data Char = Char"+ ,"data Double = Double"+ ,"data Float = Float"+ ,"data Integer = Integer"+ ,"data Maybe a = Nothing | Just a"+ ,"data Either a b = Left a | Right b"+ ,"type Rational = Ratio Integer"+ ,"data (Integral a) => Ratio a = !a :% !a"+ ,"type String = [Char]"+ ] +++ listCtor :+ map tupleDefn (0:[2..32])++listCtor = DataDecl () (DataType ()) Nothing (DHApp () (DHead () $ Ident () "[]") (UnkindedVar () $ Ident () "a"))+ [QualConDecl () Nothing Nothing $ ConDecl () (Ident () "[]") []+ ,QualConDecl () Nothing Nothing $ ConDecl () (Ident () "(:)") [tyVar "a", TyList () $ tyVar "a"]] []++tupleDefn :: Int -> Decl ()+tupleDefn n = DataDecl () (DataType ()) Nothing dhead [QualConDecl () Nothing Nothing $ ConDecl () (Ident () s) (map tyVar vars)] []+ where s = "(" ++ replicate (n - 1) ',' ++ ")"+ vars = ['v':show i | i <- [1..n]]+ dhead = foldr (flip (DHApp ())) (DHead () $ Ident () s) (map (UnkindedVar () . Ident ()) vars)
+ src/Data/Derive/UniplateTypeable.hs view
@@ -0,0 +1,102 @@+module Data.Derive.UniplateTypeable where+{-+import "uniplate" Data.Generics.Uniplate.Typeable++example :: Custom++instance (Typeable a, PlateAll a to, Uniplate to, Typeable to) => PlateAll (Sample a) to where+ plateAll (First) = plate First+ plateAll (Second x1 x2) = plate Second |+ x1 |+ x2+ plateAll (Third x1) = plate Third |+ x1++test :: Bool++instance (Typeable to, Uniplate to) => PlateAll Bool to where+ plateAll False = plate False+ plateAll True = plate True++test :: Either a b++instance (Typeable a, PlateAll a to, Typeable b, PlateAll b to, Typeable to, Uniplate to) => PlateAll (Either a b) to where+ plateAll (Left x1) = plate Left |+ x1+ plateAll (Right x1) = plate Right |+ x1++-}++import Data.Derive.DSL.HSE++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeUniplateTypeable :: Derivation+makeUniplateTypeable = derivationCustomDSL "UniplateTypeable" custom $+ List [App "InstDecl" (List [App "()" (List []),App "Nothing" (List+ []),App "IRule" (List [App "()" (List []),App "Nothing" (List []),+ App "Just" (List [App "CxTuple" (List [App "()" (List []),List [+ App "ClassA" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "Typeable"])]),List [App "TyVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "a"])])]]),App "ClassA" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "PlateAll"])]),List [+ App "TyVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "a"])]),App "TyVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "to"])])]]),App "ClassA"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "Uniplate"])]),List [+ App "TyVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "to"])])]]),App "ClassA" (List [App "()" (List []+ ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "Typeable"])]),List [App "TyVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "to"])+ ])]])]])]),App "IHApp" (List [App "()" (List []),App "IHApp" (List+ [App "()" (List []),App "IHCon" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "PlateAll"])])]),App "TyParen" (List [App "()" (+ List []),App "TyApp" (List [App "()" (List []),App "TyCon" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),DataName])])]),App "TyVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "a"])])])])]),App "TyVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),String "to"])])])]),App "Just" (List [+ List [App "InsDecl" (List [App "()" (List []),App "FunBind" (List+ [App "()" (List []),MapCtor (App "Match" (List [App "()" (List [])+ ,App "Ident" (List [App "()" (List []),String "plateAll"]),List [+ App "PParen" (List [App "()" (List []),App "PApp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])]))])])],App "UnGuardedRhs" (+ List [App "()" (List []),Fold (App "InfixApp" (List [App "()" (+ List []),Tail,App "QVarOp" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Symbol" (List [App "()" (List []),+ String "|+"])])]),Head])) (Concat (List [Reverse (MapField (App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),Concat (List [String "x"+ ,ShowInt FieldIndex])])])]))),List [App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "plate"])])]),App "Con" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])])])])]]))]),App "Nothing" (List [])]))])])]])])]+-- GENERATED STOP++-- InstDecl SrcLoc (Maybe Overlap) [TyVarBind] Context QName [Type] [InstDecl]+-- InstDecl l (Maybe (Overlap l)) (InstRule l) (Maybe [InstDecl l])+custom x [InstDecl () x2 (IParen () rule) mbDecl] = custom x [InstDecl () x2 rule mbDecl]+custom (_,d) [InstDecl () x2 (IRule () x3 _ ihead) x7] = [InstDecl () x2 (IRule () x3 x4 iheadOut) x7]+ where+ (_x6, x5) = collect [] ihead+ vars = dataDeclVars d+ dd = (if null vars then id else TyParen ()) $ tyApps (tyCon $ dataDeclName d) (map tyVar vars)+ x4 = Just $ CxTuple () $+ concatMap f vars ++ [ClassA () (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]]+ x6 = [dd, tyVar "to"]+ iheadOut = foldr (flip (IHApp ())) (IHCon () x5) x6+ f v = [ClassA () (qname "Typeable") [tyVar v], ClassA () (qname "PlateAll") [tyVar v, tyVar "to"]]+ collect acc (IHCon () qname) = (acc, qname)+ collect acc (IHInfix () arg qname) = (arg:acc, qname)+ collect acc (IHParen () ih) = collect acc ih+ collect acc (IHApp () ih arg) = collect (arg:acc) ih
+ src/Data/Derive/Update.hs view
@@ -0,0 +1,47 @@+{-|+ A Pseudo derivation. For every label, creates a function+ foo_u and foo_s which updates and sets the label respectively,+ e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'+-}+module Data.Derive.Update(makeUpdate) where++{-++test :: Computer++speed_u :: (Int -> Int) -> Computer -> Computer+speed_u f x = x{speed = f (speed x)}++speed_s :: Int -> Computer -> Computer+speed_s v x = x{speed = v}++weight_u :: (Double -> Double) -> Computer -> Computer+weight_u f x = x{weight = f (weight x)}++weight_s :: Double -> Computer -> Computer+weight_s v x = x{weight = v}++test :: Sample++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.Maybe+++makeUpdate :: Derivation+makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d+++makeUpdateField :: DataDecl -> String -> [Decl ()]+makeUpdateField d field =+ [TypeSig () [name upd] (TyFun () (TyParen () (TyFun () typF typF)) typR)+ ,bind upd [pVar "f",pVar "x"] $ RecUpdate () (var "x") [FieldUpdate () (qname field) (App () (var "f") (Paren () $ App () (var field) (var "x")))]+ ,TypeSig () [name set] (TyFun () typF typR)+ ,bind set [pVar "v",pVar "x"] $ RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")]]+ where+ set = field ++ "_s"+ upd = field ++ "_u"+ typR = TyFun () (dataDeclType d) (dataDeclType d)+ typF = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
+ src/Data/DeriveDSL.hs view
@@ -0,0 +1,21 @@++module Data.DeriveDSL(DSL, deriveDSL, applyDSL, dynamicDSL) where++import Data.Derive.DSL.Derive+import Data.Derive.DSL.Apply+import Data.Derive.DSL.DSL+import Data.Derive.DSL.HSE+import Data.Derive.DSL.SYB+import Data.Maybe+++deriveDSL :: [Decl ()] -> Maybe DSL+deriveDSL = listToMaybe . derive+++applyDSL :: DSL -> DataDecl -> Either String [Decl ()]+applyDSL dsl inp = Right $ apply dsl $ toInput inp+++dynamicDSL :: DSL -> Maybe [Decl ()]+dynamicDSL = dslSYB
+ src/Data/DeriveMain.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Needed for Haddock docs++-- | Use this module to create your own derive program, supporting custom derivations.+-- As an example:+--+-- @+-- import "Data.DeriveMain" ('deriveMain')+-- import "Data.Derive.All" ('derivations')+-- import MyProject.MyDerivation (myDerivation)+-- @+--+-- @+-- main :: IO+-- main = 'deriveMain' $ [myDerivation] ++ 'derivations'+-- @+module Data.DeriveMain(deriveMain) where++import Derive.Main+import Data.Derive.All(derivations)
+ src/Data/DeriveTH.hs view
@@ -0,0 +1,44 @@+-- | 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 makeEq ''Foo )+-- @+module Data.DeriveTH(derive, derives, deriveFromDec, module Data.Derive.All) where++import Control.Monad++import Data.Derive.All+import Data.Derive.Internal.Derivation+import Language.Haskell.TH.All as TH hiding (Derivation(..),toName)+import Language.Haskell as HS+import Language.Haskell.Convert+++-- | Derive an instance of some class. @derive@ only derives instances+-- for the type of the argument.+derive :: Derivation -> TH.Name -> Q [Dec]+derive d name = do+ x <- reify name+ case x of+ TyConI dec -> deriveFromDec d dec+ _ -> error $ "Data.DeriveTH.derive: Expected a data type declaration, got:\n" ++ show x+++derives :: [Derivation] -> [TH.Name] -> Q [Dec]+derives xs ys = liftM concat $ sequence [derive x y | y <- ys, x <- xs]+++-- | Derive an instance of some class. @deriveFromDec@ only derives instances+-- for the type of the argument.+deriveFromDec :: Derivation -> Dec -> Q [Dec]+deriveFromDec d x = do+ x <- liftM normData $ expandData x+ let unsup x = error $ "Derivation of " ++ derivationName d ++ " does not yet support Template Haskell, requires info for " ++ x+ case derivationOp d (tyCon $ derivationName d) unsup $ toFullDataDecl x of+ Left y -> runIO (putStrLn $ "Warning, couldn't derive: " ++ y) >> return []+ Right v -> return $ convert v++toFullDataDecl :: Dec -> FullDataDecl+toFullDataDecl x = (ModuleName () "Todo", convert x)
+ src/Derive/Derivation.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE ViewPatterns #-}++module Derive.Derivation(wantDerive, performDerive, writeDerive) where++import System.IO+import System.IO.Unsafe+import Language.Haskell+import Control.Arrow+import Control.Monad+import Data.List+import Derive.Utils+import Derive.Flags+import Data.Derive.Internal.Derivation+import qualified Data.Map as Map+++---------------------------------------------------------------------+-- WHAT DO YOU WANT TO DERIVE++wantDerive :: [Flag] -> Module () -> Module () -> [Type ()]+wantDerive flag real mine = nub $ map fromTyParens $ wantDeriveFlag flag decls ++ wantDeriveAnnotation real mine+ where decls = filter isDataDecl $ moduleDecls mine+++wantDeriveFlag :: [Flag] -> [DataDecl] -> [Type ()]+wantDeriveFlag flags decls = [TyApp () (tyCon x) d | Derive xs <- flags, x <- xs, d <- declst]+ where declst = [tyApps (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d) | d <- decls]++wantDeriveAnnotation :: Module () -> Module () -> [Type ()]+wantDeriveAnnotation real mine = moduleDerives mine \\ moduleDerives real+++moduleDerives :: Module () -> [Type ()]+moduleDerives = concatMap f . moduleDecls+ where+ f (DataDecl _ _ _ (fromDeclHead -> (name, vars)) _ deriv) = g name vars deriv+ f (GDataDecl _ _ _ (fromDeclHead -> (name, vars)) _ _ deriv) = g name vars deriv+ f (DerivDecl _ _ _ (fromIParen -> IRule _ _ _ (fromInstHead -> (name, args)))) = [TyCon () name `tyApps` args]+ f _ = []++ g name vars deriv = [TyCon () a `tyApps` (b:bs) | IRule _ _ _ (fromInstHead -> (a,bs)) <- map fromIParen $ f deriv]+ where b = TyCon () (UnQual () name) `tyApps` map (tyVar . prettyPrint) vars+ f [Deriving _ _ xs] = xs+ f _ = []+++---------------------------------------------------------------------+-- ACTUALLY DERIVE IT++performDerive :: [Derivation] -> Module () -> [Type ()] -> [String]+performDerive derivations modu = concatMap ((:) "" . f)+ where+ grab = getDecl modu++ g = getDerivation derivations+ f ty = case d ty grab (moduleName modu, grab typ1Name) of+ Left x -> unsafePerformIO $ let res = msg x in hPutStrLn stderr res >> return ["-- " ++ res]+ Right x -> concatMap (lines . prettyPrint) x+ where+ d = derivationOp $ g clsName+ (cls,typ1:_) = fromTyApps ty+ clsName = prettyPrint cls+ typ1Name = tyRoot typ1+ msg x = "Deriving " ++ prettyPrint ty ++ ": " ++ x+++getDecl :: Module () -> (String -> Decl ())+getDecl modu = \name -> Map.findWithDefault (error $ "Can't find data type definition for: " ++ name) name mp+ where+ mp = Map.fromList $ concatMap f $ moduleDecls modu+ f x@(DataDecl _ _ _ (fromDeclHead -> (name, _)) _ _) = [(prettyPrint name, x)]+ f x@(GDataDecl _ _ _ (fromDeclHead -> (name, _)) _ _ _) = [(prettyPrint name, x)]+ f x@(TypeDecl _ (fromDeclHead -> (name, _)) _) = [(prettyPrint name, x)]+ f _ = []+++getDerivation :: [Derivation] -> String -> Derivation+getDerivation derivations = \name -> Map.findWithDefault (error $ "Don't know how to derive type class: " ++ name) name mp+ where+ mp = Map.fromList $ map (derivationName &&& id) derivations+++---------------------------------------------------------------------+-- WRITE IT BACK++writeDerive :: FilePath -> ModuleName () -> [Flag] -> [String] -> IO ()+writeDerive file modu flags xs = do+ -- force the output first, ensure that we don't crash half way through+ () <- length (concat xs) `seq` return ()++ let append = Append `elem` flags+ let output = [x | Output x <- flags]++ let ans = take 1 ["module " ++ x ++ " where" | Modu x <- reverse flags] +++ ["import " ++ if null i then prettyPrint modu else i | Import i <- flags] +++ xs++ when append $ do+ src <- readFile' file+ writeGenerated file ans++ forM output $ \o -> writeFile o $ unlines ans+ when (not append && null output) $ putStr $ unlines ans
+ src/Derive/Flags.hs view
@@ -0,0 +1,65 @@++module Derive.Flags(Flag(..), getFlags, addFlags, flagInfo) where++import System.Environment+import System.Console.GetOpt+import System.Directory+import Language.Haskell+import System.Exit+import System.IO+import Data.Maybe+++data Flag = Version | Help | Output String | Import String | Modu String+ | Append | Derive [String] | NoOpts | Preprocessor | Test | Generate+ 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 Modu "MODULE") "add a module MODULE where statement"+ ,Option "a" ["append"] (NoArg Append) "append the result to the file"+ ,Option "d" ["derive"] (ReqArg splt "DERIVES") "things to derive for all types"+ ,Option "n" ["no-opts"] (NoArg NoOpts) "ignore the file options"+ ,Option "F" ["preprocessor"] (NoArg Preprocessor) "operate as a GHC preprocessor with -pgmF"+ ,Option "" ["test"] (NoArg Test) "run the test suite"+ ,Option "" ["generate"] (NoArg Generate) "perform code generation"+ ]+ where splt = Derive . words . map (\x -> if x == ',' then ' ' else x)+++flagInfo = usageInfo "Usage: derive [OPTION...] files..." options+++getFlags :: IO ([Flag], [String])+getFlags = do+ args <- getArgs+ case getOpt Permute options args of+ (o,n,[] ) | Version `elem` o -> putStrLn "Derive 2.5.* (C) Neil Mitchell 2006-2013" >> exitSuccess+ | Help `elem` o -> putStr flagInfo >> exitSuccess+ | Preprocessor `elem` o -> return (o,n)+ | otherwise -> do files <- mapM pickFile n; return (o, files)+ (_,_,errs) -> hPutStr stderr (concat errs ++ flagInfo) >> exitFailure+ where+ exitSuccess = exitWith ExitSuccess+++pickFile :: FilePath -> IO FilePath+pickFile orig = f [orig, orig ++ ".hs", orig ++ ".lhs"]+ where+ f [] = error $ "File not found: " ++ orig+ f (x:xs) = do+ b <- doesFileExist x+ if b then return x else f xs+++addFlags :: [Flag] -> (SrcLoc, [String]) -> [Flag]+addFlags flags (sl,xs)+ | NoOpts `elem` flags = flags+ | errs /= [] = error $ prettyPrint sl ++ "\n" ++ concat errs+ | otherwise = flags ++ a+ where (a,_,errs) = getOpt Permute options xs
+ src/Derive/Generate.hs view
@@ -0,0 +1,115 @@++module Derive.Generate(generate) where++import Language.Haskell.Exts+import Data.DeriveDSL+import Derive.Utils+import Control.Monad+import Data.Maybe+import System.FilePath+import System.Directory+import Data.Char+import Data.List+++evil = words "TTypeable Uniplate"++-- generate extra information for each derivation+generate :: IO ()+generate = do+ xs <- getDirectoryContents "src/Data/Derive"+ xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]+ lis <- mapM generateFile $ map ("src/Data/Derive" </>) xs+ let names = map dropExtension xs+ n = maximum $ map length names+ writeGenerated "src/Data/Derive/All.hs" $+ ["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] +++ ["derivations :: [Derivation]"+ ,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"]+ writeGenerated "README.md" $ ["-->",""] ++ lis ++ ["","<!--"]+ writeGenerated "derive.cabal" $ map (" Data.Derive."++) names+++-- return the Documentation string+generateFile :: FilePath -> IO String+generateFile file = do+ let name = takeBaseName file+ putStrLn $ "Generating " ++ name+ src <- readSrc file+ when (isJust $ srcExample src) $ do+ let dsl = fromMaybe (error $ "Couldn't derive example for " ++ name) $+ deriveDSL $ fromJust $ srcExample src+ writeGenerated file $+ [""+ ,"import Data.Derive.DSL.DSL"+ ,"import Data.Derive.Internal.Derivation"+ ,""+ ,"make" ++ name ++ " :: Derivation"+ ] ++ (if srcCustom src then+ ["make" ++ name ++ " = derivationCustomDSL " ++ show name ++ " custom $"]+ else+ ["make" ++ name ++ " = derivationDSL " ++ show name ++ " dsl" ++ name+ ,""+ ,"dsl" ++ name ++ " ="+ ]) +++ map (replicate 4 ' ' ++) (wrap 66 $ show dsl)++ let inst = dynamicDSL dsl+ instFile = takeDirectory file </> "Instance" </> name <.> "hs"+ b <- doesFileExist instFile++ if not (srcCustom src) && isJust inst then do+ writeGenerated instFile $+ ["{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}"] +++ ["","module Data.Derive.Instance." ++ name ++ " where",""] +++ (map prettyPrint $ srcImportStd src) +++ ["import Data.Derive.Internal.Instance",""] +++ (map prettyPrint $ fromJust inst) ++ [""]+ else when b $+ error $ "Previously generated dynamic instance can not be regenerated, " ++ name++ let imp = listToMaybe $ srcImport src+ return $+ "* **[" ++ name ++ "](" ++ instUrl name imp ++ ")**" +++ concat [" - from the library [" ++ pkg ++ "](" ++ pkgUrl pkg ++ ")" | Just imp <- [imp], let pkg = fromMaybe "base" $ importPkg imp]++pkgUrl x = "http://hackage.haskell.org/package/" ++ x++instUrl name Nothing = "http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-" ++ name ++ ".html"+instUrl name (Just x) = "http://hackage.haskell.org/packages/archive/" ++ pkgName ++ "/" ++ pkgVersion ++ "/doc/html/" ++ modu ++ ".html#t%3A" ++ nam+ where+ (a,b) = break (== '-') $ fromMaybe "base" $ importPkg x+ pkgName = a+ pkgVersion = if null b then "latest" else tail b+ modu = reps '.' '-' $ prettyPrint $ importModule x+ nam = case importSpecs x of Just (ImportSpecList _ False (IAbs _ _ y:_)) -> prettyPrint y ; _ -> name+++wrap :: Int -> String -> [String]+wrap n = f . lexemes+ where+ f [] = []+ f (x:xs) = [reverse $ dropWhile isSpace $ reverse $ concat $ x:a] ++ f (dropWhile (all isSpace) b)+ where (a,b) = thisLine (n - length x) xs++ thisLine i [] = ([], [])+ thisLine i (x:xs) | j > i = ([], x:xs)+ | otherwise = (x:a, b)+ where j = length x+ (a,b) = thisLine (i - j) xs+++lexemes :: String -> [String]+lexemes [] = []+lexemes x = a : lexemes b+ where (a,b) = lexeme x+++lexeme :: String -> (String, String)+lexeme xs@(x:_) | isAlpha x = span isAlpha xs+lexeme ('\"':xs) = let (a,b) = f xs in ('\"':a,b)+ where f ('\\':x:xs) = let (a,b) = f xs in ('\\':x:a,b)+ f ('\"':xs) = ("\"",xs)+ f (x:xs) = let (a,b) = f xs in (x:a,b)+ f [] = ([],[])+lexeme (x:xs) = ([x], xs)
+ src/Derive/Main.hs view
@@ -0,0 +1,67 @@++module Derive.Main(deriveMain) where++import Language.Haskell+import Data.Derive.All(Derivation)+import Derive.Derivation+import Derive.Generate+import Derive.Test+import Derive.Flags+import Data.List+import System.Directory+++deriveMain :: [Derivation] -> IO ()+deriveMain derivations = do+ (flags,files) <- getFlags+ if Test `elem` flags then+ test+ else if Generate `elem` flags then+ generate+ else if Preprocessor `elem` flags then+ (if length files /= 3 then+ error $ "Expected to be invoked as a GHC preprocessor with 3 files, but got " ++ show (length files)+ else do+ copyFile (files !! 1) (files !! 2)+ mainFile derivations (Append:flags) (files !! 2)+ )+ else if null files then+ putStr $ "No files specified\n" ++ flagInfo+ else+ mapM_ (mainFile derivations flags) files+++mainFile :: [Derivation] -> [Flag] -> FilePath -> IO ()+mainFile derivations flags file = do+ src <- readFile file+ src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src+ let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=defaultExtensions}+ real = parse src+ mine = parse $ uncomment src :: Module SrcSpanInfo+ flags <- return $ foldl addFlags flags+ [(getPointLoc sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine]+ let blur = fmap (const ())+ let res = performDerive derivations (blur mine :: Module ()) $ wantDerive flags (blur real) (blur mine)+ writeDerive file (moduleName $ blur mine) flags res+++uncomment :: String -> String+uncomment ('{':'-':'!':xs) = ' ':' ':' ':uncomment xs+uncomment ('!':'-':'}':xs) = ' ':' ':' ':uncomment xs+uncomment (x:xs) = x:uncomment xs+uncomment [] = []+++-- Taken from HLint, update occasionally+defaultExtensions :: [Extension]+defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions++badExtensions =+ [Arrows -- steals proc+ ,TransformListComp -- steals the group keyword+ ,XmlSyntax, RegularPatterns -- steals a-b+ ,UnboxedTuples -- breaks (#) lens operator+ ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break+ ,DoRec, RecursiveDo -- breaks rec+ ,TypeApplications -- HSE fails on @ patterns+ ]
+ src/Derive/Test.hs view
@@ -0,0 +1,100 @@++module Derive.Test(test) where++import Derive.Utils+import Data.Derive.DSL.HSE+import Control.Monad+import Data.Maybe+import Data.List+import System.FilePath+import System.Process+import System.Exit+import Control.Arrow+import Data.Derive.All+import Data.Derive.Internal.Derivation+++-- These overlap with other derivations+overlaps =+ [["BinaryDefer","EnumCyclic","LazySet","DataAbstract"]+ ,["Serialize"]]++-- REASONS:+-- UniplateDirect: Doesn't work through Template Haskell+-- Typeable cannot be separately derived in GHC 7.8+exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary","Typeable"]++-- These must be first and in every set+priority = []+++listType :: Decl ()+listType = DataDecl () (DataType ()) Nothing (DHApp () (DHead () (Ident () "[]")) (UnkindedVar () $ Ident () "a"))+ [QualConDecl () Nothing Nothing (ConDecl () (Ident () "[]") [])+ ,QualConDecl () Nothing Nothing (ConDecl () (Ident () "Cons")+ [TyVar () (Ident () "a")+ ,TyApp () (TyCon () (UnQual () (Ident () "List"))) (TyVar () (Ident () "a"))])]+ []+++-- test each derivation+test :: IO ()+test = do+ decls <- fmap (filter isDataDecl . moduleDecls) $ readHSE "Data/Derive/Internal/Test.hs"++ -- check the test bits+ let ts = ("[]",listType) : map (dataDeclName &&& id) decls+ mapM_ (testFile ts) derivations++ -- check the $(derive) bits+ putStrLn "Type checking examples"+ let name = "AutoGenerated_Test"+ devs <- sequence [liftM ((,) d) $ readSrc $ "Data/Derive" </> derivationName d <.> "hs" | d <- derivations]+ let lookupDev x = fromMaybe (error $ "Couldn't find derivation: " ++ x) $ find ((==) x . derivationName . fst) devs++ let sets = zip [1..] $ map (map lookupDev) $ map (priority++) $+ [d | d <- map (derivationName . fst) devs, d `notElem` (exclude ++ priority ++ concat overlaps)] : overlaps++ forM sets $ \(i,xs) -> autoTest (name++show i) decls xs+ writeFile (name++".hs") $ unlines $+ ["import " ++ name ++ show (fst i) | i <- sets] ++ ["main = putStrLn \"Type checking successful\""]+ res <- system $ "runhaskell -isrc " ++ name ++ ".hs"+ when (res /= ExitSuccess) $ error "Failed to typecheck results"+++testFile :: [(String,Decl ())] -> Derivation -> IO ()+testFile types (Derivation name op) = do+ putStrLn $ "Testing " ++ name+ src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"+ forM_ (srcTest src) $ \(typ,res) -> do+ let d = if tyRoot typ /= name then tyRoot typ else tyRoot $ head $ snd $ fromTyApps $ fromTyParen typ+ let grab x = fromMaybe (error $ "Error in tests, couldn't resolve type: " ++ x) $ lookup x types+ let Right r = op typ grab (ModuleName () "Example", grab d)+ when (not $ r `outEq` res) $+ error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r++detailedNeq as bs | na /= nb = "Lengths don't match, " ++ show na ++ " vs " ++ show nb+ where na = length as ; nb = length bs++detailedNeq as bs = "Mismatch on line " ++ show i ++ "\n" ++ show a ++ "\n" ++ show b+ where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)+++autoTest :: String -> [DataDecl] -> [(Derivation,Src)] -> IO ()+autoTest name ts ds =+ writeFile (name++".hs") $ unlines $+ ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses,TypeOperators,DeriveDataTypeable #-}"+ ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}"+ ,"module " ++ name ++ " where"+ ,"import Prelude"+ ,"import Data.DeriveTH"+ ,"import Data.Typeable"+ ,"import Derive.TestInstances()"] +++ [prettyPrint i | (_,s) <- ds, i <- srcImportStd s] +++ [prettyPrint t ++ "\n deriving Typeable" | t <- ts2] +++ ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | (d,_) <- ds]+ where+ types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]"+ ts2 = filter (not . isBuiltIn) ts++isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]
+ src/Derive/Utils.hs view
@@ -0,0 +1,86 @@++module Derive.Utils where++import Data.Derive.DSL.HSE+import Data.List+import qualified Data.ByteString.Char8 as BS+import System.Directory+import System.IO+import System.FilePath+import Control.Monad+import Data.Maybe+++data Src = Src+ {srcName :: String+ ,srcImport :: [ImportDecl ()]+ ,srcExample :: Maybe [Decl ()]+ ,srcTest :: [(Type (),[Decl ()])]+ ,srcCustom :: Bool+ }++-- skip the importPkg bits+srcImportStd :: Src -> [ImportDecl ()]+srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y]++nullSrc = Src "" [] Nothing [] False+++readHSE :: FilePath -> IO (Module ())+readHSE file = do+ src <- readFile' file+ src <- return $ takeWhile (/= "-}") $ drop 1 $ dropWhile (/= "{-") $+ dropWhile (not . isPrefixOf "module ") $ lines src++ let mode = defaultParseMode{extensions=map EnableExtension [MultiParamTypeClasses,FlexibleContexts,TemplateHaskell,PackageImports,TypeOperators]}+ return $ fmap (const ()) $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src+++data Pragma = Example Bool | Test (Type ())++asPragma :: Decl () -> Maybe Pragma+asPragma (TypeSig _ [x] t)+ | x ~= "example" = Just $ Example $ prettyPrint t == "Custom"+ | x ~= "test" = Just $ Test t+asPragma _ = Nothing+++readSrc :: FilePath -> IO Src+readSrc file = do+ modu <- readHSE file+ return $ foldl f nullSrc{srcName=takeBaseName file, srcImport=moduleImports modu}+ [ (p,xs)+ | p:real <- tails $ moduleDecls modu, Just p <- [asPragma p]+ , let xs = takeWhile (isNothing . asPragma) real ]+ where+ f src (Example x,bod) = src{srcExample = Just bod, srcCustom = x}+ f src (Test x,bod) = src{srcTest = srcTest src ++ [(x,bod)]}+++generatedStart = "-- GENERATED START"+generatedStop = "-- GENERATED STOP"++++writeGenerated :: FilePath -> [String] -> IO ()+writeGenerated file x = do+ src <- fmap lines $ readFile' file+ let pre = takeWhile (/= generatedStart) src+ post = drop 1 $ dropWhile (/= generatedStop) src+ src2 = pre ++ [generatedStart] ++ x ++ [generatedStop] ++ post+ when (src /= src2) $+ seq (length src2) $ writeBinaryFile file $ unlines src2+++readFile' :: FilePath -> IO String+readFile' file = do+ b <- doesFileExist file+ if b then fmap BS.unpack $ BS.readFile file else return []+++writeBinaryFile :: FilePath -> String -> IO ()+writeBinaryFile file x = withBinaryFile file WriteMode (`hPutStr` x)+++rep from to x = if x == from then to else x+reps from to = map (rep from to)
+ src/Language/Haskell.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE PatternGuards #-}+module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where++import Language.Haskell.Exts hiding (var,app,binds,paren,FieldDecl)+import qualified Language.Haskell.Exts as HSE+import Data.List+import Data.Generics.Uniplate.Data+import Data.Data+import Data.Char+import Data.Maybe+import Control.Arrow+++infix 1 ?+True ? b = const b+False ? b = id++++-- insert explicit foralls+foralls :: Type () -> Type ()+foralls x = TyForall () (Just $ map (UnkindedVar ()) $ nub [y | TyVar _ y <- universe x]) Nothing x+++tyApps x [] = x+tyApps x (y:ys) = tyApps (TyApp () x y) ys+++fromTyApps (TyTuple _ _ xs) = (tyCon $ "(" ++ replicate (length xs - 1) ',' ++ ")", xs)+fromTyApps (TyApp _ x y) = let (a,b) = fromTyApps x in (a, b ++ [y])+fromTyApps (TyList _ x) = (TyCon () $ Special () $ ListCon (), [x])+fromTyApps x = (x, [])++fromTyTuple (TyTuple _ _ xs) = xs+fromTyTuple x = [x]++fromTyParen (TyParen () x) = fromTyParen x+fromTyParen x = x++fromTyParens = transform fromTyParen++tyRoot = prettyPrint . fst . fromTyApps . fromTyParen++isTyFun :: Type () -> Bool+isTyFun TyFun{} = True+isTyFun _ = False++isTyParen TyParen{} = True ; isTyParen _ = False++fromTyList (TyList _ x) = Just x+fromTyList (TyApp _ (TyCon _ (Special _ ListCon{})) x) = Just x+fromTyList x = Nothing+++x ~= y = prettyPrint x == y+++appP x@App{} y = App () x y+appP x y = App () (paren x) (paren y)+++simplify :: Data a => a -> a+simplify = transformBi fDecl . transformBi fMatch . transformBi fPat . transformBi fTyp . transformBi fExp+ where+ fExp :: Exp () -> Exp ()+ fExp (App _ op (List _ xs))+ | op ~= "length" = Lit () $ Int () (fromIntegral $ length xs) (show $ length xs)+ | op ~= "head" = head xs+ | op ~= "null" = con $ show $ null xs+ fExp (InfixApp _ (Lit _ (Int _ i _)) op (Lit _ (Int _ j _)))+ | op ~= "-" = Lit () $ Int () (i - j) (show $ i-j)+ | op ~= "+" = Lit () $ Int () (i + j) (show $ i+j)+ | op ~= ">" = Con () $ UnQual () $ Ident () $ show $ i > j+ fExp (InfixApp _ x op y)+ | op ~= "`const`" = x+ | op ~= "&&" && y ~= "True" = x+ | x ~= "id" && op ~= "." = y+ | y ~= "id" && op ~= "." = x+ fExp (InfixApp _ (Lit _ (String _ x _)) op (Lit _ (String _ y _))) | op ~= "++" = Lit () $ String () (x ++ y) (show $ x ++ y)+ fExp (App _ (App _ (App _ flp f) x) y) | flp ~= "flip" = fExp $ appP (fExp $ appP f y) x+ fExp (App _ (Paren _ x@App{}) y) = fExp $ App () x y+ fExp (App _ (Paren _ (InfixApp _ x op y)) z) | op ~= "." = fExp $ appP x $ fExp $ appP y z+ fExp (App _ op x) | op ~= "id" = x+ fExp (App _ (App _ flp con) x) | flp ~= "flip" && con ~= "const" = var "id"+ fExp (App _ (App _ con x) y) | con ~= "const" = x+ fExp (App _ choose (Tuple _ _ [x@(ExpTypeSig _ y _),z])) | choose ~= "choose" && y == z = fExp $ App () (var "return") x+ fExp (App _ op x) | op ~= "id" = x+ fExp (InfixApp _ (App _ when true) dot res)+ | when ~= "when" && true ~= "True" = res+ fExp (InfixApp _ x y z) | y ~= "++" && z ~= "[]" = x+ fExp (App _ (LeftSection _ x op) y) = fExp $ InfixApp () x op (paren y)+ fExp (Paren _ x) | isAtom x = x+ fExp (Do _ [Qualifier _ x]) = x+ fExp (Do _ (Qualifier _ (App _ ret unit):xs)) | ret ~= "return" && unit ~= "()" = fExp $ Do () xs+ fExp (Do _ (Generator _ (PVar _ x) (App _ ret y):xs)) | ret ~= "return" && once x2 xs = simplify $ Do () $ subst x2 y xs+ where x2 = Var () $ UnQual () x+ fExp (Case _ (ExpTypeSig _ x@Lit{} _) alts) = fExp $ Case () x alts+ fExp (Case _ (Lit _ x) alts) | good:_ <- good = good+ where good = [z | Alt _ (PLit _ Signless{} y) (UnGuardedRhs _ z) Nothing <- alts, y == x]+ fExp (If _ x t f)+ | x ~= "True" = t+ | x ~= "False" = f+ fExp (App _ (App _ when b) x)+ | when ~= "when" && b ~= "True" = x+ | when ~= "when" && b ~= "False" = App () (Var () $ UnQual () $ Ident () "return") (Con () $ Special () $ TupleCon () Boxed 0)+ fExp (App _ (Paren _ (Lambda _ [PVar _ x] y)) z) | once x2 y = fExp $ subst x2 z y+ where x2 = Var () $ UnQual () x+ fExp (App _ (Paren _ (Lambda _ [PWildCard _] x)) _) = x+ fExp (Lambda s ps x) = Lambda s (minPat x ps) x+ fExp (Con _ x) = Con () $ rename x+ fExp x = x++ fTyp :: Type () -> Type ()+ fTyp (TyApp _ x y) | x ~= "[]" = TyList () y+ fTyp (TyApp _ (TyCon _ (Special _ ListCon{})) x) = TyList () x+ fTyp (TyParen _ x@TyCon{}) = x+ fTyp (TyParen _ x@TyVar{}) = x+ fTyp (TyParen _ x@TyList{}) = x+ fTyp (TyCon _ nam) = TyCon () $ rename nam+ fTyp x = x++ fPat :: Pat () -> Pat ()+ fPat (PParen _ x@(PApp _ _ [])) = x+ fPat (PParen _ (PParen _ x)) = PParen () x+ fPat (PApp _ nam xs) = case rename nam of+ Special _ (TupleCon _ Boxed _) -> PTuple () Boxed xs+ nam -> PApp () nam xs+ fPat (PParen _ (PTuple _ l xs)) = PTuple () l xs+ fPat x = x++ fMatch :: Match () -> Match ()+ fMatch (Match sl nam pat (GuardedRhss _ [GuardedRhs _ [Qualifier _ x] bod]) decls)+ | x ~= "True" = fMatch $ Match sl nam pat (UnGuardedRhs () bod) decls+ fMatch (Match sl nam [PVar _ x] (UnGuardedRhs _ (Case _ (Var _ (UnQual _ x2)) [Alt _ pat (UnGuardedRhs _ y) Nothing])) decls)+ | x == x2 = fMatch $ Match sl nam [PParen () pat] (UnGuardedRhs () y) decls+ fMatch o@(Match a b c d bind) = fBinds (Match a b (minPat o c) d) bind++ fDecl :: Decl () -> Decl ()+ fDecl (PatBind a b c bind) = fBinds (PatBind a b c) bind+ fDecl (FunBind _ xs) = FunBind () $ filter (not . isGuardFalse) xs+ fDecl x = x++ fBinds context Nothing = context Nothing+ fBinds context (Just (BDecls _ bind)) | inline /= [] =+ simplify $ subst (Var () $ UnQual () from) to $ context $+ let xs = take i bind ++ drop (i+1) bind in if null xs then Nothing else Just $ BDecls () xs+ where+ f (PatBind _ (PVar _ x) (UnGuardedRhs _ bod) Nothing) = [(x,bod)]+ f (FunBind _ [Match _ x [PVar _ v] (UnGuardedRhs _ (Paren _ (App _ bod (Var _ v2)))) Nothing])+ | UnQual () v == v2 = [(x,bod)]+ f (FunBind _ [Match sl x pat (UnGuardedRhs _ bod) Nothing]) = [(x,Paren () $ Lambda sl pat bod)]+ f _ = []++ (i,from,to) = head inline+ inline = [(i, x, bod)+ | (i,b) <- zip [0..] bind, (x,bod) <- f b+ , isAtom bod || once (Var () $ UnQual () x) (context $ Just $ BDecls () bind)]+ fBinds a y = a y++ subst from to = transformBi $ \x -> if x == from then to else x+ once x y = length (filter (== x) (universeBi y)) <= 1++ minPat o ps = transformBi f ps+ where+ known = nub [x | UnQual _ x <- universeBi o]+ f (PVar () x) | x `notElem` known = PWildCard ()+ f (PAsPat () x y) | x `notElem` known = y+ f x = x++++isGuardFalse (Match sl nam pat (GuardedRhss _ [GuardedRhs _ [Qualifier _ x] bod]) decls) = x ~= "False"+isGuardFalse _ = False+++rename (UnQual _ (Ident _ ('(':xs@(x:_))))+ | x == ',' = Special () $ TupleCon () Boxed $ length xs+ | x /= ')' = UnQual () $ Symbol () $ init xs+rename x = x+++isAtom Con{} = True+isAtom Var{} = True+isAtom Lit{} = True+isAtom Paren{} = True+isAtom _ = False+++paren x = if isAtom x then x else Paren () x++sl = SrcLoc "" 0 0++noSl mr = transformBi (const sl) mr+++isIdent (x:xs) = isAlpha x || x == '_'+title (x:xs) = toUpper x : xs++qname = UnQual () . name+var = Var () . qname+con = Con () . qname+tyVar = TyVar () . name+tyVarBind = UnkindedVar () . name+tyCon = TyCon () . qname+pVar = PVar () . name+qvop = QVarOp () . UnQual () . Symbol ()++dataDeclType :: DataDecl -> Type ()+dataDeclType d = tyApp (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d)++dataDeclFields :: DataDecl -> [String]+dataDeclFields = sort . nub . filter (not . null) . map fst . concatMap ctorDeclFields . dataDeclCtors+++-- A declaration that is either a DataDecl of GDataDecl+type DataDecl = Decl ()+type CtorDecl = Either (QualConDecl ()) (GadtDecl ())+type FieldDecl = [(String, Type ())]++type FullDataDecl = (ModuleName (), DataDecl)+++moduleName (Module _ (Just (ModuleHead _ name _ _)) _ _ _) = name+moduleDecls (Module _ _ _ _ decls) = decls+moduleImports (Module _ _ _ imps _) = imps+modulePragmas (Module _ _ pragmas _ _) = pragmas+++showDecls x = unlines $ map prettyPrint x+++tyApp x [] = x+tyApp x xs = TyApp () (tyApp x $ init xs) (last xs)+++tyFun [x] = x+tyFun (x:xs) = TyFun () x (tyFun xs)+++apps x [] = x+apps x (y:ys) = apps (App () x y) ys+++bind :: String -> [Pat ()] -> Exp () -> Decl ()+bind s p e = binds s [(p,e)]++binds :: String -> [([Pat ()], Exp ())] -> Decl ()+binds n [([],e)] = PatBind () (pVar n) (UnGuardedRhs () e) Nothing+binds n xs = FunBind () [Match () (name n) p (UnGuardedRhs () e) Nothing | (p,e) <- xs]+++isDataDecl :: Decl () -> Bool+isDataDecl DataDecl{} = True+isDataDecl GDataDecl{} = True+isDataDecl _ = False++dataDeclName :: DataDecl -> String+dataDeclName (DataDecl _ _ _ name _ _) = prettyPrint $ fst $ fromDeclHead name+dataDeclName (GDataDecl _ _ _ name _ _ _) = prettyPrint $ fst $ fromDeclHead name++fromDeclHead :: DeclHead a -> (Name a, [TyVarBind a])+fromDeclHead (DHead _ n) = (n, [])+fromDeclHead (DHInfix _ x n) = (n, [x])+fromDeclHead (DHParen _ x) = fromDeclHead x+fromDeclHead (DHApp _ dh x) = second (++[x]) $ fromDeclHead dh++fromIParen :: InstRule a -> InstRule a+fromIParen (IParen _ x) = fromIParen x+fromIParen x = x++fromInstHead :: InstHead a -> (QName a, [Type a])+fromInstHead (IHCon _ x) = (x, [])+fromInstHead (IHInfix _ t x) = (x, [t])+fromInstHead (IHParen _ x) = fromInstHead x+fromInstHead (IHApp l hd t) = second (++ [t]) $ fromInstHead hd+++dataDeclVars :: DataDecl -> [String]+dataDeclVars (DataDecl _ _ _ hd _ _) = map f $ snd $ fromDeclHead hd+ where f (KindedVar _ x _) = prettyPrint x+ f (UnkindedVar _ x) = prettyPrint x++dataDeclVarsStar :: DataDecl -> [String]+dataDeclVarsStar (DataDecl _ _ _ hd _ _) = mapMaybe f $ snd $ fromDeclHead hd+ where f (UnkindedVar _ x) = Just $ prettyPrint x+ f (KindedVar _ x (KindStar _)) = Just $ prettyPrint x+ f _ = Nothing++dataDeclArity :: DataDecl -> Int+dataDeclArity = length . dataDeclVars++dataDeclCtors :: DataDecl -> [CtorDecl]+dataDeclCtors (DataDecl _ _ _ _ ctors _) = map Left ctors+++ctorDeclName :: CtorDecl -> String+ctorDeclName = prettyPrint . ctorDeclName'++ctorDeclName' :: CtorDecl -> Name ()+ctorDeclName' (Left (QualConDecl _ _ _ (ConDecl _ name _))) = name+ctorDeclName' (Left (QualConDecl _ _ _ (InfixConDecl _ _ name _))) = name+ctorDeclName' (Left (QualConDecl _ _ _ (RecDecl _ name _))) = name++ctorDeclFields :: CtorDecl -> FieldDecl+ctorDeclFields (Left (QualConDecl _ _ _ (ConDecl _ name fields))) = map ((,) "") fields+ctorDeclFields (Left (QualConDecl _ _ _ (InfixConDecl _ x1 name x2))) = map ((,) "") [x1,x2]+ctorDeclFields (Left (QualConDecl _ _ _ (RecDecl _ name fields))) = [(prettyPrint a, b) | HSE.FieldDecl _ as b <- fields, a <- as]++ctorDeclArity :: CtorDecl -> Int+ctorDeclArity = length . ctorDeclFields++declName :: Decl () -> String+declName (DataDecl _ _ _ name _ _) = prettyPrint $ fst $ fromDeclHead name+declName (GDataDecl _ _ _ name _ _ _) = prettyPrint $ fst $ fromDeclHead name+declName (TypeDecl _ name _) = prettyPrint $ fst $ fromDeclHead name
+ src/Language/Haskell/Convert.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Language.Haskell.Convert(Convert, convert) where++import Language.Haskell as HS+import qualified Language.Haskell.Exts as HSE(FieldDecl(..))+import Language.Haskell.TH.Compat+import Language.Haskell.TH.Syntax as TH+import Control.Exception+import Data.Typeable+import System.IO.Unsafe+import Data.Maybe+++class (Typeable a, Typeable b, Show a, Show b) => Convert a b where+ conv :: a -> b+++convert :: forall a b . Convert a b => a -> b+convert a = unsafePerformIO $+ (return $! (conv a :: b)) `Control.Exception.catch` (\(e :: SomeException) -> error $ msg e)+ where+ msg e = "Could not convert " ++ show (typeOf a) ++ " to " +++ show (typeOf (undefined :: b)) ++ "\n" ++ show a +++ "\n" ++ show e++++appT :: TH.Type -> [TH.Type] -> TH.Type+appT = foldl AppT++c mr = convert mr++instance Convert a b => Convert [a] [b] where+ conv = map c++++instance Convert TH.Dec (HS.Decl ()) where+ conv x = case x of+#if __GLASGOW_HASKELL__ >= 800+ DataD cxt n vs _ con ds -> f (DataType ()) cxt n vs con ds+ NewtypeD cxt n vs _ con ds -> f (NewType ()) cxt n vs [con] ds+ where+ f :: DataOrNew () -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> unused -> HS.Decl ()+ f t cxt n vs con _ = DataDecl () t (Just $ c cxt) (dh (c n) (c vs)) (c con) []+#else+ DataD cxt n vs con ds -> f (DataType ()) cxt n vs con ds+ NewtypeD cxt n vs con ds -> f (NewType ()) cxt n vs [con] ds+ where+ f :: DataOrNew () -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> [TH.Name] -> HS.Decl ()+ f t cxt n vs con ds = DataDecl () t (Just $ c cxt) (dh (c n) (c vs)) (c con) []+#endif++ dh name [] = DHead () name+ dh name xs = DHApp () (dh name $ init xs) (last xs)++instance Convert TH.Cxt (HS.Context ()) where+ conv = CxTuple () . map c++instance Convert (Maybe (HS.Context ())) TH.Cxt where+ conv Nothing = []+ conv (Just (CxSingle _ x)) = [c x]+ conv (Just (CxTuple _ xs)) = map c xs+ conv (Just (CxEmpty _)) = []++instance Convert TH.Name (HS.TyVarBind ()) where+ conv = UnkindedVar () . c++instance Convert TH.Name (HS.Name ()) where+ conv x = name $ if '.' `elem` x2 then reverse $ takeWhile (/= '.') $ reverse x2 else x2+ where x2 = show x++instance Convert TH.Name (HS.QName ()) where+ conv x = if x2 == Ident () "[]" then Special () $ ListCon () else UnQual () x2+ where x2 = c x++instance Convert TH.Con (HS.QualConDecl ()) where+ conv (ForallC vs cxt x) = QualConDecl () (Just $ c vs) (Just $ c cxt) (c x)+ conv x = QualConDecl () Nothing Nothing (c x)++instance Convert TH.Con (HS.ConDecl ()) where+ conv (NormalC n xs) = ConDecl () (c n) (c xs)+ conv (RecC n xs) = RecDecl () (c n) [HSE.FieldDecl () [c x] $ c (y,z) | (x,y,z) <- xs]+ conv (InfixC x n y) = InfixConDecl () (c x) (c n) (c y)++instance Convert TH.StrictType (HS.Type ()) where+#if __GLASGOW_HASKELL__ >= 800+ conv (Bang SourceUnpack SourceStrict, x) = TyBang () (BangedTy ()) (Unpack ()) $ c x+ conv (Bang SourceUnpack _, x) = TyBang () (NoStrictAnnot ()) (Unpack ()) $ c x+ conv (Bang _ SourceStrict, x) = TyBang () (BangedTy ()) (NoUnpack ()) $ c x+ conv (Bang _ _, x) = c x+#else+ conv (IsStrict, x) = TyBang () (BangedTy ()) (NoUnpack ()) $ c x+ conv (NotStrict, x) = c x+#if __GLASGOW_HASKELL__ >= 704+ conv (Unpacked, x) = TyBang () (BangedTy ()) (Unpack ()) $ c x+#endif+#endif++instance Convert TH.Type (HS.Type ()) where+ conv (ForallT xs cxt t) = TyForall () (Just $ c xs) (Just $ c cxt) (c t)+ conv (VarT x) = TyVar () $ c x+ conv (ConT x) | ',' `elem` show x = TyTuple () Boxed []+ | otherwise = TyCon () $ c x+ conv (AppT (AppT ArrowT x) y) = TyFun () (c x) (c y)+ conv (ArrowT) = TyCon () $ Special () $ FunCon ()+ conv (AppT ListT x) = TyList () $ c x+ conv (ListT) = TyCon () $ Special () $ ListCon ()+ conv (TupleT _) = TyTuple () Boxed []+ conv (AppT x y) = case c x of+ TyTuple _ b xs -> TyTuple () b $ xs ++ [c y]+ x -> TyApp () x $ c y++instance Convert TH.Type (HS.Asst ()) where+ conv (ConT x) = ClassA () (UnQual () $ c x) []+ conv (AppT x y) = case c x of+ ClassA _ a b -> ClassA () a (b ++ [c y])++instance Convert (HS.Decl ()) TH.Dec where+ conv (InstDecl _ _ (fromIParen -> IRule _ _ cxt (fromInstHead -> (nam,typ))) ds) =+ instanceD (c cxt) (c $ tyApp (TyCon () nam) typ) [c d | InsDecl _ d <- fromMaybe [] ds]+ conv (FunBind _ ms@(HS.Match _ nam _ _ _:_)) = FunD (c nam) (c ms)+ conv (PatBind _ p bod ds) = ValD (c p) (c bod) (c ds)+ conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ)+#if __GLASGOW_HASKELL__ >= 800+ -- ! certainly BROKEN because it ignores contexts+ conv (DataDecl _ DataType{} ctx (fromDeclHead -> (nam, typ)) cs ds) =+ DataD (c ctx) (c nam) (c typ) Nothing (c cs) [] -- (c (map fst ds))+ conv (DataDecl _ NewType{} ctx (fromDeclHead -> (nam, typ)) [con] ds) =+ NewtypeD (c ctx) (c nam) (c typ) Nothing (c con) [] -- (c (map fst ds))+#else+ conv (DataDecl _ DataType{} ctx (fromDeclHead -> (nam, typ)) cs ds) =+ DataD (c ctx) (c nam) (c typ) (c cs) []+ conv (DataDecl _ NewType{} ctx (fromDeclHead -> (nam, typ)) [con] ds) =+ NewtypeD (c ctx) (c nam) (c typ) (c con) []+#endif++instance Convert (HS.QualConDecl ()) TH.Con where+ conv (QualConDecl _ Nothing Nothing con) = c con+ conv (QualConDecl _ vs cx con) = ForallC (c $ fromMaybe [] vs) (c cx) (c con)++instance Convert (HS.ConDecl ()) TH.Con where+ conv (ConDecl _ nam typ) = NormalC (c nam) (c typ)+ conv (InfixConDecl _ l nam r) = InfixC (c l) (c nam) (c r)+ conv (RecDecl _ nam fs) = RecC (c nam) (concatMap c fs)++instance Convert (HSE.FieldDecl ()) [TH.VarStrictType] where+ conv (HSE.FieldDecl _ names ty) = [(c name, bang, t) | let (bang,t) = c ty, name <- names]++instance Convert (HS.Type ()) TH.StrictType where+#if __GLASGOW_HASKELL__ >= 800+ conv (TyBang _ BangedTy{} _ t) = (Bang NoSourceUnpackedness SourceStrict, c t)+#else+ conv (TyBang _ BangedTy{} _ t) = (IsStrict, c t)+#if __GLASGOW_HASKELL__ >= 704+ conv (TyBang _ _ Unpack{} t) = (Unpacked, c t)+#else+ conv (TyBang _ _ Unpack{} t) = (IsStrict, c t)+#endif+#endif+#if __GLASGOW_HASKELL__ >= 800+ conv t = (Bang NoSourceUnpackedness NoSourceStrictness, c t)+#else+ conv t = (NotStrict, c t)+#endif++instance Convert ([HS.Name ()],HS.Type ()) [TH.VarStrictType] where+ conv (names,bt) = [(c name,s,t) | name <- names]+ where (s,t) = c bt++instance Convert (HS.Asst ()) TH.Type where+ conv (InfixA _ x y z) = c $ ClassA () y [x,z]+ conv (ClassA _ x y) = appT (ConT $ c x) (c y)++instance Convert (HS.Type ()) TH.Type where+ conv (TyCon _ (Special _ ListCon{})) = ListT+ conv (TyCon _ (Special _ UnitCon{})) = TupleT 0+ conv (TyParen _ x) = c x+ conv (TyForall _ x y z) = ForallT (c $ fromMaybe [] x) (c y) (c z)+ conv (TyVar _ x) = VarT $ c x+ conv (TyCon _ x) = if x ~= "[]" then error "here" else ConT $ c x+ conv (TyFun _ x y) = AppT (AppT ArrowT (c x)) (c y)+ conv (TyList _ x) = AppT ListT (c x)+ conv (TyTuple _ _ x) = appT (TupleT (length x)) (c x)+ conv (TyApp _ x y) = AppT (c x) (c y)++instance Convert (HS.Name ()) TH.Name where+ conv = mkName . filter (`notElem` "()") . prettyPrint++instance Convert (HS.Match ()) TH.Clause where+ conv (HS.Match _ _ ps bod ds) = Clause (c ps) (c bod) (c ds)++instance Convert (HS.Rhs ()) TH.Body where+ conv (UnGuardedRhs _ x) = NormalB (c x)+ conv (GuardedRhss _ x) = GuardedB (c x)++instance Convert (HS.Exp ()) TH.Exp where+ conv (Con _ (Special _ UnitCon{})) = TupE []+ conv (Var _ x) = VarE (c x)+ conv (Con _ x) = ConE (c x)+ conv (Lit _ x) = LitE (c x)+ conv (App _ x y) = AppE (c x) (c y)+ conv (Paren _ x) = c x+ conv (InfixApp _ x y z) = InfixE (Just $ c x) (c y) (Just $ c z)+ conv (LeftSection _ x y) = InfixE (Just $ c x) (c y) Nothing+ conv (RightSection _ y z) = InfixE Nothing (c y) (Just $ c z)+ conv (Lambda _ x y) = LamE (c x) (c y)+ conv (Tuple _ _ x) = TupE (c x)+ conv (If _ x y z) = CondE (c x) (c y) (c z)+ conv (Let _ x y) = LetE (c x) (c y)+ conv (Case _ x y) = CaseE (c x) (c y)+ conv (Do _ x) = DoE (c x)+ conv (EnumFrom _ x) = ArithSeqE $ FromR (c x)+ conv (EnumFromTo _ x y) = ArithSeqE $ FromToR (c x) (c y)+ conv (EnumFromThen _ x y) = ArithSeqE $ FromThenR (c x) (c y)+ conv (EnumFromThenTo _ x y z) = ArithSeqE $ FromThenToR (c x) (c y) (c z)+ conv (List _ x) = ListE (c x)+ conv (ExpTypeSig _ x y) = SigE (c x) (c y)+ conv (RecConstr _ x y) = RecConE (c x) (c y)+ conv (RecUpdate _ x y) = RecUpdE (c x) (c y)+ -- Work around bug 3395, convert to do notation instead+ conv (ListComp _ x y) = CompE $ c $ y ++ [QualStmt () $ Qualifier () x]++instance Convert (HS.GuardedRhs ()) (TH.Guard, TH.Exp) where+ conv (GuardedRhs _ g x) = (conv g, conv x)++instance Convert [HS.Stmt ()] TH.Guard where+ conv xs = PatG $ map conv xs++instance Convert (HS.Binds ()) [TH.Dec] where+ conv (BDecls _ x) = c x++instance Convert (Maybe (HS.Binds ())) [TH.Dec] where+ conv Nothing = []+ conv (Just x) = c x++instance Convert (HS.Pat ()) TH.Pat where+ conv (PParen _ x) = c x+ conv (PLit _ Signless{} x) = LitP (c x)+ conv (PTuple _ _ x) = TupP (c x)+ conv (PApp _ x y) = ConP (c x) (c y)+ conv (PVar _ x) = VarP (c x)+ conv (PInfixApp _ x y z) = InfixP (c x) (c y) (c z)+ conv (PIrrPat _ x) = TildeP (c x)+ conv (PAsPat _ x y) = AsP (c x) (c y)+ conv (PWildCard{}) = WildP+ conv (PRec _ x y) = RecP (c x) (c y)+ conv (PList _ x) = ListP (c x)+ conv (PatTypeSig _ x y) = SigP (c x) (c y)++instance Convert (HS.Literal ()) TH.Lit where+ conv (Char _ x _) = CharL x+ conv (String _ x _) = StringL x+ conv (Int _ x _) = IntegerL x+ conv (Frac _ x _) = RationalL x+ conv (PrimInt _ x _) = IntPrimL x+ conv (PrimWord _ x _) = WordPrimL x+ conv (PrimFloat _ x _) = FloatPrimL x+ conv (PrimDouble _ x _) = DoublePrimL x++instance Convert (HS.QName ()) TH.Name where+ conv (UnQual _ x) = c x+ conv (Qual _ m x) = c (Ident () $ prettyPrint m ++ "." ++ prettyPrint x)+ conv (Special _ (TupleCon _ Boxed i)) = Name (mkOccName $ "(" ++ replicate (i-1) ',' ++ ")") NameS++instance Convert (HS.PatField ()) TH.FieldPat where+ conv (PFieldPat _ name pat) = (c name, c pat)+ conv (PFieldPun _ name) = (c name, c $ PVar () $ Ident () $ prettyPrint name)+ conv (PFieldWildcard _) = error "Can't convert PFieldWildcard"++instance Convert (HS.QOp ()) TH.Exp where+ conv (QVarOp _ x) = c $ Var () x+ conv (QConOp _ x) = c $ Con () x++instance Convert (HS.Alt ()) TH.Match where+ conv (Alt _ x y z) = TH.Match (c x) (c y) (c z)++instance Convert (HS.Stmt ()) TH.Stmt where+ conv (Generator _ x y) = BindS (c x) (c y)+ conv (LetStmt _ x) = LetS (c x)+ conv (Qualifier _ x) = NoBindS (c x)++instance Convert (HS.QualStmt ()) TH.Stmt where+ conv (QualStmt _ x) = c x++instance Convert (HS.FieldUpdate ()) TH.FieldExp where+ conv (FieldUpdate _ x y) = (c x, c y)++instance Convert (HS.TyVarBind ()) TH.Name where+ conv (UnkindedVar _ x) = c x++#if __GLASGOW_HASKELL__ >= 612+instance Convert TH.TyVarBndr (HS.TyVarBind ()) where+ conv (PlainTV x) = UnkindedVar () $ c x+ conv (KindedTV x y) = KindedVar () (c x) $ c y++#if __GLASGOW_HASKELL__ < 706+instance Convert (TH.Kind ()) HS.Kind where+ conv StarK = KindStar+ conv (ArrowK x y) = KindFn (c x) $ c y+#else+instance Convert TH.Kind (HS.Kind ()) where+ conv StarT = KindStar ()+ conv (AppT (AppT ArrowT x) y) = KindFn () (c x) (c y)+#endif++#if __GLASGOW_HASKELL__ < 709+instance Convert TH.Pred (HS.Asst ()) where+ conv (ClassP x y) = ClassA () (UnQual () $ c x) $ c y+ conv (TH.EqualP x y) = HS.EqualP () (c x) $ c y++instance Convert (HS.Asst ()) TH.Pred where+ conv (ClassA _ x y) = ClassP (c x) $ c y+ conv (HS.EqualP _ x y) = TH.EqualP (c x) $ c y+#endif++instance Convert (HS.TyVarBind ()) TH.TyVarBndr where+ conv (UnkindedVar _ x) = PlainTV $ c x+ conv (KindedVar _ x y) = KindedTV (c x) $ c y++#if __GLASGOW_HASKELL__ < 706+instance Convert (HS.Kind ()) TH.Kind where+ conv (KindStar _) = StarK+ conv (KindFn _ x y) = ArrowK (c x) $ c y+#else+instance Convert (HS.Kind ()) TH.Kind where+ conv KindStar{} = StarT+ conv (KindFn _ x y) = AppT (AppT ArrowT (c x)) (c y)+#endif+#endif
+ src/Language/Haskell/TH/All.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -w #-}++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.Data, module Language.Haskell.TH.ExpandSynonym,+ ) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Peephole+import Language.Haskell.TH.Helper+import Language.Haskell.TH.ExpandSynonym+import Language.Haskell.TH.Data++import Control.Monad++++-- | The type of ways to derive classes.+-- Should not really be in this module!+data Derivation = Derivation {+ derivationDeriver :: DataDef -> Q [Dec], -- ^ The derivation function proper+ derivationName :: String -- ^ The name of the derivation+ }+++-- create a new derivation more abstractly+derivation :: (DataDef -> [Dec]) -> String -> Derivation+derivation f = Derivation (return . f)+++derivationQ :: (DataDef -> Q [Dec]) -> String -> Derivation+derivationQ = Derivation
+ src/Language/Haskell/TH/Compat.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}++-- | Compatibility definitions to paper over differences between 6.10 and 6.12.+module Language.Haskell.TH.Compat where++import Language.Haskell.TH+++#if __GLASGOW_HASKELL__ >= 612+fromTyVar :: TyVarBndr -> Name+fromTyVar (PlainTV v) = v+fromTyVar (KindedTV v _) = v+#else+fromTyVar :: Name -> Name+fromTyVar v = v+#endif++#if __GLASGOW_HASKELL__ >= 800+instanceD = InstanceD Nothing+#else+instanceD = InstanceD+#endif++dataDefinitionTypeArgs :: Dec -> [Name]+#if __GLASGOW_HASKELL__ >= 802+dataDefinitionTypeArgs (DataD _ _ _ _ _ deriv_clauses) =+ deriv_clauses >>= from_deriv_clause+dataDefinitionTypeArgs (NewtypeD _ _ _ _ _ deriv_clauses) =+ deriv_clauses >>= from_deriv_clause++from_deriv_clause :: DerivClause -> [Name]+from_deriv_clause (DerivClause _ cxt) = map from_cxt cxt+#elif __GLASGOW_HASKELL__ >= 800+dataDefinitionTypeArgs (DataD _cx name _ _ _ cxt) = map from_cxt cxt+dataDefinitionTypeArgs (NewtypeD cx name _ _ _ cxt) = map from_cxt cxt+#elif __GLASGOW_HASKELL__ >= 612+dataDefinitionTypeArgs (DataD _cx name _ _ args) = args+dataDefinitionTypeArgs (NewtypeD cx name _ _ args) = args+#else+dataDefinitionTypeArgs (DataD _cx name args cons _derv) = args+dataDefinitionTypeArgs (NewtypeD cx name args con derv) = args+#endif++from_cxt :: Type -> Name+from_cxt (ConT name) = name++#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 709+typeToPred :: Type -> Pred+typeToPred (ConT v) = ClassP v []+typeToPred (AppT x y) = ClassP v (t++[y])+ where ClassP v t = typeToPred x+#else+typeToPred :: Type -> Type+typeToPred x = x+#endif
+ src/Language/Haskell/TH/Data.hs view
@@ -0,0 +1,142 @@++-- | The core module of the Data.Derive system. This module contains+-- the data types used for communication between the extractors and+-- the derivors.++{-# language CPP #-}++module Language.Haskell.TH.Data where++import Data.Char+import Data.Generics++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Compat+++-- must be one of DataD or NewtypeD+type DataDef = Dec++type CtorDef = Con+++dataName :: DataDef -> String+#if __GLASGOW_HASKELL__ >= 800+dataName (DataD _ name _ _ _ _) = unqualifiedName name+dataName (NewtypeD _ name _ _ _ _) = unqualifiedName name+#else+dataName (DataD _ name _ _ _) = unqualifiedName name+dataName (NewtypeD _ name _ _ _) = unqualifiedName name+#endif++qualifiedDataName :: DataDef -> Name+#if __GLASGOW_HASKELL__ >= 800+qualifiedDataName (DataD _ name _ _ _ _) = name+qualifiedDataName (NewtypeD _ name _ _ _ _) = name+#else+qualifiedDataName (DataD _ name _ _ _) = name+qualifiedDataName (NewtypeD _ name _ _ _) = name+#endif++dataArity :: DataDef -> Int+#if __GLASGOW_HASKELL__ >= 800+dataArity (DataD _ _ xs _ _ _) = length xs+dataArity (NewtypeD _ _ xs _ _ _) = length xs+#else+dataArity (DataD _ _ xs _ _) = length xs+dataArity (NewtypeD _ _ xs _ _) = length xs+#endif++dataArgs :: DataDef -> [Name]+dataArgs = dataDefinitionTypeArgs+++dataCtors :: DataDef -> [CtorDef]+#if __GLASGOW_HASKELL__ >= 800+dataCtors (DataD _ _ _ _ xs _) = xs+dataCtors (NewtypeD _ _ _ _ x _) = [x]+#else+dataCtors (DataD _ _ _ xs _) = xs+dataCtors (NewtypeD _ _ _ x _) = [x]+#endif+++ctorName :: CtorDef -> String+ctorName (NormalC name _ ) = unqualifiedName name+ctorName (RecC name _ ) = unqualifiedName name+ctorName (InfixC _ name _) = unqualifiedName name+ctorName (ForallC _ _ c ) = ctorName c++qualifiedCtorName :: CtorDef -> Name+qualifiedCtorName (NormalC name _ ) = name+qualifiedCtorName (RecC name _ ) = name+qualifiedCtorName (InfixC _ name _) = name+qualifiedCtorName (ForallC _ _ c ) = qualifiedCtorName c+++ctorArity :: CtorDef -> Int+ctorArity (NormalC _ xs ) = length xs+ctorArity (RecC _ xs ) = length xs+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 varStrictType) = [unqualifiedName name | (name,strict,typ) <- varStrictType]+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++-- i_123432 -> i+dropNumber :: String -> String+dropNumber xs = if all isDigit a then reverse (tail b) else xs+ where (a,b) = break (== '_') $ reverse xs+++normData :: DataDef -> DataDef+normData = everywhere (mkT normType)+ where+ normType :: Type -> Type+ normType (ConT x) | show x == "[]" = ListT+ normType x = x++unqualifiedName :: Name -> String+unqualifiedName = dropModule . show+++-- 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 = nameBase x+isTupleT _ = False
+ src/Language/Haskell/TH/ExpandSynonym.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE PatternGuards #-}++-- | Expand type synonyms in data declarations.+-- +-- This is needed for some type based derivations.+module Language.Haskell.TH.ExpandSynonym (expandData) where++import Language.Haskell.TH+import Language.Haskell.TH.Compat+import Language.Haskell.TH.Data+import Data.Generics++-- | Expand type synonyms in a data declaration+expandData :: DataDef -> Q DataDef+expandData = everywhereM (mkM expandType)++expandType :: Type -> Q Type+expandType t = expandType' t []++-- Walk over a type, collecting applied arguments+expandType' :: Type -> [Type] -> Q Type+expandType' (AppT t arg) args = expandType' t (arg:args)+expandType' t@(ConT name) args = do result <- expandSyn name args+ case result of+ Just (t',args') -> everywhereM (mkM expandType) $ foldl AppT t' args'+ _ -> return $ foldl AppT t args+expandType' t args = return $ foldl AppT t args++-- Is the name a type synonym and are there enough arguments? if so, apply it+expandSyn :: Name -> [Type] -> Q (Maybe (Type, [Type]))+expandSyn name args = recover (return Nothing) $ do+ info <- reify name+ case info of+ TyConI (TySynD _ synArgs t) | length args >= length synArgs+ -> return $ Just (substitute (map fromTyVar synArgs) argsInst t, argsMore) -- instantiate type synonym+ where (argsInst,argsMore) = splitAt (length synArgs) args+ _ -> return Nothing+ -- `recover` return Nothing++-- Substitute names for types in a type+substitute :: [Name] -> [Type] -> Type -> Type+substitute ns ts = subst (zip ns ts)+ where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` (map fromTyVar ns)) . fst) s) t)+ subst s (VarT n)+ | Just t' <- lookup n s = t'+ subst s (AppT a b) = AppT (subst s a) (subst s b)+ subst _ t = t
+ src/Language/Haskell/TH/Helper.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+++-- | 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.Char++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Data+import Language.Haskell.TH.Compat++++-- * 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 = [typeToPred $ 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 (typeToPred . l1 cls) ctxTypes++-- | Build a type signature declaration with a string name+sigN :: String -> Type -> Dec+sigN nam ty = SigD (mkName nam) ty++-- | Build a fundecl with a string name+funN :: String -> [Clause] -> Dec+funN nam claus = FunD (mkName nam) claus++-- * Pattern vs Value abstraction++class Eq nm => NameLike nm where+ toName :: nm -> Name+instance NameLike Name where toName = id+instance NameLike String where toName = mkName++-- | The class used to overload lifting operations. To reduce code+-- duplication, we overload the wrapped constructors (and everything+-- else, but that's irrelevant) to work in patterns, expressions, and+-- types.+class Valcon a where+ -- | Build an application node, with a name for a head and a+ -- provided list of arguments.+ lK :: NameLike nm => nm -> [a] -> a+ -- | Reference a named variable.+ vr :: NameLike nm => nm -> a+ -- | Lift a TH 'Lit'+ raw_lit :: Lit -> a+ -- | Tupling+ tup :: [a] -> a+ -- | Listing+ lst :: [a] -> a+instance Valcon Exp where+ lK nm ys = let name = toName nm in case (nameBase name, ys) of+ ("[]", []) -> ConE name+ ("[]", xs) -> lst xs+ ((x:_), args) | isUpper x || x == ':' -> foldl AppE (ConE name) args+ ((x:_), [a,b]) | isOper x -> InfixE (Just a) (VarE name) (Just b)+ where isOper x = not (isAlpha x || x == '_')+ (nm, args) -> foldl AppE (VarE name) args++ vr = VarE . toName+ raw_lit = LitE+ tup = TupE+ lst = ListE+instance Valcon Pat where+ lK = ConP . toName+ vr = VarP . toName+ raw_lit = LitP+ tup = TupP+ lst = ListP+instance Valcon Type where+ lK nm = foldl AppT (if bNm == "[]" then ListT else ConT (mkName bNm))+ where bNm = nameBase (toName nm)+ vr = VarT . toName+ raw_lit = error "raw_lit @ Type"++ -- XXX work around bug in GHC < 6.10+ -- (see http://hackage.haskell.org/trac/ghc/ticket/2358 for details)+ tup [t] = t+ tup ts = foldl AppT (TupleT (length ts)) ts++ 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 :: (NameLike nm, Valcon a) => nm -> a+l1 :: (NameLike nm, Valcon a) => nm -> a -> a+l2 :: (NameLike nm, Valcon a) => nm -> a -> a -> a+l0 s = lK s []+l1 s a = lK s [a]+l2 s a b = lK s [a,b]++-- * 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
+ src/Language/Haskell/TH/Peephole.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE PatternGuards #-}++{-# OPTIONS_GHC -Wwarn #-}+{-+Otherwise I get:++src/Language/Haskell/TH/Peephole.hs:64:1: warning:+ Pattern match checker exceeded (2000000) iterations in+ an equation for ‘peep’. (Use -fmax-pmcheck-iterations=n+ to set the maximun number of iterations to n)++Seriously. Your warning checker is crap. My code is fine.+Don't produce warnings about code I can't possibly fix.+Especially not by default.+-}++module Language.Haskell.TH.Peephole(peephole, replaceVar, replaceVars) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Helper+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 (InfixE (Just (AppE pure x)) ap y)+ | ap ~= "<*>" && pure ~= "pure" = peep $ InfixE (Just x) (l0 "<$>") y++peep (InfixE (Just x) fmap (Just (AppE pure y)))+ | fmap ~= "<$>" && pure ~= "pure" = peep $ AppE pure (peep $ AppE x y)++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 (AppE (AppE comp f) g) x)+ | comp ~= "." = peep $ AppE f (peep $ AppE g x)+peep (AppE (InfixE (Just f) comp (Just g)) x)+ | comp ~= "." = peep $ AppE f (peep $ AppE g x)++peep (AppE (AppE (AppE flip f) x) y)+ | flip ~= "flip" = peep $ AppE (AppE f y) x++peep (AppE (InfixE (Just x) op Nothing) y) = peep $ InfixE (Just x) op (Just y)+peep (AppE (InfixE Nothing op (Just y)) x) = peep $ InfixE (Just x) op (Just y)++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 (AppE len (ListE xs))+ | len ~= "length" = LitE $ IntegerL $ toInteger $ length xs++peep (TupE [x]) = x++peep (AppE (LamE [pat] x) e) = CaseE e [Match pat (NormalB x) []]++peep (AppE (CaseE e [Match p (NormalB x) []]) y)+ = CaseE e [Match p (NormalB $ peep $ AppE x y) []]++-- 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