{-# 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


-- | Tool to generate 'ToJSON' and 'FromJSONWithErrs' instances for
-- types generated by 'datatypesTool'.  This depends on 'enumTool'.
-- For historical reasons this does not generate 'FromJSON' instances;
-- you probably want to use 'jsonTool'' instead.
jsonTool :: APITool
jsonTool :: APITool
jsonTool = APINodeTool -> APITool
apiNodeTool (APINodeTool -> APITool) -> APINodeTool -> APITool
forall a b. (a -> b) -> a -> b
$ APINodeTool
toJsonNodeTool APINodeTool -> APINodeTool -> APINodeTool
forall a. Semigroup a => a -> a -> a
<> APINodeTool
fromJsonWithErrsNodeTool

-- | Tool to generate 'ToJSON', 'FromJSON' and 'FromJSONWithErrs'
-- instances for types generated by 'datatypesTool'.  This depends on
-- 'enumTool'.  Note that generated 'FromJSON' and 'FromJSONWithErrs'
-- instances will always agree on the decoding of a value, but that
-- the 'FromJSONWithErrs' instances for basic types are more liberal
-- than 'FromJSON'.
jsonTool' :: APITool
jsonTool' :: APITool
jsonTool' = APINodeTool -> APITool
apiNodeTool (APINodeTool -> APITool) -> APINodeTool -> APITool
forall a b. (a -> b) -> a -> b
$ APINodeTool
toJsonNodeTool APINodeTool -> APINodeTool -> APINodeTool
forall a. Semigroup a => a -> a -> a
<> APINodeTool
fromJsonNodeTool
                                         APINodeTool -> APINodeTool -> APINodeTool
forall a. Semigroup a => a -> a -> a
<> APINodeTool
fromJsonWithErrsNodeTool


-- | Tool to generate 'ToJSON' instance for an API node
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 Tool (APINode, APIType)
forall a. Monoid a => a
mempty
                 APINodeTool -> APINodeTool -> APINodeTool
forall a. Semigroup a => a -> a -> a
<> APINodeTool
gen_pr

-- | Tool to generate 'FromJSON' instance for an API node, which
-- relies on the 'FromJSONWithErrs' instance.
fromJsonNodeTool :: APINodeTool
fromJsonNodeTool :: APINodeTool
fromJsonNodeTool = APINodeTool
gen_FromJSON

-- | Tool to generate 'FromJSONWithErrs' instance for an API node
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 Tool (APINode, APIType)
forall a. Monoid a => a
mempty
                           APINodeTool -> APINodeTool -> APINodeTool
forall a. Semigroup a => a -> a -> a
<> APINodeTool
gen_in


{-
instance ToJSON JobId where
    toJSON = String . _JobId
-}

gen_sn_to :: Tool (APINode, SpecNewtype)
gen_sn_to :: Tool (APINode, SpecNewtype)
gen_sn_to = (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
 -> Tool (APINode, SpecNewtype))
-> (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
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| $(SpecNewtype -> ExpQ
forall {m :: * -> *}. Quote m => SpecNewtype -> m Exp
ine SpecNewtype
sn) . $(APINode -> ExpQ
newtypeProjectionE APINode
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  |]


{-
instance FromJSONWithErrs JobId where
    parseJSONWithErrs = withText "JobId" (pure . JobId)
-}

gen_sn_fm :: Tool (APINode, SpecNewtype)
gen_sn_fm :: Tool (APINode, SpecNewtype)
gen_sn_fm = (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
 -> Tool (APINode, SpecNewtype))
-> (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
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| $(SpecNewtype -> ExpQ
forall {m :: * -> *}. Quote m => SpecNewtype -> m Exp
wth SpecNewtype
sn) $(TypeName -> ExpQ
typeNameE (APINode -> TypeName
anName APINode
an)) (pure . $(ToolSettings -> APINode -> SpecNewtype -> ExpQ
nodeNewtypeConE ToolSettings
ts APINode
an SpecNewtype
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         |]



{-
instance ToJSON JobSpecId where
     toJSON = \ x ->
        object
            [ "Id"         .= jsiId         x
            , "Input"      .= jsiInput      x
            , "Output"     .= jsiOutput     x
            , "PipelineId" .= jsiPipelineId x
            ]
-}

gen_sr_to :: Tool (APINode, SpecRecord)
gen_sr_to :: Tool (APINode, SpecRecord)
gen_sr_to = (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
 -> Tool (APINode, SpecRecord))
-> (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecRecord
sr) -> do
    Name
x <- String -> Q Name
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 = [Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
            Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'object ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
            [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ [e| $(FieldName -> ExpQ
fieldNameE FieldName
fn) .= $(APINode -> FieldName -> ExpQ
nodeFieldE APINode
an FieldName
fn) $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) |]
                  | (FieldName
fn, FieldType
_) <- SpecRecord -> [(FieldName, FieldType)]
srFields SpecRecord
sr ]


{-
instance FromJSONWithErrs JobSpecId where
     parseJSONWithErrs (Object v) =
        JobSpecId <$>
            v .: "Id"                               <*>
            v .: "Input"                            <*>
            v .: "Output"                           <*>
            v .: "PipelineId"
     parseJSONWithErrs Null       = parseJSONWithErrs (Object mempty)
     parseJSONWithErrs v          = failWith $ expectedObject val
-}

gen_sr_fm :: Tool (APINode, SpecRecord)
gen_sr_fm :: Tool (APINode, SpecRecord)
gen_sr_fm = (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
 -> Tool (APINode, SpecRecord))
-> (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecRecord
sr) -> do
    Name
x <- String -> Q Name
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]
                      [Name -> [Q Clause] -> DecQ
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, Name -> Q Clause
forall {m :: * -> *}. Quote m => Name -> m Clause
cl' Name
x]]
  where
    cl :: APINode -> SpecRecord -> Name -> Q Clause
cl APINode
an SpecRecord
sr Name
x  = [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Object [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]] (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
bdy) []
      where
        bdy :: ExpQ
bdy = ExpQ -> [ExpQ] -> ExpQ
applicativeE (APINode -> ExpQ
nodeConE APINode
an) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((FieldName, FieldType) -> ExpQ)
-> [(FieldName, FieldType)] -> [ExpQ]
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) $(FieldName -> ExpQ
fieldNameE FieldName
fn) parseJSONWithErrs $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
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 = [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Null []] (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [e| parseJSONWithErrs (Object mempty) |]) []

    cl' :: Name -> m Clause
cl'  Name
x = [m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
bdy' Name
x)) []
    bdy' :: Name -> m Exp
