diff --git a/Data/Derive/All.hs b/Data/Derive/All.hs
--- a/Data/Derive/All.hs
+++ b/Data/Derive/All.hs
@@ -5,36 +5,38 @@
import Data.Derive.Internal.Derivation
-- GENERATED START
-import Data.Derive.Arbitrary as D
-import Data.Derive.ArbitraryOld as D
-import Data.Derive.Arities as D
-import Data.Derive.Binary as D
-import Data.Derive.BinaryDefer as D
-import Data.Derive.Bounded as D
-import Data.Derive.Data 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.LazySet as D
-import Data.Derive.Monoid as D
-import Data.Derive.NFData as D
-import Data.Derive.Ord as D
-import Data.Derive.PlateTypeable as D
-import Data.Derive.Read as D
-import Data.Derive.Ref as D
-import Data.Derive.Serial as D
-import Data.Derive.Set as D
-import Data.Derive.Show as D
-import Data.Derive.Traversable as D
-import Data.Derive.Typeable as D
-import Data.Derive.Update as D
+import Data.Derive.Arbitrary as D
+import Data.Derive.ArbitraryOld as D
+import Data.Derive.Arities as D
+import Data.Derive.Binary as D
+import Data.Derive.BinaryDefer as D
+import Data.Derive.Bounded as D
+import Data.Derive.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.LazySet 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.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,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeLazySet,makeMonoid,makeNFData,makeOrd,makePlateTypeable,makeRead,makeRef,makeSerial,makeSet,makeShow,makeTraversable,makeTypeable,makeUpdate]
+derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeData,makeDataAbstract,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeLazySet,makeMonoid,makeNFData,makeOrd,makeRead,makeRef,makeSerial,makeSet,makeShow,makeTraversable,makeTypeable,makeUniplateDirect,makeUniplateTypeable,makeUpdate]
-- GENERATED STOP
diff --git a/Data/Derive/Arbitrary.hs b/Data/Derive/Arbitrary.hs
--- a/Data/Derive/Arbitrary.hs
+++ b/Data/Derive/Arbitrary.hs
@@ -25,7 +25,7 @@
import Data.Derive.DSL.HSE
import qualified Language.Haskell as H
import Data.List
-import Data.Generics.PlateData
+import Data.Generics.Uniplate.DataOnly
-- GENERATED START
diff --git a/Data/Derive/ArbitraryOld.hs b/Data/Derive/ArbitraryOld.hs
--- a/Data/Derive/ArbitraryOld.hs
+++ b/Data/Derive/ArbitraryOld.hs
@@ -1,6 +1,6 @@
module Data.Derive.ArbitraryOld where
{-
-import "QuickCheck-1.1.0.0" Test.QuickCheck(Arbitrary)
+import "QuickCheck-1.2.0.0" Test.QuickCheck(Arbitrary(..), choose,variant)
example :: Sample
diff --git a/Data/Derive/BinaryDefer.hs b/Data/Derive/BinaryDefer.hs
--- a/Data/Derive/BinaryDefer.hs
+++ b/Data/Derive/BinaryDefer.hs
@@ -5,11 +5,19 @@
example :: Sample
instance BinaryDefer a => BinaryDefer (Sample a) where
- bothDefer = defer [\ ~(First) -> unit First
- ,\ ~(Second x1 x2) -> unit Second << x1 << x2
- ,\ ~(Third x1) -> unit Third << x1
+ bothDefer = defer [\ ~(o@(First)) -> if null [] then unit (First) < if null [const () x1, const () x2] then unit (Second x1 x2) < if null [const () x1] then unit (Third x1) < BinaryDefer (FailList e a) where
+ bothDefer = defer [\ ~(o@Zoro) -> unit Zoro < unit Fail << x1
+ ,\ ~(Const x1 x2) -> unit Const << x1 << x2
+ ]
+
-}
-- GENERATED START
@@ -26,15 +34,30 @@
(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
- "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),
- MapField (App "PVar" (List [App "Ident" (List [Concat (List [
- String "x",ShowInt FieldIndex])])]))])])])],Fold (App "InfixApp" (
- List [Tail,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (
- List [String "<<"])])]),Head])) (Concat (List [Reverse (MapField (
+ "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])])])]))),List [App "App" (
- List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
- String "unit"])])]),App "Con" (List [App "UnQual" (List [App
- "Ident" (List [CtorName])])])])]]))]))])])]),App "BDecls" (List [
- List []])])])])]
+ List [String "x",ShowInt FieldIndex])])])]))]))])]),App "QVarOp" (
+ List [App "UnQual" (List [App "Symbol" (List [String "< Input -> Out
diff --git a/Data/Derive/DSL/DSL.hs b/Data/Derive/DSL/DSL.hs
--- a/Data/Derive/DSL/DSL.hs
+++ b/Data/Derive/DSL/DSL.hs
@@ -5,7 +5,7 @@
import Data.Derive.DSL.HSE
import Data.List
import Data.Data
-import Data.Generics.PlateData
+import Data.Generics.Uniplate.DataOnly
data DSL = App String DSL{-List-}
| Concat DSL
diff --git a/Data/Derive/DSL/HSE.hs b/Data/Derive/DSL/HSE.hs
--- a/Data/Derive/DSL/HSE.hs
+++ b/Data/Derive/DSL/HSE.hs
@@ -5,7 +5,7 @@
import Language.Haskell hiding (List, App, String, Int)
import qualified Language.Haskell.Exts as H
import Data.Data
-import Data.Generics.PlateData
+import Data.Generics.Uniplate.DataOnly
import Data.Maybe
import Data.List
import Data.Function
diff --git a/Data/Derive/Data.hs b/Data/Derive/Data.hs
--- a/Data/Derive/Data.hs
+++ b/Data/Derive/Data.hs
@@ -1,4 +1,4 @@
-module Data.Derive.Data where
+module Data.Derive.Data(makeData) where
{-
import Data.Data
diff --git a/Data/Derive/DataAbstract.hs b/Data/Derive/DataAbstract.hs
new file mode 100644
--- /dev/null
+++ b/Data/Derive/DataAbstract.hs
@@ -0,0 +1,62 @@
+{-|
+ For deriving Data on abstract data types.
+-}
+module Data.Derive.DataAbstract(makeDataAbstract) where
+{-
+import Data.Data(Data(..))
+
+example :: Custom
+
+instance Typeable a => Data (Sample a) where
+ gfoldl k r x = r x
+ gunfold = error "Data.gunfold not implemented on abstract data type: Sample"
+ toConstr = error "Data.gunfold not implemented on abstract data type: Sample"
+ dataTypeOf = error "Data.gunfold not implemented on abstract data type: Sample"
+
+-}
+
+import Data.Derive.DSL.HSE
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeDataAbstract :: Derivation
+makeDataAbstract = derivationCustomDSL "DataAbstract" custom $
+ List [Instance ["Typeable"] "Data" (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
+ "x"])])])])]),App "BDecls" (List [List []])])]])]),App "InsDecl" (
+ List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
+ String "gunfold"])]),App "Nothing" (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
+ "Data.gunfold not implemented on abstract data type: ",DataName])]
+ )])])]),App "BDecls" (List [List []])])]),App "InsDecl" (List [App
+ "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+ "toConstr"])]),App "Nothing" (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
+ "Data.gunfold not implemented on abstract data type: ",DataName])]
+ )])])]),App "BDecls" (List [List []])])]),App "InsDecl" (List [App
+ "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+ "dataTypeOf"])]),App "Nothing" (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
+ "Data.gunfold not implemented on abstract data type: ",DataName])]
+ )])])]),App "BDecls" (List [List []])])])])]
+-- GENERATED STOP
+
+custom = customContext context
+
+context :: FullDataDecl -> Context
+context d = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
diff --git a/Data/Derive/EnumCyclic.hs b/Data/Derive/EnumCyclic.hs
--- a/Data/Derive/EnumCyclic.hs
+++ b/Data/Derive/EnumCyclic.hs
@@ -18,7 +18,7 @@
succ a = if b == length [First{},Second{},Third{}] then toEnum 0 else toEnum (b+1)
where b = fromEnum a
- pred a = if b == 0 then toEnum length [First{},Second{},Third{}] else toEnum (b-1)
+ pred a = if b == 0 then toEnum (length [First{},Second{},Third{}]) else toEnum (b-1)
where b = fromEnum a
-}
@@ -85,20 +85,21 @@
"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])])]),Application (List [App "Var" (
+ List [App "Int" (List [Int 0])])]),App "App" (List [App "Var" (
List [App "UnQual" (List [App "Ident" (List [String "toEnum"])])])
- ,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 "BDecls" (List [List [App "PatBind" (List
- [App "PVar" (List [App "Ident" (List [String "b"])]),App "Nothing"
- (List []),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 "BDecls" (List [List []])])]])])]])])])]
+ ,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 "BDecls" (
+ List [List [App "PatBind" (List [App "PVar" (List [App "Ident" (
+ List [String "b"])]),App "Nothing" (List []),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
+ "BDecls" (List [List []])])]])])]])])])]
-- GENERATED STOP
diff --git a/Data/Derive/Fold.hs b/Data/Derive/Fold.hs
--- a/Data/Derive/Fold.hs
+++ b/Data/Derive/Fold.hs
@@ -39,11 +39,11 @@
import Language.Haskell
import Data.Derive.Internal.Derivation
import Data.List
-import Data.Generics.PlateData
+import Data.Generics.Uniplate.DataOnly
makeFold :: Derivation
-makeFold = Derivation "Fold" $ \(_,d) -> Right $ simplify $ mkFold d
+makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d
mkFold :: DataDecl -> [Decl]
diff --git a/Data/Derive/Foldable.hs b/Data/Derive/Foldable.hs
--- a/Data/Derive/Foldable.hs
+++ b/Data/Derive/Foldable.hs
@@ -16,7 +16,7 @@
test :: FailList
instance Foldable (FailList t1) where
- foldr _ b Zero = b
+ foldr _ b Zoro = b
foldr _ b (Fail _) = b
foldr _f b (Const a1 a2) = _f a1 (Data.Foldable.foldr _f b a2)
diff --git a/Data/Derive/From.hs b/Data/Derive/From.hs
--- a/Data/Derive/From.hs
+++ b/Data/Derive/From.hs
@@ -33,7 +33,7 @@
makeFrom :: Derivation
-makeFrom = Derivation "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d
+makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d
makeFromCtor :: DataDecl -> CtorDecl -> [Decl]
diff --git a/Data/Derive/Functor.hs b/Data/Derive/Functor.hs
--- a/Data/Derive/Functor.hs
+++ b/Data/Derive/Functor.hs
@@ -19,7 +19,7 @@
test :: FailList
instance Functor (FailList t1) where
- fmap _ Zero = Zero
+ fmap _ Zoro = Zoro
fmap _ (Fail a1) = Fail a1
fmap _f (Const a1 a2) = Const (_f a1) (fmap _f a2)
diff --git a/Data/Derive/Has.hs b/Data/Derive/Has.hs
--- a/Data/Derive/Has.hs
+++ b/Data/Derive/Has.hs
@@ -25,7 +25,7 @@
makeHas :: Derivation
-makeHas = Derivation "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d
+makeHas = derivationCustom "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d
makeHasField :: DataDecl -> String -> [Decl]
diff --git a/Data/Derive/Internal/Derivation.hs b/Data/Derive/Internal/Derivation.hs
--- a/Data/Derive/Internal/Derivation.hs
+++ b/Data/Derive/Internal/Derivation.hs
@@ -1,26 +1,35 @@
module Data.Derive.Internal.Derivation(
- Derivation(..), derivationDSL, derivationCustomDSL,
+ Derivation(..),
+ derivationParams, derivationCustom, derivationDSL, derivationCustomDSL,
customSplice, customContext
) where
import Data.DeriveDSL
import Data.Derive.DSL.HSE
-import Data.Generics.PlateData
+import Data.Generics.Uniplate.DataOnly
data Derivation = Derivation
{derivationName :: String
- ,derivationOp :: FullDataDecl -> Either String [Decl]
+ ,derivationOp :: Type -> (String -> Decl) -> FullDataDecl -> Either String [Decl]
}
+derivationParams :: String -> ([Type] -> (String -> Decl) -> FullDataDecl -> Either String [Decl]) -> Derivation
+derivationParams name op = Derivation name $ \ty grab decs -> op (snd $ fromTyApps $ fromTyParen ty) grab decs
+
+
+derivationCustom :: String -> (FullDataDecl -> Either String [Decl]) -> Derivation
+derivationCustom name op = derivationParams name $ \ty grab decs -> op decs
+
+
derivationDSL :: String -> DSL -> Derivation
derivationDSL name dsl = derivationCustomDSL name (const id) dsl
derivationCustomDSL :: String -> (FullDataDecl -> [Decl] -> [Decl]) -> DSL -> Derivation
-derivationCustomDSL name custom dsl = Derivation name $
+derivationCustomDSL name custom dsl = derivationCustom name $
\d -> case applyDSL dsl $ snd d of
Left x -> Left x
Right x -> Right $ simplify $ custom d x
diff --git a/Data/Derive/Internal/Traversal.hs b/Data/Derive/Internal/Traversal.hs
--- a/Data/Derive/Internal/Traversal.hs
+++ b/Data/Derive/Internal/Traversal.hs
@@ -25,7 +25,7 @@
import qualified Data.Set as S
import Control.Monad.Writer
import Control.Applicative
-import Data.Generics.PlateData
+import Data.Generics.Uniplate.DataOnly
import Data.Maybe
---------------------------------------------------------------------------------
@@ -89,7 +89,7 @@
-- | Derivation for a Traversable like class with just 1 method
traversalDerivation1 :: TraveralType -> String -> Derivation
-traversalDerivation1 tt nm = Derivation (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 "")
diff --git a/Data/Derive/Is.hs b/Data/Derive/Is.hs
--- a/Data/Derive/Is.hs
+++ b/Data/Derive/Is.hs
@@ -19,7 +19,7 @@
makeIs :: Derivation
-makeIs = Derivation "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d
+makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d
makeIsCtor :: DataDecl -> CtorDecl -> [Decl]
diff --git a/Data/Derive/LazySet.hs b/Data/Derive/LazySet.hs
--- a/Data/Derive/LazySet.hs
+++ b/Data/Derive/LazySet.hs
@@ -25,7 +25,7 @@
makeLazySet :: Derivation
-makeLazySet = Derivation "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d
+makeLazySet = derivationCustom "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d
makeLazySetField :: DataDecl -> String -> [Decl]
diff --git a/Data/Derive/PlateTypeable.hs b/Data/Derive/PlateTypeable.hs
deleted file mode 100644
--- a/Data/Derive/PlateTypeable.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-module Data.Derive.PlateTypeable where
-{-
-import "uniplate" Data.Generics.PlateTypeable(PlateAll)
-
-example :: Sample
-
-instance (PlateAll a (Sample a), Typeable a) => Uniplate (Sample a) where
- uniplate = uniplateAll
-
-instance (Typeable t, Typeable a, Uniplate t, PlateAll a t) => PlateAll (Sample a) t where
- plateAll (First) = plate First
- plateAll (Second x1 x2) = plate Second |+ x1 |+ x2
- plateAll (Third x1) = plate Third |+ x1
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makePlateTypeable :: Derivation
-makePlateTypeable = derivationDSL "PlateTypeable" dslPlateTypeable
-
-dslPlateTypeable =
- List [Instance ["PlateAll","Typeable"] "Uniplate" (List [App
- "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App
- "Ident" (List [String "uniplate"])]),App "Nothing" (List []),App
- "UnGuardedRhs" (List [App "Var" (List [App "UnQual" (List [App
- "Ident" (List [String "uniplateAll"])])])]),App "BDecls" (List [
- List []])])])]),App "InstDecl" (List [List [App "ClassA" (List [
- App "UnQual" (List [App "Ident" (List [String "Typeable"])]),List
- [App "TyVar" (List [App "Ident" (List [String "t"])])]]),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 "Uniplate"])]),List [App "TyVar" (List [App "Ident" (
- List [String "t"])])]]),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 "t"])])]])],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 "t"])])],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 "BDecls" (List [List []])]))])])]])]
--- GENERATED STOP
diff --git a/Data/Derive/Ref.hs b/Data/Derive/Ref.hs
--- a/Data/Derive/Ref.hs
+++ b/Data/Derive/Ref.hs
@@ -28,7 +28,7 @@
makeRef :: Derivation
-makeRef = Derivation "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d
+makeRef = derivationCustom "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d
makeRefField :: DataDecl -> String -> [Decl]
diff --git a/Data/Derive/Set.hs b/Data/Derive/Set.hs
--- a/Data/Derive/Set.hs
+++ b/Data/Derive/Set.hs
@@ -27,7 +27,7 @@
makeSet :: Derivation
-makeSet = Derivation "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d
+makeSet = derivationCustom "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d
makeSetField :: DataDecl -> String -> [Decl]
diff --git a/Data/Derive/Traversable.hs b/Data/Derive/Traversable.hs
--- a/Data/Derive/Traversable.hs
+++ b/Data/Derive/Traversable.hs
@@ -17,7 +17,7 @@
import Control.Applicative(pure, (<*>))
instance Traversable (FailList t1) where
- traverse _f (Zero) = pure Nil
+ traverse _f (Zoro) = pure Nil
traverse _f (Fail a1) = pure (Fail a1)
traverse _f (Const a1 a2) = (Const <$> _f a1) <*> traverse _f a2
diff --git a/Data/Derive/Typeable.hs b/Data/Derive/Typeable.hs
--- a/Data/Derive/Typeable.hs
+++ b/Data/Derive/Typeable.hs
@@ -70,7 +70,7 @@
makeTypeable :: Derivation
-makeTypeable = Derivation "Typeable" $ \(ModuleName modu,x) -> Right $ mkTypeable modu x
+makeTypeable = derivationCustom "Typeable" $ \(ModuleName modu,x) -> Right $ mkTypeable modu x
mkTypeable :: String -> DataDecl -> [Decl]
diff --git a/Data/Derive/UniplateDirect.hs b/Data/Derive/UniplateDirect.hs
new file mode 100644
--- /dev/null
+++ b/Data/Derive/UniplateDirect.hs
@@ -0,0 +1,215 @@
+{-# LANGUAGE PatternGuards #-}
+-- NOTE: Cannot be guessed as it relies on type information
+
+-- | Derive Uniplate and Biplate using the Direct combinators.
+-- You must specific monomorphic instances, i.e:
+--
+-- > data Foo a = Foo a Int
+-- >
+-- > {-!
+-- > deriving instance UniplateDirect (Foo Int)
+-- > deriving instance UniplateDirect (Foo Int) Int
+-- > !-}
+--
+-- All types referred to must be in scope at the time.
+--
+-- @deriving UniplateDirect@ with no arguments will be assumed to derive the Uniplate
+-- instance on all types being unit.
+module Data.Derive.UniplateDirect(makeUniplateDirect) where
+
+
+{-
+import "uniplate" Data.Generics.Uniplate.Direct
+
+
+-- test tuples
+test :: UniplateDirect ((), Maybe ()) ()
+instance Biplate ((), Maybe ()) () where
+ {-# INLINE biplate #-}
+ biplate (x1, x2) = plate (,) |* x1 |+ x2
+
+test :: UniplateDirect (Sample Int)
+instance Uniplate (Sample Int) where
+ {-# INLINE uniplate #-}
+ uniplate x = plate x
+
+test :: UniplateDirect (Sample Int) Int
+instance Biplate (Sample Int) Int where
+ {-# INLINE biplate #-}
+ biplate (Second x1 x2) = plate Second |* x1 |* x2
+ biplate (Third x1) = plate Third |* x1
+ biplate x = plate x
+
+test :: UniplateDirect Computer
+instance Uniplate Computer where
+ {-# INLINE uniplate #-}
+ uniplate x = plate x
+
+test :: UniplateDirect Computer Computer
+instance Biplate Computer Computer where
+ {-# INLINE biplate #-}
+ biplate = plateSelf
+
+test :: UniplateDirect Computer Double
+instance Biplate Computer Double where
+ {-# INLINE biplate #-}
+ biplate (Laptop x1 x2) = plate Laptop |* x1 |- x2
+ biplate x = plate x
+
+test :: UniplateDirect (Assoced (Maybe Bool)) Char
+instance Biplate (Assoced (Maybe Bool)) Char where
+ {-# INLINE biplate #-}
+ biplate (Assoced x1 x2) = plate (Assoced x1) ||* x2
+
+-- test following external declarations
+test :: UniplateDirect (Either Bool Computer) Int
+instance Biplate (Either Bool Computer) Int where
+ {-# INLINE biplate #-}
+ biplate (Right x1) = plate Right |+ x1
+ biplate x = plate x
+
+-- test recursive bits
+test :: UniplateDirect (List Int) Bool
+instance Biplate (List Int) Bool where
+ {-# INLINE biplate #-}
+ biplate x = plate x
+-}
+
+import Language.Haskell
+import Data.Generics.Uniplate.DataOnly
+import Data.Derive.Internal.Derivation
+import Data.Maybe
+import qualified Data.Map as Map
+import Control.Arrow
+import Control.Monad.State
+
+
+makeUniplateDirect :: Derivation
+makeUniplateDirect = derivationParams "UniplateDirect" $ \args grab (_,ty) -> simplify $
+ let known = map (declName &&& id) knownCtors
+ grab2 x = fromMaybe (grab x) $ lookup x known
+ in case args of
+ _ | not $ null [() | TyVar _ <- universeBi args] -> error "UniplateDirect only accepts monomorphic types"
+ [] -> make True grab2 x x
+ where x = tyApps (tyCon $ dataDeclName ty) $ replicate (dataDeclArity ty) $ TyCon $ Special UnitCon
+ [x] -> make True grab2 x x
+ [x,y] -> make False grab2 x y
+ _ -> error $ "UniplateDirect requires exactly one or two arguments, got " ++ show (length args)
+
+
+make :: Bool -> (String -> DataDecl) -> Type -> Type -> Either String [Decl]
+make uni grab from to = Right [InstDecl sl [] (UnQual $ Ident $ if uni then "Uniplate" else "Biplate") (from : [to | not uni])
+ [InsInline sl True AlwaysActive (qname $ if uni then "uniplate" else "biplate"), InsDecl ms]]
+ where
+ ty = grab $ tyRoot from
+ match pat bod = Match sl (Ident $ if uni then "uniplate" else "biplate") [pat] Nothing (UnGuardedRhs bod) (BDecls [])
+ 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") Nothing (UnGuardedRhs $ var "plateSelf") (BDecls [])
+ bods = run (fromTyParens to) $ mapM (make1 grab) $ substData from ty
+
+
+make1 :: (String -> DataDecl) -> (String,[Type]) -> S (Maybe (Pat, Exp))
+make1 grab (name,tys) = do
+ ops <- mapM (fmap show . operator grab) tys
+ let vars = ['x':show i | i <- [1..length tys]]
+ pat = PParen $ PApp (qname name) $ map pVar vars
+ (good,bad) = span ((==) "|-" . fst) $ zip ops $ map var vars
+ bod = foldl (\x (y,z) -> InfixApp x (QVarOp $ UnQual $ Symbol y) z) (App (var "plate") $ paren $ apps (con name) (map snd good)) bad
+ return $ if all (== "|-") ops then Nothing else Just (pat,bod)
+
+
+data Ans = Hit | Miss | Try | ListHit | ListTry deriving Eq
+
+instance Show Ans where
+ show Hit = "|*"
+ show Miss = "|-"
+ show Try = "|+"
+ show ListHit = "||*"
+ show ListTry = "||+"
+
+ansList Hit = ListHit
+ansList Miss = Miss
+ansList _ = ListTry
+
+
+ansJoin (Miss:xs) = ansJoin xs
+ansJoin [] = Miss
+ansJoin _ = Try
+
+
+type S a = State (Map.Map Type Ans) a
+
+run :: Type -> S a -> a
+run to act = evalState act (Map.singleton to Hit)
+
+operator :: (String -> DataDecl) -> Type -> S Ans
+operator grab from = do
+ mp <- get
+ case Map.lookup from mp of
+ Just y -> return y
+ Nothing -> do
+ fix Miss
+ where
+ fix ans = do
+ s <- get
+ modify $ Map.insert from ans
+ ans2 <- operator2 grab from
+ if ans == ans2
+ then return ans
+ else put s >> fix ans2
+
+
+operator2 :: (String -> DataDecl) -> Type -> S Ans
+operator2 grab from
+ | isTyFun from = return Try
+ | Just from2 <- fromTyList from = fmap ansList $ operator grab from2
+ | otherwise = case subst from $ grab $ tyRoot from of
+ Left from2 -> operator grab from2
+ Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs
+
+
+subst :: Type -> Decl -> Either Type [(String,[Type])]
+subst ty x@TypeDecl{} = Left $ substType ty x
+subst ty x = Right $ substData ty x
+
+substData :: Type -> Decl -> [(String,[Type])]
+substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . fromBangType . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat]
+ where
+ rep = zip (dataDeclVars dat) (snd $ fromTyApps $ fromTyParen ty)
+ f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep
+ f x = x
+
+substType :: Type -> Decl -> Type
+substType ty (TypeDecl _ _ vars d) = fromTyParens $ transform f d
+ where
+ rep = zip (map prettyPrint vars) (snd $ fromTyApps ty)
+ f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep
+ f x = x
+
+
+knownCtors :: [Decl]
+knownCtors = map (fromParseResult . parseDecl)
+ ["data Int = Int"
+ ,"data Bool = Bool"
+ ,"data Char = Char"
+ ,"data Double = Double"
+ ,"data Float = Float"
+ ,"data Integer = Integer"
+ ,"data Maybe a = Nothing | Just a"
+ ,"data Either a b = Left a | Right b"
+ ,"type Rational = Ratio Integer"
+ ,"data (Integral a) => Ratio a = !a :% !a"
+ ,"type String = [Char]"
+ ] ++
+ listCtor :
+ map tupleDefn (0:[2..32])
+
+listCtor = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]
+ [QualConDecl sl [] [] $ ConDecl (Ident "[]") []
+ ,QualConDecl sl [] [] $ ConDecl (Ident "(:)") [UnBangedTy $ tyVar "a", UnBangedTy $ TyList $ tyVar "a"]] []
+
+tupleDefn :: Int -> Decl
+tupleDefn n = DataDecl sl DataType [] (Ident s) (map (UnkindedVar . Ident) vars) [QualConDecl sl [] [] $ ConDecl (Ident s) (map (UnBangedTy . tyVar) vars)] []
+ where s = "(" ++ replicate (n - 1) ',' ++ ")"
+ vars = ['v':show i | i <- [1..n]]
diff --git a/Data/Derive/UniplateTypeable.hs b/Data/Derive/UniplateTypeable.hs
new file mode 100644
--- /dev/null
+++ b/Data/Derive/UniplateTypeable.hs
@@ -0,0 +1,72 @@
+module Data.Derive.UniplateTypeable where
+{-
+import "uniplate" Data.Generics.Uniplate.Typeable
+
+example :: Custom
+
+instance (Typeable a, PlateAll a to, Uniplate to, Typeable to) => PlateAll (Sample a) to where
+ plateAll (First) = plate First
+ plateAll (Second x1 x2) = plate Second |+ x1 |+ x2
+ plateAll (Third x1) = plate Third |+ x1
+
+test :: Bool
+
+instance (Typeable to, Uniplate to) => PlateAll Bool to where
+ plateAll False = plate False
+ plateAll True = plate True
+
+test :: Either a b
+
+instance (Typeable a, PlateAll a to, Typeable b, PlateAll b to, Typeable to, Uniplate to) => PlateAll (Either a b) to where
+ plateAll (Left x1) = plate Left |+ x1
+ plateAll (Right x1) = plate Right |+ x1
+
+-}
+
+import Data.Derive.DSL.HSE
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeUniplateTypeable :: Derivation
+makeUniplateTypeable = derivationCustomDSL "UniplateTypeable" custom $
+ List [App "InstDecl" (List [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 "BDecls" (List [List []])]))])])]])]
+-- GENERATED STOP
+
+
+custom (_,d) [InstDecl x1 _ x3 _ x5] = [InstDecl x1 x2 x3 x4 x5]
+ where
+ vars = dataDeclVars d
+ dd = (if null vars then id else TyParen) $ tyApps (tyCon $ dataDeclName d) (map tyVar vars)
+ x2 = concatMap f vars ++ [ClassA (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]]
+ x4 = [dd, tyVar "to"]
+ f v = [ClassA (qname "Typeable") [tyVar v], ClassA (qname "PlateAll") [tyVar v, tyVar "to"]]
diff --git a/Data/Derive/Update.hs b/Data/Derive/Update.hs
--- a/Data/Derive/Update.hs
+++ b/Data/Derive/Update.hs
@@ -31,7 +31,7 @@
makeUpdate :: Derivation
-makeUpdate = Derivation "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d
+makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d
makeUpdateField :: DataDecl -> String -> [Decl]
diff --git a/Data/DeriveDSL.hs b/Data/DeriveDSL.hs
--- a/Data/DeriveDSL.hs
+++ b/Data/DeriveDSL.hs
@@ -7,7 +7,6 @@
import Data.Derive.DSL.HSE
import Data.Derive.DSL.SYB
import Data.Maybe
-import Data.Generics.PlateData
deriveDSL :: [Decl] -> Maybe DSL
diff --git a/Data/DeriveTH.hs b/Data/DeriveTH.hs
--- a/Data/DeriveTH.hs
+++ b/Data/DeriveTH.hs
@@ -12,7 +12,7 @@
import Data.Derive.All
import Data.Derive.Internal.Derivation
-import Language.Haskell.TH.All as TH hiding (Derivation,toName)
+import Language.Haskell.TH.All as TH hiding (Derivation(..),toName)
import Language.Haskell as HS
import Language.Haskell.Convert
@@ -35,7 +35,8 @@
deriveFromDec :: Derivation -> Dec -> Q [Dec]
deriveFromDec d x = do
x <- liftM normData $ expandData x
- case derivationOp d $ toFullDataDecl x of
+ let unsup x = error $ "Derivation of " ++ derivationName d ++ " does not yet support Template Haskell, requires info for " ++ x
+ case derivationOp d (tyCon $ derivationName d) unsup $ toFullDataDecl x of
Left y -> runIO (putStrLn $ "Warning, couldn't derive: " ++ y) >> return []
Right v -> return $ convert v
diff --git a/Derive/Derivation.hs b/Derive/Derivation.hs
--- a/Derive/Derivation.hs
+++ b/Derive/Derivation.hs
@@ -4,60 +4,80 @@
import System.IO
import System.IO.Unsafe
import Language.Haskell
+import Control.Arrow
import Control.Monad
+import Data.Maybe
import Data.List
import Derive.Utils
import Derive.Flags
import Data.Derive.All
import Data.Derive.Internal.Derivation
+import qualified Data.Map as Map
---------------------------------------------------------------------
-- WHAT DO YOU WANT TO DERIVE
-wantDerive :: [Flag] -> (String, Module) -> [(String, DataDecl)]
-wantDerive flag (str,modu) = nub $ wantDeriveFlag flag decls ++ wantDeriveAnnotation str decls
- where decls = filter isDataDecl $ moduleDecls modu
+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] -> [(String, DataDecl)]
-wantDeriveFlag flags decls = [(x, d) | Derive xs <- flags, x <- xs, d <- decls]
+wantDeriveFlag :: [Flag] -> [DataDecl] -> [Type]
+wantDeriveFlag flags decls = [TyApp (tyCon x) d | Derive xs <- flags, x <- xs, d <- declst]
+ where declst = [tyApps (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d) | d <- decls]
+wantDeriveAnnotation :: Module -> Module -> [Type]
+wantDeriveAnnotation real mine = moduleDerives mine \\ moduleDerives real
--- find annotations by looking for {-! !-} parts, and matching up the source loc
-wantDeriveAnnotation :: String -> [DataDecl] -> [(String, DataDecl)]
-wantDeriveAnnotation src decls = [(d, decl) | (pos, ds) <- annotations, let decl = match pos, d <- ds]
+
+moduleDerives :: Module -> [Type]
+moduleDerives = concatMap f . moduleDecls
where
- annotations :: [((Int,Int), [String])]
- annotations = [((i,j),parse xs) | (i,s) <- zip [1..] $ lines src, (j,'{':'-':'!':xs) <- zip [1..] $ tails s]
-
- parse :: String -> [String]
- parse = words . reps ',' ' ' . closeComment
+ 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 _ = []
- closeComment ('!':'-':'}':xs) = ""
- closeComment ('-':'}':xs) = ""
- closeComment (x:xs) = x : closeComment xs
- closeComment [] = ""
-
- match :: (Int,Int) -> DataDecl
- match p = head [d | d <- reverse decls, let sl = dataDeclSrcLoc d, (srcLine sl, srcColumn sl) < p]
+ g name vars deriv = [TyCon a `tyApps` (b:bs) | (a,bs) <- deriv]
+ where b = TyCon (UnQual name) `tyApps` map (tyVar . prettyPrint) vars
---------------------------------------------------------------------
-- ACTUALLY DERIVE IT
-performDerive :: ModuleName -> [(String, DataDecl)] -> [String]
+performDerive :: Module -> [Type] -> [String]
performDerive modu = concatMap ((:) "" . f)
where
- f (name,dat) =
- case d (modu,dat) of
+ grab = getDecl modu
+
+ f ty = case d ty grab (moduleName modu, grab typ1Name) of
Left x -> unsafePerformIO $ let res = msg x in hPutStrLn stderr res >> return ["-- " ++ res]
Right x -> concatMap (lines . prettyPrint) x
- where d = head $ [op | Derivation n op <- derivations, n == name] ++
- error (msg "Unknown derivation")
- msg x = "Deriving " ++ name ++ " for " ++ dataDeclName dat ++ ": " ++ x
+ where
+ d = derivationOp $ getDerivation clsName
+ (cls,typ1:_) = fromTyApps ty
+ clsName = prettyPrint cls
+ typ1Name = tyRoot typ1
+ msg x = "Deriving " ++ prettyPrint ty ++ ": " ++ x
+getDecl :: Module -> (String -> Decl)
+getDecl modu = \name -> Map.findWithDefault (error $ "Can't find data type definition for: " ++ name) name mp
+ where
+ mp = Map.fromList $ concatMap f $ moduleDecls modu
+ f x@(DataDecl _ _ _ name _ _ _) = [(prettyPrint name, x)]
+ f x@(GDataDecl _ _ _ name _ _ _ _) = [(prettyPrint name, x)]
+ f x@(TypeDecl _ name _ _) = [(prettyPrint name, x)]
+ f _ = []
+
+
+getDerivation :: String -> Derivation
+getDerivation = \name -> Map.findWithDefault (error $ "Don't know how to derive type class: " ++ name) name mp
+ where
+ mp = Map.fromList $ map (derivationName &&& id) derivations
+
+
---------------------------------------------------------------------
-- WRITE IT BACK
@@ -81,302 +101,3 @@
when (not append && null output) $
putStr $ unlines xs
-
-
-
-{-
-
-
-
-
-
-
-
-
-import System.Console.GetOpt
-import System.Environment
-import System.Directory
-import System.Exit
-import System.Cmd
-import System.FilePath
-import System.Random
-import System.IO
-import Control.Monad
-import Data.Maybe
-import Data.List
-import Data.Char
-import Data.Int
-
-
-data Flag = Version | Help | Output String | Import String | Module String | Use String
- | Append | Derive [String] | KeepTemp | NoOpts
- deriving (Eq, Show)
-
-
-options :: [OptDescr Flag]
-options =
- [ Option "v" ["version"] (NoArg Version) "show version number"
- , Option "h?" ["help"] (NoArg Help) "show help message"
- , Option "o" ["output"] (ReqArg Output "FILE") "output FILE"
- , Option "i" ["import"] (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"
- , Option "u" ["use"] (ReqArg Use "MODULE") "use additional derivations"
- , Option "m" ["module"] (ReqArg Module "MODULE") "add a module MODULE where statement"
- , Option "a" ["append"] (NoArg Append) "append the result to the file"
- , Option "d" ["derive"] (ReqArg splt "DERIVES") "things to derive for all types"
- , Option "k" ["keep"] (NoArg KeepTemp) "keep temporary file"
- , Option "n" ["no-opts"] (NoArg NoOpts) "ignore the file options"
- ]
- where
- splt = Derive . words . map (\x -> if x == ',' then ' ' else x)
-
-
-getOpts :: IO ([Flag], [String])
-getOpts = do
- args <- getArgs
- case getOpt Permute options args of
- (o,n,[] ) | Version `elem` o -> putStrLn "Derive 0.1, (C) Neil Mitchell & Stefan O'Rear 2006-2008" >> exitSuccess
- | Help `elem` o -> putStr useage >> exitSuccess
- | null n -> putStr ("no files specified\n" ++ useage) >> exitSuccess
- | otherwise -> return (o, n)
- (_,_,errs) -> hPutStr stderr (concat errs ++ useage) >> exitFailure
- where
- useage = usageInfo "Usage: derive [OPTION...] files..." options
- exitSuccess = exitWith ExitSuccess
-
-main :: IO ()
-main = do
- (flags,files) <- getOpts
- fles <- mapM pickFile files
- mapM_ (mainFile flags) (catMaybes fles)
- when (any isNothing fles) exitFailure
-
-
-pickFile :: FilePath -> IO (Maybe FilePath)
-pickFile orig = f [orig, orig <.> "hs", orig <.> "lhs"]
- where
- f [] = hPutStrLn stderr ("Error, file not found: " ++ orig) >> return Nothing
- f (x:xs) = do
- b <- doesFileExist x
- if b then return $ Just x else f xs
-
-appendMsg :: String
-appendMsg = "--------------------------------------------------------\n" ++
- "-- DERIVES GENERATED CODE\n" ++
- "-- DO NOT MODIFY BELOW THIS LINE\n" ++
- "-- CHECKSUM: "
-
-
--- delete the end of a file with the appendMsg and a correct hash
--- make sure there are at least 4 blank lines at the end
--- return True for warning
-dropAppend :: String -> (String,Bool)
-dropAppend xs = f 0 xs
- where
- f i ys | appendMsg `isPrefixOf` ys =
- if hashString (filter (/= '\r') rest) == chk
- then f i []
- else (ys ++ "\n\n\n\n", True)
- where (chk, rest) = span isDigit $ drop (length appendMsg) ys
-
- f i [] = (replicate (4 - i) '\n', False)
- f i ('\n':ys) = add '\n' (f (i+1) ys)
- f _ (y:ys) = add y (f 0 ys)
-
- add c ~(cs,b) = (c:cs,b)
-
-
--- note: need to be careful that on Windows we don't convert \n files into
--- \r\n files
-mainFile :: [Flag] -> FilePath -> IO ()
-mainFile flags file = do
- file <- canonicalizePath file
- (fileflags,pragmas,modname,datas,reqs) <- parseFile flags file
- let devs = ["'\\n': $( _derive_string_instance make" ++ cls ++ " ''" ++ ctor ++ " )"
- | (ctor,cls) <- reqs]
-
- let hscode x = "{ -# OPTIONS_GHC -fth -fglasgow-exts -w #- }\n" ++
- unlines pragmas ++
- "module " ++ modname ++ " where\n" ++
- "import Data.DeriveTH\n" ++
- "import Data.Derive.All\n" ++
- concat [ "import " ++ x ++ "\n" | Use x <- flags ] ++
- datas ++ "\n" ++
- "main = Prelude.writeFile " ++ show x ++ " $\n" ++
- " Prelude.unlines [" ++ concat (intersperse ", " devs) ++ "]\n"
-
- -- note: Wrong on Hugs on Windows
- tmpdir <- getTemporaryDirectory
- b <- doesDirectoryExist tmpdir
- tmpdr <- return $ if b && KeepTemp `notElem` flags then tmpdir else ""
-
- (hsfile, hshndl) <- openTempFileLocal tmpdr "Temp.hs"
- (txfile, txhndl) <- openTempFileLocal tmpdr "Temp.txt"
- hClose txhndl
-
- hPutStr hshndl $ hscode txfile
- hClose hshndl
-
- let incdir = dropTrailingPathSeparator $ joinPath $ reverse $
- drop (1 + length (filter (== '.') modname)) $ reverse $ splitPath file
- cmd = "ghc -w -i. -i\"" ++ incdir ++ "\" -e " ++ modname ++ ".main " ++ hsfile
- code <- system cmd
- when (code /= ExitSuccess) $ do
- putStrLn "Failed to generate the code"
- exitWith code
-
- res <- readFile' txfile
- when (KeepTemp `notElem` flags) $ do
- removeFile hsfile
- removeFile txfile
-
- flgs <- return $ fileflags ++ flags
- if Append `elem` flgs then do
- src <- readFileBinary file
- let (src2,c) = dropAppend src
- ans = (if '\r' `elem` src then windowsNewLine else id)
- (src2 ++ if null res then "" else appendMsg ++ hashString res ++ "\n" ++ res)
- when c $ putStrLn "Warning, Checksum does not match, please edit the file manually"
- writeFileBinary file ans
- else do
- let modline = concat $ take 1 ["module " ++ x ++ " where\n" | Module x <- flgs]
- impline = unlines ["import " ++ if null i then modname else i | Import i <- flgs]
- answer = modline ++ impline ++ res
-
- case [x | Output x <- flgs] of
- [] -> putStr answer
- (x:_) -> writeFile x answer
-
-
--- return the flags, a string that is the data structures only (including Typeable, Data)
--- and a set of derivation names with types
-
--- first disguard blank lines and lines which are -- comments
--- next find all lines which start a section, i.e. have something in column 0
--- group lines so every line starts at column 1
--- look for newtype, data etc.
--- look for deriving
-parseFile :: [Flag] -> FilePath -> IO ([Flag], [String], String, String, [(String,String)])
-parseFile flags file = do
- src <- liftM lines $ readFile file
- optns <- if NoOpts `elem` flags then return [] else parseOptions src
- pragmas <- return $ parsePragmas src
- modname <- parseModname src
- let deriv = concat [x | Derive x <- flags ++ optns]
- (decl,req) <- return $ unzip $ concatMap (checkData deriv) $ joinLines $
- map dropComments $ filter (not . isBlank) src
- return (optns, pragmas, modname, unlines decl, concat req)
- where
- parsePragmas (x:xs)
- | "{ -#" `isPrefixOf` x2 && "#- }" `isSuffixOf` x2 = x2 : parsePragmas xs
- | null x2 = parsePragmas xs
- where x2 = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace x
- parsePragmas _ = []
-
- parseOptions (x:xs)
- | "{ -# OPTIONS_DERIVE " `isPrefixOf` x = do
- a <- readOptions $ takeWhile (/= '#') $ drop 19 x
- b <- parseOptions xs
- return $ a ++ b
- | "{ -# OPTIONS" `isPrefixOf` x = parseOptions xs
- parseOptions _ = return []
-
- readOptions x = case getOpt Permute options (words x) of
- (a,_,ns) -> mapM_ putStr ns >> return a
-
-
- parseModname (x:_) | "module " `isPrefixOf` x = return $ takeWhile f $ dropWhile isSpace $ drop 6 x
- where f y = not (isSpace y) && y `notElem` "("
- parseModname (_:ys) = parseModname ys
- parseModname [] = putStrLn "Error, module name not detected" >> return "Main"
-
-
- isBlank x = null x2 || "--" `isPrefixOf` x2
- where x2 = dropWhile isSpace x
-
- dropComments ('-':'-':_) = []
- dropComments (x:xs) = x : dropComments xs
- dropComments [] = []
-
- joinLines (x1:x2:xs) | col1 x1 && not (col1 x2) = joinLines ((x1 ++ x2) : xs)
- where col1 = null . takeWhile isSpace
- joinLines (x:xs) = x : joinLines xs
- joinLines [] = []
-
- checkData extra x
- | keyword `elem` ["data","newtype"] = [(x, map ((,) name) req)]
- | keyword `elem` ["type","import"] = [(x,[])]
- | otherwise = []
- where
- keyword = takeWhile (not . isSpace) x
- name = parseName $ drop (length keyword) x
- req = nub $ extra ++ parseDeriving x
-
-
- -- which derivings have been requested
- -- find all things inside { -! !- } and 'words' them
- parseDeriving :: String -> [String]
- parseDeriving x = words $ f False x
- where
- f _ ('{':'-':'!':xs) = ' ' : f True xs
- f _ ('!':'-':'}':xs) = ' ' : f False xs
- f b (y:ys) = [if y == ',' then ' ' else y | b] ++ f b ys
- f _ [] = []
-
-
- -- if there is a =>, its just after that
- -- if there isn't, then its right now
- -- if the => is after =, then ignore
- parseName x = if "=>" `isPrefixOf` b
- then parseName (drop 2 b)
- else head (words a)
- where (a,b) = break (== '=') x
-
-
-hashString :: String -> String
-hashString = show . abs . foldl f 0 . filter (not . isSpace)
- where
- f :: Int32 -> Char -> Int32
- f x y = x * 31 + fromIntegral (ord y)
-
-
--- Note: openTempFile is not available on Hugs, which sucks
-openTempFileLocal :: FilePath -> String -> IO (FilePath, Handle)
-openTempFileLocal dir template = do
- i <- randomRIO (1000::Int,9999)
- let (file,ext) = splitExtension template
- s = dir (file ++ show i) <.> ext
- b <- doesFileExist s
- if b then openTempFileLocal dir template else do
- h <- openFile s ReadWriteMode
- return (s, h)
-
-
-readFile' :: FilePath -> IO String
-readFile' file = do
- h <- openFile file ReadMode
- res <- hGetContents h
- length res `seq` return ()
- hClose h
- return res
-
-
-readFileBinary :: FilePath -> IO String
-readFileBinary file = do
- h <- openBinaryFile file ReadMode
- hGetContents h
-
-
-writeFileBinary :: FilePath -> String -> IO ()
-writeFileBinary file s = do
- h <- openBinaryFile file WriteMode
- hPutStr h s
- hClose h
-
-
-windowsNewLine :: String -> String
-windowsNewLine ('\r':'\n':xs) = '\r':'\n': windowsNewLine xs
-windowsNewLine ('\n':xs) = '\r':'\n': windowsNewLine xs
-windowsNewLine (x:xs) = x : windowsNewLine xs
-windowsNewLine [] = []
-
--}
diff --git a/Derive/Generate.hs b/Derive/Generate.hs
--- a/Derive/Generate.hs
+++ b/Derive/Generate.hs
@@ -12,13 +12,13 @@
import Data.List
-evil = words $ "PlateDirect TTypeable Uniplate"
+evil = words $ "TTypeable Uniplate"
-- generate extra information for each derivation
generate :: IO ()
generate = do
xs <- getDirectoryContents "Data/Derive"
- xs <- return [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]
+ xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]
lis <- mapM generateFile $ map ("Data/Derive" ) xs
let names = map dropExtension xs
n = maximum $ map length names
diff --git a/Derive/Test.hs b/Derive/Test.hs
--- a/Derive/Test.hs
+++ b/Derive/Test.hs
@@ -18,7 +18,17 @@
import Data.Derive.Internal.Derivation
+-- These overlap with other derivations
+overlap = ["BinaryDefer","EnumCyclic","LazySet","DataAbstract"]
+-- REASONS:
+-- UniplateDirect: Doesn't work through Template Haskell
+exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial"]
+
+-- These must be first and in every set
+priority = ["Eq","Typeable"]
+
+
listType :: Decl
listType = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]
[QualConDecl sl [] [] (ConDecl (Ident "[]") [])
@@ -39,10 +49,19 @@
-- check the $(derive) bits
putStrLn "Type checking examples"
- let name = "AutoGenerated_Test.hs"
- srcs <- sequence [readSrc $ "Data/Derive" derivationName d <.> "hs" | d <- derivations]
- writeFile name $ unlines $ autoTest srcs decls derivations
- res <- system $ "runhaskell " ++ name
+ let name = "AutoGenerated_Test"
+ devs <- sequence [ liftM ((,) d) $ readSrc $ "Data/Derive" derivationName d <.> "hs"
+ | d <- derivations, derivationName d `notElem` exclude]
+
+ let within xs = flip elem xs . derivationName . fst
+ (pri,norm) = partition (within priority) devs
+ (dev2,dev1) = partition (within overlap) norm
+
+ autoTest (name++"1") decls $ pri ++ dev1
+ autoTest (name++"2") decls $ pri ++ dev2
+ writeFile (name++".hs") $ unlines
+ ["import "++name++"1","import "++name++"2","main = putStrLn \"Type checking successful\""]
+ res <- system $ "runhaskell " ++ name ++ ".hs"
when (res /= ExitSuccess) $ error "Failed to typecheck results"
@@ -51,8 +70,9 @@
putStrLn $ "Testing " ++ name
src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"
forM_ (srcTest src) $ \(typ,res) -> do
- let t = fromMaybe (error $ "wanting type: " ++ typ) $ lookup typ types
- let Right r = op (ModuleName "Example", t)
+ let d = if tyRoot typ /= name then tyRoot typ else tyRoot $ head $ snd $ fromTyApps $ fromTyParen typ
+ let grab x = fromMaybe (error $ "Error in tests, couldn't resolve type: " ++ x) $ lookup x types
+ let Right r = op typ grab (ModuleName "Example", grab d)
when (not $ r `outEq` res) $
error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r
@@ -63,29 +83,20 @@
where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)
-ignore = ["ArbitraryOld","Serial","BinaryDefer","EnumCyclic","Ref","PlateTypeable","LazySet"]
-
-autoTest :: [Src] -> [DataDecl] -> [Derivation] -> [String]
-autoTest ss ts ds =
- ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses #-}"
- ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields #-}"
- ,"import Data.DeriveTH"
- ,"import Derive.TestInstances()"] ++
- [prettyPrint i | s <- ss2, i <- srcImportStd s] ++
- ["main :: IO ()"
- ,"main = putStrLn \"Type checking successful\""] ++
- [prettyPrint t | t <- ts2] ++
- ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | d <- ds2]
+autoTest :: String -> [DataDecl] -> [(Derivation,Src)] -> IO ()
+autoTest name ts ds =
+ writeFile (name++".hs") $ unlines $
+ ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses,TypeOperators #-}"
+ ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}"
+ ,"module " ++ name ++ " where"
+ ,"import Prelude"
+ ,"import Data.DeriveTH"
+ ,"import Derive.TestInstances()"] ++
+ [prettyPrint i | (_,s) <- ds, i <- srcImportStd s] ++
+ [prettyPrint t | t <- ts2] ++
+ ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | (d,_) <- ds]
where
types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]"
ts2 = filter (not . isBuiltIn) ts
- ds2 = filter (flip notElem ignore . derivationName) $ order ds
- ss2 = filter (flip notElem ignore . srcName) ss
isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]
-
-
-
-order :: [Derivation] -> [Derivation]
-order ds = yes ++ no
- where (yes,no) = partition (flip elem ["Eq","Typeable"] . derivationName) ds
diff --git a/Derive/Utils.hs b/Derive/Utils.hs
--- a/Derive/Utils.hs
+++ b/Derive/Utils.hs
@@ -16,7 +16,7 @@
{srcName :: String
,srcImport :: [ImportDecl]
,srcExample :: Maybe [Decl]
- ,srcTest :: [(String,[Decl])]
+ ,srcTest :: [(Type,[Decl])]
,srcCustom :: Bool
}
@@ -37,12 +37,12 @@
return $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src
-data Pragma = Example Bool | Test String
+data Pragma = Example Bool | Test Type
asPragma :: Decl -> Maybe Pragma
asPragma (TypeSig _ [x] t)
| x ~= "example" = Just $ Example $ prettyPrint t == "Custom"
- | x ~= "test" = Just $ Test $ prettyPrint t
+ | x ~= "test" = Just $ Test t
asPragma _ = Nothing
diff --git a/Language/Haskell.hs b/Language/Haskell.hs
--- a/Language/Haskell.hs
+++ b/Language/Haskell.hs
@@ -3,7 +3,7 @@
import Language.Haskell.Exts hiding (var,app,binds,paren)
import Data.List
-import Data.Generics.PlateData
+import Data.Generics.Uniplate.Data
import Data.Data
import Data.Char
@@ -22,9 +22,32 @@
tyApps x [] = x
tyApps x (y:ys) = tyApps (TyApp x y) ys
+
+fromTyApps (TyTuple _ xs) = (tyCon $ "(" ++ replicate (length xs - 1) ',' ++ ")", xs)
+fromTyApps (TyApp x y) = let (a,b) = fromTyApps x in (a, b ++ [y])
+fromTyApps (TyList x) = (TyCon $ Special ListCon, [x])
+fromTyApps x = (x, [])
+
+fromTyTuple (TyTuple _ xs) = xs
+fromTyTuple x = [x]
+
+fromTyParen (TyParen x) = fromTyParen x
+fromTyParen x = x
+
+fromTyParens = transform fromTyParen
+
+tyRoot = prettyPrint . fst . fromTyApps . fromTyParen
+
isTyFun TyFun{} = True
isTyFun _ = False
+isTyParen TyParen{} = True ; isTyParen _ = False
+
+fromTyList (TyList x) = Just x
+fromTyList (TyApp (TyCon (Special ListCon)) x) = Just x
+fromTyList x = Nothing
+
+
x ~= y = prettyPrint x == y
@@ -38,6 +61,7 @@
fExp (App op (List xs))
| op ~= "length" = Lit $ Int $ fromIntegral $ 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
@@ -77,28 +101,31 @@
fExp (App (Paren (Lambda _ [PVar x] y)) z) | once x2 y = fExp $ subst x2 z y
where x2 = Var $ UnQual x
fExp (App (Paren (Lambda _ [PWildCard] x)) _) = x
+ fExp (Lambda s ps x) = Lambda s (minPat x ps) x
+ fExp (Con x) = Con $ rename x
fExp x = x
- fTyp (TyApp x y) | x ~= "[]" = TyApp (TyCon (Special ListCon)) y
- fTyp (TyParen x@(TyApp (TyCon (Special ListCon)) _)) = 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 x = x
fPat (PParen x@(PApp _ [])) = x
- fPat (PApp nam xs) = PApp (rename nam) xs
+ fPat (PParen (PParen x)) = PParen x
+ fPat (PApp nam xs) = case rename nam of
+ Special (TupleCon Boxed _) -> PTuple xs
+ nam -> PApp nam xs
+ fPat (PParen (PTuple xs)) = PTuple 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 (UnGuardedAlt y) (BDecls [])])) 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 (transformBi f c) d e) bind
- where
- known = nub [x | UnQual x <- universeBi o]
- f (PVar x) | x `notElem` known = PWildCard
- f x = x
+ fMatch o@(Match a b c d e bind) = fBinds (Match a b (minPat o c) d e) bind
fDecl (PatBind a b c d bind) = fBinds (PatBind a b c d) bind
fDecl (FunBind xs) = FunBind $ filter (not . isGuardFalse) xs
@@ -122,11 +149,22 @@
subst from to = transformBi $ \x -> if x == from then to else x
once x y = length (filter (== x) (universeBi y)) <= 1
+ minPat o ps = transformBi f ps
+ where
+ known = nub [x | UnQual x <- universeBi o]
+ f (PVar x) | x `notElem` known = PWildCard
+ f (PAsPat x y) | x `notElem` known = y
+ f x = x
+
+
+
isGuardFalse (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) = x ~= "False"
isGuardFalse _ = False
-rename (UnQual (Ident ('(':xs))) | head xs `notElem` ",)" = UnQual $ Symbol $ init xs
+rename (UnQual (Ident ('(':xs@(x:_))))
+ | x == ',' = Special $ TupleCon Boxed $ length xs
+ | x /= ')' = UnQual $ Symbol $ init xs
rename x = x
@@ -179,9 +217,6 @@
showDecls x = unlines $ map prettyPrint x
-unParseOk (ParseOk x) = x
-
-
tyApp x [] = x
tyApp x xs = TyApp (tyApp x $ init xs) (last xs)
@@ -246,3 +281,9 @@
ctorDeclArity :: CtorDecl -> Int
ctorDeclArity = length . ctorDeclFields
+
+declName :: Decl -> String
+declName (DataDecl _ _ _ name _ _ _) = prettyPrint name
+declName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name
+declName (TypeDecl _ name _ _) = prettyPrint name
+
diff --git a/Language/Haskell/Convert.hs b/Language/Haskell/Convert.hs
--- a/Language/Haskell/Convert.hs
+++ b/Language/Haskell/Convert.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
module Language.Haskell.Convert(Convert, convert) where
@@ -206,3 +206,30 @@
instance Convert HS.GuardedAlt (TH.Guard, TH.Exp) where
conv (GuardedAlt _ x y) = (PatG (c x), c y)
+
+
+#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.Kind HS.Kind where
+ conv StarK = KindStar
+ conv (ArrowK x y) = KindFn (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.TyVarBind TH.TyVarBndr where
+ conv (UnkindedVar x) = PlainTV $ c x
+ conv (KindedVar x y) = KindedTV (c x) $ c y
+
+instance Convert HS.Kind TH.Kind where
+ conv KindStar = StarK
+ conv (KindFn x y) = ArrowK (c x) $ c y
+#endif
diff --git a/Language/Haskell/TH/Compat.hs b/Language/Haskell/TH/Compat.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/Compat.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP #-}
+
+-- | Compatibility definitions to paper over differences between 6.10 and 6.12.
+module Language.Haskell.TH.Compat where
+
+import Language.Haskell.TH
+
+
+#if __GLASGOW_HASKELL__ >= 612
+fromTyVar :: TyVarBndr -> Name
+fromTyVar (PlainTV v) = v
+fromTyVar (KindedTV v _) = v
+#else
+fromTyVar :: Name -> Name
+fromTyVar v = v
+#endif
+
+
+dataDefinitionTypeArgs :: Dec -> [Name]
+#if __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
+
+
+#if __GLASGOW_HASKELL__ >= 612
+typeToPred :: Type -> Pred
+typeToPred (ConT v) = ClassP v []
+typeToPred (AppT x y) = ClassP v (t++[y])
+ where ClassP v t = typeToPred x
+#else
+typeToPred :: Type -> Type
+typeToPred x = x
+#endif
diff --git a/Language/Haskell/TH/Data.hs b/Language/Haskell/TH/Data.hs
--- a/Language/Haskell/TH/Data.hs
+++ b/Language/Haskell/TH/Data.hs
@@ -1,3 +1,4 @@
+
-- | The core module of the Data.Derive system. This module contains
-- the data types used for communication between the extractors and
-- the derivors.
@@ -8,6 +9,7 @@
import Data.Generics
import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Compat
import Language.Haskell.TH.SYB
@@ -30,9 +32,9 @@
dataArity (NewtypeD _ _ xs _ _) = length xs
dataArgs :: DataDef -> [Name]
-dataArgs (DataD _cx name args cons _derv) = args
-dataArgs (NewtypeD cx name args con derv) = args
+dataArgs = dataDefinitionTypeArgs
+
dataCtors :: DataDef -> [CtorDef]
dataCtors (DataD _ _ _ xs _) = xs
dataCtors (NewtypeD _ _ _ x _) = [x]
@@ -115,5 +117,5 @@
isTupleT (TupleT _) = True
isTupleT (ConT x) = head sx == '(' && last sx == ')' &&
all (== ',') (take (length sx - 2) (tail sx))
- where sx = show x
+ where sx = nameBase x
isTupleT _ = False
diff --git a/Language/Haskell/TH/ExpandSynonym.hs b/Language/Haskell/TH/ExpandSynonym.hs
--- a/Language/Haskell/TH/ExpandSynonym.hs
+++ b/Language/Haskell/TH/ExpandSynonym.hs
@@ -6,6 +6,7 @@
module Language.Haskell.TH.ExpandSynonym (expandData) where
import Language.Haskell.TH
+import Language.Haskell.TH.Compat
import Language.Haskell.TH.Data
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.SYB
@@ -33,7 +34,7 @@
info <- reify name
case info of
TyConI (TySynD _ synArgs t) | length args >= length synArgs
- -> return $ Just (substitute synArgs argsInst t, argsMore) -- instantiate type synonym
+ -> return $ Just (substitute (map fromTyVar synArgs) argsInst t, argsMore) -- instantiate type synonym
where (argsInst,argsMore) = splitAt (length synArgs) args
_ -> return Nothing
-- `recover` return Nothing
@@ -41,7 +42,7 @@
-- Substitute names for types in a type
substitute :: [Name] -> [Type] -> Type -> Type
substitute ns ts = subst (zip ns ts)
- where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` ns) . fst) s) t)
+ where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` (map fromTyVar ns)) . fst) s) t)
subst s (VarT n)
| Just t' <- lookup n s = t'
subst s (AppT a b) = AppT (subst s a) (subst s b)
diff --git a/Language/Haskell/TH/FixedPpr.hs b/Language/Haskell/TH/FixedPpr.hs
--- a/Language/Haskell/TH/FixedPpr.hs
+++ b/Language/Haskell/TH/FixedPpr.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell, CPP #-}
-- TH.Ppr contains a prettyprinter for the
-- Template Haskell datatypes
@@ -9,6 +10,7 @@
import Text.PrettyPrint.HughesPJ (render)
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Data(isTupleT)
import Data.Char ( toLower, isAlpha )
nestDepth :: Int
@@ -107,7 +109,11 @@
pprExp :: Precedence -> Exp -> Doc
pprExp _ (VarE v) = ppr v
-pprExp _ (ConE c) = ppr c
+pprExp _ (ConE c)
+ | isTupleT (ConT c) = text (nameBase c)
+ | c == '[] = text ("[]")
+ | c == '(:) = text ("(:)")
+ | otherwise = ppr c
pprExp i (LitE l) = pprLit i l
pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
<+> pprExp appPrec e2
@@ -203,8 +209,14 @@
pprPat i (LitP l) = pprLit i l
pprPat _ (VarP v) = ppr v
pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps
-pprPat i (ConP s ps) = parensIf (i > noPrec) $ ppr s
+pprPat i (ConP s ps) = parensIf (i > noPrec) $ x
<+> sep (map (pprPat appPrec) ps)
+ where
+ x | isTupleT (ConT s) = text (nameBase s)
+ | s == '[] = text "[]"
+ | s == '(:) = text "(:)"
+ | otherwise = ppr s
+
pprPat i (InfixP p1 n p2)
= parensIf (i > noPrec)
$ pprPat opPrec p1 <+> pprName_ False n <+> pprPat opPrec p2
@@ -237,7 +249,7 @@
$ text "deriving"
<+> parens (hsep $ punctuate comma $ map ppr decs)
where pref :: [Doc] -> [Doc]
- pref [] = [char '='] -- Can't happen in H98
+ pref [] = [] -- Can't happen in H98
pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
ppr (NewtypeD ctxt t xs c decs)
= text "newtype"
@@ -253,9 +265,21 @@
<+> ppr c <+> hsep (map ppr xs) <+> ppr fds
$$ where_clause ds
ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
- $$ where_clause ds
+ $$ where_clause (map deQualLhsHead ds)
ppr (SigD f t) = ppr f <+> text "::" <+> ppr t
ppr (ForeignD f) = ppr f
+
+deQualLhsHead :: Dec -> Dec
+deQualLhsHead (FunD n cs) = FunD (deQualName n) cs
+deQualLhsHead (ValD p b ds) = ValD (go p) b ds
+ where
+ go (VarP n) = VarP (deQualName n)
+ go (InfixP p1 n p2) = InfixP p1 (deQualName n) p2
+ go x = x
+deQualLhsHead x = x
+
+deQualName :: Name -> Name
+deQualName = mkName . nameBase
------------------------------
instance Ppr FunDep where
@@ -306,7 +330,11 @@
------------------------------
pprParendType :: Type -> Doc
pprParendType (VarT v) = ppr v
-pprParendType (ConT c) = ppr c
+pprParendType (ConT c)
+ | c == ''[] = pprParendType ListT
+ | c == ''(->) = pprParendType ArrowT
+ | isTupleT (ConT c) = pprParendType (TupleT (length (nameBase c) - 1))
+ | otherwise = ppr c
pprParendType (TupleT 0) = text "()"
pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
pprParendType ArrowT = parens (text "->")
@@ -356,3 +384,20 @@
showtextl :: Show a => a -> Doc
showtextl = text . map toLower . show
+
+
+#if __GLASGOW_HASKELL__ >= 612
+
+instance Ppr TyVarBndr where
+ ppr (PlainTV v) = ppr v
+ ppr (KindedTV v k) = parens $ ppr v <+> text "::" <+> ppr k
+
+instance Ppr Kind where
+ ppr StarK = text "*"
+ ppr (ArrowK j k) = ppr j <+> text "->" <+> ppr k
+
+instance Ppr Pred where
+ ppr (ClassP n ts) = ppr n <+> hsep (map ppr ts)
+ ppr (EqualP t u ) = ppr t <+> text "~" <+> ppr u
+
+#endif
diff --git a/Language/Haskell/TH/Helper.hs b/Language/Haskell/TH/Helper.hs
--- a/Language/Haskell/TH/Helper.hs
+++ b/Language/Haskell/TH/Helper.hs
@@ -10,6 +10,7 @@
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Data
+import Language.Haskell.TH.Compat
@@ -60,7 +61,7 @@
where
vrs = vars 't' (dataArity dat)
hed = l1 cls (lK (dataName dat) vrs)
- ctx = [l1 r v | r <- req, v <- vrs]
+ ctx = [typeToPred $ l1 r v | r <- req, v <- vrs]
-- | Build an instance of a class for a data type, using the heuristic
@@ -74,7 +75,7 @@
where
vrs = vars 't' (dataArity dat)
hed = l1 cls (lK (dataName dat) vrs)
- ctx = map (l1 cls) ctxTypes
+ ctx = map (typeToPred . l1 cls) ctxTypes
-- | Build a type signature declaration with a string name
sigN :: String -> Type -> Dec
diff --git a/Language/Haskell/TH/SYB.hs b/Language/Haskell/TH/SYB.hs
--- a/Language/Haskell/TH/SYB.hs
+++ b/Language/Haskell/TH/SYB.hs
@@ -2,11 +2,11 @@
module Language.Haskell.TH.SYB where
+#ifdef TH_SYB
import Data.Generics hiding (Fixity)
import Language.Haskell.TH.Syntax
import Data.PackedString
-#ifdef TH_SYB
instance Data PackedString where gfoldl k z x = z x
diff --git a/Main.hs b/Main.hs
--- a/Main.hs
+++ b/Main.hs
@@ -6,6 +6,7 @@
import Derive.Generate
import Derive.Test
import Derive.Flags
+import Data.List
main :: IO ()
@@ -24,8 +25,34 @@
mainFile :: [Flag] -> FilePath -> IO ()
mainFile flags file = do
src <- readFile file
- let modu = unParseOk $ parseFileContents src -- FIXME: with this file mode
+ src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src
+ let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=extension}
+ real = parse src
+ mine = parse $ uncomment src
flags <- return $ foldl addFlags flags
- [(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas modu]
- let res = performDerive (moduleName modu) $ wantDerive flags (src,modu)
- writeDerive file (moduleName modu) flags res
+ [(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine]
+ let res = performDerive mine $ wantDerive flags real mine
+ writeDerive file (moduleName mine) flags res
+
+
+uncomment :: String -> String
+uncomment ('{':'-':'!':xs) = ' ':' ':' ':uncomment xs
+uncomment ('!':'-':'}':xs) = ' ':' ':' ':uncomment xs
+uncomment (x:xs) = x:uncomment xs
+uncomment [] = []
+
+
+-- Taken from HLint, update occasionally
+extension =
+ [OverlappingInstances,UndecidableInstances,IncoherentInstances,RecursiveDo
+ ,ParallelListComp,MultiParamTypeClasses,NoMonomorphismRestriction,FunctionalDependencies
+ ,Rank2Types,RankNTypes,PolymorphicComponents,ExistentialQuantification,ScopedTypeVariables
+ ,ImplicitParams,FlexibleContexts,FlexibleInstances,EmptyDataDecls
+ ,KindSignatures,BangPatterns,TypeSynonymInstances,TemplateHaskell
+ ,ForeignFunctionInterface,Generics,NoImplicitPrelude,NamedFieldPuns,PatternGuards
+ ,GeneralizedNewtypeDeriving,ExtensibleRecords,RestrictedTypeSynonyms,HereDocuments
+ ,MagicHash,TypeFamilies,StandaloneDeriving,UnicodeSyntax,PatternSignatures,UnliftedFFITypes
+ ,LiberalTypeSynonyms,TypeOperators,RecordWildCards,RecordPuns,DisambiguateRecordFields
+ ,OverloadedStrings,GADTs,MonoPatBinds,RelaxedPolyRec,ExtendedDefaultRules,UnboxedTuples
+ ,DeriveDataTypeable,ConstrainedClassMethods,PackageImports,ImpredicativeTypes
+ ,NewQualifiedOperators,PostfixOperators,QuasiQuotes,ViewPatterns]
diff --git a/derive.cabal b/derive.cabal
--- a/derive.cabal
+++ b/derive.cabal
@@ -1,9 +1,9 @@
Cabal-Version: >= 1.6
Build-Type: Default
Name: derive
-Version: 2.0.1
+Version: 2.1.0
build-type: Simple
-Copyright: 2006-2009, Neil Mitchell
+Copyright: 2006-2010, Neil Mitchell
Maintainer: ndmitchell@gmail.com
Homepage: http://community.haskell.org/~ndm/derive/
License: BSD3
@@ -35,9 +35,9 @@
Library
Build-Depends:
- haskell-src-exts == 1.1.*, filepath, mtl,
- base == 4.*, syb, template-haskell, uniplate, containers,
- pretty, packedstring
+ haskell-src-exts == 1.3.* && >= 1.3.2, filepath, mtl,
+ base == 4.*, syb, template-haskell, uniplate == 1.3.*, containers,
+ pretty
Exposed-Modules:
Data.DeriveTH
@@ -51,12 +51,10 @@
Data.Derive.Instance.Arities
Data.Derive.Class.Arities
Data.Derive.Class.Default
- Data.Derive.Internal.Derivation
- Data.Derive.Internal.Instance
- Data.Derive.Internal.Traversal
Language.Haskell
Language.Haskell.Convert
Language.Haskell.TH.All
+ Language.Haskell.TH.Compat
Language.Haskell.TH.Data
Language.Haskell.TH.ExpandSynonym
Language.Haskell.TH.FixedPpr
@@ -71,6 +69,7 @@
Data.Derive.BinaryDefer
Data.Derive.Bounded
Data.Derive.Data
+ Data.Derive.DataAbstract
Data.Derive.Default
Data.Derive.Enum
Data.Derive.EnumCyclic
@@ -85,7 +84,6 @@
Data.Derive.Monoid
Data.Derive.NFData
Data.Derive.Ord
- Data.Derive.PlateTypeable
Data.Derive.Read
Data.Derive.Ref
Data.Derive.Serial
@@ -93,5 +91,12 @@
Data.Derive.Show
Data.Derive.Traversable
Data.Derive.Typeable
+ Data.Derive.UniplateDirect
+ Data.Derive.UniplateTypeable
Data.Derive.Update
-- GENERATED STOP
+
+ Other-Modules:
+ Data.Derive.Internal.Derivation
+ Data.Derive.Internal.Instance
+ Data.Derive.Internal.Traversal
diff --git a/derive.htm b/derive.htm
--- a/derive.htm
+++ b/derive.htm
@@ -103,12 +103,13 @@
-- GENERATED START
-->
Arbitrary - from the library QuickCheck
-ArbitraryOld - from the library QuickCheck-1.1.0.0
+ArbitraryOld - from the library QuickCheck-1.2.0.0
Arities - from the library derive
Binary - from the library binary
BinaryDefer - from the library binarydefer
Bounded - from the library base
Data - from the library base
+DataAbstract - from the library base
Default - from the library derive
Enum - from the library base
EnumCyclic - from the library base
@@ -123,7 +124,6 @@
Monoid - from the library base
NFData - from the library parallel
Ord - from the library base
-PlateTypeable - from the library uniplate
Read - from the library base
Ref
Serial - from the library smallcheck
@@ -131,6 +131,8 @@
Show - from the library base
Traversable - from the library base
Typeable - from the library base
+UniplateDirect - from the library uniplate
+UniplateTypeable - from the library uniplate
Update