{-# 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
    { ServerConfig -> Map String ApiOptions
allApiOptions :: M.Map String ApiOptions
    -- ^ Map of API options for all action GADTs used in the API
    }
    deriving (Int -> ServerConfig -> ShowS
[ServerConfig] -> ShowS
ServerConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerConfig] -> ShowS
$cshowList :: [ServerConfig] -> ShowS
show :: ServerConfig -> String
$cshow :: ServerConfig -> String
showsPrec :: Int -> ServerConfig -> ShowS
$cshowsPrec :: Int -> ServerConfig -> ShowS
Show, forall x. Rep ServerConfig x -> ServerConfig
forall x. ServerConfig -> Rep ServerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ServerConfig x -> ServerConfig
$cfrom :: forall x. ServerConfig -> Rep ServerConfig x
Generic)

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

defaultServerConfig :: ServerConfig
defaultServerConfig :: ServerConfig
defaultServerConfig = Map String ApiOptions -> ServerConfig
ServerConfig forall k a. Map k a
M.empty

-- | Generate a server configuration and give it the specified name
mkServerConfig :: String -> Q [Dec]
mkServerConfig :: String -> Q [Dec]
mkServerConfig (String -> Name
mkName -> Name
cfgName) = do
    Dec
sig' <- forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
cfgName (forall (m :: * -> *). Quote m => Name -> m Type
conT ''ServerConfig)
    [Dec]
body' <-
        [d|$(varP cfgName) = ServerConfig $(getApiOptionsMap)|]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Dec
sig' forall a. a -> [a] -> [a]
: [Dec]
body'

-- | Generates `Map String ApiOptions`
-- Containing the ApiOptions of all types with an ApiOpts instance
getApiOptionsMap :: Q Exp
getApiOptionsMap :: Q Exp
getApiOptionsMap =
    Name -> Q Info
reify ''HasApiOptions forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ClassI Dec
_ [Dec]
instances -> do
            [Exp]
cfgs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Dec -> Q Exp
nameAndCfg [Dec]
instances
            [e|M.fromList $(pure $ ListE cfgs)|]
        Info
i -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected ClassI but got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Info
i
  where
    nameAndCfg :: Dec -> Q Exp
    nameAndCfg :: Dec -> Q Exp
nameAndCfg = \case
        InstanceD Maybe Overlap
_ Cxt
_ (AppT Type
klass Type
ty') [Dec]
_ | Type
klass forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''HasApiOptions -> do
            (Name
name, Type
ty) <- Type -> Q (Name, Type)
getNameAndTypePattern Type
ty'
            [e|
                ( $(stringE $ show name)
                , apiOptions @($(pure ty))
                )
                |]
        Dec
d -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected instance InstanceD but got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Dec
d

    getNameAndTypePattern :: Type -> Q (Name, Type)
    getNameAndTypePattern :: Type -> Q (Name, Type)
getNameAndTypePattern = \case
        ty :: Type
ty@(ConT Name
n) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, Type
ty)
        AppT Type
ty Type
_ -> (forall s t a b. Field2 s t a b => Lens s t a b
_2 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Type -> Type -> Type
`AppT` Type
WildCardT)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q (Name, Type)
getNameAndTypePattern Type
ty
        Type
ty -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"stipExtraParams: Expected to find constructor, got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Type
ty

------------------------------------------------------------------------------------------
-- Some utility functions that can be useful when remapping names
------------------------------------------------------------------------------------------
dropPrefix :: String -> String -> String
dropPrefix :: String -> ShowS
dropPrefix String
pre String
s = if String
pre forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
s then forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pre) String
s else String
s

dropSuffix :: String -> String -> String
dropSuffix :: String -> ShowS
dropSuffix String
pre String
s = if String
pre forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` String
s then forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pre) String
s else String
s

dropFirstWord :: String -> String
dropFirstWord :: ShowS
dropFirstWord = forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile Char -> Bool
isLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1