diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,16 @@ -Changelog for Derive - +2.6.4 + Rewrite for haskell-src-exts == 1.20.* + #27, disable a few more extensions by default (sync with the HLint list) +2.6.3 + #24, support GHC 8.2 +2.6.2 + #19, more upgrade bug fixes +2.6.1 + #19, allow haskell-src-exts-1.19 +2.6 + Remove lots of derivations that didn't seem useful (Eq, Show etc) + Change to use annotated Haskell syntax trees + Require haskell-src-exts-1.18 2.5.26 #17, fix incomplete pattern matches for certain types of data 2.5.25 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 @@ -1,7 +1,8 @@ # Derive [![Hackage version](https://img.shields.io/hackage/v/derive.svg?label=Hackage)](https://hackage.haskell.org/package/derive) [![Build Status](https://img.shields.io/travis/ndmitchell/derive.svg)](https://travis-ci.org/ndmitchell/derive) +**Warning: This package has no official maintainer anymore. Use at your own risk. You may wish to consider the built-in mechanism [`GHC.Generics`](https://hackage.haskell.org/package/base-4.11.1.0/docs/GHC-Generics.html) or libraries such as [`generic-deriving`](https://hackage.haskell.org/package/generic-deriving).** -Data.Derive is a library and a tool for deriving instances for Haskell programs. It is designed to work with custom derivations, SYB and Template Haskell mechanisms. The tool requires GHC, but the generated code is portable to all compilers. We see this tool as a competitor to DrIFT. +Data.Derive is a library and a tool for deriving instances for Haskell programs. It is designed to work with custom derivations, SYB and Template Haskell mechanisms. The tool requires GHC, but the generated code is portable to all compilers. We see this tool as a competitor to DrIFT. This document proceeds as follows: @@ -35,16 +36,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 +48,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,11 +1,10 @@ -cabal-version: >= 1.8 -build-type: Default -name: derive -version: 2.5.26 +cabal-version: 1.18 build-type: Simple -copyright: Neil Mitchell 2006-2016 -author: Neil Mitchell -maintainer: Neil Mitchell +name: derive +version: 2.6.5 +copyright: Neil Mitchell 2006-2017 +author: Neil Mitchell and others +maintainer: None homepage: https://github.com/ndmitchell/derive#readme bug-reports: https://github.com/ndmitchell/derive/issues license: BSD3 @@ -20,23 +19,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.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.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.20.*, transformers >= 0.2, uniplate >= 1.5 && < 1.7 @@ -68,16 +69,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 +81,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 [] 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 ()] @@ -90,7 +90,7 @@ f [] = fromConstr $ readCon dat "[]" f (x:xs) = fromConstrB (g x (f xs `asTypeOf` res)) $ readCon dat "(:)" dat = dataTypeOf res - + g :: (Data a, Data b) => Output -> a -> b g x xs = r2 where r2 = if typeOf r2 == typeOf xs then coerce xs else fromOutput x @@ -99,7 +99,10 @@ res = evalState (fromConstrM f $ readCon dat str) args f :: Data a => State [Output] a f = res where res = if typeOf (fromState res) == typeOf sl then return $ coerce sl else - do x:xs <- get; put xs; return $ fromOutput x + do l <- get + case l of + x:xs -> do put xs; return $ fromOutput x + [] -> error "fromOutput: null" fromOutput (OString x) = coerce x fromOutput (OInt x) = coerce x 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 @@ -27,13 +27,13 @@ dlistAny :: forall a . Data a => DSL -> Maybe a dlistAny x | isNothing con = Nothing - | otherwise = res + | otherwise = res where con = readConstr dat "(:)" val = fromConstr (fromJust con) :: a - + dat = dataTypeOf (undefined :: a) - + res = gmapQi 0 f val f :: Data d => d -> Maybe a @@ -56,24 +56,28 @@ f :: forall b . Data b => State (Bool,[DSL]) b f = if typeOf (undefined :: b) == typeOf sl then return $ coerce sl else do - (b,x:xs) <- get - case syb x of - Nothing -> do put (False,xs) ; return undefined - Just y -> do put (b,xs) ; return y + (b,l) <- get + case l of + x:xs -> + case syb x of + Nothing -> do put (False,xs) ; return undefined + Just y -> do put (b,xs) ; return y + [] -> + error "dapp: null" dsimple :: Data a => DSL -> Maybe a dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle -dinstance :: DSL -> Maybe Decl +dinstance :: 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 +86,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"]] [] -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)] [] 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,37 @@ --------------------------------------------------------------------- -- 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 = concatMap f . moduleDecls +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 $ f deriv] + where b = TyCon () (UnQual () name) `tyApps` map (tyVar . prettyPrint) vars + f [Deriving _ _ xs] = xs + f _ = [] --------------------------------------------------------------------- -- ACTUALLY DERIVE IT -performDerive :: [Derivation] -> Module -> [Type] -> [String] +performDerive :: [Derivation] -> Module () -> [Type ()] -> [String] performDerive derivations modu = concatMap ((:) "" . f) where grab = getDecl modu @@ -61,13 +64,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,11 +83,11 @@ --------------------------------------------------------------------- -- 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 () - + let append = Append `elem` flags let output = [x | Output x <- flags] 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 @@ -59,5 +60,8 @@ [Arrows -- steals proc ,TransformListComp -- steals the group keyword ,XmlSyntax, RegularPatterns -- steals a-b + ,UnboxedTuples -- breaks (#) lens operator + ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break + ,DoRec, RecursiveDo -- breaks rec + ,TypeApplications -- HSE fails on @ patterns ] - diff --git a/src/Derive/Test.hs b/src/Derive/Test.hs --- a/src/Derive/Test.hs +++ b/src/Derive/Test.hs @@ -25,15 +25,15 @@ 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"))])] [] @@ -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,12 @@ {-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Convert(Convert, convert) where import Language.Haskell as HS -import Language.Haskell.TH.Syntax as TH +import qualified Language.Haskell.Exts as HSE(FieldDecl(..)) import Language.Haskell.TH.Compat +import Language.Haskell.TH.Syntax as TH import Control.Exception import Data.Typeable import System.IO.Unsafe @@ -35,113 +37,127 @@ -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) [] #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) [] #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 + conv (InstDecl _ _ (fromIParen -> IRule _ _ cxt (fromInstHead -> (nam,typ))) ds) = + instanceD (c cxt) (c $ tyApp (TyCon () nam) typ) [c d | InsDecl _ d <- fromMaybe [] ds] + conv (FunBind _ ms@(HS.Match _ nam _ _ _:_)) = FunD (c nam) (c ms) conv (PatBind _ p bod ds) = ValD (c p) (c bod) (c ds) conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ) #if __GLASGOW_HASKELL__ >= 800 -- ! certainly BROKEN because it ignores contexts - conv (DataDecl _ DataType ctx 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 diff --git a/src/Language/Haskell/TH/Compat.hs b/src/Language/Haskell/TH/Compat.hs --- a/src/Language/Haskell/TH/Compat.hs +++ b/src/Language/Haskell/TH/Compat.hs @@ -22,17 +22,23 @@ #endif dataDefinitionTypeArgs :: Dec -> [Name] -#if __GLASGOW_HASKELL__ >= 800 +#if __GLASGOW_HASKELL__ >= 802 +dataDefinitionTypeArgs (DataD _ _ _ _ _ deriv_clauses) = + deriv_clauses >>= from_deriv_clause +dataDefinitionTypeArgs (NewtypeD _ _ _ _ _ deriv_clauses) = + deriv_clauses >>= from_deriv_clause + +from_deriv_clause :: DerivClause -> [Name] +from_deriv_clause (DerivClause _ cxt) = map from_cxt cxt +#elif __GLASGOW_HASKELL__ >= 800 dataDefinitionTypeArgs (DataD _cx name _ _ _ cxt) = map from_cxt cxt dataDefinitionTypeArgs (NewtypeD cx name _ _ _ cxt) = map from_cxt cxt -#else -#if __GLASGOW_HASKELL__ >= 612 +#elif __GLASGOW_HASKELL__ >= 612 dataDefinitionTypeArgs (DataD _cx name _ _ args) = args dataDefinitionTypeArgs (NewtypeD cx name _ _ args) = args #else dataDefinitionTypeArgs (DataD _cx name args cons _derv) = args dataDefinitionTypeArgs (NewtypeD cx name args con derv) = args -#endif #endif from_cxt :: Type -> Name