rethinkdb-client-driver 0.0.8 → 0.0.9
raw patch · 2 files changed
+884/−1 lines, 2 filesdep +template-haskell
Dependencies added: template-haskell
Files
rethinkdb-client-driver.cabal view
@@ -1,5 +1,5 @@ name: rethinkdb-client-driver-version: 0.0.8+version: 0.0.9 license: MIT license-file: LICENSE author: Tomas Carnecky@@ -42,6 +42,7 @@ , network , old-locale , scientific+ , template-haskell , text , time , unordered-containers@@ -51,6 +52,7 @@ other-modules : Database.RethinkDB.Messages , Database.RethinkDB.Types , Database.RethinkDB.Types.Datum+ , Database.RethinkDB.TH ghc-options : -Wall
+ src/Database/RethinkDB/TH.hs view
@@ -0,0 +1,881 @@+-- Copied from aeson-0.8.0.2++{-# LANGUAGE CPP, FlexibleInstances, IncoherentInstances, NamedFieldPuns,+ NoImplicitPrelude, OverlappingInstances, TemplateHaskell,+ UndecidableInstances #-}++{-|+Module: Data.Aeson.TH+Copyright: (c) 2011, 2012 Bryan O'Sullivan+ (c) 2011 MailRank, Inc.+License: Apache+Stability: experimental+Portability: portable++Functions to mechanically derive 'ToDatum' and 'FromDatum' instances. Note that+you need to enable the @TemplateHaskell@ language extension in order to use this+module.++An example shows how instances are generated for arbitrary data types. First we+define a data type:++@+data D a = Nullary+ | Unary Int+ | Product String Char a+ | Record { testOne :: Double+ , testTwo :: Bool+ , testThree :: D a+ } deriving Eq+@++Next we derive the necessary instances. Note that we make use of the+feature to change record field names. In this case we drop the first 4+characters of every field name. We also modify constructor names by+lower-casing them:++@+$('deriveDatum' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D)+@++Now we can use the newly created instances.++@+d :: D 'Int'+d = Record { testOne = 3.14159+ , testTwo = 'True'+ , testThree = Product \"test\" \'A\' 123+ }+@++>>> fromDatum (toDatum d) == Success d+> True++Please note that you can derive instances for tuples using the following syntax:++@+-- FromDatum and ToDatum instances for 4-tuples.+$('deriveDatum' 'defaultOptions' ''(,,,))+@++-}++module Database.RethinkDB.TH+ ( -- * Encoding configuration+ Options(..), SumEncoding(..), defaultOptions, defaultTaggedObject++ -- * FromDatum and ToDatum derivation+ , deriveDatum++ , deriveToDatum+ , deriveFromDatum++ , mkToDatum+ , mkParseDatum+ ) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++import Database.RethinkDB.Types.Datum+ ( Datum(..), Object, object, (.=), (.:), (.:?)+ , ToDatum, toDatum, FromDatum, parseDatum+ )++-- from aeson:+import Data.Aeson.Types+ ( Parser, Options(..), SumEncoding(..)+ , defaultOptions, defaultTaggedObject+ )++-- from base:+import Control.Applicative ( pure, (<$>), (<*>) )+import Control.Monad ( return, mapM, liftM2, fail )+import Data.Bool ( Bool(False, True), otherwise, (&&) )+import Data.Eq ( (==) )+import Data.Function ( ($), (.) )+import Data.Functor ( fmap )+import Data.Int ( Int )+import Data.Either ( Either(Left, Right) )+import Data.List ( (++), foldl, foldl', intercalate+ , length, map, zip, genericLength, all, partition+ )+import Data.Maybe ( Maybe(Nothing, Just), catMaybes )+import Prelude ( String, (-), Integer, fromIntegral, error )+import Text.Printf ( printf )+import Text.Show ( show )++-- from unordered-containers:+import qualified Data.HashMap.Strict as H ( lookup, toList )++-- from template-haskell:+import Language.Haskell.TH+import Language.Haskell.TH.Syntax ( VarStrictType )++-- from text:+import qualified Data.Text as T ( Text, pack, unpack )++-- from vector:+import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList )+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )+++--------------------------------------------------------------------------------+-- Convenience+--------------------------------------------------------------------------------++-- | Generates both 'ToDatum' and 'FromDatum' instance declarations for the given+-- data type.+--+-- This is a convienience function which is equivalent to calling both+-- 'deriveToDatum' and 'deriveFromDatum'.+deriveDatum :: Options+ -- ^ Encoding options.+ -> Name+ -- ^ Name of the type for which to generate 'ToDatum' and 'FromDatum'+ -- instances.+ -> Q [Dec]+deriveDatum opts name =+ liftM2 (++)+ (deriveToDatum opts name)+ (deriveFromDatum opts name)+++--------------------------------------------------------------------------------+-- ToDatum+--------------------------------------------------------------------------------++{-+TODO: Don't constrain phantom type variables.++data Foo a = Foo Int+instance (ToDatum a) ⇒ ToDatum Foo where ...++The above (ToDatum a) constraint is not necessary and perhaps undesirable.+-}++-- | Generates a 'ToDatum' instance declaration for the given data type.+deriveToDatum :: Options+ -- ^ Encoding options.+ -> Name+ -- ^ Name of the type for which to generate a 'ToDatum' instance+ -- declaration.+ -> Q [Dec]+deriveToDatum opts name =+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons+ where+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec+ fromCons tvbs cons =+ instanceD (applyCon ''ToDatum typeNames)+ (classType `appT` instanceType)+ [ funD 'toDatum+ [ clause []+ (normalB $ consToDatum opts cons)+ []+ ]+ ]+ where+ classType = conT ''ToDatum+ typeNames = map tvbName tvbs+ instanceType = foldl' appT (conT name) $ map varT typeNames++-- | Generates a lambda expression which encodes the given data type as Datum.+mkToDatum :: Options -- ^ Encoding options.+ -> Name -- ^ Name of the type to encode.+ -> Q Exp+mkToDatum opts name = withType name (\_ cons -> consToDatum opts cons)++-- | Helper function used by both 'deriveToDatum' and 'mkToDatum'. Generates code+-- to generate the Datum encoding of a number of constructors. All constructors+-- must be from the same type.+consToDatum :: Options+ -- ^ Encoding options.+ -> [Con]+ -- ^ Constructors for which to generate Datum generating code.+ -> Q Exp++consToDatum _ [] = error $ "Data.Aeson.TH.consToDatum: "+ ++ "Not a single constructor given!"++-- A single constructor is directly encoded. The constructor itself may be+-- forgotten.+consToDatum opts [con] = do+ value <- newName "value"+ lam1E (varP value) $ caseE (varE value) [encodeArgs opts False con]++consToDatum opts cons = do+ value <- newName "value"+ lam1E (varP value) $ caseE (varE value) matches+ where+ matches+ | allNullaryToStringTag opts && all isNullary cons =+ [ match (conP conName []) (normalB $ conStr opts conName) []+ | con <- cons+ , let conName = getConName con+ ]+ | otherwise = [encodeArgs opts True con | con <- cons]++conStr :: Options -> Name -> Q Exp+conStr opts = appE [|String|] . conTxt opts++conTxt :: Options -> Name -> Q Exp+conTxt opts = appE [|T.pack|] . conStringE opts++conStringE :: Options -> Name -> Q Exp+conStringE opts = stringE . constructorTagModifier opts . nameBase++-- | If constructor is nullary.+isNullary :: Con -> Bool+isNullary (NormalC _ []) = True+isNullary _ = False++encodeSum :: Options -> Bool -> Name -> Q Exp -> Q Exp+encodeSum opts multiCons conName exp+ | multiCons =+ case sumEncoding opts of+ TwoElemArray ->+ [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])+ TaggedObject{tagFieldName, contentsFieldName} ->+ [|object|] `appE` listE+ [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)+ , infixApp [|T.pack contentsFieldName|] [|(.=)|] exp+ ]+ ObjectWithSingleField ->+ [|object|] `appE` listE+ [ infixApp (conTxt opts conName) [|(.=)|] exp+ ]++ | otherwise = exp++-- | Generates code to generate the Datum encoding of a single constructor.+encodeArgs :: Options -> Bool -> Con -> Q Match+-- Nullary constructors. Generates code that explicitly matches against the+-- constructor even though it doesn't contain data. This is useful to prevent+-- type errors.+encodeArgs opts multiCons (NormalC conName []) =+ match (conP conName [])+ (normalB (encodeSum opts multiCons conName [e|toDatum ([] :: [()])|]))+ []++-- Polyadic constructors with special case for unary constructors.+encodeArgs opts multiCons (NormalC conName ts) = do+ let len = length ts+ args <- mapM newName ["arg" ++ show n | n <- [1..len]]+ js <- case [[|toDatum|] `appE` varE arg | arg <- args] of+ -- Single argument is directly converted.+ [e] -> return e+ -- Multiple arguments are converted to a Datum array.+ es -> do+ mv <- newName "mv"+ let newMV = bindS (varP mv)+ ([|VM.unsafeNew|] `appE`+ litE (integerL $ fromIntegral len))+ stmts = [ noBindS $+ [|VM.unsafeWrite|] `appE`+ (varE mv) `appE`+ litE (integerL ix) `appE`+ e+ | (ix, e) <- zip [(0::Integer)..] es+ ]+ ret = noBindS $ [|return|] `appE` varE mv+ return $ [|Array|] `appE`+ (varE 'V.create `appE`+ doE (newMV:stmts++[ret]))+ match (conP conName $ map varP args)+ (normalB $ encodeSum opts multiCons conName js)+ []++-- Records.+encodeArgs opts multiCons (RecC conName ts) = do+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]+ let exp = [|object|] `appE` pairs++ pairs | omitNothingFields opts = infixApp maybeFields+ [|(++)|]+ restFields+ | otherwise = listE $ map toPair argCons++ argCons = zip args ts++ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)++ restFields = listE $ map toPair rest++ (maybes, rest) = partition isMaybe argCons++ isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe+ isMaybe _ = False++ maybeToPair (arg, (field, _, _)) =+ infixApp (infixE (Just $ toFieldName field)+ [|(.=)|]+ Nothing)+ [|(<$>)|]+ (varE arg)++ toPair (arg, (field, _, _)) =+ infixApp (toFieldName field)+ [|(.=)|]+ (varE arg)++ toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field++ match (conP conName $ map varP args)+ ( normalB+ $ if multiCons+ then case sumEncoding opts of+ TwoElemArray -> [|toDatum|] `appE` tupE [conStr opts conName, exp]+ TaggedObject{tagFieldName} ->+ [|object|] `appE`+ -- TODO: Maybe throw an error in case+ -- tagFieldName overwrites a field in pairs.+ infixApp (infixApp [|T.pack tagFieldName|]+ [|(.=)|]+ (conStr opts conName))+ [|(:)|]+ pairs+ ObjectWithSingleField ->+ [|object|] `appE` listE+ [ infixApp (conTxt opts conName) [|(.=)|] exp ]+ else exp+ ) []++-- Infix constructors.+encodeArgs opts multiCons (InfixC _ conName _) = do+ al <- newName "argL"+ ar <- newName "argR"+ match (infixP (varP al) conName (varP ar))+ ( normalB+ $ encodeSum opts multiCons conName+ $ [|toDatum|] `appE` listE [ [|toDatum|] `appE` varE a+ | a <- [al,ar]+ ]+ )+ []+-- Existentially quantified constructors.+encodeArgs opts multiCons (ForallC _ _ con) =+ encodeArgs opts multiCons con+++--------------------------------------------------------------------------------+-- FromDatum+--------------------------------------------------------------------------------++-- | Generates a 'FromDatum' instance declaration for the given data type.+deriveFromDatum :: Options+ -- ^ Encoding options.+ -> Name+ -- ^ Name of the type for which to generate a 'FromDatum' instance+ -- declaration.+ -> Q [Dec]+deriveFromDatum opts name =+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons+ where+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec+ fromCons tvbs cons =+ instanceD (applyCon ''FromDatum typeNames)+ (classType `appT` instanceType)+ [ funD 'parseDatum+ [ clause []+ (normalB $ consFromDatum name opts cons)+ []+ ]+ ]+ where+ classType = conT ''FromDatum+ typeNames = map tvbName tvbs+ instanceType = foldl' appT (conT name) $ map varT typeNames++-- | Generates a lambda expression which parses the Datum encoding of the given+-- data type.+mkParseDatum :: Options -- ^ Encoding options.+ -> Name -- ^ Name of the encoded type.+ -> Q Exp+mkParseDatum opts name =+ withType name (\_ cons -> consFromDatum name opts cons)++-- | Helper function used by both 'deriveFromDatum' and 'mkParseDatum'. Generates+-- code to parse the Datum encoding of a number of constructors. All constructors+-- must be from the same type.+consFromDatum :: Name+ -- ^ Name of the type to which the constructors belong.+ -> Options+ -- ^ Encoding options+ -> [Con]+ -- ^ Constructors for which to generate Datum parsing code.+ -> Q Exp++consFromDatum _ _ [] = error $ "Data.Aeson.TH.consFromDatum: "+ ++ "Not a single constructor given!"++consFromDatum tName opts [con] = do+ value <- newName "value"+ lam1E (varP value) (parseArgs tName opts con (Right value))++consFromDatum tName opts cons = do+ value <- newName "value"+ lam1E (varP value) $ caseE (varE value) $+ if allNullaryToStringTag opts && all isNullary cons+ then allNullaryMatches+ else mixedMatches++ where+ allNullaryMatches =+ [ do txt <- newName "txt"+ match (conP 'String [varP txt])+ (guardedB $+ [ liftM2 (,) (normalG $+ infixApp (varE txt)+ [|(==)|]+ ([|T.pack|] `appE`+ conStringE opts conName)+ )+ ([|pure|] `appE` conE conName)+ | con <- cons+ , let conName = getConName con+ ]+ +++ [ liftM2 (,)+ (normalG [|otherwise|])+ ( [|noMatchFail|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|T.unpack|] `appE` varE txt)+ )+ ]+ )+ []+ , do other <- newName "other"+ match (varP other)+ (normalB $ [|noStringFail|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|valueConName|] `appE` varE other)+ )+ []+ ]++ mixedMatches =+ case sumEncoding opts of+ TaggedObject {tagFieldName, contentsFieldName} ->+ parseObject $ parseTaggedObject tagFieldName contentsFieldName+ ObjectWithSingleField ->+ parseObject $ parseObjectWithSingleField+ TwoElemArray ->+ [ do arr <- newName "array"+ match (conP 'Array [varP arr])+ (guardedB $+ [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)+ [|(==)|]+ (litE $ integerL 2))+ (parse2ElemArray arr)+ , liftM2 (,) (normalG [|otherwise|])+ (([|not2ElemArray|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|V.length|] `appE` varE arr)))+ ]+ )+ []+ , do other <- newName "other"+ match (varP other)+ ( normalB+ $ [|noArrayFail|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|valueConName|] `appE` varE other)+ )+ []+ ]++ parseObject f =+ [ do obj <- newName "obj"+ match (conP 'Object [varP obj]) (normalB $ f obj) []+ , do other <- newName "other"+ match (varP other)+ ( normalB+ $ [|noObjectFail|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|valueConName|] `appE` varE other)+ )+ []+ ]++ parseTaggedObject typFieldName valFieldName obj = do+ conKey <- newName "conKey"+ doE [ bindS (varP conKey)+ (infixApp (varE obj)+ [|(.:)|]+ ([|T.pack|] `appE` stringE typFieldName))+ , noBindS $ parseContents conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject+ ]++ parse2ElemArray arr = do+ conKey <- newName "conKey"+ conVal <- newName "conVal"+ let letIx n ix =+ valD (varP n)+ (normalB ([|V.unsafeIndex|] `appE`+ varE arr `appE`+ litE (integerL ix)))+ []+ letE [ letIx conKey 0+ , letIx conVal 1+ ]+ (caseE (varE conKey)+ [ do txt <- newName "txt"+ match (conP 'String [varP txt])+ (normalB $ parseContents txt+ (Right conVal)+ 'conNotFoundFail2ElemArray+ )+ []+ , do other <- newName "other"+ match (varP other)+ ( normalB+ $ [|firstElemNoStringFail|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|valueConName|] `appE` varE other)+ )+ []+ ]+ )++ parseObjectWithSingleField obj = do+ conKey <- newName "conKey"+ conVal <- newName "conVal"+ caseE ([e|H.toList|] `appE` varE obj)+ [ match (listP [tupP [varP conKey, varP conVal]])+ (normalB $ parseContents conKey (Right conVal) 'conNotFoundFailObjectSingleField)+ []+ , do other <- newName "other"+ match (varP other)+ (normalB $ [|wrongPairCountFail|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|show . length|] `appE` varE other)+ )+ []+ ]++ parseContents conKey contents errorFun =+ caseE (varE conKey)+ [ match wildP+ ( guardedB $+ [ do g <- normalG $ infixApp (varE conKey)+ [|(==)|]+ ([|T.pack|] `appE`+ conNameExp opts con)+ e <- parseArgs tName opts con contents+ return (g, e)+ | con <- cons+ ]+ +++ [ liftM2 (,)+ (normalG [e|otherwise|])+ ( varE errorFun+ `appE` (litE $ stringL $ show tName)+ `appE` listE (map ( litE+ . stringL+ . constructorTagModifier opts+ . nameBase+ . getConName+ ) cons+ )+ `appE` ([|T.unpack|] `appE` varE conKey)+ )+ ]+ )+ []+ ]++parseNullaryMatches :: Name -> Name -> [Q Match]+parseNullaryMatches tName conName =+ [ do arr <- newName "arr"+ match (conP 'Array [varP arr])+ (guardedB $+ [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)+ ([|pure|] `appE` conE conName)+ , liftM2 (,) (normalG [|otherwise|])+ (parseTypeMismatch tName conName+ (litE $ stringL "an empty Array")+ (infixApp (litE $ stringL $ "Array of length ")+ [|(++)|]+ ([|show . V.length|] `appE` varE arr)+ )+ )+ ]+ )+ []+ , matchFailed tName conName "Array"+ ]++parseUnaryMatches :: Name -> [Q Match]+parseUnaryMatches conName =+ [ do arg <- newName "arg"+ match (varP arg)+ ( normalB $ infixApp (conE conName)+ [|(<$>)|]+ ([|parseDatum|] `appE` varE arg)+ )+ []+ ]++parseRecord :: Options -> Name -> Name -> [VarStrictType] -> Name -> ExpQ+parseRecord opts tName conName ts obj =+ foldl' (\a b -> infixApp a [|(<*>)|] b)+ (infixApp (conE conName) [|(<$>)|] x)+ xs+ where+ x:xs = [ [|lookupField|]+ `appE` (litE $ stringL $ show tName)+ `appE` (litE $ stringL $ constructorTagModifier opts $ nameBase conName)+ `appE` (varE obj)+ `appE` ( [|T.pack|] `appE` fieldLabelExp opts field+ )+ | (field, _, _) <- ts+ ]++getValField :: Name -> String -> [MatchQ] -> Q Exp+getValField obj valFieldName matches = do+ val <- newName "val"+ doE [ bindS (varP val) $ infixApp (varE obj)+ [|(.:)|]+ ([|T.pack|] `appE`+ (litE $ stringL valFieldName))+ , noBindS $ caseE (varE val) matches+ ]++-- | Generates code to parse the Datum encoding of a single constructor.+parseArgs :: Name -- ^ Name of the type to which the constructor belongs.+ -> Options -- ^ Encoding options.+ -> Con -- ^ Constructor for which to generate Datum parsing code.+ -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or+ -- Right valName+ -> Q Exp+-- Nullary constructors.+parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =+ getValField obj valFieldName $ parseNullaryMatches tName conName+parseArgs tName _ (NormalC conName []) (Right valName) =+ caseE (varE valName) $ parseNullaryMatches tName conName++-- Unary constructors.+parseArgs _ _ (NormalC conName [_]) (Left (valFieldName, obj)) =+ getValField obj valFieldName $ parseUnaryMatches conName+parseArgs _ _ (NormalC conName [_]) (Right valName) =+ caseE (varE valName) $ parseUnaryMatches conName++-- Polyadic constructors.+parseArgs tName _ (NormalC conName ts) (Left (valFieldName, obj)) =+ getValField obj valFieldName $ parseProduct tName conName $ genericLength ts+parseArgs tName _ (NormalC conName ts) (Right valName) =+ caseE (varE valName) $ parseProduct tName conName $ genericLength ts++-- Records.+parseArgs tName opts (RecC conName ts) (Left (_, obj)) =+ parseRecord opts tName conName ts obj+parseArgs tName opts (RecC conName ts) (Right valName) = do+ obj <- newName "recObj"+ caseE (varE valName)+ [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []+ , matchFailed tName conName "Object"+ ]++-- Infix constructors. Apart from syntax these are the same as+-- polyadic constructors.+parseArgs tName _ (InfixC _ conName _) (Left (valFieldName, obj)) =+ getValField obj valFieldName $ parseProduct tName conName 2+parseArgs tName _ (InfixC _ conName _) (Right valName) =+ caseE (varE valName) $ parseProduct tName conName 2++-- Existentially quantified constructors. We ignore the quantifiers+-- and proceed with the contained constructor.+parseArgs tName opts (ForallC _ _ con) contents =+ parseArgs tName opts con contents++-- | Generates code to parse the Datum 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.+ -> [Q Match]+parseProduct tName conName numArgs =+ [ do arr <- newName "arr"+ -- List of: "parseDatum (arr `V.unsafeIndex` <IX>)"+ let x:xs = [ [|parseDatum|]+ `appE`+ infixApp (varE arr)+ [|V.unsafeIndex|]+ (litE $ integerL ix)+ | ix <- [0 .. numArgs - 1]+ ]+ match (conP 'Array [varP arr])+ (normalB $ 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)+ )+ )+ )+ []+ , matchFailed tName conName "Array"+ ]+++--------------------------------------------------------------------------------+-- Parsing errors+--------------------------------------------------------------------------------++matchFailed :: Name -> Name -> String -> MatchQ+matchFailed tName conName expected = do+ other <- newName "other"+ match (varP other)+ ( normalB $ parseTypeMismatch tName conName+ (litE $ stringL expected)+ ([|valueConName|] `appE` varE other)+ )+ []++parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ+parseTypeMismatch tName conName expected actual =+ foldl appE+ [|parseTypeMismatch'|]+ [ litE $ stringL $ nameBase conName+ , litE $ stringL $ show tName+ , expected+ , actual+ ]++class (FromDatum a) => LookupField a where+ lookupField :: String -> String -> Object -> T.Text -> Parser a++instance (FromDatum a) => LookupField a where+ lookupField tName rec obj key =+ case H.lookup key obj of+ Nothing -> unknownFieldFail tName rec (T.unpack key)+ Just v -> parseDatum v++instance (FromDatum a) => LookupField (Maybe a) where+ lookupField _ _ = (.:?)++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++noArrayFail :: String -> String -> Parser fail+noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o++noObjectFail :: String -> String -> Parser fail+noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o++firstElemNoStringFail :: String -> String -> Parser fail+firstElemNoStringFail t o = fail $ printf "When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." t o++wrongPairCountFail :: String -> String -> Parser fail+wrongPairCountFail t n =+ fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs."+ t n++noStringFail :: String -> String -> Parser fail+noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o++noMatchFail :: String -> String -> Parser fail+noMatchFail t o =+ fail $ printf "When parsing %s expected a String with the tag of a constructor but got %s." t o++not2ElemArray :: String -> Int -> Parser fail+not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2 elements but got %i elements" t i++conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail+conNotFoundFail2ElemArray t cs o =+ fail $ printf "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s."+ t (intercalate ", " cs) o++conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail+conNotFoundFailObjectSingleField t cs o =+ fail $ printf "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s."+ t (intercalate ", " cs) o++conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser fail+conNotFoundFailTaggedObject t cs o =+ fail $ printf "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s."+ t (intercalate ", " cs) o++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++-- | 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 :: Options -> Con -> Q Exp+conNameExp opts = litE+ . stringL+ . constructorTagModifier opts+ . nameBase+ . getConName++-- | Creates a string literal expression from a record field label.+fieldLabelExp :: Options -- ^ Encoding options+ -> Name+ -> Q Exp+fieldLabelExp opts = litE . stringL . fieldLabelModifier opts . nameBase++-- | The name of the outermost 'Value' constructor.+valueConName :: Datum -> String+valueConName (Object _) = "Object"+valueConName (Array _) = "Array"+valueConName (String _) = "String"+valueConName (Number _) = "Number"+valueConName (Bool _) = "Boolean"+valueConName (Time _) = "Time"+valueConName Null = "Null"++applyCon :: Name -> [Name] -> Q [Pred]+applyCon con typeNames = return (map apply typeNames)+ where apply t = ClassP con [VarT t]