{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -- | Derive standard HTTP-classes module Mig.Extra.Derive ( deriveParam, deriveNewtypeParam, deriveBody, deriveParamBody, deriveNewtypeBody, deriveNewtypeParamBody, deriveHttp, deriveNewtypeHttp, deriveNewtypeForm, deriveForm, mapDerive, -- * useful with derive-topdown library paramClasses, bodyClasses, paramBodyClasses, httpClasses, ) where import Data.Aeson (FromJSON, ToJSON) import Data.OpenApi (ToParamSchema, ToSchema) import GHC.Generics (Generic) import Language.Haskell.TH import Web.FormUrlEncoded (FromForm, ToForm) import Web.HttpApiData (FromHttpApiData, ToHttpApiData) paramClasses :: [Name] paramClasses = [''Show, ''Eq, ''Ord, ''Generic, ''ToJSON, ''FromJSON, ''ToParamSchema, ''ToHttpApiData, ''FromHttpApiData] bodyClasses :: [Name] bodyClasses = [''Show, ''Eq, ''Ord, ''Generic, ''ToJSON, ''FromJSON, ''ToSchema, ''ToHttpApiData, ''FromHttpApiData] paramBodyClasses :: [Name] paramBodyClasses = [''Show, ''Eq, ''Ord, ''Generic, ''ToJSON, ''FromJSON, ''ToParamSchema, ''ToSchema, ''ToHttpApiData, ''FromHttpApiData] httpClasses :: [Name] httpClasses = [''Show, ''Eq, ''Ord, ''Generic, ''ToJSON, ''FromJSON, ''ToParamSchema, ''ToSchema, ''ToHttpApiData, ''FromHttpApiData] mapDerive :: (Name -> Q [Dec]) -> [Name] -> Q [Dec] mapDerive f types = fmap concat (mapM f types) -- | Derives standard WEB-classes for a newtype suitable for request parameter deriveNewtypeParam :: Name -> Q [Dec] deriveNewtypeParam typeName = do let typeCon = conT typeName [d| deriving newtype instance Show $(typeCon) deriving newtype instance Eq $(typeCon) deriving newtype instance Ord $(typeCon) deriving newtype instance ToJSON $(typeCon) deriving newtype instance FromJSON $(typeCon) deriving newtype instance ToParamSchema $(typeCon) deriving newtype instance ToHttpApiData $(typeCon) deriving newtype instance FromHttpApiData $(typeCon) |] -- | Derives standard WEB-classes for a type suitable for request parameter deriveParam :: Name -> Q [Dec] deriveParam typeName = do let typeCon = conT typeName [d| deriving stock instance Show $(typeCon) deriving stock instance Eq $(typeCon) deriving stock instance Ord $(typeCon) deriving instance Generic $(typeCon) deriving anyclass instance ToJSON $(typeCon) deriving anyclass instance FromJSON $(typeCon) deriving anyclass instance ToParamSchema $(typeCon) deriving anyclass instance ToHttpApiData $(typeCon) deriving anyclass instance FromHttpApiData $(typeCon) |] -- | Derives standard WEB-classes for a newtype suitable for request body or response deriveNewtypeBody :: Name -> Q [Dec] deriveNewtypeBody typeName = do let typeCon = conT typeName [d| deriving newtype instance Show $(typeCon) deriving newtype instance Eq $(typeCon) deriving newtype instance Ord $(typeCon) deriving newtype instance ToJSON $(typeCon) deriving newtype instance FromJSON $(typeCon) deriving newtype instance ToSchema $(typeCon) |] -- | Derives standard WEB-classes for a type suitable for request body or response deriveBody :: Name -> Q [Dec] deriveBody typeName = do let typeCon = conT typeName [d| deriving instance Show $(typeCon) deriving instance Eq $(typeCon) deriving instance Ord $(typeCon) deriving instance Generic $(typeCon) deriving instance ToJSON $(typeCon) deriving instance FromJSON $(typeCon) deriving instance ToSchema $(typeCon) |] -- | Derives standard WEB-classes for a newtype suitable for request form deriveNewtypeForm :: Name -> Q [Dec] deriveNewtypeForm typeName = do let typeCon = conT typeName [d| deriving newtype instance Show $(typeCon) deriving newtype instance Eq $(typeCon) deriving newtype instance Ord $(typeCon) deriving newtype instance ToForm $(typeCon) deriving newtype instance FromForm $(typeCon) deriving newtype instance ToSchema $(typeCon) |] -- | Derives standard WEB-classes for a type suitable for request form deriveForm :: Name -> Q [Dec] deriveForm typeName = do let typeCon = conT typeName [d| deriving instance Show $(typeCon) deriving instance Eq $(typeCon) deriving instance Ord $(typeCon) deriving instance Generic $(typeCon) deriving instance FromForm $(typeCon) deriving instance ToForm $(typeCon) deriving instance ToSchema $(typeCon) |] deriveNewtypeHttp :: Name -> Q [Dec] deriveNewtypeHttp = deriveNewtypeParamBody deriveHttp :: Name -> Q [Dec] deriveHttp = deriveParamBody -- | Derives standard WEB-classes for a newtype which is both body and param deriveNewtypeParamBody :: Name -> Q [Dec] deriveNewtypeParamBody typeName = do let typeCon = conT typeName [d| deriving newtype instance Show $(typeCon) deriving newtype instance Eq $(typeCon) deriving newtype instance Ord $(typeCon) deriving newtype instance ToJSON $(typeCon) deriving newtype instance FromJSON $(typeCon) deriving newtype instance ToSchema $(typeCon) deriving newtype instance ToParamSchema $(typeCon) deriving newtype instance ToHttpApiData $(typeCon) deriving newtype instance FromHttpApiData $(typeCon) |] -- | Derives standard WEB-classes for a type which is both body and param deriveParamBody :: Name -> Q [Dec] deriveParamBody typeName = do let typeCon = conT typeName [d| deriving stock instance Show $(typeCon) deriving stock instance Eq $(typeCon) deriving stock instance Ord $(typeCon) deriving stock instance Generic $(typeCon) deriving anyclass instance ToJSON $(typeCon) deriving anyclass instance FromJSON $(typeCon) deriving anyclass instance ToSchema $(typeCon) deriving anyclass instance ToParamSchema $(typeCon) deriving anyclass instance ToHttpApiData $(typeCon) deriving anyclass instance FromHttpApiData $(typeCon) |]