{-# LANGUAGE CPP #-}
module Composite.Swagger.TH where
import Composite.CoRecord (Field)
import Composite.Swagger.Base (wrappedSchema)
import Data.Proxy (Proxy (Proxy))
import Data.Swagger (ToSchema, declareNamedSchema)
import Language.Haskell.TH
( Dec, Name, Q, mkName
, bang, bangType, clause, conT, cxt, funD, instanceD, newtypeD, normalB, recC, varBangType , wildP
, noSourceStrictness, noSourceUnpackedness )
makeToSchema :: String -> Name -> Q [Dec]
makeToSchema :: String -> Name -> Q [Dec]
makeToSchema String
schemaName Name
wrapperName =
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
([TypeQ] -> CxtQ
cxt [])
[t| ToSchema $(conT wrapperName) |]
[ Name -> [ClauseQ] -> Q Dec
funD
'declareNamedSchema
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB [| wrappedSchema (Proxy :: Proxy $(conT wrapperName)) schemaName |]) [] ]
]
]
makeToSchemaWrapper :: String -> Name -> Q [Dec]
makeToSchemaWrapper :: String -> Name -> Q [Dec]
makeToSchemaWrapper String
wrapperNameStr Name
fieldsTyName = do
let wrapperName :: Name
wrapperName = String -> Name
mkName String
wrapperNameStr
extractorName :: Name
extractorName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"un" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
wrapperNameStr
fieldTy :: TypeQ
fieldTy = [t| Field $(conT fieldsTyName) |]
Dec
wrapperNewtype <- CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> Q Dec
newtypeD
([TypeQ] -> CxtQ
cxt [])
Name
wrapperName
[]
Maybe Kind
forall a. Maybe a
Nothing
(Name -> [VarBangTypeQ] -> ConQ
recC Name
wrapperName [Name -> BangTypeQ -> VarBangTypeQ
varBangType Name
extractorName (BangQ -> TypeQ -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness) TypeQ
fieldTy)])
#if MIN_VERSION_template_haskell(2,12,0)
[]
#else
(cxt [])
#endif
[Dec]
wrapperInstances <- String -> Name -> Q [Dec]
makeToSchema String
wrapperNameStr Name
wrapperName
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
wrapperNewtypeDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[Dec]
wrapperInstances