diff --git a/Data/Derive/All.hs b/Data/Derive/All.hs
--- a/Data/Derive/All.hs
+++ b/Data/Derive/All.hs
@@ -23,6 +23,7 @@
import Data.Derive.Functor as D
import Data.Derive.Has as D
import Data.Derive.Is as D
+import Data.Derive.JSON as D
import Data.Derive.LazySet as D
import Data.Derive.Monoid as D
import Data.Derive.NFData as D
@@ -39,5 +40,5 @@
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,makeLazySet,makeMonoid,makeNFData,makeOrd,makeRead,makeRef,makeSerial,makeSerialize,makeSet,makeShow,makeTraversable,makeTypeable,makeUniplateDirect,makeUniplateTypeable,makeUpdate]
+derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeData,makeDataAbstract,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeJSON,makeLazySet,makeMonoid,makeNFData,makeOrd,makeRead,makeRef,makeSerial,makeSerialize,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
@@ -76,8 +76,8 @@
-- Fix the context
-- C a b => Arbitrary a, Arbitrary b
-- a -> b => CoArbitrary a, Arbitrary b
-context :: FullDataDecl -> Context
-context (_,d) = nub $ concatMap (f True . fromBangType . snd) $ concatMap ctorDeclFields $ dataDeclCtors d
+context :: FullDataDecl -> Context -> Context
+context (_,d) _ = nub $ concatMap (f True . fromBangType . 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
diff --git a/Data/Derive/DSL/Apply.hs b/Data/Derive/DSL/Apply.hs
--- a/Data/Derive/DSL/Apply.hs
+++ b/Data/Derive/DSL/Apply.hs
@@ -5,7 +5,6 @@
import Data.Derive.DSL.HSE
import Data.Derive.DSL.DSL
-import Data.Maybe
import Data.List
import Data.Generics.Uniplate.DataOnly
@@ -29,8 +28,6 @@
applyEnv :: DSL -> Env -> Output
applyEnv dsl env@(Env input ctor field fold) = f dsl
where
- vars = dataDeclVars input
-
f (Instance ctx hd body) =
OApp "InstDecl"
[out
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
@@ -9,7 +9,6 @@
import Data.Maybe
import Data.List
import Data.Function
-import Unsafe.Coerce
import Control.Monad.State
@@ -92,7 +91,6 @@
f [] = fromConstr $ readCon dat "[]"
f (x:xs) = fromConstrB (g x (f xs `asTypeOf` res)) $ readCon dat "(:)"
dat = dataTypeOf res
- typ = typeOf 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
diff --git a/Data/Derive/DSL/SYB.hs b/Data/Derive/DSL/SYB.hs
--- a/Data/Derive/DSL/SYB.hs
+++ b/Data/Derive/DSL/SYB.hs
@@ -6,7 +6,6 @@
import Data.Derive.DSL.HSE
import qualified Language.Haskell.Exts as H
import Data.Derive.DSL.DSL
-import Control.Monad
import Control.Monad.State hiding (lift)
import Data.Generics
import Data.Maybe
@@ -60,10 +59,6 @@
case syb x of
Nothing -> do put (False,xs) ; return undefined
Just y -> do put (b,xs) ; return y
-
-
-derr :: Data a => DSL -> Maybe a
-derr x = error $ "Couldn't dslSYB on: " ++ show x
dsimple :: Data a => DSL -> Maybe a
diff --git a/Data/Derive/Data.hs b/Data/Derive/Data.hs
--- a/Data/Derive/Data.hs
+++ b/Data/Derive/Data.hs
@@ -151,5 +151,5 @@
| x ~= "ctorFixity" = Con (UnQual (Ident "Prefix"))
where ctor = dataDeclCtors (snd d) !! fromInteger y
-context :: FullDataDecl -> Context
-context d = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
+context :: FullDataDecl -> Context -> Context
+context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
diff --git a/Data/Derive/DataAbstract.hs b/Data/Derive/DataAbstract.hs
--- a/Data/Derive/DataAbstract.hs
+++ b/Data/Derive/DataAbstract.hs
@@ -58,5 +58,5 @@
custom = customContext context
-context :: FullDataDecl -> Context
-context d = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
+context :: FullDataDecl -> Context -> Context
+context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
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
@@ -42,9 +42,8 @@
f x = x
-customContext :: (FullDataDecl -> Context) -> (FullDataDecl -> [Decl] -> [Decl])
+customContext :: (FullDataDecl -> Context -> Context) -> (FullDataDecl -> [Decl] -> [Decl])
customContext custom d = map f
where
- ctx = custom d
- f (InstDecl sl _ a b c) = InstDecl sl ctx a b c
+ f (InstDecl sl ctx a b c) = InstDecl sl (custom d ctx) a b c
f x = x
diff --git a/Data/Derive/JSON.hs b/Data/Derive/JSON.hs
new file mode 100644
--- /dev/null
+++ b/Data/Derive/JSON.hs
@@ -0,0 +1,165 @@
+-- |
+-- Copyright: (c) Bertram Felgenhauer 2009
+-- License: BSD3
+-- Stability: experimental
+-- Portability: portable
+--
+-- Derive 'Text.JSON' instances.
+--
+-- Unlike Text.JSON.Generics, single constructor types are /not/ handled
+-- specially. Every value is encoded as an object with a single field,
+-- with the constructor name as key and the values as its contents.
+--
+-- If the constructor is a record, the contents is an Object with the
+-- field names as keys. Otherwise, the contents is an array.
+
+module Data.Derive.JSON (makeJSON) where
+
+import qualified Language.Haskell as H
+import Language.Haskell (
+ Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, BangType, Stmt,
+ (~=), var, pVar, con, strE, strP, apps, qname, sl,
+ ctorDeclFields, ctorDeclName, dataDeclCtors)
+
+{-
+import "json" Text.JSON
+import Text.JSON.Types
+
+example :: Custom
+instance JSON a => JSON (Sample a) where
+ readJSON (JSObject x) = $(readJSON)
+ readJSON _ = Error "..."
+ showJSON (First) = $(showJSON 0)
+ showJSON (Second x1 x2) = $(showJSON 1)
+ showJSON (Third x1) = $(showJSON 2)
+-}
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeJSON :: Derivation
+makeJSON = derivationCustomDSL "JSON" custom $
+ List [Instance ["JSON"] "JSON" (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 "BDecls" (
+ List [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 "BDecls"
+ (List [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 "BDecls" (List [List []])]))])])])]
+-- GENERATED STOP
+
+-- ^ 'Derivation' for 'JSON'
+
+custom :: FullDataDecl -> [Decl] -> [Decl]
+custom = customSplice splice
+
+splice :: FullDataDecl -> Exp -> Exp
+splice d x | x ~= "readJSON" = mkRead d
+splice d (H.App x (H.Lit (H.Int y))) | x~= "showJSON" = mkShow d y
+splice _ e = error $ "makeJSON: unrecognized splice: " ++ show e
+
+------------------------------------------------------------------------------
+-- showJSON
+
+mkShow :: FullDataDecl -> Integer -> Exp
+mkShow d y = let
+ hasFields = any (not . null . fst) (ctorDeclFields c)
+ c = dataDeclCtors (snd d) !! fromInteger y
+ mkFields = if hasFields then mkShowRecordFields else mkShowPlainFields
+ in
+ mkJSObject $ H.List
+ [H.Tuple [strE (ctorDeclName c), mkFields (ctorDeclFields c)]]
+
+mkShowPlainFields :: FieldDecl -> Exp
+mkShowPlainFields fs = mkJSArray $ H.List
+ [var "showJSON" `H.App` xi | xi <- vars "x" fs]
+
+mkShowRecordFields :: FieldDecl -> Exp
+mkShowRecordFields fs = mkJSObject $ H.List
+ [ H.Tuple [strE fn, var "showJSON" `H.App` xi]
+ | ((fn, _), xi) <- zip fs (vars "x" fs)]
+
+------------------------------------------------------------------------------
+-- readJSON
+
+mkRead :: FullDataDecl -> Exp
+mkRead (_, d) = let
+ readError = con "Error" `H.App` strE "malformed JSON for type ...: ..."
+ in
+ H.Case (var "fromJSObject" `H.App` var "x") $
+ map mkReadCtor (dataDeclCtors d) ++
+ [H.Alt H.sl H.PWildCard (H.UnGuardedAlt readError) (H.BDecls [])]
+
+mkReadCtor :: CtorDecl -> Alt
+mkReadCtor c = let
+ cn = ctorDeclName c
+ fs = ctorDeclFields c
+ hasFields = any (not . null . fst) fs
+ body | hasFields = mkReadRecord cn fs
+ | otherwise = mkReadPlain cn fs
+ in
+ H.Alt sl (H.PList [H.PTuple [strP cn, pVar "y"]])
+ (H.UnGuardedAlt body) (H.BDecls [])
+
+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") Nothing
+ (H.UnGuardedRhs $ var "fromJSObject" `H.App` var "z")
+ (H.BDecls [])]] ++
+ zipWith (mkReadRecordField cn) (pVars "x" fs) fs ++
+ mkReadTrailer cn fs
+
+mkReadRecordField :: String -> Pat -> (String, BangType) -> Stmt
+mkReadRecordField cn xi (fn, _) = H.Generator sl xi $
+ apps (var "maybe") [
+ var "fail" `H.App` 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")] ++
+ mkReadTrailer cn fs
+
+mkReadTrailer :: String -> FieldDecl -> [Stmt]
+mkReadTrailer cn fs =
+ [ H.Generator sl yi (var "readJSON" `H.App` xi)
+ | (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] ++
+ [H.Qualifier $ var "return" `H.App` apps (con cn) (vars "y" fs)]
+
+------------------------------------------------------------------------------
+-- utilites
+
+mkJSObject :: Exp -> Exp
+mkJSObject e = con "JSObject" `H.App` (var "toJSObject" `H.App` e)
+
+mkJSArray :: Exp -> Exp
+mkJSArray e = con "JSArray" `H.App` e
+
+vars :: String -> FieldDecl -> [Exp]
+vars pre fs = [var (pre ++ show i) | i <- [1..length fs]]
+
+pVars :: String -> FieldDecl -> [Pat]
+pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]]
diff --git a/Data/Derive/LazySet.hs b/Data/Derive/LazySet.hs
--- a/Data/Derive/LazySet.hs
+++ b/Data/Derive/LazySet.hs
@@ -21,7 +21,6 @@
import Language.Haskell
import Data.Derive.Internal.Derivation
-import Data.Maybe
makeLazySet :: Derivation
diff --git a/Derive/Derivation.hs b/Derive/Derivation.hs
--- a/Derive/Derivation.hs
+++ b/Derive/Derivation.hs
@@ -6,7 +6,6 @@
import Language.Haskell
import Control.Arrow
import Control.Monad
-import Data.Maybe
import Data.List
import Derive.Utils
import Derive.Flags
diff --git a/Derive/Test.hs b/Derive/Test.hs
--- a/Derive/Test.hs
+++ b/Derive/Test.hs
@@ -2,14 +2,11 @@
module Derive.Test(test) where
import Derive.Utils
-import Language.Haskell.Exts
import Data.Derive.DSL.HSE
-import Data.DeriveDSL
import Control.Monad
import Data.Maybe
import Data.List
import System.FilePath
-import System.Directory
import System.Cmd
import System.Exit
import Control.Arrow
diff --git a/Language/Haskell.hs b/Language/Haskell.hs
--- a/Language/Haskell.hs
+++ b/Language/Haskell.hs
@@ -252,6 +252,10 @@
dataDeclSrcLoc (DataDecl sl _ _ _ _ _ _) = sl
dataDeclSrcLoc (GDataDecl sl _ _ _ _ _ _ _) = sl
+dataDeclContext :: DataDecl -> Context
+dataDeclContext (DataDecl _ _ ctx _ _ _ _) = ctx
+dataDeclContext _ = error "dataDeclContext: not a DataDecl"
+
dataDeclName :: DataDecl -> String
dataDeclName (DataDecl _ _ _ name _ _ _) = prettyPrint name
dataDeclName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name
diff --git a/derive.cabal b/derive.cabal
--- a/derive.cabal
+++ b/derive.cabal
@@ -1,7 +1,7 @@
Cabal-Version: >= 1.6
Build-Type: Default
Name: derive
-Version: 2.2.0
+Version: 2.3.0
build-type: Simple
Copyright: 2006-2010, Neil Mitchell
Maintainer: ndmitchell@gmail.com
@@ -80,6 +80,7 @@
Data.Derive.Functor
Data.Derive.Has
Data.Derive.Is
+ Data.Derive.JSON
Data.Derive.LazySet
Data.Derive.Monoid
Data.Derive.NFData
diff --git a/derive.htm b/derive.htm
--- a/derive.htm
+++ b/derive.htm
@@ -72,7 +72,7 @@
Acknowledgements
- Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson, Joel Raymont, Benedikt Huber, Stefan O'Rear, Robin Green.
+ Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson, Joel Raymont, Benedikt Huber, Stefan O'Rear, Robin Green, Bertram Felgenhauer.
@@ -120,6 +120,7 @@
Functor - from the library base
Has
Is
+JSON - from the library json
LazySet
Monoid - from the library base
NFData - from the library parallel