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

-- |TH splice which makes it more convenient to define 'ToSchema' instance for 'Record' types.
--
-- For example:
--
-- @
--   type MyRecord = '[FFoo, FBar]
--   newtype MyRecordWrapper = MyRecordWrapper { unMyRecordWrapper :: Record MyRecord }
--   makeToSchema "MyRecordWrapper" ''MyRecordWrapper
-- @
--
-- is equivalent to:
--
-- @
--   instance ToSchema MyRecordWrapper where
--     declareNamedSchema = wrappedSchema (Proxy :: Proxy MyRecordWrapper) "MyRecordWrapper"
-- @
makeToSchema :: String -> Name -> Q [Dec]
makeToSchema :: String -> Name -> Q [Dec]
makeToSchema String
schemaName Name
wrapperName =
  forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
        [t| ToSchema $(conT wrapperName) |]
        [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            'declareNamedSchema
            [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => m Pat
wildP] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| wrappedSchema (Proxy :: Proxy $(conT wrapperName)) schemaName |]) [] ]
        ]
    ]

-- |TH splice which makes it more convenient to define 'ToSchema' instance for 'Record' types.
--
-- For example:
--
-- @
--   type MyRecord = '[FFoo, FBar]
--   makeToSchemaWrapper "MyRecordWrapper" ''MyRecord
-- @
--
-- is equivalent to:
--
-- @
--   newtype MyRecordWrapper = MyRecordWrapper { unMyRecordWrapper :: Record MyRecord }
--   instance ToSchema MyRecordWrapper where
--     declareNamedSchema = wrappedSchema (Proxy :: Proxy MyRecordWrapper) "MyRecordWrapper"
-- @
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 forall a b. (a -> b) -> a -> b
$ String
"un" forall a. Semigroup a => a -> a -> a
<> String
wrapperNameStr
      fieldTy :: Q Type
fieldTy = [t| Field $(conT fieldsTyName) |]
  Dec
wrapperNewtype <- forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD
    (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
    Name
wrapperName
    [] -- TyVarBndrs
    forall a. Maybe a
Nothing -- kind
    (forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
recC Name
wrapperName [forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType Name
extractorName (forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness) Q Type
fieldTy)])
#if MIN_VERSION_template_haskell(2,12,0)
    [] -- deriving context
#else
    (cxt [])
#endif
  [Dec]
wrapperInstances <- String -> Name -> Q [Dec]
makeToSchema String
wrapperNameStr Name
wrapperName
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Dec
wrapperNewtypeforall a. a -> [a] -> [a]
:[Dec]
wrapperInstances