Config.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use newtype instead of data" #-}

module DomainDriven.Server.Config
    ( module DomainDriven.Server.Config
    , Name
    )
where

import Data.Char (isLower)
import qualified Data.List as L
import qualified Data.Map as M
import DomainDriven.Server.Class
import DomainDriven.Server.Types
import GHC.Generics (Generic)
import Language.Haskell.TH
import Lens.Micro ((%~), _2)
import Prelude

-- | Configuration used to generate server
-- This is expected to be generated by `mkServerConfig`. It is only explicit due to
-- the GHC stage restrictions.
data ServerConfig = ServerConfig
    { allApiOptions :: M.Map String ApiOptions
    -- ^ Map of API options for all action GADTs used in the API
    }
    deriving (Show, Generic)

class HasApiOptions (action :: Action) where
    apiOptions :: ApiOptions
    apiOptions = defaultApiOptions

defaultServerConfig :: ServerConfig
defaultServerConfig = ServerConfig M.empty

-- | Generate a server configuration and give it the specified name
mkServerConfig :: String -> Q [Dec]
mkServerConfig (mkName -> cfgName) = do
    sig' <- sigD cfgName (conT ''ServerConfig)
    body' <-
        [d|$(varP cfgName) = ServerConfig $(getApiOptionsMap)|]
    pure $ sig' : body'

-- | Generates `Map String ApiOptions`
-- Containing the ApiOptions of all types with an ApiOpts instance
getApiOptionsMap :: Q Exp
getApiOptionsMap =
    reify ''HasApiOptions >>= \case
        ClassI _ instances -> do
            cfgs <- traverse nameAndCfg instances
            [e|M.fromList $(pure $ ListE cfgs)|]
        i -> fail $ "Expected ClassI but got: " <> show i
  where
    nameAndCfg :: Dec -> Q Exp
    nameAndCfg = \case
        InstanceD _ _ (AppT klass ty') _ | klass == ConT ''HasApiOptions -> do
            (name, ty) <- getNameAndTypePattern ty'
            [e|
                ( $(stringE $ show name)
                , apiOptions @($(pure ty))
                )
                |]
        d -> fail $ "Expected instance InstanceD but got: " <> show d

    getNameAndTypePattern :: Type -> Q (Name, Type)
    getNameAndTypePattern = \case
        ty@(ConT n) -> pure (n, ty)
        AppT ty _ -> (_2 %~ (`AppT` WildCardT)) <$> getNameAndTypePattern ty
        ty -> fail $ "stipExtraParams: Expected to find constructor, got: " <> show ty

------------------------------------------------------------------------------------------
-- Some utility functions that can be useful when remapping names
------------------------------------------------------------------------------------------
dropPrefix :: String -> String -> String
dropPrefix pre s = if pre `L.isPrefixOf` s then drop (length pre) s else s

dropSuffix :: String -> String -> String
dropSuffix pre s = if pre `L.isSuffixOf` s then take (length s - length pre) s else s

dropFirstWord :: String -> String
dropFirstWord = L.dropWhile isLower . drop 1