derive 2.0.0 → 2.0.1
raw patch · 17 files changed
+175/−128 lines, 17 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Data/Derive/Arbitrary.hs +20/−13
- Data/Derive/Data.hs +47/−31
- Data/Derive/Fold.hs +12/−12
- Data/Derive/Foldable.hs +4/−4
- Data/Derive/From.hs +7/−1
- Data/Derive/Functor.hs +3/−3
- Data/Derive/Internal/Derivation.hs +2/−2
- Data/Derive/Is.hs +23/−27
- Data/Derive/Monoid.hs +31/−17
- Data/Derive/NFData.hs +1/−1
- Data/Derive/Ord.hs +6/−5
- Data/Derive/Read.hs +1/−1
- Data/Derive/Show.hs +3/−3
- Data/DeriveDSL.hs +1/−1
- Derive/Test.hs +4/−3
- Language/Haskell.hs +9/−3
- derive.cabal +1/−1
Data/Derive/Arbitrary.hs view
@@ -14,6 +14,7 @@ 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@@ -49,19 +50,25 @@ "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (List [Int 1])])])]])])]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])])- ]),MapCtor (App "Alt" (List [App "PLit" (List [App "Int" (List [- CtorIndex])]),App "UnGuardedAlt" (List [App "Do" (List [Concat (- List [MapField (App "Generator" (List [App "PVar" (List [App- "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]),- App "Var" (List [App "UnQual" (List [App "Ident" (List [String- "arbitrary"])])])])),List [App "Qualifier" (List [App "App" (List- [App "Var" (List [App "UnQual" (List [App "Ident" (List [String- "return"])])]),App "Paren" (List [Application (Concat (List [List- [App "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName]- )])])],MapField (App "Var" (List [App "UnQual" (List [App "Ident"- (List [Concat (List [String "x",ShowInt FieldIndex])])])]))]))])])- ])]])])]),App "BDecls" (List [List []])]))])])]])]),App "BDecls" (- List [List []])])])])]+ ]),Concat (List [MapCtor (App "Alt" (List [App "PLit" (List [App+ "Int" (List [CtorIndex])]),App "UnGuardedAlt" (List [App "Do" (+ List [Concat (List [MapField (App "Generator" (List [App "PVar" (+ List [App "Ident" (List [Concat (List [String "x",ShowInt+ FieldIndex])])]),App "Var" (List [App "UnQual" (List [App "Ident"+ (List [String "arbitrary"])])])])),List [App "Qualifier" (List [+ App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"+ (List [String "return"])])]),App "Paren" (List [Application (+ Concat (List [List [App "Con" (List [App "UnQual" (List [App+ "Ident" (List [CtorName])])])],MapField (App "Var" (List [App+ "UnQual" (List [App "Ident" (List [Concat (List [String "x",+ ShowInt FieldIndex])])])]))]))])])])]])])]),App "BDecls" (List [+ List []])])),List [App "Alt" (List [App "PWildCard" (List []),App+ "UnGuardedAlt" (List [App "App" (List [App "Var" (List [App+ "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit"+ (List [App "String" (List [String+ "FATAL ERROR: Arbitrary instance, logic bug"])])])]),App "BDecls"+ (List [List []])])]])])])]])]),App "BDecls" (List [List []])])])])+ ] -- GENERATED STOP custom = customContext context
Data/Derive/Data.hs view
@@ -13,6 +13,7 @@ 0 -> z First 1 -> const k 1 $ const k 2 $ z Second 2 -> const k 1 $ z Third+ i -> error $ ("Data.gunfold for Sample" ++ ", unknown index: ") ++ show i toConstr x@First{} = indexConstr (dataTypeOf x) (0+1) toConstr x@Second{} = indexConstr (dataTypeOf x) (1+1)@@ -32,6 +33,7 @@ gunfold k z c = case constrIndex c - 1 of 0 -> k $ k $ z Laptop 1 -> k $ z Desktop+ i -> error $ "Data.gunfold for Computer, unknown index: " ++ show i toConstr x@Laptop{} = indexConstr (dataTypeOf x) 1 toConstr x@Desktop{} = indexConstr (dataTypeOf x) 2 dataTypeOf _ = ty@@ -76,37 +78,51 @@ "constrIndex"])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String "c"])])])]),App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String "-"])])]),App "Lit" (List [App- "Int" (List [Int 1])])]),MapCtor (App "Alt" (List [App "PLit" (- List [App "Int" (List [CtorIndex])]),App "UnGuardedAlt" (List [- Fold (App "InfixApp" (List [Head,App "QVarOp" (List [App "UnQual"- (List [App "Symbol" (List [String "$"])])]),Tail])) (Concat (List- [MapField (Application (List [App "Var" (List [App "UnQual" (List- [App "Ident" (List [String "const"])])]),App "Var" (List [App- "UnQual" (List [App "Ident" (List [String "k"])])]),App "Lit" (- List [App "Int" (List [FieldIndex])])])),List [App "App" (List [- App "Var" (List [App "UnQual" (List [App "Ident" (List [String "z"- ])])]),App "Con" (List [App "UnQual" (List [App "Ident" (List [- CtorName])])])])]]))]),App "BDecls" (List [List []])]))])]),App- "BDecls" (List [List []])])]])]),App "InsDecl" (List [App- "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [- String "toConstr"]),List [App "PAsPat" (List [App "Ident" (List [- String "x"]),App "PRec" (List [App "UnQual" (List [App "Ident" (- List [CtorName])]),List []])])],App "Nothing" (List []),App- "UnGuardedRhs" (List [Application (List [App "Var" (List [App- "UnQual" (List [App "Ident" (List [String "indexConstr"])])]),App- "Paren" (List [App "App" (List [App "Var" (List [App "UnQual" (- List [App "Ident" (List [String "dataTypeOf"])])]),App "Var" (List- [App "UnQual" (List [App "Ident" (List [String "x"])])])])]),App- "Paren" (List [App "InfixApp" (List [App "Lit" (List [App "Int" (- List [CtorIndex])]),App "QVarOp" (List [App "UnQual" (List [App- "Symbol" (List [String "+"])])]),App "Lit" (List [App "Int" (List- [Int 1])])])])])]),App "BDecls" (List [List []])]))])]),App- "InsDecl" (List [App "FunBind" (List [List [App "Match" (List [App- "Ident" (List [String "dataTypeOf"]),List [App "PWildCard" (List [- ])],App "Nothing" (List []),App "UnGuardedRhs" (List [App "Var" (- List [App "UnQual" (List [App "Ident" (List [String "ty"])])])]),- App "BDecls" (List [List [App "PatBind" (List [App "PVar" (List [- App "Ident" (List [String "ty"])]),App "Nothing" (List []),App+ "Int" (List [Int 1])])]),Concat (List [MapCtor (App "Alt" (List [+ App "PLit" (List [App "Int" (List [CtorIndex])]),App+ "UnGuardedAlt" (List [Fold (App "InfixApp" (List [Head,App+ "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String "$"+ ])])]),Tail])) (Concat (List [MapField (Application (List [App+ "Var" (List [App "UnQual" (List [App "Ident" (List [String "const"+ ])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [+ String "k"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])]+ )),List [App "App" (List [App "Var" (List [App "UnQual" (List [App+ "Ident" (List [String "z"])])]),App "Con" (List [App "UnQual" (+ List [App "Ident" (List [CtorName])])])])]]))]),App "BDecls" (List+ [List []])])),List [App "Alt" (List [App "PVar" (List [App "Ident"+ (List [String "i"])]),App "UnGuardedAlt" (List [App "InfixApp" (+ List [App "Var" (List [App "UnQual" (List [App "Ident" (List [+ String "error"])])]),App "QVarOp" (List [App "UnQual" (List [App+ "Symbol" (List [String "$"])])]),App "InfixApp" (List [App "Paren"+ (List [App "InfixApp" (List [App "Lit" (List [App "String" (List [+ Concat (List [String "Data.gunfold for ",DataName])])]),App+ "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String+ "++"])])]),App "Lit" (List [App "String" (List [String+ ", unknown index: "])])])]),App "QVarOp" (List [App "UnQual" (List+ [App "Symbol" (List [String "++"])])]),App "App" (List [App "Var"+ (List [App "UnQual" (List [App "Ident" (List [String "show"])])]),+ App "Var" (List [App "UnQual" (List [App "Ident" (List [String "i"+ ])])])])])])]),App "BDecls" (List [List []])])]])])]),App "BDecls"+ (List [List []])])]])]),App "InsDecl" (List [App "FunBind" (List [+ MapCtor (App "Match" (List [App "Ident" (List [String "toConstr"])+ ,List [App "PAsPat" (List [App "Ident" (List [String "x"]),App+ "PRec" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),+ List []])])],App "Nothing" (List []),App "UnGuardedRhs" (List [+ Application (List [App "Var" (List [App "UnQual" (List [App+ "Ident" (List [String "indexConstr"])])]),App "Paren" (List [App+ "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (+ List [String "dataTypeOf"])])]),App "Var" (List [App "UnQual" (+ List [App "Ident" (List [String "x"])])])])]),App "Paren" (List [+ App "InfixApp" (List [App "Lit" (List [App "Int" (List [CtorIndex]+ )]),App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [+ String "+"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])])+ ]),App "BDecls" (List [List []])]))])]),App "InsDecl" (List [App+ "FunBind" (List [List [App "Match" (List [App "Ident" (List [+ String "dataTypeOf"]),List [App "PWildCard" (List [])],App+ "Nothing" (List []),App "UnGuardedRhs" (List [App "Var" (List [App+ "UnQual" (List [App "Ident" (List [String "ty"])])])]),App+ "BDecls" (List [List [App "PatBind" (List [App "PVar" (List [App+ "Ident" (List [String "ty"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [Application (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [String "mkDataType"])])]),App "SpliceExp" (List [App "ParenSplice" (List [App "Var" (List [App
Data/Derive/Fold.hs view
@@ -14,25 +14,25 @@ test :: Computer foldComputer :: (Double -> Int -> a) -> (Int -> a) -> Computer -> a-foldComputer f1 f2 (Laptop x1 x2) = f1 x1 x2-foldComputer f1 f2 (Desktop x1) = f2 x1+foldComputer f _ (Laptop x1 x2) = f x1 x2+foldComputer _ f (Desktop x1) = f x1 test :: Assoced foldAssoced :: (typ -> String -> a) -> Assoced typ -> a-foldAssoced f1 (Assoced x1 x2) = f1 x1 x2+foldAssoced f (Assoced x1 x2) = f x1 x2 test :: Either foldEither :: (a -> c) -> (b -> c) -> Either a b -> c-foldEither f1 f2 (Left x1) = f1 x1-foldEither f1 f2 (Right x1) = f2 x1+foldEither f _ (Left x1) = f x1+foldEither _ f (Right x1) = f x1 test :: Bool foldBool :: a -> a -> Bool -> a-foldBool f1 f2 False = f1-foldBool f1 f2 True = f2+foldBool f _ False = f+foldBool _ f True = f -} @@ -47,13 +47,13 @@ mkFold :: DataDecl -> [Decl]-mkFold d = [TypeSig sl [name n] (foldType d), FunBind $ zipWith f funs $ dataDeclCtors d]+mkFold d = [TypeSig sl [name n] (foldType d), FunBind $ zipWith f [0..] $ dataDeclCtors d] where n = "fold" ++ title (dataDeclName d)- funs = ['f' : show i | i <- [1..length (dataDeclCtors d)]]- f fun c = Match sl (name n) pat Nothing (UnGuardedRhs bod) (BDecls [])- where pat = map pVar funs ++ [PParen $ PApp (qname $ ctorDeclName c) (map pVar vars)]- bod = apps (var fun) (map var vars)+ f i c = Match sl (name n) pat Nothing (UnGuardedRhs bod) (BDecls [])+ 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)]]
Data/Derive/Foldable.hs view
@@ -16,19 +16,19 @@ test :: FailList instance Foldable (FailList t1) where- foldr _f b Zero = b- foldr _f b (Fail a1) = b+ foldr _ b Zero = b+ foldr _ b (Fail _) = b foldr _f b (Const a1 a2) = _f a1 (Data.Foldable.foldr _f b a2) test :: Sample instance Foldable Sample where- foldr _f b First = b+ foldr _ b First = b foldr _f b (Second a1 a2) = _f a1 (_f a2 b) foldr _f b (Third a1) = _f a1 b test :: Either instance Foldable (Either t1) where- foldr _f b (Left a1) = b+ foldr _ b (Left _) = b foldr _f b (Right a1) = _f a1 b -}
Data/Derive/From.hs view
@@ -16,12 +16,15 @@ 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" -} @@ -34,7 +37,7 @@ makeFromCtor :: DataDecl -> CtorDecl -> [Decl]-makeFromCtor d c = [TypeSig sl [name from] typ, FunBind [match]]+makeFromCtor d c = [TypeSig sl [name from] typ, FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]] where n = ctorDeclName c from = "from" ++ n@@ -46,6 +49,9 @@ 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 sl (name from) [PWildCard] Nothing (UnGuardedRhs err) (BDecls [])+ err = App (var "error") $ Lit $ String $ from ++ " failed, not a " ++ n tyTuple [] = TyCon $ Special UnitCon
Data/Derive/Functor.hs view
@@ -19,8 +19,8 @@ test :: FailList instance Functor (FailList t1) where- fmap _f Zero = Zero- fmap _f (Fail a1) = Fail a1+ fmap _ Zero = Zero+ fmap _ (Fail a1) = Fail a1 fmap _f (Const a1 a2) = Const (_f a1) (fmap _f a2) test :: State@@ -29,7 +29,7 @@ test :: Sample instance Functor Sample where- fmap _f First = First+ fmap _ First = First fmap _f (Second a1 a2) = Second (_f a1) (_f a2) fmap _f (Third a1) = Third (_f a1) -}
Data/Derive/Internal/Derivation.hs view
@@ -16,14 +16,14 @@ derivationDSL :: String -> DSL -> Derivation-derivationDSL name dsl = Derivation name $ applyDSL dsl . snd+derivationDSL name dsl = derivationCustomDSL name (const id) dsl derivationCustomDSL :: String -> (FullDataDecl -> [Decl] -> [Decl]) -> DSL -> Derivation derivationCustomDSL name custom dsl = Derivation name $ \d -> case applyDSL dsl $ snd d of Left x -> Left x- Right x -> Right $ custom d x+ Right x -> Right $ simplify $ custom d x customSplice :: (FullDataDecl -> Exp -> Exp) -> (FullDataDecl -> [Decl] -> [Decl])
Data/Derive/Is.hs view
@@ -1,37 +1,33 @@-module Data.Derive.Is where+module Data.Derive.Is(makeIs) where {- -example :: Sample+test :: Sample -isFirst (First {}) = True; isFirst _ | length [First{},Second{},Third{}] > 1 = False-isSecond (Second{}) = True; isSecond _ | length [First{},Second{},Third{}] > 1 = False-isThird (Third {}) = True; isThird _ | length [First{},Second{},Third{}] > 1 = False+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+ -}--- GENERATED START -import Data.Derive.DSL.DSL+import Language.Haskell import Data.Derive.Internal.Derivation + makeIs :: Derivation-makeIs = derivationDSL "Is" dslIs+makeIs = Derivation "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d -dslIs =- MapCtor (App "FunBind" (List [List [App "Match" (List [App "Ident"- (List [Concat (List [String "is",CtorName])]),List [App "PParen" (- List [App "PRec" (List [App "UnQual" (List [App "Ident" (List [- CtorName])]),List []])])],App "Nothing" (List []),App- "UnGuardedRhs" (List [App "Con" (List [App "UnQual" (List [App- "Ident" (List [String "True"])])])]),App "BDecls" (List [List []])- ]),App "Match" (List [App "Ident" (List [Concat (List [String "is"- ,CtorName])]),List [App "PWildCard" (List [])],App "Nothing" (List- []),App "GuardedRhss" (List [List [App "GuardedRhs" (List [List [- App "Qualifier" (List [App "InfixApp" (List [App "App" (List [App- "Var" (List [App "UnQual" (List [App "Ident" (List [String- "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [- App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])])- ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [- String ">"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])],- App "Con" (List [App "UnQual" (List [App "Ident" (List [String- "False"])])])])]]),App "BDecls" (List [List []])])]]))--- GENERATED STOP++makeIsCtor :: DataDecl -> CtorDecl -> [Decl]+makeIsCtor d c =+ [TypeSig sl [name nam] (dataDeclType d `TyFun` tyCon "Bool")+ ,FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]]+ where+ nam = "is" ++ ctorDeclName c+ + match = Match sl (name nam) [PParen $ PRec (qname $ ctorDeclName c) []] Nothing (UnGuardedRhs $ con "True") (BDecls [])+ defMatch = Match sl (name nam) [PWildCard] Nothing (UnGuardedRhs $ con "False") (BDecls [])
Data/Derive/Monoid.hs view
@@ -13,6 +13,7 @@ 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@@ -35,21 +36,34 @@ "Ident" (List [String "const"])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String "mempty"])])]),App "Lit" (List [ App "Int" (List [FieldIndex])])])]))])))])])]),App "BDecls" (List- [List []])])]),App "InsDecl" (List [App "FunBind" (List [MapCtor (- App "Match" (List [App "Ident" (List [String "mappend"]),List [App- "PParen" (List [App "PApp" (List [App "UnQual" (List [App "Ident"- (List [CtorName])]),MapField (App "PVar" (List [App "Ident" (List- [Concat (List [String "x",ShowInt FieldIndex])])]))])]),App- "PParen" (List [App "PApp" (List [App "UnQual" (List [App "Ident"- (List [CtorName])]),MapField (App "PVar" (List [App "Ident" (List- [Concat (List [String "y",ShowInt FieldIndex])])]))])])],App- "Nothing" (List []),App "UnGuardedRhs" (List [Application (Concat- (List [List [App "Con" (List [App "UnQual" (List [App "Ident" (- List [CtorName])])])],MapField (App "Paren" (List [Application (- List [App "Var" (List [App "UnQual" (List [App "Ident" (List [- String "mappend"])])]),App "Var" (List [App "UnQual" (List [App- "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])])])- ,App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (- List [String "y",ShowInt FieldIndex])])])])])]))]))]),App "BDecls"- (List [List []])]))])])])]+ [List []])])]),App "InsDecl" (List [App "FunBind" (List [Concat (+ List [MapCtor (App "Match" (List [App "Ident" (List [String+ "mappend"]),List [App "PParen" (List [App "PApp" (List [App+ "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App+ "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt+ FieldIndex])])]))])]),App "PParen" (List [App "PApp" (List [App+ "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App+ "PVar" (List [App "Ident" (List [Concat (List [String "y",ShowInt+ FieldIndex])])]))])])],App "Nothing" (List []),App "UnGuardedRhs"+ (List [Application (Concat (List [List [App "Con" (List [App+ "UnQual" (List [App "Ident" (List [CtorName])])])],MapField (App+ "Paren" (List [Application (List [App "Var" (List [App "UnQual" (+ List [App "Ident" (List [String "mappend"])])]),App "Var" (List [+ App "UnQual" (List [App "Ident" (List [Concat (List [String "x",+ ShowInt FieldIndex])])])]),App "Var" (List [App "UnQual" (List [+ App "Ident" (List [Concat (List [String "y",ShowInt FieldIndex])])+ ])])])]))]))]),App "BDecls" (List [List []])])),List [App "Match"+ (List [App "Ident" (List [String "mappend"]),List [App "PWildCard"+ (List []),App "PWildCard" (List [])],App "Nothing" (List []),App+ "GuardedRhss" (List [List [App "GuardedRhs" (List [List [App+ "Qualifier" (List [App "InfixApp" (List [App "App" (List [App+ "Var" (List [App "UnQual" (List [App "Ident" (List [String+ "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [+ App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])])+ ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [+ String ">"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])],+ App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"+ (List [String "error"])])]),App "Lit" (List [App "String" (List [+ Concat (List [String "Monoid.mappend: Different constructors for "+ ,DataName])])])])])]]),App "BDecls" (List [List []])])]])])])])] -- GENERATED STOP
Data/Derive/NFData.hs view
@@ -1,6 +1,6 @@ module Data.Derive.NFData where {--import "parallel" Control.Parallel.Strategies+import "parallel" Control.Parallel.Strategies(NFData, rnf) example :: Sample instance NFData a => NFData (Sample a) where
Data/Derive/Ord.hs view
@@ -14,9 +14,9 @@ EQ & x = x x & _ = x - tag (First{}) = 0- tag (Second{}) = 1- tag (Third{}) = 2+ tag (First{}) = 0 :: Int+ tag (Second{}) = 1 :: Int+ tag (Third{}) = 2 :: Int -} -- GENERATED START@@ -87,6 +87,7 @@ App "Ident" (List [String "tag"]),List [App "PParen" (List [App "PRec" (List [App "UnQual" (List [App "Ident" (List [CtorName])]), List []])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App- "Lit" (List [App "Int" (List [CtorIndex])])]),App "BDecls" (List [- List []])]))])]])])]])])])]+ "ExpTypeSig" (List [App "Lit" (List [App "Int" (List [CtorIndex])]+ ),App "TyCon" (List [App "UnQual" (List [App "Ident" (List [String+ "Int"])])])])]),App "BDecls" (List [List []])]))])]])])]])])])] -- GENERATED STOP
Data/Derive/Read.hs view
@@ -38,7 +38,7 @@ test :: Computer instance Read Computer where- readsPrec p0 r =+ readsPrec _ r = readParen False (\r0 -> [ (Laptop x1 x2, r10) | ("Laptop", r1) <- lex r0
Data/Derive/Show.hs view
@@ -18,15 +18,15 @@ test :: Sample instance Show a => Show (Sample a) where- showsPrec p First = showString "First"+ showsPrec _ First = showString "First" showsPrec p (Second x1 x2) = showParen (p > 10) $ showString "Second " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2 showsPrec p (Third x1) = showParen (p > 10) $ showString "Third " . showsPrec 11 x1 test :: Computer instance Show Computer where- showsPrec p (Laptop x1 x2) =+ showsPrec _ (Laptop x1 x2) = showString "Laptop {weight = " . showsPrec 0 x1 . showString ", speed = " . showsPrec 0 x2 . showChar '}'- showsPrec p (Desktop x1) =+ showsPrec _ (Desktop x1) = showString "Desktop {speed = " . showsPrec 0 x1 . showChar '}' test :: (:*:)
Data/DeriveDSL.hs view
@@ -15,7 +15,7 @@ applyDSL :: DSL -> DataDecl -> Either String [Decl]-applyDSL dsl inp = Right $ simplify $ apply dsl $ toInput inp+applyDSL dsl inp = Right $ apply dsl $ toInput inp dynamicDSL :: DSL -> Maybe [Decl]
Derive/Test.hs view
@@ -68,11 +68,12 @@ autoTest :: [Src] -> [DataDecl] -> [Derivation] -> [String] autoTest ss ts ds = ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses #-}"- ,"{-# OPTIONS_GHC -fno-warn-missing-fields #-}"+ ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields #-}" ,"import Data.DeriveTH"- ,"import Derive.TestInstances"] +++ ,"import Derive.TestInstances()"] ++ [prettyPrint i | s <- ss2, i <- srcImportStd s] ++- ["main = putStrLn \"Type checking successful\""] +++ ["main :: IO ()"+ ,"main = putStrLn \"Type checking successful\""] ++ [prettyPrint t | t <- ts2] ++ ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | d <- ds2] where
Language/Haskell.hs view
@@ -47,6 +47,7 @@ | 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 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@@ -71,10 +72,11 @@ | x ~= "True" = t | x ~= "False" = f fExp (App (App when b) x)- | b ~= "True" = x- | b ~= "False" = App (Var $ UnQual $ Ident "return") (Con $ Special $ TupleCon Boxed 0)+ | 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 x = x fTyp (TyApp x y) | x ~= "[]" = TyApp (TyCon (Special ListCon)) y@@ -92,7 +94,11 @@ | x ~= "True" = fMatch $ Match sl nam pat sig (UnGuardedRhs bod) decls fMatch (Match sl nam [PVar x] sig (UnGuardedRhs (Case (Var (UnQual x2)) [Alt _ pat (UnGuardedAlt y) (BDecls [])])) decls) | x == x2 = fMatch $ Match sl nam [PParen pat] sig (UnGuardedRhs y) decls- fMatch (Match a b c d e bind) = fBinds (Match a b c d e) bind+ fMatch o@(Match a b c d e bind) = fBinds (Match a b (transformBi f c) d e) bind+ where+ known = nub [x | UnQual x <- universeBi o]+ f (PVar x) | x `notElem` known = PWildCard+ f x = x fDecl (PatBind a b c d bind) = fBinds (PatBind a b c d) bind fDecl (FunBind xs) = FunBind $ filter (not . isGuardFalse) xs
derive.cabal view
@@ -1,7 +1,7 @@ Cabal-Version: >= 1.6 Build-Type: Default Name: derive-Version: 2.0.0+Version: 2.0.1 build-type: Simple Copyright: 2006-2009, Neil Mitchell Maintainer: ndmitchell@gmail.com