packages feed

derive 2.2.0 → 2.3.0

raw patch · 15 files changed

+183/−27 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Data.Derive.JSON: makeJSON :: Derivation
+ Language.Haskell: dataDeclContext :: DataDecl -> Context
- Data.Derive.Internal.Derivation: customContext :: (FullDataDecl -> Context) -> (FullDataDecl -> [Decl] -> [Decl])
+ Data.Derive.Internal.Derivation: customContext :: (FullDataDecl -> Context -> Context) -> (FullDataDecl -> [Decl] -> [Decl])

Files

Data/Derive/All.hs view
@@ -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
Data/Derive/Arbitrary.hs view
@@ -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
Data/Derive/DSL/Apply.hs view
@@ -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
Data/Derive/DSL/HSE.hs view
@@ -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
Data/Derive/DSL/SYB.hs view
@@ -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
Data/Derive/Data.hs view
@@ -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"]]
Data/Derive/DataAbstract.hs view
@@ -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"]]
Data/Derive/Internal/Derivation.hs view
@@ -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
+ Data/Derive/JSON.hs view
@@ -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]]
Data/Derive/LazySet.hs view
@@ -21,7 +21,6 @@  import Language.Haskell import Data.Derive.Internal.Derivation-import Data.Maybe   makeLazySet :: Derivation
Derive/Derivation.hs view
@@ -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
Derive/Test.hs view
@@ -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
Language/Haskell.hs view
@@ -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
derive.cabal view
@@ -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
derive.htm view
@@ -72,7 +72,7 @@ <h3>Acknowledgements</h3>  <p>-    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. </p>  @@ -120,6 +120,7 @@ <li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AFunctor'>Functor</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li> <li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Has.html'>Has</a></b></li> <li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Is.html'>Is</a></b></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/json/latest/doc/html/Text-JSON.html#t%3AJSON'>JSON</a></b> - from the library <a href='http://hackage.haskell.org/package/json'>json</a></li> <li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-LazySet.html'>LazySet</a></b></li> <li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t%3AMonoid'>Monoid</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li> <li><b><a href='http://hackage.haskell.org/packages/archive/parallel/latest/doc/html/Control-Parallel-Strategies.html#t%3ANFData'>NFData</a></b> - from the library <a href='http://hackage.haskell.org/package/parallel'>parallel</a></li>