diff --git a/Data/Aeson/TH/Smart.hs b/Data/Aeson/TH/Smart.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/TH/Smart.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell, OverloadedStrings, ScopedTypeVariables #-} +-- Shamelessly copied from Bryan O'Sullivan, 2011 + +module Data.Aeson.TH.Smart + ( deriveJSON + + , deriveToJSON + , deriveFromJSON + + , mkToJSON + , mkParseJSON + ) where + +import Data.Aeson ( toJSON, Object, object, (.=), (.:?) + , ToJSON, toJSON + , FromJSON, parseJSON + ) +import Data.Aeson.Types ( Value(..), Parser ) +import Control.Applicative ( pure, (<$>), (<*>) ) +import Control.Monad ( return, mapM, liftM2, fail ) +import Data.Bool ( otherwise) +import Data.Default ( def, Default ) +import Data.Eq ( (==) ) +import Data.Function ( ($), (.), id ) +import Data.Functor ( fmap ) +import Data.List ( (++), foldl, foldl', intercalate + , length, map, zip, genericLength + ) +import Data.Maybe ( Maybe(Nothing, Just) ) +import Prelude ( String, (-), Integer, fromIntegral, not, + error, filter, fst, snd, Bool(..), flip, maybe, (>)) +import Text.Printf ( printf ) +import Text.Show ( show ) +#if __GLASGOW_HASKELL__ < 700 +import Control.Monad ( (>>=) ) +import Prelude ( fromInteger ) +#endif +import qualified Data.HashMap.Strict as H ( lookup, toList, size ) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import qualified Data.Text as T ( Text, pack, unpack ) +import qualified Data.Vector as V ( unsafeIndex, null, length, create, filter) +import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite ) + +-------------------------------------------------------------------------------- +-- Convenience +-------------------------------------------------------------------------------- + +-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given +-- data type. +-- +-- This is a convienience function which is equivalent to calling both +-- 'deriveToJSON' and 'deriveFromJSON'. +deriveJSON :: (String -> String) + -- ^ Function to change field names. + -> Bool + -- ^ Whether to require JSON instances for type variables + -> Name + -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON' + -- instances. + -> Q [Dec] +deriveJSON withField b name = + liftM2 (++) + (deriveToJSON withField b name) + (deriveFromJSON withField b name) + + +deriveToJSON :: (String -> String) + -- ^ Function to change field names. + -> Bool + -- ^ Whether to require ToJSON instances for type variables + -> Name + -- ^ Name of the type for which to generate a 'ToJSON' instance + -- declaration. + -> Q [Dec] +deriveToJSON withField b name = + withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons + where + fromCons :: [TyVarBndr] -> [Con] -> Q Dec + fromCons tvbs cons = + instanceD + (if b then return (map (\t -> ClassP ''ToJSON [VarT t]) typeNames) else return []) + (classType `appT` instanceType) + [ funD 'toJSON + [ clause [] + (normalB $ consToJSON withField cons) + [] + ] + ] + where + classType = conT ''ToJSON + typeNames = map tvbName tvbs + instanceType = foldl' appT (conT name) $ map varT typeNames + +-- | Generates a lambda expression which encodes the given data type as JSON. +-- +-- Example: +-- +-- @ +-- data Foo = Foo Int +-- @ +-- +-- @ +-- encodeFoo :: Foo -> 'Value' +-- encodeFoo = $('mkToJSON' id ''Foo) +-- @ +-- +-- This will splice in the following code: +-- +-- @ +-- \value -> case value of Foo arg1 -> 'toJSON' arg1 +-- @ +mkToJSON :: (String -> String) -- ^ Function to change field names. + -> Name -- ^ Name of the type to encode. + -> Q Exp +mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons) + +-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code +-- to generate the JSON encoding of a number of constructors. All constructors +-- must be from the same type. +consToJSON :: (String -> String) + -- ^ Function to change field names. + -> [Con] + -- ^ Constructors for which to generate JSON generating code. + -> Q Exp +consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: " + ++ "Not a single constructor given!" +-- A single constructor is directly encoded. The constructor itself may be +-- forgotten. +consToJSON withField [con] = do + value <- newName "value" + lam1E (varP value) + $ caseE (varE value) + [encodeArgs Nothing withField con] + +consToJSON withField cons = do + value <- newName "value" + lam1E (varP value) + $ caseE (varE value) + [ encodeArgs (Just $ wrap $ [|String . T.pack|] `appE` conNameExp con) withField con + | con <- cons + ] + where + wrap :: Q Exp -> [Q Exp] -> Q Exp + wrap name exps = + [e|object|] `appE` ([e| filter (not .(==Null) . snd )|] `appE` + listE (infixApp (litE $ stringL "constructor") [e|(.=)|] name : exps)) + +-- | Generates code to generate the JSON encoding of a single constructor. +encodeArgs :: Maybe ([Q Exp] -> Q Exp) -> (String -> String) -> Con -> Q Match +encodeArgs _ _ c@(NormalC conName []) = + match (conP conName []) (normalB $ [e|toJSON|] `appE` ([|T.pack|] `appE` conNameExp c)) [] +encodeArgs wrapper _ (NormalC conName ts) = do + let len = length ts + args <- mapM newName ["arg" ++ show n | n <- [1..len]] + let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of + -- Single argument is directly converted. + [e] -> e + -- Multiple arguments are converted to a JSON array. + es -> do + mv <- newName "mv" + let newMV = bindS (varP mv) + ([e|VM.unsafeNew|] `appE` + litE (integerL $ fromIntegral len)) + stmts = [noBindS $ + [e|VM.unsafeWrite|] `appE` + (varE mv) `appE` + litE (integerL ix) `appE` e | (ix, e) <- zip [(0::Integer)..] es] + ret = noBindS $ [e|return|] `appE` varE mv + fltr = [e| V.filter (not . (== Null))|] + [e|\x-> if V.length x > 0 then Array x else Null|] `appE` (fltr `appE` (varE 'V.create `appE` doE (newMV:stmts++[ret]))) + let b = case wrapper of + Nothing -> js + (Just wrapper') -> wrapper' [infixApp (litE (stringL "value")) [e|(.=)|] js] + match (conP conName $ map varP args) (normalB b) [] +-- Records. +encodeArgs withExp withField (RecC conName ts) = do + args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]] + let args' = map (([e|toJSON|] `appE`) . varE) args + let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field) [e|(.=)|] arg + | (arg, (field, _, _)) <- zip args' ts + ] + let b = case withExp of + Nothing -> [e|object|] `appE` ([e| filter (not . disposable . snd) |] `appE` listE js) + (Just wrapper) -> wrapper js + match (conP conName $ map varP args) (normalB b) [] +-- Infix constructors. +encodeArgs withExp _ (InfixC _ conName _) = do + al <- newName "argL" + ar <- newName "argR" + let l = listE [[e|toJSON|] `appE` varE a | a <- [al,ar]] + let b = case withExp of + Nothing -> [e|toJSON|] `appE` l + (Just wrapper) -> wrapper [infixApp (litE $ stringL "value") [e|(.=)|] l] + match (infixP (varP al) conName (varP ar)) (normalB b) [] +-- Existentially quantified constructors. +encodeArgs withExp withField (ForallC _ _ con) = + encodeArgs withExp withField con + +disposable Null = True +disposable (Array x) = V.null x +disposable _ = False + +-------------------------------------------------------------------------------- +-- FromJSON +-------------------------------------------------------------------------------- + +-- | Generates a 'FromJSON' instance declaration for the given data type. +-- +-- Example: +-- +-- @ +-- data Foo = Foo Char Int +-- $('deriveFromJSON' id ''Foo) +-- @ +-- +-- This will splice in the following code: +-- +-- @ +-- instance 'FromJSON' Foo where +-- 'parseJSON' = +-- \value -> case value of +-- 'Array' arr -> +-- if (V.length arr == 2) +-- then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0) +-- \<*\> 'parseJSON' (arr `V.unsafeIndex` 1) +-- else fail \"\\" +-- other -> fail \"\\" +-- @ +deriveFromJSON :: (String -> String) + -- ^ Function to change field names. + -> Bool + -- ^ Whether to require FromJSON instances for type variables + -> Name + -- ^ Name of the type for which to generate a 'FromJSON' instance + -- declaration. + -> Q [Dec] +deriveFromJSON withField b name = + withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons + where + fromCons :: [TyVarBndr] -> [Con] -> Q Dec + fromCons tvbs cons = + instanceD (if b then return (map (\t -> ClassP ''FromJSON [VarT t]) typeNames) else return []) + (classType `appT` instanceType) + [ funD 'parseJSON + [ clause [] + (normalB $ consFromJSON name withField cons) + [] + ] + ] + where + classType = conT ''FromJSON + typeNames = map tvbName tvbs + instanceType = foldl' appT (conT name) $ map varT typeNames + +-- | Generates a lambda expression which parses the JSON encoding of the given +-- data type. +-- +-- Example: +-- +-- @ +-- data Foo = Foo 'Int' +-- @ +-- +-- @ +-- parseFoo :: 'Value' -> 'Parser' Foo +-- parseFoo = $('mkParseJSON' id ''Foo) +-- @ +-- +-- This will splice in the following code: +-- +-- @ +-- \\value -> case value of arg -> Foo \<$\> 'parseJSON' arg +-- @ +mkParseJSON :: (String -> String) -- ^ Function to change field names. + -> Name -- ^ Name of the encoded type. + -> Q Exp +mkParseJSON withField name = + withType name (\_ cons -> consFromJSON name withField cons) + +-- if it's 1ary flat constrcutor, it's just the constructor name, no matter how many +-- if there's many nary constructors, we make an object with value and constructor records +-- if there's many record constructors, we add a record with the constructor value + +-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates +-- code to parse the JSON encoding of a number of constructors. All constructors +-- must be from the same type. +consFromJSON :: Name + -- ^ Name of the type to which the constructors belong. + -> (String -> String) + -- ^ Function to change field names. + -> [Con] + -- ^ Constructors for which to generate JSON parsing code. + -> Q Exp +consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: " + ++ "Not a single constructor given!" + +consFromJSON tName withField cons = do + obj <- newName "obj" + strcon <- newName "strcon" + val <- newName "val" + matcher <- newName "matcher" + mcon <- newName "mcon" + arg <- newName "arg" + lam1E (varP arg) $ doE [ + bindS (tupP [varP mcon, varP matcher]) $ caseE (varE arg) [ + flip (match (conP 'Object [varP obj])) [] $ normalB $ doE [ + bindS (varP strcon) (sigE ([e|(.:? "constructor")|] `appE` (varE obj)) [t|Parser (Maybe T.Text)|]) + , bindS (varP val) ([e|(.:? "value")|] `appE` (varE obj)) + , noBindS ([|return|] `appE` tupE [varE strcon, [|flip maybe id|] `appE` varE arg `appE` varE val])] + , match wildP (normalB $ [|return|] `appE` tupE [conE 'Nothing, varE arg]) []] + , noBindS $ caseE (varE matcher) ([parseCon tName withField c (varE mcon) False | c <- cons] ++ [noMatch tName])] + + +conEq :: ExpQ -> Name -> ExpQ +conEq str conName = infixApp str [|(==)|] ([|T.pack|] `appE` (litE $ stringL $ nameBase conName)) + +tupSeq :: (Q a, Q b) -> Q (a, b) +tupSeq (a,b) = do + a' <- a + b' <- b + return (a', b') + +conGuard :: ExpQ -> Name -> Q Guard +conGuard mcon conName = do + a <- newName "a" + normalG $ + caseE mcon [ + match (conP 'Just [varP a]) (normalB $ conEq (varE a) conName) [], + match wildP (normalB [|True|]) []] + +ignore :: a -> b -> b +ignore _ b = b + +parseCon :: Name -> (String -> String) -> Con -> ExpQ -> Bool -> Q Match +parseCon _ _ (NormalC conName []) mcon _ = do + str <- newName "str" + grd <- normalG $ conEq (varE str) conName + expr <- conE conName + match (conP 'String [varP str]) (guardedB $ [tupSeq (normalG $ conEq (varE str) conName, [|ignore|] `appE` mcon `appE` ([|return|] `appE` conE conName))]) [] +parseCon _ _ (NormalC conName [_]) mcon _ = do + arg <- newName "arg" + match (varP arg) (guardedB [tupSeq (conGuard mcon conName, + infixApp (conE conName) [e|(<$>)|] ([e|parseJSON|] `appE` varE arg))]) [] +parseCon tName _ (NormalC conName ts) mcon _ = parseProduct tName conName (genericLength ts) mcon +parseCon tName withField (RecC conName ts) mcon b = do + obj <- newName "recObj" + let (x:xs) = [do + b' <- if b then return False else isInstance ''Default [ty] + [|lookupField|] + `appE` (if b' then [| Just def |] else [| Nothing|]) + `appE` (litE $ stringL $ show tName) + `appE` (litE $ stringL $ nameBase conName) + `appE` (varE obj) + `appE` ([e|T.pack|] `appE` fieldNameExp withField field) + | (field, _, ty) <- ts] + match (conP 'Object [varP obj]) + (guardedB [tupSeq (conGuard mcon conName, foldl' (\a b -> infixApp a [|(<*>)|] b) + (infixApp (conE conName) [|(<$>)|] x) xs)]) [] +parseCon tName _ (InfixC _ conName _) mcon _ = parseProduct tName conName 2 mcon + +parseCon tName withField (ForallC _ _ con) mcon _ = parseCon tName withField con mcon True +-- parseCon tName withField (ForallC _ _ con) mcon = parseCon tName withField con mcon +-- THIS THROWS A GHC PANIC!!! + + +-- | Generates code to parse the JSON encoding of an n-ary +-- constructor. +parseProduct :: Name -- ^ Name of the type to which the constructor belongs. + -> Name -- ^ 'Con'structor name. + -> Integer -- ^ 'Con'structor arity. + -> ExpQ -- ^ Possible requirement of the constructor + -> Q Match +parseProduct tName conName numArgs mcon = do + arr <- newName "arr" + let x:xs = [[|parseJSON|] `appE` + infixApp (varE arr) [|V.unsafeIndex|] (litE $ integerL ix) + | ix <- [0 .. numArgs - 1]] + flip (match (conP 'Array [varP arr])) [] $ + guardedB [tupSeq ( + conGuard mcon conName, + condE (infixApp ([|V.length|] `appE` varE arr) [|(==)|] (litE $ integerL numArgs)) + (foldl' (\a b -> infixApp a [|(<*>)|] b) + (infixApp (conE conName) [|(<$>)|] x) xs) + (parseTypeMismatch tName conName + (litE $ stringL $ "Array of length " ++ show numArgs) + (infixApp (litE $ stringL $ "Array of length ") + [|(++)|] ([|show . V.length|] `appE` varE arr))))] + +lookupField :: (FromJSON a) => Maybe a -> String -> String -> Object -> T.Text -> Parser a +lookupField d tName rec obj key = + case H.lookup key obj of + Nothing -> case d of + Nothing -> unknownFieldFail tName rec (T.unpack key) + Just x -> return x + Just v -> parseJSON v + +-------------------------------------------------------------------------------- +-- Parsing errors +-------------------------------------------------------------------------------- + +noMatch :: Name -> MatchQ +noMatch tName = do + flip (match wildP) [] + (normalB $ [| fail |] `appE` ([| printf "No constructors for type %s were present." |] + `appE` (sigE (litE $ stringL $ nameBase tName) (conT ''String)))) + +parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ +parseTypeMismatch tName conName expected actual = + foldl appE + [|parseTypeMismatch'|] + [ litE $ stringL $ nameBase conName + , litE $ stringL $ show tName + , expected + , actual + ] + +unknownFieldFail :: String -> String -> String -> Parser fail +unknownFieldFail tName rec key = + fail $ printf "When parsing the record %s of type %s the key %s was not present." + rec tName key + +parseTypeMismatch' :: String -> String -> String -> String -> Parser fail +parseTypeMismatch' tName conName expected actual = + fail $ printf "When parsing the constructor %s of type %s expected %s but got %s." + conName tName expected actual + +-------------------------------------------------------------------------------- +-- Utility functions +-------------------------------------------------------------------------------- + +-- | Boilerplate for top level splices. +-- +-- The given 'Name' must be from a type constructor. Furthermore, the +-- type constructor must be either a data type or a newtype. Any other +-- value will result in an exception. +withType :: Name + -> ([TyVarBndr] -> [Con] -> Q a) + -- ^ Function that generates the actual code. Will be applied + -- to the type variable binders and constructors extracted + -- from the given 'Name'. + -> Q a + -- ^ Resulting value in the 'Q'uasi monad. +withType name f = do + info <- reify name + case info of + TyConI dec -> + case dec of + DataD _ _ tvbs cons _ -> f tvbs cons + NewtypeD _ _ tvbs con _ -> f tvbs [con] + other -> error $ "Data.Aeson.TH.withType: Unsupported type: " + ++ show other + _ -> error "Data.Aeson.TH.withType: I need the name of a type." + +-- | Extracts the name from a constructor. +getConName :: Con -> Name +getConName (NormalC name _) = name +getConName (RecC name _) = name +getConName (InfixC _ name _) = name +getConName (ForallC _ _ con) = getConName con + +guardConName :: Name -> Name -> Q Stmt +guardConName conName varName = noBindS (infixApp (litE $ stringL $ nameBase conName) [e|(==)|] (varE varName)) + +-- | Extracts the name from a type variable binder. +tvbName :: TyVarBndr -> Name +tvbName (PlainTV name ) = name +tvbName (KindedTV name _) = name + +-- | Makes a string literal expression from a constructor's name. +conNameExp :: Con -> Q Exp +conNameExp = litE . stringL . nameBase . getConName + +-- | Creates a string literal expression from a record field name. +fieldNameExp :: (String -> String) -- ^ Function to change the field name. + -> Name + -> Q Exp +fieldNameExp f = litE . stringL . f . nameBase + +-- | The name of the outermost 'Value' constructor. +valueConName :: Value -> String +valueConName (Object _) = "Object" +valueConName (Array _) = "Array" +valueConName (String _) = "String" +valueConName (Number _) = "Number" +valueConName (Bool _) = "Boolean" +valueConName Null = "Null" diff --git a/Data/Default/TH.hs b/Data/Default/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Default/TH.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.Default.TH (deriveDefault) where + +import Control.Applicative +import Data.Default +import Data.List +import Language.Haskell.TH + +createInstance :: Bool -> Name -> [Name] -> Name -> [Type] -> Q Dec +createInstance b typeConstructorName typeVariables constructorName constructorArgumentTypes = do + return $ InstanceD (if b then constraints typeVariables else []) + (AppT (ConT ''Default) (foldl' (\x y -> AppT x (VarT y)) (ConT typeConstructorName) typeVariables)) + [FunD 'def [Clause [] (NormalB (foldl' (\x _ -> AppE x (VarE 'def)) (ConE constructorName) constructorArgumentTypes)) []]] + + +constraints :: [Name] -> [Pred] +constraints = map (ClassP ''Default . return . VarT) + +instanceQ :: Bool -> Name -> [TyVarBndr] -> Name -> [Type] -> Q [Dec] +instanceQ b t vs c as = return <$> createInstance b t (map name vs) c as + +name :: TyVarBndr -> Name +name (PlainTV n) = n +name (KindedTV n k) = n + +deriveDefault :: Bool -> Name -> Q [Dec] +deriveDefault b n = do + info <- reify n + case info of + TyConI (DataD _ qn tvars (con:_) _) -> case con of + NormalC conName ts -> instanceQ b qn tvars conName (map snd ts) + RecC conName ts -> instanceQ b qn tvars conName (map (\(v,s,t) -> t) ts) + InfixC t conName t' -> instanceQ b qn tvars conName (map snd [t, t']) + _ -> fail $ "Dunno how to derive Default instances for existential types" + TyConI (DataD _ _ _ [] _) -> fail $ "Really? You want to derive a Default instance for an uninhabited type?" + _ -> fail $ "Couldn't derive a Default instance; didn't know what to do with " ++ pprint info diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aeson-smart.cabal b/aeson-smart.cabal new file mode 100644 --- /dev/null +++ b/aeson-smart.cabal @@ -0,0 +1,25 @@ +name: aeson-smart +version: 0.1.0.0 +synopsis: Smart derivation of Aeson instances +description: aeson-smart generates ToJSON instances that ignore fields + with Nothing values and FromJSON instances that ignore + extra fields and fill in missing fields with their + defaults, should they have a Default instance. + Constructors without parameters have strings of their + constructor name as JSON representations. +homepage: https://github.com/lassoinc/aeson-smart +license: MIT +author: Sam Anklesaria +maintainer: amsay@amsay.net +-- copyright: +category: Web +build-type: Simple +cabal-version: >=1.8 +source-repository head + type: git + location: git://github.com/lassoinc/aeson-smart.git + +library + exposed-modules: Data.Aeson.TH.Smart, Data.Default.TH + -- other-modules: + build-depends: base ==4.5.*, aeson ==0.6.*, data-default ==0.4.*, unordered-containers ==0.2.*, template-haskell ==2.7.*, text ==0.11.*, vector ==0.9.*