bdy' Name
x = [e| failWith (expectedObject $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)) |]


{-
instance ToJSON Foo where
    toJSON (Bar x) = object [ "x" .= x ]
    toJSON (Baz x) = object [ "y" .= x ]
-}

gen_su_to :: Tool (APINode, SpecUnion)
gen_su_to :: Tool (APINode, SpecUnion)
gen_su_to = (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
 -> Tool (APINode, SpecUnion))
-> (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
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] [Name -> [Q Clause] -> DecQ
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 = ((FieldName, (APIType, String)) -> Q Clause)
-> [(FieldName, (APIType, String))] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (APINode -> FieldName -> Q Clause
cl APINode
an (FieldName -> Q Clause)
-> ((FieldName, (APIType, String)) -> FieldName)
-> (FieldName, (APIType, String))
-> Q Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldName, (APIType, String)) -> FieldName
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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                  [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [APINode -> FieldName -> [Q Pat] -> Q Pat
nodeAltConP APINode
an FieldName
fn [Name -> Q Pat
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 = ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [e| object [ $(FieldName -> ExpQ
fieldNameE FieldName
fn) .= $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) ] |]


{-
instance FromJSONWithErrs Foo where
    parseJSONWithErrs = withUnion [ ("x", fmap Bar . parseJSONWithErrs)
                                  , ("y", fmap Baz . parseJSONWithErrs) ]
-}

gen_su_fm :: Tool (APINode, SpecUnion)
gen_su_fm :: Tool (APINode, SpecUnion)
gen_su_fm = (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
 -> Tool (APINode, SpecUnion))
-> (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
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 = Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'withUnion ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (((FieldName, (APIType, String)) -> ExpQ)
-> [(FieldName, (APIType, String))] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (APINode -> (FieldName, (APIType, String)) -> ExpQ
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| ( $(FieldName -> ExpQ
fieldNameE FieldName
fn) , fmap $(APINode -> FieldName -> ExpQ
nodeAltConE APINode
an FieldName
fn) . parseJSONWithErrs ) |]


{-
instance ToJSON FrameRate where
    toJSON    = String . _text_FrameRate
-}

gen_se_to :: Tool (APINode, SpecEnum)
gen_se_to :: Tool (APINode, SpecEnum)
gen_se_to = (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
 -> Tool (APINode, SpecEnum))
-> (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
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 (APINode -> ExpQ
forall {m :: * -> *}. Quote m => APINode -> m Exp
bdy APINode
an)]
  where
    bdy :: APINode -> m Exp
bdy APINode
an = [e| String . $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (APINode -> Name
text_enum_nm APINode
an)) |]


{-
instance FromJSONWithErrs FrameRate where
    parseJSONWithErrs = jsonStrMap_p _map_FrameRate
-}

gen_se_fm :: Tool (APINode, SpecEnum)
gen_se_fm :: Tool (APINode, SpecEnum)
gen_se_fm = (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
 -> Tool (APINode, SpecEnum))
-> (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
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 (APINode -> ExpQ
forall {m :: * -> *}. Quote m => APINode -> m Exp
bdy APINode
an)]
  where
    bdy :: APINode -> m Exp
bdy APINode
an = [e| jsonStrMap_p $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (APINode -> Name
map_enum_nm APINode
an)) |]


gen_in :: Tool APINode
gen_in :: APINodeTool
gen_in = (ToolSettings -> APINode -> Q [Dec]) -> APINodeTool
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> APINode -> Q [Dec]) -> APINodeTool)
-> (ToolSettings -> APINode -> Q [Dec]) -> APINodeTool
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts APINode
an -> case APINode -> Conversion
anConvert APINode
an of
  Conversion
