{-# LANGUAGE TemplateHaskell #-}
module Data.API.Tools.JSON
( jsonTool
, jsonTool'
, toJsonNodeTool
, fromJsonNodeTool
, fromJsonWithErrsNodeTool
) where
import Data.API.JSON
import Data.API.TH
import Data.API.Tools.Combinators
import Data.API.Tools.Datatypes
import Data.API.Tools.Enum
import Data.API.Types
import Data.Aeson hiding (withText, withBool)
import Control.Applicative
import Data.Maybe
import qualified Data.Map as Map
import Data.Monoid
import qualified Data.Text as T
import Language.Haskell.TH
import Prelude
jsonTool :: APITool
jsonTool :: APITool
jsonTool = APINodeTool -> APITool
apiNodeTool forall a b. (a -> b) -> a -> b
$ APINodeTool
toJsonNodeTool forall a. Semigroup a => a -> a -> a
<> APINodeTool
fromJsonWithErrsNodeTool
jsonTool' :: APITool
jsonTool' :: APITool
jsonTool' = APINodeTool -> APITool
apiNodeTool forall a b. (a -> b) -> a -> b
$ APINodeTool
toJsonNodeTool forall a. Semigroup a => a -> a -> a
<> APINodeTool
fromJsonNodeTool
forall a. Semigroup a => a -> a -> a
<> APINodeTool
fromJsonWithErrsNodeTool
toJsonNodeTool :: APINodeTool
toJsonNodeTool :: APINodeTool
toJsonNodeTool = Tool (APINode, SpecNewtype)
-> Tool (APINode, SpecRecord)
-> Tool (APINode, SpecUnion)
-> Tool (APINode, SpecEnum)
-> Tool (APINode, APIType)
-> APINodeTool
apiSpecTool Tool (APINode, SpecNewtype)
gen_sn_to Tool (APINode, SpecRecord)
gen_sr_to Tool (APINode, SpecUnion)
gen_su_to Tool (APINode, SpecEnum)
gen_se_to forall a. Monoid a => a
mempty
forall a. Semigroup a => a -> a -> a
<> APINodeTool
gen_pr
fromJsonNodeTool :: APINodeTool
fromJsonNodeTool :: APINodeTool
fromJsonNodeTool = APINodeTool
gen_FromJSON
fromJsonWithErrsNodeTool :: APINodeTool
fromJsonWithErrsNodeTool :: APINodeTool
fromJsonWithErrsNodeTool = Tool (APINode, SpecNewtype)
-> Tool (APINode, SpecRecord)
-> Tool (APINode, SpecUnion)
-> Tool (APINode, SpecEnum)
-> Tool (APINode, APIType)
-> APINodeTool
apiSpecTool Tool (APINode, SpecNewtype)
gen_sn_fm Tool (APINode, SpecRecord)
gen_sr_fm Tool (APINode, SpecUnion)
gen_su_fm Tool (APINode, SpecEnum)
gen_se_fm forall a. Monoid a => a
mempty
forall a. Semigroup a => a -> a -> a
<> APINodeTool
gen_in
gen_sn_to :: Tool (APINode, SpecNewtype)
gen_sn_to :: Tool (APINode, SpecNewtype)
gen_sn_to = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecNewtype
sn) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''ToJSON [APINode -> TypeQ
nodeRepT APINode
an]
[Name -> ExpQ -> DecQ
simpleD 'toJSON (APINode -> SpecNewtype -> ExpQ
bdy APINode
an SpecNewtype
sn)]
where
bdy :: APINode -> SpecNewtype -> ExpQ
bdy APINode
an SpecNewtype
sn = [e| $(ine sn) . $(newtypeProjectionE an) |]
ine :: SpecNewtype -> m Exp
ine SpecNewtype
sn = case SpecNewtype -> BasicType
snType SpecNewtype
sn of
BasicType
BTstring -> [e| String |]
BasicType
BTbinary -> [e| toJSON |]
BasicType
BTbool -> [e| Bool |]
BasicType
BTint -> [e| mkInt |]
BasicType
BTutc -> [e| String . printUTC |]
gen_sn_fm :: Tool (APINode, SpecNewtype)
gen_sn_fm :: Tool (APINode, SpecNewtype)
gen_sn_fm = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecNewtype
sn) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''FromJSONWithErrs [APINode -> TypeQ
nodeRepT APINode
an]
[Name -> ExpQ -> DecQ
simpleD 'parseJSONWithErrs (ToolSettings -> APINode -> SpecNewtype -> ExpQ
bdy ToolSettings
ts APINode
an SpecNewtype
sn)]
where
bdy :: ToolSettings -> APINode -> SpecNewtype -> ExpQ
bdy ToolSettings
ts APINode
an SpecNewtype
sn = [e| $(wth sn) $(typeNameE (anName an)) (pure . $(nodeNewtypeConE ts an sn)) |]
wth :: SpecNewtype -> m Exp
wth SpecNewtype
sn =
case (SpecNewtype -> BasicType
snType SpecNewtype
sn, SpecNewtype -> Maybe Filter
snFilter SpecNewtype
sn) of
(BasicType
BTstring, Just (FtrStrg RegEx
re)) -> [e| withRegEx re |]
(BasicType
BTstring, Maybe Filter
_ ) -> [e| withText |]
(BasicType
BTbinary, Maybe Filter
_ ) -> [e| withBinary |]
(BasicType
BTbool , Maybe Filter
_ ) -> [e| withBool |]
(BasicType
BTint , Just (FtrIntg IntRange
ir)) -> [e| withIntRange ir |]
(BasicType
BTint , Maybe Filter
_ ) -> [e| withInt |]
(BasicType
BTutc , Just (FtrUTC UTCRange
ur)) -> [e| withUTCRange ur |]
(BasicType
BTutc , Maybe Filter
_ ) -> [e| withUTC |]
gen_sr_to :: Tool (APINode, SpecRecord)
gen_sr_to :: Tool (APINode, SpecRecord)
gen_sr_to = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecRecord
sr) -> do
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''ToJSON [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'toJSON (APINode -> SpecRecord -> Name -> ExpQ
bdy APINode
an SpecRecord
sr Name
x)]
where
bdy :: APINode -> SpecRecord -> Name -> ExpQ
bdy APINode
an SpecRecord
sr Name
x = forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'object forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ [e| $(fieldNameE fn) .= $(nodeFieldE an fn) $(varE x) |]
| (FieldName
fn, FieldType
_) <- SpecRecord -> [(FieldName, FieldType)]
srFields SpecRecord
sr ]
gen_sr_fm :: Tool (APINode, SpecRecord)
gen_sr_fm :: Tool (APINode, SpecRecord)
gen_sr_fm = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecRecord
sr) -> do
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''FromJSONWithErrs [APINode -> TypeQ
nodeRepT APINode
an]
[forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'parseJSONWithErrs [APINode -> SpecRecord -> Name -> Q Clause
cl APINode
an SpecRecord
sr Name
x, Q Clause
clNull, forall {m :: * -> *}. Quote m => Name -> m Clause
cl' Name
x]]
where
cl :: APINode -> SpecRecord -> Name -> Q Clause
cl APINode
an SpecRecord
sr Name
x = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Object [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
bdy) []
where
bdy :: ExpQ
bdy = ExpQ -> [ExpQ] -> ExpQ
applicativeE (APINode -> ExpQ
nodeConE APINode
an) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FieldName, FieldType) -> ExpQ
project (SpecRecord -> [(FieldName, FieldType)]
srFields SpecRecord
sr)
project :: (FieldName, FieldType) -> ExpQ
project (FieldName
fn, FieldType
ft) = [e| withDefaultField ro (fmap defaultValueAsJsValue mb_dv) $(fieldNameE fn) parseJSONWithErrs $(varE x) |]
where ro :: Bool
ro = FieldType -> Bool
ftReadOnly FieldType
ft
mb_dv :: Maybe DefaultValue
mb_dv = FieldType -> Maybe DefaultValue
ftDefault FieldType
ft
clNull :: Q Clause
clNull = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Null []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [e| parseJSONWithErrs (Object mempty) |]) []
cl' :: Name -> m Clause
cl' Name
x = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => Name -> m Exp
bdy' Name
x)) []
bdy' :: Name -> m Exp
bdy' Name
x = [e| failWith (expectedObject $(varE x)) |]
gen_su_to :: Tool (APINode, SpecUnion)
gen_su_to :: Tool (APINode, SpecUnion)
gen_su_to = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecUnion
su) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''ToJSON [APINode -> TypeQ
nodeRepT APINode
an] [forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'toJSON (APINode -> SpecUnion -> [Q Clause]
cls APINode
an SpecUnion
su)]
where
cls :: APINode -> SpecUnion -> [Q Clause]
cls APINode
an SpecUnion
su = forall a b. (a -> b) -> [a] -> [b]
map (APINode -> FieldName -> Q Clause
cl APINode
an forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (SpecUnion -> [(FieldName, (APIType, String))]
suFields SpecUnion
su)
cl :: APINode -> FieldName -> Q Clause
cl APINode
an FieldName
fn = do Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [APINode -> FieldName -> [Q Pat] -> Q Pat
nodeAltConP APINode
an FieldName
fn [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]] (FieldName -> Name -> Q Body
bdy FieldName
fn Name
x) []
bdy :: FieldName -> Name -> Q Body
bdy FieldName
fn Name
x = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [e| object [ $(fieldNameE fn) .= $(varE x) ] |]
gen_su_fm :: Tool (APINode, SpecUnion)
gen_su_fm :: Tool (APINode, SpecUnion)
gen_su_fm = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecUnion
su) ->
ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''FromJSONWithErrs [APINode -> TypeQ
nodeRepT APINode
an]
[Name -> ExpQ -> DecQ
simpleD 'parseJSONWithErrs (APINode -> SpecUnion -> ExpQ
bdy APINode
an SpecUnion
su)]
where
bdy :: APINode -> SpecUnion -> ExpQ
bdy APINode
an SpecUnion
su = forall (m :: * -> *). Quote m => Name -> m Exp
varE 'withUnion forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (forall a b. (a -> b) -> [a] -> [b]
map (forall {b}. APINode -> (FieldName, b) -> ExpQ
alt APINode
an) (SpecUnion -> [(FieldName, (APIType, String))]
suFields SpecUnion
su))
alt :: APINode -> (FieldName, b) -> ExpQ
alt APINode
an (FieldName
fn, b
_) = [e| ( $(fieldNameE fn) , fmap $(nodeAltConE an fn) . parseJSONWithErrs ) |]
gen_se_to :: Tool (APINode, SpecEnum)
gen_se_to :: Tool (APINode, SpecEnum)
gen_se_to = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecEnum
_se) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''ToJSON [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'toJSON (forall {m :: * -> *}. Quote m => APINode -> m Exp
bdy APINode
an)]
where
bdy :: APINode -> m Exp
bdy APINode
an = [e| String . $(varE (text_enum_nm an)) |]
gen_se_fm :: Tool (APINode, SpecEnum)
gen_se_fm :: Tool (APINode, SpecEnum)
gen_se_fm = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecEnum
_se) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''FromJSONWithErrs [APINode -> TypeQ
nodeRepT APINode
an]
[Name -> ExpQ -> DecQ
simpleD 'parseJSONWithErrs (forall {m :: * -> *}. Quote m => APINode -> m Exp
bdy APINode
an)]
where
bdy :: APINode -> m Exp
bdy APINode
an = [e| jsonStrMap_p $(varE (map_enum_nm an)) |]
gen_in :: Tool APINode
gen_in :: APINodeTool
gen_in = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts APINode
an -> case APINode -> Conversion
anConvert APINode
an of
Conversion
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just (FieldName
inj_fn, FieldName
_) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''FromJSONWithErrs [APINode -> TypeQ
nodeT APINode
an]
[Name -> ExpQ -> DecQ
simpleD 'parseJSONWithErrs ExpQ
bdy]
where
bdy :: ExpQ
bdy = do Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] [e| parseJSONWithErrs $(varE x) >>= $inj |]
inj :: ExpQ
inj = FieldName -> ExpQ
fieldNameVarE FieldName
inj_fn
gen_pr :: Tool APINode
gen_pr :: APINodeTool
gen_pr = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts APINode
an -> case APINode -> Conversion
anConvert APINode
an of
Conversion
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just (FieldName
_, FieldName
prj_fn) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''ToJSON [APINode -> TypeQ
nodeT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'toJSON ExpQ
bdy]
where
bdy :: ExpQ
bdy = [e| toJSON . $prj |]
prj :: ExpQ
prj = FieldName -> ExpQ
fieldNameVarE FieldName
prj_fn
gen_FromJSON :: Tool APINode
gen_FromJSON :: APINodeTool
gen_FromJSON = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts APINode
an -> do
forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ToolSettings -> TypeQ -> Q [Dec]
genIf (Bool -> Bool
not (APINode -> Bool
isSynonym APINode
an)) ToolSettings
ts (APINode -> TypeQ
nodeRepT APINode
an)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> ToolSettings -> TypeQ -> Q [Dec]
genIf (forall a. Maybe a -> Bool
isJust (APINode -> Conversion
anConvert APINode
an)) ToolSettings
ts (APINode -> TypeQ
nodeT APINode
an)
where
genIf :: Bool -> ToolSettings -> TypeQ -> Q [Dec]
genIf Bool
b ToolSettings
ts TypeQ
t | Bool
b = ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''FromJSON [TypeQ
t] [Name -> ExpQ -> DecQ
simpleD 'parseJSON [e|parseJSONDefault|]]
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
isSynonym :: APINode -> Bool
isSynonym APINode
an = case APINode -> Spec
anSpec APINode
an of
SpSynonym APIType
_ -> Bool
True
Spec
_ -> Bool
False
mkInt :: Int -> Value
mkInt :: Int -> Value
mkInt = Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger
jsonStrMap_p :: Ord a => Map.Map T.Text a -> Value -> ParserWithErrs a
jsonStrMap_p :: forall a. Ord a => Map Text a -> Value -> ParserWithErrs a
jsonStrMap_p Map Text a
mp = forall a.
Ord a =>
[Text] -> (Text -> Maybe a) -> Value -> ParserWithErrs a
json_string_p (forall k a. Map k a -> [k]
Map.keys Map Text a
mp) forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Text a
mp
json_string_p :: Ord a => [T.Text] -> (T.Text->Maybe a) -> Value -> ParserWithErrs a
json_string_p :: forall a.
Ord a =>
[Text] -> (Text -> Maybe a) -> Value -> ParserWithErrs a
json_string_p [Text]
xs Text -> Maybe a
p (String Text
t) | Just a
val <- Text -> Maybe a
p Text
t = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val
| Bool
otherwise = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> JSONError
UnexpectedEnumVal [Text]
xs Text
t
json_string_p [Text]
_ Text -> Maybe a
_ Value
v = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedString Value
v