{-# LANGUAGE LambdaCase, TemplateHaskell #-}
module BattlePlace.Util
( jsonOptions
, jsonOptionsWithTag
, swaggerSchemaOptions
, declareStruct
) where
import Control.Monad
import qualified Data.Aeson as J
import qualified Data.Swagger as SW
import GHC.Generics(Generic)
import Language.Haskell.TH
jsonOptions :: J.Options
jsonOptions = jsonOptionsWithTag "status"
jsonOptionsWithTag :: String -> J.Options
jsonOptionsWithTag tag = J.defaultOptions
{ J.fieldLabelModifier = dropBeforeUnderscore
, J.constructorTagModifier = dropBeforeUnderscore
, J.sumEncoding = J.TaggedObject
{ J.tagFieldName = tag
, J.contentsFieldName = "contents"
}
}
swaggerSchemaOptions :: SW.SchemaOptions
swaggerSchemaOptions = SW.defaultSchemaOptions
{ SW.fieldLabelModifier = dropBeforeUnderscore
, SW.constructorTagModifier = dropBeforeUnderscore
}
dropBeforeUnderscore :: String -> String
dropBeforeUnderscore = \case
x : xs -> case x of
'_' -> xs
_ -> dropBeforeUnderscore xs
[] -> []
declareStruct :: [Name] -> Q [Dec]
declareStruct names = fmap concat . forM names $ \t -> sequence
[ standaloneDerivD (pure []) [t| Generic $(conT t) |]
, instanceD (pure []) [t| J.FromJSON $(conT t) |]
[ funD 'J.parseJSON
[ clause [] (normalB [| J.genericParseJSON jsonOptions |]) []
]
]
, instanceD (pure []) [t| J.ToJSON $(conT t) |]
[ funD 'J.toJSON
[ clause [] (normalB [| J.genericToJSON jsonOptions |]) []
]
, funD 'J.toEncoding
[ clause [] (normalB [| J.genericToEncoding jsonOptions |]) []
]
]
, instanceD (pure []) [t| SW.ToSchema $(conT t) |]
[ funD 'SW.declareNamedSchema
[ clause [] (normalB [| SW.genericDeclareNamedSchemaUnrestricted swaggerSchemaOptions |]) []
]
]
]