Nothing          -> [Dec] -> Q [Dec]
forall a. a -> Q a
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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
             [Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] [e| parseJSONWithErrs $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) >>= $ExpQ
inj |]
    inj :: ExpQ
inj = FieldName -> ExpQ
fieldNameVarE FieldName
inj_fn


gen_pr :: Tool APINode
gen_pr :: APINodeTool
gen_pr = (ToolSettings -> APINode -> Q [Dec]) -> APINodeTool
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> APINode -> Q [Dec]) -> APINodeTool)
-> (ToolSettings -> APINode -> Q [Dec]) -> APINodeTool
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts APINode
an -> case APINode -> Conversion
anConvert APINode
an of
  Conversion
Nothing          -> [Dec] -> Q [Dec]
forall a. a -> Q a
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 . $ExpQ
prj |]
    prj :: ExpQ
prj = FieldName -> ExpQ
fieldNameVarE FieldName
prj_fn


-- | Generate 'FromJSON' instances like this:
--
-- > instance FromJSON T where
-- >   parseJSON = parseJSONDefault
gen_FromJSON :: Tool APINode
gen_FromJSON :: APINodeTool
gen_FromJSON = (ToolSettings -> APINode -> Q [Dec]) -> APINodeTool
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> APINode -> Q [Dec]) -> APINodeTool)
-> (ToolSettings -> APINode -> Q [Dec]) -> APINodeTool
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts APINode
an -> do
    [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
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)
         Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> ToolSettings -> TypeQ -> Q [Dec]
genIf (Conversion -> Bool
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 = [Dec] -> Q [Dec]
forall a. a -> Q a
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 (Scientific -> Value) -> (Int -> Scientific) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Scientific) -> (Int -> Integer) -> Int -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
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 = [Text] -> (Text -> Maybe a) -> Value -> ParserWithErrs a
forall a.
Ord a =>
[Text] -> (Text -> Maybe a) -> Value -> ParserWithErrs a
json_string_p (Map Text a -> [Text]
forall k a. Map k a -> [k]
Map.keys Map Text a
mp) ((Text -> Maybe a) -> Value -> ParserWithErrs a)
-> (Text -> Maybe a) -> Value -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ (Text -> Map Text a -> Maybe a) -> Map Text a -> Text -> Maybe a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Map Text a -> Maybe a
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 = a -> ParserWithErrs a
forall a. a -> ParserWithErrs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val
                              | Bool
otherwise       = JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> JSONError
UnexpectedEnumVal [Text]
xs Text
t
json_string_p [Text]
_  Text -> Maybe a
_ Value
v                            = JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedString Value
v