diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,9 @@ Changelog for Derive +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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Neil Mitchell 2006-2016. +Copyright Neil Mitchell 2006-2017. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -35,16 +35,11 @@ * **[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) -* **[Data](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3AData)** - 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) -* **[Enum](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum)** - from the library [base](http://hackage.haskell.org/package/base) * **[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) -* **[Eq](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEq)** - 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)** -* **[Foldable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Foldable.html#t%3AFoldable)** - from the library [base](http://hackage.haskell.org/package/base) * **[From](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-From.html)** -* **[Functor](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AFunctor)** - from the library [base](http://hackage.haskell.org/package/base) * **[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) @@ -52,15 +47,10 @@ * **[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) -* **[Ord](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AOrd)** - from the library [base](http://hackage.haskell.org/package/base) -* **[Read](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ARead)** - from the library [base](http://hackage.haskell.org/package/base) * **[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)** -* **[Show](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AShow)** - from the library [base](http://hackage.haskell.org/package/base) -* **[Traversable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Traversable.html#t%3ATraversable)** - from the library [base](http://hackage.haskell.org/package/base) -* **[Typeable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Typeable.html#t%3ATypeable)** - from the library [base](http://hackage.haskell.org/package/base) * **[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)** diff --git a/derive.cabal b/derive.cabal --- a/derive.cabal +++ b/derive.cabal @@ -1,9 +1,9 @@ -cabal-version: >= 1.8 +cabal-version: >= 1.18 build-type: Default name: derive -version: 2.5.26 +version: 2.6 build-type: Simple -copyright: Neil Mitchell 2006-2016 +copyright: Neil Mitchell 2006-2017 author: Neil Mitchell maintainer: Neil Mitchell homepage: https://github.com/ndmitchell/derive#readme @@ -20,23 +20,25 @@ extra-doc-files: README.md CHANGES.txt -tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 +tested-with: GHC==8.0.2, GHC==7.10.3 source-repository head type: git location: https://github.com/ndmitchell/derive.git executable derive + default-language: Haskell2010 build-depends: base==4.* , derive main-is: Main.hs 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.17 && < 1.18, + haskell-src-exts >= 1.18 && < 1.19, transformers >= 0.2, uniplate >= 1.5 && < 1.7 @@ -68,16 +70,11 @@ Data.Derive.Binary Data.Derive.BinaryDefer Data.Derive.Bounded - Data.Derive.Data Data.Derive.DataAbstract Data.Derive.Default - Data.Derive.Enum Data.Derive.EnumCyclic - Data.Derive.Eq Data.Derive.Fold - Data.Derive.Foldable Data.Derive.From - Data.Derive.Functor Data.Derive.Has Data.Derive.Is Data.Derive.JSON @@ -85,15 +82,10 @@ Data.Derive.Lens Data.Derive.Monoid Data.Derive.NFData - Data.Derive.Ord - Data.Derive.Read Data.Derive.Ref Data.Derive.Serial Data.Derive.Serialize Data.Derive.Set - Data.Derive.Show - Data.Derive.Traversable - Data.Derive.Typeable Data.Derive.UniplateDirect Data.Derive.UniplateTypeable Data.Derive.Update diff --git a/src/Data/Derive/All.hs b/src/Data/Derive/All.hs --- a/src/Data/Derive/All.hs +++ b/src/Data/Derive/All.hs @@ -11,16 +11,11 @@ import Data.Derive.Binary as D import Data.Derive.BinaryDefer as D import Data.Derive.Bounded as D -import Data.Derive.Data as D import Data.Derive.DataAbstract as D import Data.Derive.Default as D -import Data.Derive.Enum as D import Data.Derive.EnumCyclic as D -import Data.Derive.Eq as D import Data.Derive.Fold 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.JSON as D @@ -28,18 +23,13 @@ import Data.Derive.Lens as D import Data.Derive.Monoid as D import Data.Derive.NFData as D -import Data.Derive.Ord as D -import Data.Derive.Read 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.Show as D -import Data.Derive.Traversable as D -import Data.Derive.Typeable 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,makeData,makeDataAbstract,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeJSON,makeLazySet,makeLens,makeMonoid,makeNFData,makeOrd,makeRead,makeRef,makeSerial,makeSerialize,makeSet,makeShow,makeTraversable,makeTypeable,makeUniplateDirect,makeUniplateTypeable,makeUpdate] +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 diff --git a/src/Data/Derive/Arbitrary.hs b/src/Data/Derive/Arbitrary.hs --- a/src/Data/Derive/Arbitrary.hs +++ b/src/Data/Derive/Arbitrary.hs @@ -33,40 +33,63 @@ makeArbitrary :: Derivation makeArbitrary = derivationCustomDSL "Arbitrary" custom $ - List [Instance [] "Arbitrary" (List [App "InsDecl" (List [App - "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "arbitrary"])]),App "UnGuardedRhs" (List [App "Do" (List [List [ - App "Generator" (List [App "PVar" (List [App "Ident" (List [String - "x"])]),App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "choose"])])]),App "Tuple" (List [App - "Boxed" (List []),List [App "ExpTypeSig" (List [App "Lit" (List [ - App "Int" (List [Int 0])]),App "TyCon" (List [App "UnQual" (List [ - App "Ident" (List [String "Int"])])])]),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 "Qualifier" (List [App "Case" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])]) - ]),Concat (List [MapCtor (App "Alt" (List [App "PLit" (List [App - "Signless" (List []),App "Int" (List [CtorIndex])]),App - "UnGuardedRhs" (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 - "Nothing" (List [])])),List [App "Alt" (List [App "PWildCard" ( - List []),App "UnGuardedRhs" (List [App "App" (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "error"])])]), - App "Lit" (List [App "String" (List [String + 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 [])])])])] + (List [])])]])])])]])]),App "Nothing" (List [])])])]]))] -- GENERATED STOP custom = customContext context @@ -74,10 +97,10 @@ -- Fix the context -- C a b => Arbitrary a, Arbitrary b -- a -> b => CoArbitrary a, Arbitrary b -context :: FullDataDecl -> Context -> Context -context (_,d) _ = nub $ concatMap (f True . snd) $ concatMap ctorDeclFields $ dataDeclCtors d +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 (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) diff --git a/src/Data/Derive/ArbitraryOld.hs b/src/Data/Derive/ArbitraryOld.hs --- a/src/Data/Derive/ArbitraryOld.hs +++ b/src/Data/Derive/ArbitraryOld.hs @@ -15,9 +15,9 @@ 2 -> do x1 <- arbitrary return (Third x1) - coarbitrary (First) = variant 0 - coarbitrary (Second x1 x2) = variant 1 . coarbitrary x1 . coarbitrary x2 - coarbitrary (Third x1) = variant 2 . coarbitrary x1 + coarbitrary (First) = () + coarbitrary (Second x1 x2) = () + coarbitrary (Third x1) = () -} -- GENERATED START @@ -29,46 +29,61 @@ makeArbitraryOld = derivationDSL "ArbitraryOld" dslArbitraryOld dslArbitraryOld = - List [Instance ["Arbitrary"] "Arbitrary" (List [App "InsDecl" ( - List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ - String "arbitrary"])]),App "UnGuardedRhs" (List [App "Do" (List [ - List [App "Generator" (List [App "PVar" (List [App "Ident" (List [ - String "x"])]),App "App" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "choose"])])]),App "Tuple" (List [ - App "Boxed" (List []),List [App "Lit" (List [App "Int" (List [Int - 0])]),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 "Qualifier" ( - List [App "Case" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "x"])])]),MapCtor (App "Alt" (List [App - "PLit" (List [App "Signless" (List []),App "Int" (List [CtorIndex] - )]),App "UnGuardedRhs" (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 "Nothing" (List [])]))])])]])]),App "Nothing" (List [])])]) - ,App "InsDecl" (List [App "FunBind" (List [MapCtor (App "Match" ( - List [App "Ident" (List [String "coarbitrary"]),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 "Nothing" ( - List []),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List [ - Head,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ - String "."])])]),Tail])) (Concat (List [List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "variant"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])] - ,MapField (App "App" (List [App "Var" (List [App "UnQual" (List [ - App "Ident" (List [String "coarbitrary"])])]),App "Var" (List [App - "UnQual" (List [App "Ident" (List [Concat (List [String "x", - ShowInt FieldIndex])])])])]))]))]),App "Nothing" (List [])]))])])] - )] + 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 diff --git a/src/Data/Derive/Arities.hs b/src/Data/Derive/Arities.hs --- a/src/Data/Derive/Arities.hs +++ b/src/Data/Derive/Arities.hs @@ -32,13 +32,17 @@ makeArities = derivationDSL "Arities" dslArities dslArities = - List [Instance [] "Arities" (List [App "InsDecl" (List [App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "arities"]),List [App "PWildCard" (List [])],App "Nothing" - (List []),App "UnGuardedRhs" (List [App "List" (List [MapCtor ( - Application (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "const"])])]),App "Lit" (List [App "Int" ( - List [CtorArity])]),App "RecConstr" (List [App "UnQual" (List [App - "Ident" (List [CtorName])]),List []])]))])]),App "Nothing" (List [ - ])])]])])])] + 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 diff --git a/src/Data/Derive/Binary.hs b/src/Data/Derive/Binary.hs --- a/src/Data/Derive/Binary.hs +++ b/src/Data/Derive/Binary.hs @@ -56,79 +56,126 @@ makeBinary = derivationDSL "Binary" dslBinary dslBinary = - List [Instance ["Binary"] "Binary" (List [App "InsDecl" (List [App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "put"]),List [App "PVar" (List [App "Ident" (List [String - "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App - "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( - List [String "x"])])]),MapCtor (App "Alt" (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 "UnGuardedRhs" (List [App "Do" (List [ - Concat (List [List [App "Qualifier" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "putTag"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])]) - ],MapField (App "Qualifier" (List [App "App" (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "put"])])]), - App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat ( - List [String "x",ShowInt FieldIndex])])])])])]))])])]),App - "Nothing" (List [])]))])]),App "Just" (List [App "BDecls" (List [ - List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ - String "useTag"])]),App "UnGuardedRhs" (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 "Nothing" (List [])]),App "FunBind" (List [List - [App "Match" (List [App "Ident" (List [String "putTag"]),List [App - "PVar" (List [App "Ident" (List [String "x"])])],App "Nothing" ( - List []),App "UnGuardedRhs" (List [Application (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "when"])])]), - App "Var" (List [App "UnQual" (List [App "Ident" (List [String - "useTag"])])]),App "Paren" (List [App "App" (List [App "Var" (List - [App "UnQual" (List [App "Ident" (List [Concat (List [String - "putWord",ShowInt (Int 8)])])])]),App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "x"])])])])])])]),App "Nothing" ( - List [])])]])]])])])]])]),App "InsDecl" (List [App "PatBind" (List - [App "PVar" (List [App "Ident" (List [String "get"])]),App - "UnGuardedRhs" (List [App "Do" (List [List [App "Generator" (List - [App "PVar" (List [App "Ident" (List [String "i"])]),App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "getTag"])])]) - ]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "i"])])]),Concat (List [ - MapCtor (App "Alt" (List [App "PLit" (List [App "Signless" (List [ - ]),App "Int" (List [CtorIndex])]),App "UnGuardedRhs" (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 "get"])])])])),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 "Nothing" (List [])])), - List [App "Alt" (List [App "PWildCard" (List []),App - "UnGuardedRhs" (List [App "App" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit" - (List [App "String" (List [Concat (List [String - "Corrupted binary data for ",DataName])])])])]),App "Nothing" ( - List [])])]])])])]])]),App "Just" (List [App "BDecls" (List [List - [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "useTag"])]),App "UnGuardedRhs" (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 "Nothing" (List [])]),App "PatBind" (List [App - "PVar" (List [App "Ident" (List [String "getTag"])]),App - "UnGuardedRhs" (List [App "If" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "useTag"])])]),App "Var" - (List [App "UnQual" (List [App "Ident" (List [Concat (List [String - "getWord",ShowInt (Int 8)])])])]),App "App" (List [App "Var" (List - [App "UnQual" (List [App "Ident" (List [String "return"])])]),App - "Lit" (List [App "Int" (List [Int 0])])])])]),App "Nothing" (List - [])])]])])])])])] + 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 diff --git a/src/Data/Derive/BinaryDefer.hs b/src/Data/Derive/BinaryDefer.hs --- a/src/Data/Derive/BinaryDefer.hs +++ b/src/Data/Derive/BinaryDefer.hs @@ -28,36 +28,56 @@ makeBinaryDefer = derivationDSL "BinaryDefer" dslBinaryDefer dslBinaryDefer = - List [Instance ["BinaryDefer"] "BinaryDefer" (List [App "InsDecl" - (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ - String "bothDefer"])]),App "UnGuardedRhs" (List [App "App" (List [ - App "Var" (List [App "UnQual" (List [App "Ident" (List [String - "defer"])])]),App "List" (List [MapCtor (App "Lambda" (List [List - [App "PIrrPat" (List [App "PParen" (List [App "PAsPat" (List [App - "Ident" (List [String "o"]),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 "If" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "null"] - )])]),App "List" (List [MapField (Application (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "const"])])]), - App "Con" (List [App "Special" (List [App "UnitCon" (List [])])]), - App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat ( - List [String "x",ShowInt FieldIndex])])])])]))])]),App "InfixApp" - (List [App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "unit"])])]),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 "QVarOp" (List [App - "UnQual" (List [App "Symbol" (List [String "< OList xs)) = - foldl1 (\a b -> OApp "App" [a,b]) xs + foldl1 (\a b -> OApp "App" [OApp "()" [],a,b]) xs f (MapCtor dsl) = OList [applyEnv dsl env{envCtor=c} | c <- dataCtors input] diff --git a/src/Data/Derive/DSL/Derive.hs b/src/Data/Derive/DSL/Derive.hs --- a/src/Data/Derive/DSL/Derive.hs +++ b/src/Data/Derive/DSL/Derive.hs @@ -2,6 +2,7 @@ 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 @@ -24,18 +25,32 @@ guess :: Output -> [Guess] -guess (OApp "InstDecl" [OApp "Nothing" [], OList [], OList ctxt,name,typ,bod]) - | OApp "UnQual" [OApp "Ident" [OString name]] <- name - , OList [OApp "TyParen" [OApp "TyApp" - [OApp "TyCon" [OApp "UnQual" [OApp "Ident" [OString nam]]] - ,OApp "TyVar" [OApp "Ident" [OString var]]]]] <- typ +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 - , ctxt <- [x | OApp "ClassA" [OApp "UnQual" [OApp "Ident" [OString x]],_] <- map unparenA ctxt] - = [Guess $ Instance ctxt name y | Guess y <- guess bod] + = [Guess $ Instance (unContext ctx) name y | Guess y <- guess decls] where - unparenA (OApp "ParenA" [x]) = unparenA x - unparenA x = x + 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) @@ -93,22 +108,22 @@ diffs [] = [] -gssFold o@(OApp op [x,m,y]) = f True (x : follow True y) ++ f False (y : follow False x) +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 [a,m2,b]) | op == op2 && m == m2 = a2 : follow dir b2 + 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 = map (lift g) $ guess $ OList xs - where g = Fold (App op $ List [h,fromOut m,t]) + 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] +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 _ = [] diff --git a/src/Data/Derive/DSL/HSE.hs b/src/Data/Derive/DSL/HSE.hs --- a/src/Data/Derive/DSL/HSE.hs +++ b/src/Data/Derive/DSL/HSE.hs @@ -23,10 +23,10 @@ -- data Sample a = First | Second a a | Third a sample :: Input -sample = DataDecl sl DataType [] (name "Sample") [tyVarBind "a"] ctrs [] +sample = DataDecl () (DataType ()) Nothing (DHApp () (DHead () $ name "Sample") (tyVarBind "a")) ctrs Nothing where ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1] - ctr s i = QualConDecl sl [] [] $ ConDecl (name s) $ replicate i $ tyVar "a" + ctr s i = QualConDecl () Nothing Nothing $ ConDecl () (name s) $ replicate i $ tyVar "a" --------------------------------------------------------------------- @@ -57,7 +57,7 @@ toInput x = x -type Out = [Decl] +type Out = [Decl ()] diff --git a/src/Data/Derive/DSL/SYB.hs b/src/Data/Derive/DSL/SYB.hs --- a/src/Data/Derive/DSL/SYB.hs +++ b/src/Data/Derive/DSL/SYB.hs @@ -17,7 +17,7 @@ syb :: Data a => DSL -> Maybe a -syb = dsimple & dlistAny & dapp -- & derr +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 @@ -66,14 +66,14 @@ dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle -dinstance :: DSL -> Maybe Decl +dinstance :: DSL -> Maybe (Decl ()) dinstance x = do Instance _ name bod <- return x bod <- syb bod - return $ InstDecl sl Nothing [] - [ClassA (UnQual $ Ident "Data") [TyVar $ Ident "d_type"]] - (UnQual $ Ident name) [TyVar $ Ident "d_type"] - 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 @@ -82,29 +82,29 @@ return x -dmapctor :: DSL -> Maybe Exp +dmapctor :: DSL -> Maybe (Exp ()) dmapctor x = do - App "List" (List [MapCtor x]) <- return x + App "List" (List [_, MapCtor x]) <- return x x <- syb x - return $ ListComp x [QualStmt $ Generator sl (PVar $ Ident "d_ctor") - (H.App (v "d_dataCtors") (Paren $ ExpTypeSig sl (v "undefined") (TyVar $ Ident "d_type")))] + 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 "Int" (List [CtorArity])])) = Just $ Paren $ H.App (v "d_ctorArity") (v "d_ctor") -dsingle (App "Lit" (List [App "Int" (List [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 sl (H.App (v "d_ctorValue") (v "d_ctor")) (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 :: DSL -> Maybe (Exp ()) dapplication x = do Application (List xs) <- return x syb $ f xs where - f (x:y:z) = f (App "App" (List [x,y]) : z) + f (x:y:z) = f (App "App" (List [App "()" $ List [],x,y]) : z) f [x] = x -v = Var . UnQual . Ident +v = Var () . UnQual () . Ident () diff --git a/src/Data/Derive/Data.hs b/src/Data/Derive/Data.hs deleted file mode 100644 --- a/src/Data/Derive/Data.hs +++ /dev/null @@ -1,154 +0,0 @@ -module Data.Derive.Data(makeData) where -{- -import Data.Data - -example :: Custom - -instance (Data a, Typeable a) => Data (Sample a) where - gfoldl k r (First) = r First - gfoldl k r (Second x1 x2) = r Second `k` x1 `k` x2 - gfoldl k r (Third x1) = r Third `k` x1 - - gunfold k z c = case constrIndex c - 1 of - 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) - toConstr x@Third{} = indexConstr (dataTypeOf x) (2+1) - - dataTypeOf _ = ty - where ty = mkDataType $(dataName) - [mkConstr ty "First" $(ctorFields 0) $(ctorFixity 0) - ,mkConstr ty "Second" $(ctorFields 1) $(ctorFixity 1) - ,mkConstr ty "Third" $(ctorFields 2) $(ctorFixity 2)] - -test :: Computer - -instance Data Computer where - gfoldl k r (Laptop x1 x2) = r Laptop `k` x1 `k` x2 - gfoldl k r (Desktop x1) = r Desktop `k` x1 - 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 - where ty = mkDataType "Example.Computer" - [mkConstr ty "Laptop" ["weight", "speed"] Prefix - ,mkConstr ty "Desktop" ["speed"] Prefix] - --} - -import Data.Derive.DSL.HSE -import qualified Language.Haskell as H - --- GENERATED START - -import Data.Derive.DSL.DSL -import Data.Derive.Internal.Derivation - -makeData :: Derivation -makeData = derivationCustomDSL "Data" custom $ - List [Instance ["Data","Typeable"] "Data" (List [App "InsDecl" ( - List [App "FunBind" (List [MapCtor (App "Match" (List [App "Ident" - (List [String "gfoldl"]),List [App "PVar" (List [App "Ident" (List - [String "k"])]),App "PVar" (List [App "Ident" (List [String "r"])] - ),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 "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App - "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App - "Ident" (List [String "k"])])]),Head])) (Concat (List [Reverse ( - MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [ - Concat (List [String "x",ShowInt FieldIndex])])])]))),List [App - "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( - List [String "r"])])]),App "Con" (List [App "UnQual" (List [App - "Ident" (List [CtorName])])])])]]))]),App "Nothing" (List [])]))]) - ]),App "InsDecl" (List [App "FunBind" (List [List [App "Match" ( - List [App "Ident" (List [String "gunfold"]),List [App "PVar" (List - [App "Ident" (List [String "k"])]),App "PVar" (List [App "Ident" ( - List [String "z"])]),App "PVar" (List [App "Ident" (List [String - "c"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App - "Case" (List [App "InfixApp" (List [App "App" (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "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])])]),Concat (List [MapCtor (App "Alt" (List [App "PLit" ( - List [App "Signless" (List []),App "Int" (List [CtorIndex])]),App - "UnGuardedRhs" (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 "Nothing" ( - List [])])),List [App "Alt" (List [App "PVar" (List [App "Ident" ( - List [String "i"])]),App "UnGuardedRhs" (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 "Nothing" (List [])])]])])]),App "Nothing" ( - 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 - "Nothing" (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 "Just" (List [App - "BDecls" (List [List [App "PatBind" (List [App "PVar" (List [App - "Ident" (List [String "ty"])]),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 "UnQual" (List [App - "Ident" (List [String "dataName"])])])])]),App "List" (List [ - MapCtor (Application (List [App "Var" (List [App "UnQual" (List [ - App "Ident" (List [String "mkConstr"])])]),App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "ty"])])]),App "Lit" ( - List [App "String" (List [CtorName])]),App "SpliceExp" (List [App - "ParenSplice" (List [App "App" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "ctorFields"])])]),App - "Lit" (List [App "Int" (List [CtorIndex])])])])]),App "SpliceExp" - (List [App "ParenSplice" (List [App "App" (List [App "Var" (List [ - App "UnQual" (List [App "Ident" (List [String "ctorFixity"])])]), - App "Lit" (List [App "Int" (List [CtorIndex])])])])])]))])])]),App - "Nothing" (List [])])]])])])]])])])] --- GENERATED STOP - - -custom d = customContext context d . customSplice splice d - -splice :: FullDataDecl -> Exp -> Exp -splice d x | x ~= "dataName" = H.Lit $ H.String $ prettyPrint (fst d) ++ "." ++ dataDeclName (snd d) -splice d (H.App x (H.Lit (H.Int y))) - | x ~= "ctorFields" = H.List $ [H.Lit $ H.String a | (a,_) <- ctorDeclFields ctor, a /= ""] - | x ~= "ctorFixity" = Con (UnQual (Ident "Prefix")) - where ctor = dataDeclCtors (snd d) !! fromInteger y - -context :: FullDataDecl -> Context -> Context -context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVarsStar $ snd d, t <- ["Typeable","Data"]] diff --git a/src/Data/Derive/DataAbstract.hs b/src/Data/Derive/DataAbstract.hs --- a/src/Data/Derive/DataAbstract.hs +++ b/src/Data/Derive/DataAbstract.hs @@ -24,36 +24,56 @@ makeDataAbstract :: Derivation makeDataAbstract = derivationCustomDSL "DataAbstract" custom $ - List [Instance ["Typeable"] "Data" (List [App "InsDecl" (List [App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "gfoldl"]),List [App "PVar" (List [App "Ident" (List [ - String "k"])]),App "PVar" (List [App "Ident" (List [String "r"])]) - ,App "PVar" (List [App "Ident" (List [String "x"])])],App - "Nothing" (List []),App "UnGuardedRhs" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "r"])]) - ]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String + 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 "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "gunfold"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var" - (List [App "UnQual" (List [App "Ident" (List [String "error"])])]) - ,App "Lit" (List [App "String" (List [Concat (List [String + 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 - "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "toConstr"])]),App "UnGuardedRhs" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "error" - ])])]),App "Lit" (List [App "String" (List [Concat (List [String + )])])]),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 - "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "dataTypeOf"])]),App "UnGuardedRhs" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "error" - ])])]),App "Lit" (List [App "String" (List [Concat (List [String + )])])]),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 [])])])])] + )])])]),App "Nothing" (List [])])])]]))] -- GENERATED STOP custom = customContext context -context :: FullDataDecl -> Context -> Context -context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]] +context :: FullDataDecl -> Context () -> Context () +context d _ = CxTuple () [ClassA () (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]] diff --git a/src/Data/Derive/Default.hs b/src/Data/Derive/Default.hs --- a/src/Data/Derive/Default.hs +++ b/src/Data/Derive/Default.hs @@ -6,7 +6,6 @@ instance Default a => Default (Sample a) where def = head [First, Second (const def 1) (const def 2), Third (const def 1)] - -} -- GENERATED START @@ -18,15 +17,22 @@ makeDefault = derivationDSL "Default" dslDefault dslDefault = - List [Instance ["Default"] "Default" (List [App "InsDecl" (List [ - App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "def"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "head"])])]), - App "List" (List [MapCtor (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 "const"])])]),App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "def"]) - ])]),App "Lit" (List [App "Int" (List [FieldIndex])])])]))])))])]) - ]),App "Nothing" (List [])])])])] + 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 diff --git a/src/Data/Derive/Enum.hs b/src/Data/Derive/Enum.hs deleted file mode 100644 --- a/src/Data/Derive/Enum.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Data.Derive.Enum where -{- -import Prelude - -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 - --} --- GENERATED START - -import Data.Derive.DSL.DSL -import Data.Derive.Internal.Derivation - -makeEnum :: Derivation -makeEnum = derivationDSL "Enum" dslEnum - -dslEnum = - List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind" - (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List - [String "toEnum"]),List [App "PLit" (List [App "Signless" (List [] - ),App "Int" (List [CtorIndex])])],App "Nothing" (List []),App - "UnGuardedRhs" (List [App "RecConstr" (List [App "UnQual" (List [ - App "Ident" (List [CtorName])]),List []])]),App "Nothing" (List [] - )])),List [App "Match" (List [App "Ident" (List [String "toEnum"]) - ,List [App "PVar" (List [App "Ident" (List [String "n"])])],App - "Nothing" (List []),App "UnGuardedRhs" (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 "$"])])]),Fold (App "InfixApp" (List [Head,App - "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String - "++"])])]),Tail])) (List [App "Lit" (List [App "String" (List [ - String "toEnum "])]),App "App" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "show"])])]),App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "n"])])])]), - App "Lit" (List [App "String" (List [String ", not defined for "]) - ]),App "Lit" (List [App "String" (List [DataName])])])])]),App - "Nothing" (List [])])]])])]),App "InsDecl" (List [App "FunBind" ( - List [MapCtor (App "Match" (List [App "Ident" (List [String - "fromEnum"]),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 "Nothing" (List [])]))])])])] --- GENERATED STOP diff --git a/src/Data/Derive/EnumCyclic.hs b/src/Data/Derive/EnumCyclic.hs --- a/src/Data/Derive/EnumCyclic.hs +++ b/src/Data/Derive/EnumCyclic.hs @@ -31,75 +31,122 @@ makeEnumCyclic = derivationDSL "EnumCyclic" dslEnumCyclic dslEnumCyclic = - List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind" - (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List - [String "toEnum"]),List [App "PLit" (List [App "Signless" (List [] - ),App "Int" (List [CtorIndex])])],App "Nothing" (List []),App - "UnGuardedRhs" (List [App "RecConstr" (List [App "UnQual" (List [ - App "Ident" (List [CtorName])]),List []])]),App "Nothing" (List [] - )])),List [App "Match" (List [App "Ident" (List [String "toEnum"]) - ,List [App "PVar" (List [App "Ident" (List [String "n"])])],App - "Nothing" (List []),App "UnGuardedRhs" (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 "$"])])]),Fold (App "InfixApp" (List [Head,App - "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String - "++"])])]),Tail])) (List [App "Lit" (List [App "String" (List [ - String "toEnum "])]),App "App" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "show"])])]),App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "n"])])])]), - App "Lit" (List [App "String" (List [Concat (List [String + 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 "FunBind" (List [MapCtor (App - "Match" (List [App "Ident" (List [String "fromEnum"]),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 "Nothing" (List [])]))])]),App "InsDecl" (List [App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "succ"]),List [App "PVar" (List [App "Ident" (List [String - "a"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App - "If" (List [App "InfixApp" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "b"])])]),App "QVarOp" (List [App - "UnQual" (List [App "Symbol" (List [String "=="])])]),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 "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "toEnum"])])]),App "Lit" (List [App "Int" ( - List [Int 0])])]),App "App" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "toEnum"])])]),App "Paren" (List [ - App "InfixApp" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "b"])])]),App "QVarOp" (List [App "UnQual" ( - List [App "Symbol" (List [String "+"])])]),App "Lit" (List [App - "Int" (List [Int 1])])])])])])]),App "Just" (List [App "BDecls" ( - List [List [App "PatBind" (List [App "PVar" (List [App "Ident" ( - List [String "b"])]),App "UnGuardedRhs" (List [App "App" (List [ - App "Var" (List [App "UnQual" (List [App "Ident" (List [String - "fromEnum"])])]),App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "a"])])])])]),App "Nothing" (List [])])]])])])]])]), - App "InsDecl" (List [App "FunBind" (List [List [App "Match" (List - [App "Ident" (List [String "pred"]),List [App "PVar" (List [App - "Ident" (List [String "a"])])],App "Nothing" (List []),App - "UnGuardedRhs" (List [App "If" (List [App "InfixApp" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "b"])]) - ]),App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ - String "=="])])]),App "Lit" (List [App "Int" (List [Int 0])])]), - App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "toEnum"])])]),App "Paren" (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 "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "toEnum"])])]),App "Paren" (List [App - "InfixApp" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "b"])])]),App "QVarOp" (List [App "UnQual" (List [ - App "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" ( - List [Int 1])])])])])])]),App "Just" (List [App "BDecls" (List [ - List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ - String "b"])]),App "UnGuardedRhs" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "fromEnum"])])]),App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "a"])])])])]),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 diff --git a/src/Data/Derive/Eq.hs b/src/Data/Derive/Eq.hs deleted file mode 100644 --- a/src/Data/Derive/Eq.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Data.Derive.Eq where -{- -import Prelude - -example :: Sample - -instance (Eq a) => Eq (Sample a) where - First == First = True - Second x1 x2 == Second y1 y2 = x1 == y1 && x2 == y2 && True - Third x1 == Third y1 = x1 == y1 && True - _ == _ | length [First{},Second{},Third{}] > 1 = False - -test :: Assoced -instance Eq typ => Eq (Assoced typ) where - Assoced x1 x2 == Assoced y1 y2 = x1 == y1 && x2 == y2 - -test :: TwoParam -instance Eq b => Eq (TwoParam a b) where - TwoParam x1 == TwoParam y1 = x1 == y1 - --} --- GENERATED START - -import Data.Derive.DSL.DSL -import Data.Derive.Internal.Derivation - -makeEq :: Derivation -makeEq = derivationDSL "Eq" dslEq - -dslEq = - List [Instance ["Eq"] "Eq" (List [App "InsDecl" (List [App - "FunBind" (List [Concat (List [MapCtor (App "Match" (List [App - "Symbol" (List [String "=="]),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 "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 [Fold (App "InfixApp" (List [Head,App - "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String - "&&"])])]),Tail])) (Concat (List [MapField (App "InfixApp" (List [ - App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat ( - List [String "x",ShowInt FieldIndex])])])]),App "QVarOp" (List [ - App "UnQual" (List [App "Symbol" (List [String "=="])])]),App - "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [ - String "y",ShowInt FieldIndex])])])])])),List [App "Con" (List [ - App "UnQual" (List [App "Ident" (List [String "True"])])])]]))]), - App "Nothing" (List [])])),List [App "Match" (List [App "Symbol" ( - List [String "=="]),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 "Con" (List [App - "UnQual" (List [App "Ident" (List [String "False"])])])])]]),App - "Nothing" (List [])])]])])])])] --- GENERATED STOP diff --git a/src/Data/Derive/Fold.hs b/src/Data/Derive/Fold.hs --- a/src/Data/Derive/Fold.hs +++ b/src/Data/Derive/Fold.hs @@ -46,22 +46,22 @@ makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d -mkFold :: DataDecl -> [Decl] -mkFold d | isIdent $ dataDeclName d = [TypeSig sl [name n] (foldType d), FunBind $ zipWith f [0..] $ dataDeclCtors 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 sl (name n) pat Nothing (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)] + 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 :: 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] + f c = TyParen () $ tyFun $ map snd (ctorDeclFields c) ++ [v] diff --git a/src/Data/Derive/Foldable.hs b/src/Data/Derive/Foldable.hs deleted file mode 100644 --- a/src/Data/Derive/Foldable.hs +++ /dev/null @@ -1,55 +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. --} - -module Data.Derive.Foldable(makeFoldable, makeFoldableN) where - -{- -import Data.Foldable(Foldable) -import qualified Data.Foldable(foldr) - -test :: FailList -instance Foldable (FailList t1) where - foldr _ b Zoro = b - foldr _ b (Fial _) = b - foldr _f b (Const a1 a2) = _f a1 (Data.Foldable.foldr _f b a2) - -test :: Sample -instance Foldable Sample where - 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 _ b (Left _) = b - foldr _f b (Right a1) = _f a1 b --} - -import Data.Derive.Internal.Traversal -import Data.Derive.Internal.Derivation -import Language.Haskell - - -makeFoldable :: Derivation -makeFoldable = makeFoldableN 1 - -makeFoldableN :: Int -> Derivation -makeFoldableN n = traversalDerivation1 foldrTraversal{traversalArg = n} "Foldable" - -foldrTraversal = defaultTraversalType - { traversalName = Qual (ModuleName "Data.Foldable") (Ident "foldr") - , traversalFunc = \n a -> appP (var "flip") $ appP (Var n) a - , traversalPlus = fail "variable used in multiple positions in a data type" - , traversalId = App (var "flip") (var "const") - , traverseTuple = foldr (.:) $ var "id" - , traverseCtor = const $ foldr (.:) $ var "id" - , traverseFunc = \pat rhs -> Match sl (name "") [pVar "_f", pVar "b", pat] Nothing (UnGuardedRhs $ appP rhs (var "b")) Nothing - } - where a .: b = InfixApp (paren a) (qvop ".") (paren b) diff --git a/src/Data/Derive/From.hs b/src/Data/Derive/From.hs --- a/src/Data/Derive/From.hs +++ b/src/Data/Derive/From.hs @@ -36,30 +36,30 @@ makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d -makeFromCtor :: DataDecl -> CtorDecl -> [Decl] -makeFromCtor d c | isIdent n = [TypeSig sl [name from] typ, FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]] +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) + typ = TyFun () (dataDeclType d) (tyTuple $ map snd $ ctorDeclFields c) - match = Match sl (name from) [pat] Nothing (UnGuardedRhs rhs) Nothing - pat = (length vars == 0 ? id $ PParen) $ PApp (qname n) (map pVar vars) + 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 sl (name from) [PWildCard] Nothing (UnGuardedRhs err) Nothing - err = App (var "error") $ Lit $ String $ from ++ " failed, not a " ++ n + 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 [] = TyCon () $ Special () $ UnitCon () tyTuple [x] = x -tyTuple xs = TyTuple Boxed xs +tyTuple xs = TyTuple () Boxed xs -valTuple [] = Con $ Special UnitCon +valTuple [] = Con () $ Special () $ UnitCon () valTuple [x] = x -valTuple xs = Tuple Boxed xs +valTuple xs = Tuple () Boxed xs diff --git a/src/Data/Derive/Functor.hs b/src/Data/Derive/Functor.hs deleted file mode 100644 --- a/src/Data/Derive/Functor.hs +++ /dev/null @@ -1,62 +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: --- . -module Data.Derive.Functor(makeFunctor,makeFunctorN) where - -{- -import Prelude - -test :: FailList -instance Functor (FailList t1) where - fmap _ Zoro = Zoro - fmap _ (Fial a1) = Fial a1 - fmap _f (Const a1 a2) = Const (_f a1) (fmap _f a2) - -test :: State -instance Functor (State t1) where - fmap _f (StateT a1) = StateT (fmap _f . a1) - -test :: Sample -instance Functor Sample where - fmap _ First = First - fmap _f (Second a1 a2) = Second (_f a1) (_f a2) - fmap _f (Third a1) = Third (_f a1) --} - - -import Data.Derive.Internal.Traversal -import Data.Derive.Internal.Derivation -import Language.Haskell - - -makeFunctor :: Derivation -makeFunctor = makeFunctorN 1 - -makeFunctorN :: Int -> Derivation -makeFunctorN n = traversalDerivation1 functorTraversal{traversalArg = n} "Functor" - -functorTraversal = defaultTraversalType - { traversalName = qname "fmap" - , traverseArrow = Just functorForArrowType - , traverseFunc = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) Nothing - } - -functorForArrowType :: Exp -> Exp -> Exp -functorForArrowType a b - | isId a && isId b = var "id" - | isId a = LeftSection b (qvop ".") - | isId b = RightSection (qvop ".") a - | otherwise = Lambda sl [pVar "arg"] $ b .: var "arg" .: a - where isId = (var "id" ==) - a .: b = InfixApp (paren a) (qvop ".") (paren b) diff --git a/src/Data/Derive/Has.hs b/src/Data/Derive/Has.hs --- a/src/Data/Derive/Has.hs +++ b/src/Data/Derive/Has.hs @@ -28,13 +28,13 @@ makeHas = derivationCustom "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d -makeHasField :: DataDecl -> String -> [Decl] -makeHasField d field = if isIdent field then [TypeSig sl [name has] typ, binds has ms] else [] +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") + 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"] + ms | null no = [match (PWildCard ()) "True"] + | otherwise = [match (PRec () (qname $ ctorDeclName c) []) "True" | c <- yes] ++ [match (PWildCard ()) "False"] diff --git a/src/Data/Derive/Internal/Derivation.hs b/src/Data/Derive/Internal/Derivation.hs --- a/src/Data/Derive/Internal/Derivation.hs +++ b/src/Data/Derive/Internal/Derivation.hs @@ -12,15 +12,15 @@ data Derivation = Derivation {derivationName :: String - ,derivationOp :: Type -> (String -> Decl) -> FullDataDecl -> Either String [Decl] + ,derivationOp :: Type () -> (String -> Decl ()) -> FullDataDecl -> Either String [Decl ()] } -derivationParams :: String -> ([Type] -> (String -> Decl) -> FullDataDecl -> Either String [Decl]) -> Derivation +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 :: String -> (FullDataDecl -> Either String [Decl ()]) -> Derivation derivationCustom name op = derivationParams name $ \ty grab decs -> op decs @@ -28,22 +28,19 @@ derivationDSL name dsl = derivationCustomDSL name (const id) dsl -derivationCustomDSL :: String -> (FullDataDecl -> [Decl] -> [Decl]) -> DSL -> Derivation +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 :: (FullDataDecl -> Exp () -> Exp ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()]) customSplice custom d = transformBi f where - f (SpliceExp (ParenSplice x)) = custom d x + f (SpliceExp () (ParenSplice () x)) = custom d x f x = x -customContext :: (FullDataDecl -> Context -> Context) -> (FullDataDecl -> [Decl] -> [Decl]) -customContext custom ds = map f - where - f (InstDecl sl a b ctx c d e) = InstDecl sl a b (custom ds ctx) c d e - f x = x +customContext :: (FullDataDecl -> Context () -> Context ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()]) +customContext custom ds = transformBi (custom ds) diff --git a/src/Data/Derive/Internal/Traversal.hs b/src/Data/Derive/Internal/Traversal.hs --- a/src/Data/Derive/Internal/Traversal.hs +++ b/src/Data/Derive/Internal/Traversal.hs @@ -2,7 +2,7 @@ {- This module is not written/maintained by the usual Data.Derive author. - MAINTAINER: Twan van Laarhoven + MAINTAINER: Twan van Laarhoven EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com" Please send all patches to this module to Neil (ndmitchell -at- gmail), @@ -34,21 +34,21 @@ -- Information datatype, public interface -- | An expression representing a traversal of a subpart of the data -type Trav = Exp +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 + { 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 @@ -57,10 +57,10 @@ , 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] + , traversalFunc = \x y -> appP (Var () x) y + , traversalPlus = \x y -> apps (Con () $ Special () (Cons ())) [paren x, paren y] , traverseArrow = Nothing - , traverseTuple = Tuple Boxed + , traverseTuple = Tuple () Boxed , traverseCtor = \x y -> apps (con x) (map paren y) , traverseFunc = undefined } @@ -84,92 +84,100 @@ -- | Derivation for a Traversable like class with just 1 method traversalDerivation1 :: TraveralType -> String -> Derivation -traversalDerivation1 tt nm = derivationCustom (className $ traversalArg tt) (traversalInstance1 tt nm) +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 :: 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 sl Nothing [] ctx nam args (map InsDecl body)] +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 = [ ClassA (qname $ className p) (tyVar n : vars tyVar 's' (p - 1)) + 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 - + 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 :: TraveralType -> DataDecl -> WithInstances (Decl ()) deriveTraversal tt dat = fun where - fun = (\xs -> FunBind [Match sl nam a b c d | Match _ _ a b c d <- xs]) <$> body + 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 + 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 :: 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)) + 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 :: 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) +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 +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 :: 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 sl [PTuple Boxed (vars pVar 't' (length args))] - (traverseTuple tt $ zipWith App tArgs (vars var 't' (length args))) + 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" + 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..] @@ -190,13 +198,13 @@ traverseArg :: TraveralType -> Int -> Trav -> Trav traverseArg tt n e = traversalFunc tt (traversalNameN tt n) e -traversalNameN :: TraveralType -> Int -> QName +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 + 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 diff --git a/src/Data/Derive/Is.hs b/src/Data/Derive/Is.hs --- a/src/Data/Derive/Is.hs +++ b/src/Data/Derive/Is.hs @@ -22,12 +22,12 @@ makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d -makeIsCtor :: DataDecl -> CtorDecl -> [Decl] +makeIsCtor :: DataDecl -> CtorDecl -> [Decl ()] makeIsCtor d c = if not $ isIdent $ ctorDeclName c then [] else - [TypeSig sl [name nam] (dataDeclType d `TyFun` tyCon "Bool") - ,FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]] + [TypeSig () [name nam] (TyFun () (dataDeclType d) (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") Nothing - defMatch = Match sl (name nam) [PWildCard] Nothing (UnGuardedRhs $ con "False") Nothing + match = Match () (name nam) [PParen () $ PRec () (qname $ ctorDeclName c) []] (UnGuardedRhs () $ con "True") Nothing + defMatch = Match () (name nam) [PWildCard ()] (UnGuardedRhs () $ con "False") Nothing diff --git a/src/Data/Derive/JSON.hs b/src/Data/Derive/JSON.hs --- a/src/Data/Derive/JSON.hs +++ b/src/Data/Derive/JSON.hs @@ -18,7 +18,7 @@ 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, sl, + (~=), var, pVar, con, strE, strP, apps, qname, ctorDeclFields, ctorDeclName, dataDeclCtors) {- @@ -41,74 +41,87 @@ makeJSON :: Derivation makeJSON = derivationCustomDSL "JSON" custom $ - List [Instance ["JSON"] "JSON" (List [App "InsDecl" (List [App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "readJSON"]),List [App "PParen" (List [App "PApp" (List [ - App "UnQual" (List [App "Ident" (List [String "JSObject"])]),List - [App "PVar" (List [App "Ident" (List [String "x"])])]])])],App - "Nothing" (List []),App "UnGuardedRhs" (List [App "SpliceExp" ( - List [App "ParenSplice" (List [App "Var" (List [App "UnQual" (List - [App "Ident" (List [String "readJSON"])])])])])]),App "Nothing" ( - List [])]),App "Match" (List [App "Ident" (List [String "readJSON" - ]),List [App "PWildCard" (List [])],App "Nothing" (List []),App - "UnGuardedRhs" (List [App "App" (List [App "Con" (List [App - "UnQual" (List [App "Ident" (List [String "Error"])])]),App "Lit" - (List [App "String" (List [String "..."])])])]),App "Nothing" ( - List [])])]])]),App "InsDecl" (List [App "FunBind" (List [MapCtor - (App "Match" (List [App "Ident" (List [String "showJSON"]),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 "Nothing" (List []),App "UnGuardedRhs" (List [App - "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "showJSON"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])]) - ])])]),App "Nothing" (List [])]))])])])] + 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 :: FullDataDecl -> [Decl ()] -> [Decl ()] custom = customSplice splice -splice :: FullDataDecl -> Exp -> Exp +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 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 :: 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)]] + mkJSObject $ H.List () + [H.Tuple () H.Boxed [strE (ctorDeclName c), mkFields (ctorDeclFields c)]] -mkShowPlainFields :: FieldDecl -> Exp -mkShowPlainFields fs = mkJSArray $ H.List - [var "showJSON" `H.App` xi | xi <- vars "x" fs] +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, var "showJSON" `H.App` xi] +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 :: FullDataDecl -> Exp () mkRead (_, d) = let - readError = con "Error" `H.App` strE "malformed JSON for type ...: ..." + readError = H.App () (con "Error") $ strE "malformed JSON for type ...: ..." in - H.Case (var "fromJSObject" `H.App` var "x") $ + H.Case () (H.App () (var "fromJSObject") $ var "x") $ map mkReadCtor (dataDeclCtors d) ++ - [H.Alt H.sl H.PWildCard (H.UnGuardedRhs readError) Nothing] + [H.Alt () (H.PWildCard ()) (H.UnGuardedRhs () readError) Nothing] -mkReadCtor :: CtorDecl -> Alt +mkReadCtor :: CtorDecl -> Alt () mkReadCtor c = let cn = ctorDeclName c fs = ctorDeclFields c @@ -116,50 +129,50 @@ body | hasFields = mkReadRecord cn fs | otherwise = mkReadPlain cn fs in - H.Alt sl (H.PList [H.PTuple H.Boxed [strP cn, pVar "y"]]) - (H.UnGuardedRhs body) Nothing + 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 sl (H.PApp (qname "JSObject") [pVar "z"]) - (var "return" `H.App` var "y")] ++ - [H.LetStmt $ H.BDecls [H.PatBind sl (pVar "d") - (H.UnGuardedRhs $ var "fromJSObject" `H.App` var "z") +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 sl xi $ +mkReadRecordField :: String -> Pat () -> (String, Type ()) -> Stmt () +mkReadRecordField cn xi (fn, _) = H.Generator () xi $ apps (var "maybe") [ - var "fail" `H.App` strE (unwords ["readJSON: missing field", fn, + 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 sl (H.PApp (qname "JSArray") [H.PList (pVars "x" fs)]) - (var "return" `H.App` var "y")] ++ +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 :: String -> FieldDecl -> [Stmt ()] mkReadTrailer cn fs = - [ H.Generator sl yi (var "readJSON" `H.App` xi) + [ H.Generator () yi (H.App () (var "readJSON") xi) | (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] ++ - [H.Qualifier $ var "return" `H.App` apps (con cn) (vars "y" fs)] + [H.Qualifier () $ H.App () (var "return") $ apps (con cn) (vars "y" fs)] ------------------------------------------------------------------------------ -- utilites -mkJSObject :: Exp -> Exp -mkJSObject e = con "JSObject" `H.App` (var "toJSObject" `H.App` e) +mkJSObject :: Exp () -> Exp () +mkJSObject e = H.App () (con "JSObject") (H.App () (var "toJSObject") e) -mkJSArray :: Exp -> Exp -mkJSArray e = con "JSArray" `H.App` e +mkJSArray :: Exp () -> Exp () +mkJSArray e = H.App () (con "JSArray") e -vars :: String -> FieldDecl -> [Exp] +vars :: String -> FieldDecl -> [Exp ()] vars pre fs = [var (pre ++ show i) | i <- [1..length fs]] -pVars :: String -> FieldDecl -> [Pat] +pVars :: String -> FieldDecl -> [Pat ()] pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]] diff --git a/src/Data/Derive/LazySet.hs b/src/Data/Derive/LazySet.hs --- a/src/Data/Derive/LazySet.hs +++ b/src/Data/Derive/LazySet.hs @@ -27,12 +27,13 @@ makeLazySet = derivationCustom "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d -makeLazySetField :: DataDecl -> String -> [Decl] -makeLazySetField d field = if isIdent field then [TypeSig sl [name fun] typ, bind fun [pVar "v",pVar "x"] bod] else [] +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 - typ = t `TyFun` (dataDeclType d `TyFun` dataDeclType d) + 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")] + 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")] diff --git a/src/Data/Derive/Lens.hs b/src/Data/Derive/Lens.hs --- a/src/Data/Derive/Lens.hs +++ b/src/Data/Derive/Lens.hs @@ -29,8 +29,8 @@ makeLens = derivationCustom "Lens" $ \(_,d) -> Right $ concatMap (makeLensField d) $ dataDeclFields d -makeLensField :: DataDecl -> String -> [Decl] -makeLensField d field = if isIdent field then [TypeSig sl [name ref] typ, bind ref [] bod] else [] +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] @@ -38,4 +38,4 @@ bod = apps (var "lens") [var field - ,Paren $ Lambda sl [pVar "x",pVar "v"] $ RecUpdate (var "v") [FieldUpdate (qname field) (var "x")]] + ,Paren () $ Lambda () [pVar "x",pVar "v"] $ RecUpdate () (var "v") [FieldUpdate () (qname field) (var "x")]] diff --git a/src/Data/Derive/Monoid.hs b/src/Data/Derive/Monoid.hs --- a/src/Data/Derive/Monoid.hs +++ b/src/Data/Derive/Monoid.hs @@ -25,45 +25,69 @@ makeMonoid = derivationDSL "Monoid" dslMonoid dslMonoid = - List [Instance ["Monoid"] "Monoid" (List [App "InsDecl" (List [App - "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "mempty"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var" - (List [App "UnQual" (List [App "Ident" (List [String "head"])])]), - App "List" (List [MapCtor (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 "const"])])]),App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "mempty"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])])] - ))])))])])]),App "Nothing" (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 "Nothing" (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 "Nothing" (List [])])]])])])])] + 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 diff --git a/src/Data/Derive/NFData.hs b/src/Data/Derive/NFData.hs --- a/src/Data/Derive/NFData.hs +++ b/src/Data/Derive/NFData.hs @@ -18,18 +18,25 @@ makeNFData = derivationDSL "NFData" dslNFData dslNFData = - List [Instance ["NFData"] "NFData" (List [App "InsDecl" (List [App - "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [ - String "rnf"]),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 "Nothing" (List []),App "UnGuardedRhs" - (List [Fold (App "InfixApp" (List [Head,App "QVarOp" (List [App - "UnQual" (List [App "Ident" (List [String "seq"])])]),Tail])) ( - Concat (List [MapField (App "App" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "rnf"])])]),App "Var" ( - List [App "UnQual" (List [App "Ident" (List [Concat (List [String - "x",ShowInt FieldIndex])])])])])),List [App "Con" (List [App - "Special" (List [App "UnitCon" (List [])])])]]))]),App "Nothing" ( - List [])]))])])])] + 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 diff --git a/src/Data/Derive/Ord.hs b/src/Data/Derive/Ord.hs deleted file mode 100644 --- a/src/Data/Derive/Ord.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Data.Derive.Ord where -{- -import Prelude - -example :: Sample -instance Ord a => Ord (Sample a) where - compare a b = check a b - where - check (First) (First) = EQ - check (Second x1 x2) (Second y1 y2) = compare x1 y1 `_then` compare x2 y2 `_then` EQ - check (Third x1) (Third y1) = compare x1 y1 `_then` EQ - check x y | length [First{},Second{},Third{}] > 1 = compare (tag x) (tag y) - - -- leading _ to avoid a warning when not used - EQ `_then` x = x - x `_then` _ = x - - tag (First{}) = 0 :: Int - tag (Second{}) = 1 :: Int - tag (Third{}) = 2 :: Int - --} --- GENERATED START - -import Data.Derive.DSL.DSL -import Data.Derive.Internal.Derivation - -makeOrd :: Derivation -makeOrd = derivationDSL "Ord" dslOrd - -dslOrd = - List [Instance ["Ord"] "Ord" (List [App "InsDecl" (List [App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "compare"]),List [App "PVar" (List [App "Ident" (List [ - String "a"])]),App "PVar" (List [App "Ident" (List [String "b"])]) - ],App "Nothing" (List []),App "UnGuardedRhs" (List [Application ( - List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "check"])])]),App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "a"])])]),App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "b"])])])])]),App "Just" (List [ - App "BDecls" (List [List [App "FunBind" (List [Concat (List [ - MapCtor (App "Match" (List [App "Ident" (List [String "check"]), - 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 [Fold (App - "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App - "Ident" (List [String "_then"])])]),Head])) (Concat (List [List [ - App "Con" (List [App "UnQual" (List [App "Ident" (List [String - "EQ"])])])],Reverse (MapField (Application (List [App "Var" (List - [App "UnQual" (List [App "Ident" (List [String "compare"])])]),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 "Nothing" (List [])])), - List [App "Match" (List [App "Ident" (List [String "check"]),List - [App "PVar" (List [App "Ident" (List [String "x"])]),App "PVar" ( - List [App "Ident" (List [String "y"])])],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])])])])], - Application (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "compare"])])]),App "Paren" (List [App "App" - (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "tag"])])]),App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "x"])])])])]),App "Paren" (List [App "App" ( - List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "tag"])])]),App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "y"])])])])])])])]]),App "Nothing" (List []) - ])]])]),App "FunBind" (List [List [App "Match" (List [App "Ident" - (List [String "_then"]),List [App "PApp" (List [App "UnQual" (List - [App "Ident" (List [String "EQ"])]),List []]),App "PVar" (List [ - App "Ident" (List [String "x"])])],App "Nothing" (List []),App - "UnGuardedRhs" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "x"])])])]),App "Nothing" (List [])]),App - "Match" (List [App "Ident" (List [String "_then"]),List [App - "PVar" (List [App "Ident" (List [String "x"])]),App "PWildCard" ( - List [])],App "Nothing" (List []),App "UnGuardedRhs" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])]) - ])]),App "Nothing" (List [])])]]),App "FunBind" (List [MapCtor ( - App "Match" (List [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 "ExpTypeSig" (List [App "Lit" (List [App - "Int" (List [CtorIndex])]),App "TyCon" (List [App "UnQual" (List [ - App "Ident" (List [String "Int"])])])])]),App "Nothing" (List [])] - ))])]])])])]])])])] --- GENERATED STOP diff --git a/src/Data/Derive/Read.hs b/src/Data/Derive/Read.hs deleted file mode 100644 --- a/src/Data/Derive/Read.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -{-| - 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 Prelude - -example :: Custom -instance Read a => Read (Sample a) where - readsPrec p0 r = - readParen $(bracket 0) (\r0 -> $(comp 0 First )) r ++ - readParen $(bracket 1) (\r0 -> $(comp 1 Second)) r ++ - readParen $(bracket 2) (\r0 -> $(comp 2 Third )) r ++ - [] - -test :: Sample -instance Read a => Read (Sample a) where - readsPrec p0 r = - readParen False (\r0 -> - [ (First, r1) - | ("First", r1) <- lex r0]) r - ++ - readParen (p0 > 10) (\r0 -> - [ (Second x1 x2, r3) - | ("Second", r1) <- lex r0 - , (x1, r2) <- readsPrec 11 r1 - , (x2, r3) <- readsPrec 11 r2]) r - ++ - readParen (p0 > 10) (\r0 -> - [ (Third x1, r2) - | ("Third", r1) <- lex r0 - , (x1, r2) <- readsPrec 11 r1]) r - -test :: Computer -instance Read Computer where - readsPrec _ r = - readParen False (\r0 -> - [ (Laptop x1 x2, r10) - | ("Laptop", r1) <- lex r0 - , ("{", r2) <- lex r1 - , ("weight", r3) <- lex r2 - , ("=", r4) <- lex r3 - , (x1, r5) <- readsPrec 0 r4 - , (",", r6) <- lex r5 - , ("speed", r7) <- lex r6 - , ("=", r8) <- lex r7 - , (x2, r9) <- readsPrec 0 r8 - , ("}", r10) <- lex r9]) r - ++ - readParen False (\r0 -> - [ (Desktop x1, r6) - | ("Desktop", r1) <- lex r0 - , ("{", r2) <- lex r1 - , ("speed", r3) <- lex r2 - , ("=", r4) <- lex r3 - , (x1, r5) <- readsPrec 0 r4 - , ("}", r6) <- lex r5]) r - -test :: (:*:) -instance (Read a, Read b) => Read ((:*:) a b) where - readsPrec p0 r = - readParen (p0 > 10) (\r0 -> - [ ((:*:) x1 x2, r3) - | ("(:*:)", r1) <- lex r0 - , (x1, r2) <- readsPrec 11 r1 - , (x2, r3) <- readsPrec 11 r2]) r - --} -import Data.Derive.DSL.HSE -import qualified Language.Haskell as H - --- GENERATED START - -import Data.Derive.DSL.DSL -import Data.Derive.Internal.Derivation - -makeRead :: Derivation -makeRead = derivationCustomDSL "Read" custom $ - List [Instance ["Read"] "Read" (List [App "InsDecl" (List [App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "readsPrec"]),List [App "PVar" (List [App "Ident" (List [ - Concat (List [String "p",ShowInt (Int 0)])])]),App "PVar" (List [ - App "Ident" (List [String "r"])])],App "Nothing" (List []),App - "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App - "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String - "++"])])]),Tail])) (Concat (List [MapCtor (Application (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "readParen"])])]),App "SpliceExp" (List [App "ParenSplice" (List [ - App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "bracket"])])]),App "Lit" (List [App "Int" (List [ - CtorIndex])])])])]),App "Paren" (List [App "Lambda" (List [List [ - App "PVar" (List [App "Ident" (List [Concat (List [String "r", - ShowInt (Int 0)])])])],App "SpliceExp" (List [App "ParenSplice" ( - List [Application (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "comp"])])]),App "Lit" (List [App "Int" ( - List [CtorIndex])]),App "Con" (List [App "UnQual" (List [App - "Ident" (List [CtorName])])])])])])])]),App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "r"])])])])),List [App - "List" (List [List []])]]))]),App "Nothing" (List [])])]])])])] --- GENERATED STOP - -custom = customSplice splice - -getCtor d i = dataDeclCtors (snd d) !! fromIntegral i -hasFields c = any ((/=) "" . fst) $ ctorDeclFields c - -splice :: FullDataDecl -> Exp -> Exp -splice d (H.App x (H.Lit (H.Int y))) | x ~= "bracket", let c = getCtor d y = - if hasFields c || null (ctorDeclFields c) - then con "False" - else Paren $ InfixApp (var "p0") (QVarOp $ UnQual $ Symbol ">") (H.Lit $ H.Int 10) - -splice d (H.App (H.App x (H.Lit (H.Int y))) _) | x ~= "comp" = - if hasFields c then readFields c else readCtor c - where c = getCtor d y - - -readCtor :: CtorDecl -> Exp -readCtor c = - ListComp (Tuple Boxed [cpat, var ('r':show (cn+1))]) $ - matchStr (ctorDeclName c) 0 : - [QualStmt $ Generator sl - (PTuple Boxed [pVar $ v 'x' 0, pVar $ v 'r' 1]) - (apps (var "readsPrec") [H.Lit $ H.Int 11, var $ v 'r' 0]) - | i <- [1..cn], let v c j = c : show (i+j)] - where - cn = ctorDeclArity c - cpat = apps (Con $ UnQual $ ctorDeclName' c) $ map (var . ('x':) . show) [1..cn] - - -readFields :: CtorDecl -> Exp -readFields c = - ListComp (Tuple Boxed [cpat, var $ 'r':show ((cn*4)+2)]) $ - matchStr (ctorDeclName c) 0 : - concat [ - matchStr (r == 1 ? "{" $ ",") r : - matchStr fld (r+1) : - matchStr "=" (r+2) : - QualStmt (Generator sl - (PTuple Boxed [pVar $ 'x':show i, pVar $ 'r':show (r+4)]) - (apps (var "readsPrec") [H.Lit $ H.Int 0, var $ 'r':show (r+3)])) - : [] - | (i,r,(fld,_)) <- zip3 [1..] [1,5..] (ctorDeclFields c) - ] ++ - [matchStr "}" ((cn*4)+1)] - where - cn = ctorDeclArity c - cpat = apps (Con $ UnQual $ ctorDeclName' c) $ map (var . ('x':) . show) [1..cn] - - -matchStr :: String -> Int -> QualStmt -matchStr s i = QualStmt $ Generator sl (PTuple Boxed [PLit H.Signless $ H.String s, pVar $ 'r':show (i+1)]) (var "lex" `H.App` var ('r':show i)) - - - - -{- - -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 --} diff --git a/src/Data/Derive/Ref.hs b/src/Data/Derive/Ref.hs --- a/src/Data/Derive/Ref.hs +++ b/src/Data/Derive/Ref.hs @@ -29,14 +29,14 @@ makeRef = derivationCustom "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d -makeRefField :: DataDecl -> String -> [Decl] -makeRefField d field = if isIdent field then [TypeSig sl [name ref] typ, bind ref [] bod] else [] +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) + typ = TyApp () (tyCon "Ref") (dataDeclType d) - bod = RecConstr (qname "Ref") - [FieldUpdate (qname "select") (var field) - ,FieldUpdate (qname "update") $ Lambda sl [pVar "f",pVar "v"] $ - RecUpdate (var "v") [FieldUpdate (qname field) $ App (var "f") $ Paren $ App (var field) (var "v")] + 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")] ] diff --git a/src/Data/Derive/Serial.hs b/src/Data/Derive/Serial.hs --- a/src/Data/Derive/Serial.hs +++ b/src/Data/Derive/Serial.hs @@ -28,38 +28,57 @@ makeSerial = derivationDSL "Serial" dslSerial dslSerial = - List [Instance ["Serial"] "Serial" (List [App "InsDecl" (List [App - "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "series"])]),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List - [Tail,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ - String "\\/"])])]),Head])) (Reverse (MapCtor (App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [ - String "cons",ShowInt CtorArity])])])]),App "Con" (List [App - "UnQual" (List [App "Ident" (List [CtorName])])])]))))]),App - "Nothing" (List [])])]),App "InsDecl" (List [App "FunBind" (List [ - List [App "Match" (List [App "Ident" (List [String "coseries"]), - List [App "PVar" (List [App "Ident" (List [String "rs"])]),App - "PVar" (List [App "Ident" (List [String "d"])])],App "Nothing" ( - List []),App "UnGuardedRhs" (List [App "ListComp" (List [App - "Lambda" (List [List [App "PVar" (List [App "Ident" (List [String - "t"])])],App "Case" (List [App "Var" (List [App "UnQual" (List [ - App "Ident" (List [String "t"])])]),MapCtor (App "Alt" (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 "UnGuardedRhs" (List [ - Application (Concat (List [List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [Concat (List [String "t",ShowInt - CtorIndex])])])])],MapField (App "Var" (List [App "UnQual" (List [ - App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]) - ])]))]))]),App "Nothing" (List [])]))])]),MapCtor (App "QualStmt" - (List [App "Generator" (List [App "PVar" (List [App "Ident" (List - [Concat (List [String "t",ShowInt CtorIndex])])]),App "InfixApp" ( - List [Application (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [Concat (List [String "alts",ShowInt CtorArity])])]) - ]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String - "rs"])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List - [String "d"])])])]),App "QVarOp" (List [App "UnQual" (List [App - "Ident" (List [String "const"])])]),App "RecConstr" (List [App - "UnQual" (List [App "Ident" (List [CtorName])]),List []])])])]))]) - ]),App "Nothing" (List [])])]])])])] + 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 diff --git a/src/Data/Derive/Serialize.hs b/src/Data/Derive/Serialize.hs --- a/src/Data/Derive/Serialize.hs +++ b/src/Data/Derive/Serialize.hs @@ -56,79 +56,127 @@ makeSerialize = derivationDSL "Serialize" dslSerialize dslSerialize = - List [Instance ["Serialize"] "Serialize" (List [App "InsDecl" ( - List [App "FunBind" (List [List [App "Match" (List [App "Ident" ( - List [String "put"]),List [App "PVar" (List [App "Ident" (List [ - String "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [ - App "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "x"])])]),MapCtor (App "Alt" (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 "UnGuardedRhs" (List [App "Do" (List [ - Concat (List [List [App "Qualifier" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "putTag"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])]) - ],MapField (App "Qualifier" (List [App "App" (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "put"])])]), - App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat ( - List [String "x",ShowInt FieldIndex])])])])])]))])])]),App - "Nothing" (List [])]))])]),App "Just" (List [App "BDecls" (List [ - List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ - String "useTag"])]),App "UnGuardedRhs" (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 "Nothing" (List [])]),App "FunBind" (List [List - [App "Match" (List [App "Ident" (List [String "putTag"]),List [App - "PVar" (List [App "Ident" (List [String "x"])])],App "Nothing" ( - List []),App "UnGuardedRhs" (List [Application (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "when"])])]), - App "Var" (List [App "UnQual" (List [App "Ident" (List [String - "useTag"])])]),App "Paren" (List [App "App" (List [App "Var" (List - [App "UnQual" (List [App "Ident" (List [Concat (List [String - "putWord",ShowInt (Int 8)])])])]),App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "x"])])])])])])]),App "Nothing" ( - List [])])]])]])])])]])]),App "InsDecl" (List [App "PatBind" (List - [App "PVar" (List [App "Ident" (List [String "get"])]),App - "UnGuardedRhs" (List [App "Do" (List [List [App "Generator" (List - [App "PVar" (List [App "Ident" (List [String "i"])]),App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "getTag"])])]) - ]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "i"])])]),Concat (List [ - MapCtor (App "Alt" (List [App "PLit" (List [App "Signless" (List [ - ]),App "Int" (List [CtorIndex])]),App "UnGuardedRhs" (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 "get"])])])])),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 "Nothing" (List [])])), - List [App "Alt" (List [App "PWildCard" (List []),App - "UnGuardedRhs" (List [App "App" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit" - (List [App "String" (List [Concat (List [String + 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 [List - [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "useTag"])]),App "UnGuardedRhs" (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 "Nothing" (List [])]),App "PatBind" (List [App - "PVar" (List [App "Ident" (List [String "getTag"])]),App - "UnGuardedRhs" (List [App "If" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "useTag"])])]),App "Var" - (List [App "UnQual" (List [App "Ident" (List [Concat (List [String - "getWord",ShowInt (Int 8)])])])]),App "App" (List [App "Var" (List - [App "UnQual" (List [App "Ident" (List [String "return"])])]),App - "Lit" (List [App "Int" (List [Int 0])])])])]),App "Nothing" (List - [])])]])])])])])] + 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 diff --git a/src/Data/Derive/Set.hs b/src/Data/Derive/Set.hs --- a/src/Data/Derive/Set.hs +++ b/src/Data/Derive/Set.hs @@ -30,11 +30,12 @@ makeSet = derivationCustom "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d -makeSetField :: DataDecl -> String -> [Decl] -makeSetField d field = [TypeSig sl [name set] typ, bind set [pVar "v",pVar "x"] bod] +makeSetField :: DataDecl -> String -> [Decl ()] +makeSetField d field = [TypeSig () [name set] typ, bind set [pVar "v",pVar "x"] bod] where set = "set" ++ title field - typ = typField `TyFun` (dataDeclType d `TyFun` dataDeclType d) + 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")] + bod = RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")] diff --git a/src/Data/Derive/Show.hs b/src/Data/Derive/Show.hs deleted file mode 100644 --- a/src/Data/Derive/Show.hs +++ /dev/null @@ -1,90 +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 Prelude - -example :: Custom -instance Show a => Show (Sample a) where - showsPrec p (First) = $(show 0) - showsPrec p (Second x1 x2) = $(show 1) - showsPrec p (Third x1) = $(show 2) - - -test :: Sample -instance Show a => Show (Sample a) where - 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 _ (Laptop x1 x2) = - showString "Laptop {weight = " . showsPrec 0 x1 . showString ", speed = " . showsPrec 0 x2 . showChar '}' - showsPrec _ (Desktop x1) = - showString "Desktop {speed = " . showsPrec 0 x1 . showChar '}' - -test :: (:*:) -instance (Show a, Show b) => Show ((:*:) a b) where - showsPrec p ((:*:) x1 x2) = showParen (p > 10) $ showString "(:*:) " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2 --} - -import Data.List -import Data.Derive.DSL.HSE -import qualified Language.Haskell as H - --- GENERATED START - -import Data.Derive.DSL.DSL -import Data.Derive.Internal.Derivation - -makeShow :: Derivation -makeShow = derivationCustomDSL "Show" custom $ - List [Instance ["Show"] "Show" (List [App "InsDecl" (List [App - "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [ - String "showsPrec"]),List [App "PVar" (List [App "Ident" (List [ - String "p"])]),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 "Nothing" (List []),App "UnGuardedRhs" (List [App - "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "show"] - )])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])])]),App - "Nothing" (List [])]))])])])] --- GENERATED STOP - --- Left is a literal string, Right is a variable - -custom = customSplice splice - -splice :: FullDataDecl -> Exp -> Exp -splice d (H.App x (H.Lit (H.Int y))) | x ~= "show" = combine $ compress $ - if fields then customFields c else customPlain c - where - fields = any (not . null . fst) (ctorDeclFields c) - c = dataDeclCtors (snd d) !! fromInteger y - - out (Left [x]) = H.App (var "showChar") (H.Lit $ H.Char x) - out (Left xs ) = H.App (var "showString") (H.Lit $ H.String xs) - out (Right x) = apps (var "showsPrec") [H.Lit $ H.Int (fields ? 0 $ 11), var $ 'x' : show x] - - compress (Left x:Left y:z) = compress $ Left (x++y) : z - compress (x:y) = x : compress y - compress [] = [] - - paren = InfixApp (H.App (var "showParen") (Paren $ InfixApp (var "p") (qvop ">") (H.Lit $ H.Int 10))) (qvop "$") - combine xs = (fields || or [' ' `notElem` x | Left x <- xs] ? id $ paren) $ - foldr1 (\x y -> InfixApp x (qvop ".") y) $ map out xs - - -customPlain :: CtorDecl -> [Either String Int] -customPlain c = intersperse (Left " ") $ Left (ctorDeclName c) : map Right [1..length (ctorDeclFields c)] - -customFields :: CtorDecl -> [Either String Int] -customFields c = Left (ctorDeclName c ++ " {") : concat (intersperse [Left ", "] xs) ++ [Left "}"] - where xs = [[Left (n ++ " = "), Right i] | (i,(n,t)) <- zip [1..] $ ctorDeclFields c] diff --git a/src/Data/Derive/Traversable.hs b/src/Data/Derive/Traversable.hs deleted file mode 100644 --- a/src/Data/Derive/Traversable.hs +++ /dev/null @@ -1,56 +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, makeTraversableN) where - -{- -import Data.Traversable -import Control.Applicative(pure, (<*>)) - -instance Traversable (FailList t1) where - traverse _f (Zoro) = pure Nil - traverse _f (Fial a1) = pure (Fial a1) - traverse _f (Const a1 a2) = (Const <$> _f a1) <*> traverse _f a2 - -instance Traversable Sample where - traverse _f (First) = pure First - traverse _f (Second a1 a2) = (Second <$> _f a1) <*> _f a2 - traverse _f (Third a1) = Third <$> _f a1 - -instance Traversable (Either t1) where - traverse _f (Left a1) = pure (Left a1) - traverse _f (Right a1) = Right <$> _f a1 --} - -import Data.Derive.Internal.Traversal -import Data.Derive.Internal.Derivation -import Language.Haskell - - -makeTraversable :: Derivation -makeTraversable = makeTraversableN 1 - -makeTraversableN :: Int -> Derivation -makeTraversableN n = traversalDerivation1 traverseTraversal{traversalArg = n} "Traversable" - -traverseTraversal = defaultTraversalType - { traversalName = qname "traverse" - , traversalId = var "pure" - , traversalPlus = fail "variable used in multiple positions in a data type" - , traverseTuple = \args -> liftAN (Con $ Special $ TupleCon Unboxed $ length args) args - , traverseCtor = \ctor -> liftAN (con ctor) - , traverseFunc = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) Nothing - } - -liftAN :: Exp -> [Exp] -> Exp -liftAN base args = foldl (<*>) (appP (var "pure") base) args - where x <*> y = InfixApp (paren x) (QVarOp $ UnQual $ Symbol "<*>") (paren y) diff --git a/src/Data/Derive/Typeable.hs b/src/Data/Derive/Typeable.hs deleted file mode 100644 --- a/src/Data/Derive/Typeable.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-| - 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. - - Also creates a @typename_\@ value to hold the - 'TypeRep'. --} -module Data.Derive.Typeable(makeTypeable) where -{- -import Data.Typeable - -test :: Bool -typename_Bool :: TyCon -typename_Bool = mkTyCon3 "package" "Example" "Bool" -instance Typeable Bool where - typeOf _ = mkTyConApp typename_Bool [] - -test :: Sample -typename_Sample :: TyCon -typename_Sample = mkTyCon3 "package" "Example" "Sample" -instance Typeable1 Sample where - typeOf1 _ = mkTyConApp typename_Sample [] -instance Typeable a => Typeable (Sample a) where - typeOf = typeOfDefault - -test :: Either -typename_Either :: TyCon -typename_Either = mkTyCon3 "package" "Example" "Either" -instance Typeable2 Either where - typeOf2 _ = mkTyConApp typename_Either [] -instance Typeable a => Typeable1 (Either a) where - typeOf1 = typeOf1Default -instance (Typeable a, Typeable b) => Typeable (Either a b) where - typeOf = typeOfDefault --} - -import Language.Haskell -import Data.Derive.Internal.Derivation -import Data.List - --- 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 = derivationCustom "Typeable" $ \(ModuleName modu,x) -> Right $ mkTypeable modu x - - -mkTypeable :: String -> DataDecl -> [Decl] -mkTypeable modu d = - [TypeSig sl [name fun] (tyCon "TyCon")] ++ - [PatBind sl (pVar fun) (UnGuardedRhs bod) Nothing | - let bod = apps (var "mkTyCon3") [Lit $ String "package", Lit $ String modu, Lit $ String nam]] ++ - [inst [] (showN n) [tyCon nam] [PWildCard] $ apps (var "mkTyConApp") [var fun, List []]] ++ - [inst [ClassA (qname "Typeable") [v] | v <- tvs] i [TyParen $ tyApp (tyCon nam) tvs] [] $ var $ "typeOf" ++ i ++ "Default" - | (vs,i) <- zip (tail $ inits $ dataDeclVars d) $ map showN [n-1,n-2..] - , let tvs = map tyVar vs] - where - nam = dataDeclName d - fun = "typename_" ++ nam - n = length $ dataDeclVars d - - -inst ctxt n typ pat expr = - InstDecl sl Nothing [] ctxt (qname $ "Typeable" ++ n) typ - [InsDecl $ bind ("typeOf" ++ n) pat expr] - -showN 0 = "" -showN n = show n diff --git a/src/Data/Derive/UniplateDirect.hs b/src/Data/Derive/UniplateDirect.hs --- a/src/Data/Derive/UniplateDirect.hs +++ b/src/Data/Derive/UniplateDirect.hs @@ -94,33 +94,38 @@ 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" + _ | 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 + 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) - -make :: Bool -> (String -> DataDecl) -> Type -> Type -> Either String [Decl] -make uni grab from to = Right [InstDecl sl Nothing [] [] (UnQual $ Ident $ if uni then "Uniplate" else "Biplate") (from : [to | not uni]) - [InsDecl $ InlineSig sl True AlwaysActive (qname $ if uni then "uniplate" else "biplate"), InsDecl ms]] +-- 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 sl (Ident $ if uni then "uniplate" else "biplate") [pat] Nothing (UnGuardedRhs bod) Nothing + 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") (var "plate" `App` var "x") | any isNothing bods] - else PatBind sl (pVar "biplate") (UnGuardedRhs $ var "plateSelf") Nothing + 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 :: (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 + 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 + 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) @@ -143,12 +148,12 @@ ansJoin _ = Try -type S a = State (Map.Map Type Ans) a +type S a = State (Map.Map (Type ()) Ans) a -run :: Type -> S a -> a +run :: Type () -> S a -> a run to act = evalState act (Map.singleton to Hit) -operator :: (String -> DataDecl) -> Type -> S Ans +operator :: (String -> DataDecl) -> Type () -> S Ans operator grab from = do mp <- get case Map.lookup from mp of @@ -165,7 +170,7 @@ else put s >> fix ans2 -operator2 :: (String -> DataDecl) -> Type -> S Ans +operator2 :: (String -> DataDecl) -> Type () -> S Ans operator2 grab from | isTyFun from = return Try | Just from2 <- fromTyList from = fmap ansList $ operator grab from2 @@ -174,27 +179,34 @@ Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs -subst :: Type -> Decl -> Either Type [(String,[Type])] +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 :: 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 (TyVar () x) = fromMaybe (TyVar () x) $ lookup (prettyPrint x) rep f x = x -substType :: Type -> Decl -> Type -substType ty (TypeDecl _ _ vars d) = fromTyParens $ transform f d +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 (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 . parseDecl) +knownCtors :: [Decl ()] +knownCtors = map (fromParseResult . fmap clearAnn . parseDecl) ["data Int = Int" ,"data Bool = Bool" ,"data Char = Char" @@ -210,11 +222,12 @@ listCtor : map tupleDefn (0:[2..32]) -listCtor = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"] - [QualConDecl sl [] [] $ ConDecl (Ident "[]") [] - ,QualConDecl sl [] [] $ ConDecl (Ident "(:)") [tyVar "a", TyList $ tyVar "a"]] [] +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"]] Nothing -tupleDefn :: Int -> Decl -tupleDefn n = DataDecl sl DataType [] (Ident s) (map (UnkindedVar . Ident) vars) [QualConDecl sl [] [] $ ConDecl (Ident s) (map tyVar vars)] [] +tupleDefn :: Int -> Decl () +tupleDefn n = DataDecl () (DataType ()) Nothing dhead [QualConDecl () Nothing Nothing $ ConDecl () (Ident () s) (map tyVar vars)] Nothing where s = "(" ++ replicate (n - 1) ',' ++ ")" vars = ['v':show i | i <- [1..n]] + dhead = foldr (flip (DHApp ())) (DHead () $ Ident () s) (map (UnkindedVar () . Ident ()) vars) diff --git a/src/Data/Derive/UniplateTypeable.hs b/src/Data/Derive/UniplateTypeable.hs --- a/src/Data/Derive/UniplateTypeable.hs +++ b/src/Data/Derive/UniplateTypeable.hs @@ -32,42 +32,71 @@ makeUniplateTypeable :: Derivation makeUniplateTypeable = derivationCustomDSL "UniplateTypeable" custom $ - List [App "InstDecl" (List [App "Nothing" (List []),List [],List [ - App "ClassA" (List [App "UnQual" (List [App "Ident" (List [String - "Typeable"])]),List [App "TyVar" (List [App "Ident" (List [String - "a"])])]]),App "ClassA" (List [App "UnQual" (List [App "Ident" ( - List [String "PlateAll"])]),List [App "TyVar" (List [App "Ident" ( - List [String "a"])]),App "TyVar" (List [App "Ident" (List [String - "to"])])]]),App "ClassA" (List [App "UnQual" (List [App "Ident" ( - List [String "Uniplate"])]),List [App "TyVar" (List [App "Ident" ( - List [String "to"])])]]),App "ClassA" (List [App "UnQual" (List [ - App "Ident" (List [String "Typeable"])]),List [App "TyVar" (List [ - App "Ident" (List [String "to"])])]])],App "UnQual" (List [App - "Ident" (List [String "PlateAll"])]),List [App "TyParen" (List [ - App "TyApp" (List [App "TyCon" (List [App "UnQual" (List [App - "Ident" (List [DataName])])]),App "TyVar" (List [App "Ident" (List - [String "a"])])])]),App "TyVar" (List [App "Ident" (List [String - "to"])])],List [App "InsDecl" (List [App "FunBind" (List [MapCtor - (App "Match" (List [App "Ident" (List [String "plateAll"]),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 "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App - "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App - "Symbol" (List [String "|+"])])]),Head])) (Concat (List [Reverse ( - MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [ - Concat (List [String "x",ShowInt FieldIndex])])])]))),List [App - "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( - List [String "plate"])])]),App "Con" (List [App "UnQual" (List [ - App "Ident" (List [CtorName])])])])]]))]),App "Nothing" (List [])] - ))])])]])] + 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 - -custom (_,d) [InstDecl x1 x2 x3 _ x5 _ x7] = [InstDecl x1 x2 x3 x4 x5 x6 x7] +-- 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 = concatMap f vars ++ [ClassA (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]] + 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"] - f v = [ClassA (qname "Typeable") [tyVar v], ClassA (qname "PlateAll") [tyVar v, 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 diff --git a/src/Data/Derive/Update.hs b/src/Data/Derive/Update.hs --- a/src/Data/Derive/Update.hs +++ b/src/Data/Derive/Update.hs @@ -34,14 +34,14 @@ makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d -makeUpdateField :: DataDecl -> String -> [Decl] +makeUpdateField :: DataDecl -> String -> [Decl ()] makeUpdateField d field = - [TypeSig sl [name upd] (TyParen (TyFun typF typF) `TyFun` typR) - ,bind upd [pVar "f",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (App (var "f") (Paren $ App (var field) (var "x")))] - ,TypeSig sl [name set] (typF `TyFun` typR) - ,bind set [pVar "v",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]] + [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 = dataDeclType d `TyFun` dataDeclType d + typR = TyFun () (dataDeclType d) (dataDeclType d) typF = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d diff --git a/src/Data/DeriveDSL.hs b/src/Data/DeriveDSL.hs --- a/src/Data/DeriveDSL.hs +++ b/src/Data/DeriveDSL.hs @@ -9,13 +9,13 @@ import Data.Maybe -deriveDSL :: [Decl] -> Maybe DSL +deriveDSL :: [Decl ()] -> Maybe DSL deriveDSL = listToMaybe . derive -applyDSL :: DSL -> DataDecl -> Either String [Decl] +applyDSL :: DSL -> DataDecl -> Either String [Decl ()] applyDSL dsl inp = Right $ apply dsl $ toInput inp -dynamicDSL :: DSL -> Maybe [Decl] +dynamicDSL :: DSL -> Maybe [Decl ()] dynamicDSL = dslSYB diff --git a/src/Data/DeriveTH.hs b/src/Data/DeriveTH.hs --- a/src/Data/DeriveTH.hs +++ b/src/Data/DeriveTH.hs @@ -41,4 +41,4 @@ Right v -> return $ convert v toFullDataDecl :: Dec -> FullDataDecl -toFullDataDecl x = (ModuleName "Todo", convert x) +toFullDataDecl x = (ModuleName () "Todo", convert x) diff --git a/src/Derive/Derivation.hs b/src/Derive/Derivation.hs --- a/src/Derive/Derivation.hs +++ b/src/Derive/Derivation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} module Derive.Derivation(wantDerive, performDerive, writeDerive) where @@ -16,35 +17,35 @@ --------------------------------------------------------------------- -- WHAT DO YOU WANT TO DERIVE -wantDerive :: [Flag] -> Module -> Module -> [Type] +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] +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 :: Module () -> Module () -> [Type ()] wantDeriveAnnotation real mine = moduleDerives mine \\ moduleDerives real -moduleDerives :: Module -> [Type] +moduleDerives :: Module () -> [Type ()] moduleDerives = concatMap f . moduleDecls where - f (DataDecl _ _ _ name vars _ deriv) = g name vars deriv - f (GDataDecl _ _ _ name vars _ _ deriv) = g name vars deriv - f (DerivDecl _ _ _ _ name args) = [TyCon name `tyApps` args] + 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) | (a,bs) <- deriv] - where b = TyCon (UnQual name) `tyApps` map (tyVar . prettyPrint) vars + g name vars deriv = [TyCon () a `tyApps` (b:bs) | IRule _ _ _ (fromInstHead -> (a,bs)) <- map fromIParen $ maybe [] (\(Deriving _ xs) -> xs) deriv] + where b = TyCon () (UnQual () name) `tyApps` map (tyVar . prettyPrint) vars --------------------------------------------------------------------- -- ACTUALLY DERIVE IT -performDerive :: [Derivation] -> Module -> [Type] -> [String] +performDerive :: [Derivation] -> Module () -> [Type ()] -> [String] performDerive derivations modu = concatMap ((:) "" . f) where grab = getDecl modu @@ -61,13 +62,13 @@ msg x = "Deriving " ++ prettyPrint ty ++ ": " ++ x -getDecl :: Module -> (String -> Decl) +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 _ _ _ name _ _ _) = [(prettyPrint name, x)] - f x@(GDataDecl _ _ _ name _ _ _ _) = [(prettyPrint name, x)] - f x@(TypeDecl _ name _ _) = [(prettyPrint name, x)] + 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 _ = [] @@ -80,7 +81,7 @@ --------------------------------------------------------------------- -- WRITE IT BACK -writeDerive :: FilePath -> ModuleName -> [Flag] -> [String] -> IO () +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 () diff --git a/src/Derive/Generate.hs b/src/Derive/Generate.hs --- a/src/Derive/Generate.hs +++ b/src/Derive/Generate.hs @@ -54,10 +54,10 @@ ]) ++ 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 #-}"] ++ @@ -82,7 +82,7 @@ pkgName = a pkgVersion = if null b then "latest" else tail b modu = reps '.' '-' $ prettyPrint $ importModule x - nam = case importSpecs x of Just (False,IAbs _ y:_) -> prettyPrint y ; _ -> name + nam = case importSpecs x of Just (ImportSpecList _ False (IAbs _ _ y:_)) -> prettyPrint y ; _ -> name wrap :: Int -> String -> [String] @@ -102,7 +102,7 @@ lexemes :: String -> [String] lexemes [] = [] lexemes x = a : lexemes b - where (a,b) = lexeme x + where (a,b) = lexeme x lexeme :: String -> (String, String) diff --git a/src/Derive/Main.hs b/src/Derive/Main.hs --- a/src/Derive/Main.hs +++ b/src/Derive/Main.hs @@ -37,11 +37,12 @@ src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=defaultExtensions} real = parse src - mine = parse $ uncomment src + mine = parse $ uncomment src :: Module SrcSpanInfo flags <- return $ foldl addFlags flags - [(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine] - let res = performDerive derivations mine $ wantDerive flags real mine - writeDerive file (moduleName mine) flags res + [(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 diff --git a/src/Derive/Test.hs b/src/Derive/Test.hs --- a/src/Derive/Test.hs +++ b/src/Derive/Test.hs @@ -25,16 +25,16 @@ exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary","Typeable"] -- These must be first and in every set -priority = ["Eq"] +priority = [] -listType :: Decl -listType = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"] - [QualConDecl sl [] [] (ConDecl (Ident "[]") []) - ,QualConDecl sl [] [] (ConDecl (Ident "Cons") - [TyVar (Ident "a") - ,TyApp (TyCon (UnQual (Ident "List"))) (TyVar (Ident "a"))])] - [] +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"))])] + Nothing -- test each derivation @@ -62,14 +62,14 @@ when (res /= ExitSuccess) $ error "Failed to typecheck results" -testFile :: [(String,Decl)] -> Derivation -> IO () +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) + 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 diff --git a/src/Derive/Utils.hs b/src/Derive/Utils.hs --- a/src/Derive/Utils.hs +++ b/src/Derive/Utils.hs @@ -13,32 +13,32 @@ data Src = Src {srcName :: String - ,srcImport :: [ImportDecl] - ,srcExample :: Maybe [Decl] - ,srcTest :: [(Type,[Decl])] + ,srcImport :: [ImportDecl ()] + ,srcExample :: Maybe [Decl ()] + ,srcTest :: [(Type (),[Decl ()])] ,srcCustom :: Bool } -- skip the importPkg bits -srcImportStd :: Src -> [ImportDecl] +srcImportStd :: Src -> [ImportDecl ()] srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y] nullSrc = Src "" [] Nothing [] False -readHSE :: FilePath -> IO Module +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 $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src + return $ fmap (const ()) $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src -data Pragma = Example Bool | Test Type +data Pragma = Example Bool | Test (Type ()) -asPragma :: Decl -> Maybe Pragma +asPragma :: Decl () -> Maybe Pragma asPragma (TypeSig _ [x] t) | x ~= "example" = Just $ Example $ prettyPrint t == "Custom" | x ~= "test" = Just $ Test t diff --git a/src/Language/Haskell.hs b/src/Language/Haskell.hs --- a/src/Language/Haskell.hs +++ b/src/Language/Haskell.hs @@ -1,12 +1,14 @@ - +{-# LANGUAGE PatternGuards #-} module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where -import Language.Haskell.Exts hiding (var,app,binds,paren) +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 ? @@ -16,158 +18,164 @@ -- insert explicit foralls -foralls :: Type -> Type -foralls x = TyForall (Just $ map UnkindedVar $ nub [y | TyVar y <- universe x]) [] x +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 +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 (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 (TyTuple _ _ xs) = xs fromTyTuple x = [x] -fromTyParen (TyParen x) = fromTyParen 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 (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) +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 (App op (List xs)) - | op ~= "length" = Lit $ Int $ fromIntegral $ length xs + 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 - | op ~= "+" = Lit $ Int $ i + j - | op ~= ">" = Con $ UnQual $ Ident $ show $ i > j - fExp (InfixApp x op y) + 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 - 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) + 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 /= [] = head good - where good = [z | Alt _ (PLit Signless y) (UnGuardedRhs z) Nothing <- alts, y == x] - fExp (If x t f) + 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) + 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 + | 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 (Con _ x) = Con () $ rename x fExp x = x - 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 :: 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 (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 :: 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 sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) - | 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 (UnGuardedRhs y) Nothing])) decls) - | x == x2 = fMatch $ Match sl nam [PParen pat] sig (UnGuardedRhs y) decls - fMatch o@(Match a b c d e bind) = fBinds (Match a b (minPat o c) d e) bind + 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 (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 + 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] Nothing (UnGuardedRhs (Paren (App bod (Var v2)))) Nothing]) - | UnQual v == v2 = [(x,bod)] - f (FunBind [Match sl x pat Nothing (UnGuardedRhs bod) Nothing]) = [(x,Paren $ Lambda sl pat bod)] + 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)] + , 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 + 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 + 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 sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) = x ~= "False" +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 (UnQual _ (Ident _ ('(':xs@(x:_)))) + | x == ',' = Special () $ TupleCon () Boxed $ length xs + | x /= ')' = UnQual () $ Symbol () $ init xs rename x = x @@ -178,7 +186,7 @@ isAtom _ = False -paren x = if isAtom x then x else Paren x +paren x = if isAtom x then x else Paren () x sl = SrcLoc "" 0 0 @@ -188,16 +196,16 @@ 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 +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 :: DataDecl -> Type () dataDeclType d = tyApp (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d) dataDeclFields :: DataDecl -> [String] @@ -205,96 +213,103 @@ -- A declaration that is either a DataDecl of GDataDecl -type DataDecl = Decl -type CtorDecl = Either QualConDecl GadtDecl -type FieldDecl = [(String, Type)] +type DataDecl = Decl () +type CtorDecl = Either (QualConDecl ()) (GadtDecl ()) +type FieldDecl = [(String, Type ())] -type FullDataDecl = (ModuleName, DataDecl) +type FullDataDecl = (ModuleName (), DataDecl) -moduleName (Module _ name _ _ _ _ _) = name -moduleDecls (Module _ _ _ _ _ _ decls) = decls -moduleImports (Module _ _ _ _ _ imps _) = imps -modulePragmas (Module _ _ pragmas _ _ _ _) = pragmas +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) +tyApp x xs = TyApp () (tyApp x $ init xs) (last xs) tyFun [x] = x -tyFun (x:xs) = TyFun x (tyFun xs) +tyFun (x:xs) = TyFun () x (tyFun xs) apps x [] = x -apps x (y:ys) = apps (App x y) ys +apps x (y:ys) = apps (App () x y) ys -bind :: String -> [Pat] -> Exp -> Decl +bind :: String -> [Pat ()] -> Exp () -> Decl () bind s p e = binds s [(p,e)] -binds :: String -> [([Pat], Exp)] -> Decl -binds n [([],e)] = PatBind sl (pVar n) (UnGuardedRhs e) Nothing -binds n xs = FunBind [Match sl (name n) p Nothing (UnGuardedRhs e) Nothing | (p,e) <- xs] +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 :: 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 -dataDeclSrcLoc :: DataDecl -> SrcLoc -dataDeclSrcLoc (DataDecl sl _ _ _ _ _ _) = sl -dataDeclSrcLoc (GDataDecl sl _ _ _ _ _ _ _) = sl +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 -dataDeclContext :: DataDecl -> Context -dataDeclContext (DataDecl _ _ ctx _ _ _ _) = ctx -dataDeclContext _ = error "dataDeclContext: not a DataDecl" +fromIParen :: InstRule a -> InstRule a +fromIParen (IParen _ x) = fromIParen x +fromIParen x = x -dataDeclName :: DataDecl -> String -dataDeclName (DataDecl _ _ _ name _ _ _) = prettyPrint name -dataDeclName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name +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 _ _ _ _ vars _ _) = map f vars - where f (KindedVar x _) = prettyPrint x - f (UnkindedVar x) = prettyPrint x +dataDeclVars (DataDecl _ _ _ hd _ _) = map f $ snd $ fromDeclHead hd + where f (KindedVar _ x _) = prettyPrint x + f (UnkindedVar _ x) = prettyPrint x dataDeclVarsStar :: DataDecl -> [String] -dataDeclVarsStar (DataDecl _ _ _ _ vars _ _) = mapMaybe f vars - where f (UnkindedVar x) = Just $ prettyPrint x - f (KindedVar x KindStar) = Just $ prettyPrint x +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 +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 +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) | (as,b) <- fields, a <- as] +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 name -declName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name -declName (TypeDecl _ name _ _) = prettyPrint name - +declName :: Decl () -> String +declName (DataDecl _ _ _ name _ _) = prettyPrint $ fst $ fromDeclHead name +declName (GDataDecl _ _ _ name _ _ _) = prettyPrint $ fst $ fromDeclHead name +declName (TypeDecl _ name _) = prettyPrint $ fst $ fromDeclHead name diff --git a/src/Language/Haskell/Convert.hs b/src/Language/Haskell/Convert.hs --- a/src/Language/Haskell/Convert.hs +++ b/src/Language/Haskell/Convert.hs @@ -1,10 +1,11 @@ {-# 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.Syntax as TH -import Language.Haskell.TH.Compat import Control.Exception import Data.Typeable import System.IO.Unsafe @@ -35,113 +36,128 @@ -instance Convert TH.Dec HS.Decl where +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 + 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 sl t (c cxt) (c n) (c vs) (c con) [] + 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) Nothing #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 + 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 sl t (c cxt) (c n) (c vs) (c con) [] + 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) Nothing #endif -instance Convert TH.Name HS.TyVarBind where - conv = UnkindedVar . c + dh name [] = DHead () name + dh name xs = DHApp () (dh name $ init xs) (last xs) -instance Convert TH.Name HS.Name where +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 +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 sl (c vs) (c cxt) (c x) - conv x = QualConDecl sl [] [] (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) [([c x], c (y,z)) | (x,y,z) <- xs] - conv (InfixC x n y) = InfixConDecl (c x) (c n) (c y) +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 +instance Convert TH.StrictType (HS.Type ()) where #if __GLASGOW_HASKELL__ >= 800 - conv (Bang SourceUnpack SourceStrict, x) = TyBang UnpackedTy $ TyBang BangedTy $ c x - conv (Bang SourceUnpack _, x) = TyBang UnpackedTy $ c x - conv (Bang _ SourceStrict, x) = TyBang BangedTy $ c x + 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 $ c x + conv (IsStrict, x) = TyBang () (BangedTy ()) (NoUnpack ()) $ c x conv (NotStrict, x) = c x #if __GLASGOW_HASKELL__ >= 704 - conv (Unpacked, x) = TyBang UnpackedTy $ c x + 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) (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 [] +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 + 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) [] +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]) + ClassA _ a b -> ClassA () a (b ++ [c y]) -instance Convert HS.Decl TH.Dec where - conv (InstDecl _ _ _ cxt nam typ ds) = instanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds] - conv (FunBind ms@(HS.Match _ nam _ _ _ _:_)) = FunD (c nam) (c ms) +instance Convert (HS.Decl ()) TH.Dec where +-- NEIL conv (InstDecl _ _ _ cxt nam typ ds) = instanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- 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 nam typ cs ds) = + 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 nam typ [con] ds) = - NewtypeD (c ctx) (c nam) (c typ) Nothing (c con) [] -- (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 nam typ cs ds) = - DataD (c ctx) (c nam) (c typ) (c cs) (c (map fst ds)) - conv (DataDecl _ NewType ctx nam typ [con] ds) = - NewtypeD (c ctx) (c nam) (c typ) (c con) (c (map fst ds)) + 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 _ [] [] con) = c con - conv (QualConDecl _ vs cx con) = ForallC (c 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 (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.Type TH.StrictType where +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) + conv (TyBang _ BangedTy{} _ t) = (Bang NoSourceUnpackedness SourceStrict, c t) #else - conv (TyBang BangedTy t) = (IsStrict, c t) + conv (TyBang _ BangedTy{} _ t) = (IsStrict, c t) #if __GLASGOW_HASKELL__ >= 704 - conv (TyBang UnpackedTy t) = (Unpacked, c t) + conv (TyBang _ _ Unpack{} t) = (Unpacked, c t) #else - conv (TyBang UnpackedTy t) = (IsStrict, c t) + conv (TyBang _ _ Unpack{} t) = (IsStrict, c t) #endif #endif #if __GLASGOW_HASKELL__ >= 800 @@ -150,162 +166,167 @@ conv t = (NotStrict, c t) #endif -instance Convert ([HS.Name],HS.Type) [TH.VarStrictType] where +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.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.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 +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.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.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) +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 (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) + 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] + conv (ListComp _ x y) = CompE $ c $ y ++ [QualStmt () $ Qualifier () x] -instance Convert HS.GuardedRhs (TH.Guard, TH.Exp) where - conv = undefined +instance Convert (HS.GuardedRhs ()) (TH.Guard, TH.Exp) where + conv (GuardedRhs _ g x) = (conv g, conv x) -instance Convert HS.Binds [TH.Dec] where - conv (BDecls x) = c x +instance Convert [HS.Stmt ()] TH.Guard where + conv xs = PatG $ map conv xs -instance Convert (Maybe HS.Binds) [TH.Dec] where +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) +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.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.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 = undefined +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.QOp ()) TH.Exp where + conv (QVarOp _ x) = c $ Var () x + conv (QConOp _ x) = c $ Con () x -instance Convert HS.Alt TH.Match where +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 +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) + 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.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.FieldUpdate ()) TH.FieldExp where + conv (FieldUpdate _ x y) = (c x, c y) -instance Convert HS.TyVarBind TH.Name where - conv (UnkindedVar x) = c x +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 +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 +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) +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 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 +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 +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 +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) +instance Convert (HS.Kind ()) TH.Kind where + conv KindStar{} = StarT + conv (KindFn _ x y) = AppT (AppT ArrowT (c x)) (c y) #endif #endif