mig-extra-0.1.0.0: src/Mig/Extra/Derive.hs

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