module DomainDriven.Server.Helpers where

import Control.Monad
import Control.Monad.State
import Data.Generics.Product
import qualified Data.List as L
import DomainDriven.Internal.Text
import DomainDriven.Server.Types
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (OccName (..))
import Lens.Micro
import Prelude

runServerGenM :: ServerGenState -> ServerGenM a -> Q a
runServerGenM :: forall a. ServerGenState -> ServerGenM a -> Q a
runServerGenM ServerGenState
s ServerGenM a
m = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall a. ServerGenM a -> StateT ServerGenState Q a
unServerGenM ServerGenM a
m) ServerGenState
s

liftQ :: Q a -> ServerGenM a
liftQ :: forall a. Q a -> ServerGenM a
liftQ Q a
m = forall a. StateT ServerGenState Q a -> ServerGenM a
ServerGenM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q a
m

withLocalState :: (ServerGenState -> ServerGenState) -> ServerGenM a -> ServerGenM a
withLocalState :: forall a.
(ServerGenState -> ServerGenState) -> ServerGenM a -> ServerGenM a
withLocalState ServerGenState -> ServerGenState
fs ServerGenM a
m = forall a. StateT ServerGenState Q a -> ServerGenM a
ServerGenM forall a b. (a -> b) -> a -> b
$ do
    ServerGenState
startState <- forall s (m :: * -> *). MonadState s m => m s
get
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ServerGenState -> ServerGenState
fs
    a
a <- forall a. ServerGenM a -> StateT ServerGenState Q a
unServerGenM ServerGenM a
m
    forall s (m :: * -> *). MonadState s m => s -> m ()
put ServerGenState
startState
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

mkUrlSegment :: ConstructorName -> ServerGenM UrlSegment
mkUrlSegment :: ConstructorName -> ServerGenM UrlSegment
mkUrlSegment ConstructorName
n = do
    ApiOptions
opts <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"options")
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        ConstructorName
n
            forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Name String
unqualifiedString
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to (ApiOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"renameConstructor")
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to String -> UrlSegment
UrlSegment

unqualifiedString :: Lens' Name String
unqualifiedString :: Lens' Name String
unqualifiedString = forall a s. HasType a s => Lens s s a a
typed @OccName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed

askTypeName :: ServerGenM Name
askTypeName :: ServerGenM Name
askTypeName = do
    ServerGenState
si <- forall s (m :: * -> *). MonadState s m => m s
get
    let baseName :: String
        baseName :: String
baseName =
            ServerGenState
si forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"baseGadt" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Name String
unqualifiedString

        cNames :: [String]
        cNames :: [String]
cNames =
            ServerGenState
si
                forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info"
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @[ConstructorName]
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Name
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Name String
unqualifiedString
        separator :: String
        separator :: String
separator = ServerGenState
si forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @ApiOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"typenameSeparator"

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
L.intercalate String
separator forall a b. (a -> b) -> a -> b
$ String
baseName forall a. a -> [a] -> [a]
: [String]
cNames

askApiTypeName :: ServerGenM Name
askApiTypeName :: ServerGenM Name
askApiTypeName = (Lens' Name String
unqualifiedString forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ String
"Api") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerGenM Name
askTypeName

askEndpointTypeName :: ServerGenM Name
askEndpointTypeName :: ServerGenM Name
askEndpointTypeName = (Lens' Name String
unqualifiedString forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ String
"Endpoint") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerGenM Name
askTypeName

askServerName :: ServerGenM Name
askServerName :: ServerGenM Name
askServerName =
    (\Name
n -> Name
n forall a b. a -> (a -> b) -> b
& Lens' Name String
unqualifiedString forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ String -> String
lowerFirst forall a b. a -> (a -> b) -> b
& Lens' Name String
unqualifiedString forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ String
"Server")
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerGenM Name
askTypeName

askHandlerName :: ServerGenM Name
askHandlerName :: ServerGenM Name
askHandlerName =
    (\Name
n -> Name
n forall a b. a -> (a -> b) -> b
& Lens' Name String
unqualifiedString forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ String -> String
lowerFirst forall a b. a -> (a -> b) -> b
& Lens' Name String
unqualifiedString forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ String
"Handler")
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerGenM Name
askTypeName

askBodyTag :: ConstructorName -> ServerGenM TyLit
askBodyTag :: ConstructorName -> ServerGenM TyLit
askBodyTag ConstructorName
cName = do
    UrlSegment
constructorSegment <- ConstructorName -> ServerGenM UrlSegment
mkUrlSegment ConstructorName
cName
    UrlSegment
gadtSegment <-
        forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"options" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"bodyNameBase") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just String
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> UrlSegment
UrlSegment String
n
            Maybe String
Nothing ->
                forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets
                    ( forall s a. s -> Getting a s a -> a
^.
                        forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info"
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"currentGadt"
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Name -> String
nameBase
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to String -> UrlSegment
UrlSegment
                    )

    String
separator <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @ApiOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"typenameSeparator")
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLit
StrTyLit
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
L.intercalate String
separator
        forall a b. (a -> b) -> a -> b
$ (UrlSegment
gadtSegment forall a. a -> [a] -> [a]
: [UrlSegment
constructorSegment])
            forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed

enterApi :: ApiSpec -> ServerGenM a -> ServerGenM a
enterApi :: forall a. ApiSpec -> ServerGenM a -> ServerGenM a
enterApi ApiSpec
spec ServerGenM a
m = forall a.
(ServerGenState -> ServerGenState) -> ServerGenM a -> ServerGenM a
withLocalState (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info" forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ServerInfo -> ServerInfo
extendServerInfo) ServerGenM a
m
  where
    extendServerInfo :: ServerInfo -> ServerInfo
    extendServerInfo :: ServerInfo -> ServerInfo
extendServerInfo ServerInfo
i =
        ServerInfo
i forall a b. a -> (a -> b) -> b
& forall a s. HasType a s => Lens s s a a
typed forall s t a b. ASetter s t a b -> b -> s -> t
.~ ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @ApiOptions forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"currentGadt" forall s t a b. ASetter s t a b -> b -> s -> t
.~ ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed

enterApiPiece :: ApiPiece -> ServerGenM a -> ServerGenM a
enterApiPiece :: forall a. ApiPiece -> ServerGenM a -> ServerGenM a
enterApiPiece ApiPiece
p ServerGenM a
m = do
    UrlSegment
newSegment <- ConstructorName -> ServerGenM UrlSegment
mkUrlSegment (ApiPiece
p forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @ConstructorName)
    let extendServerInfo :: ServerInfo -> ServerInfo
        extendServerInfo :: ServerInfo -> ServerInfo
extendServerInfo ServerInfo
i =
            ServerInfo
i
                forall a b. a -> (a -> b) -> b
& (forall a s. HasType a s => Lens s s a a
typed @[UrlSegment] forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [UrlSegment
newSegment])
                forall a b. a -> (a -> b) -> b
& (forall a s. HasType a s => Lens s s a a
typed @[ConstructorName] forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ ApiPiece
p forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    forall a.
(ServerGenState -> ServerGenState) -> ServerGenM a -> ServerGenM a
withLocalState (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info" forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ServerInfo -> ServerInfo
extendServerInfo) ServerGenM a
m

hasJsonContentType :: HandlerSettings -> Bool
hasJsonContentType :: HandlerSettings -> Bool
hasJsonContentType HandlerSettings
hs = case HandlerSettings
hs forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"contentTypes" of
    AppT (AppT Type
PromotedConsT (ConT Name
n)) (SigT Type
PromotedNilT (AppT Type
ListT Type
StarT)) ->
        Name -> String
nameBase Name
n forall a. Eq a => a -> a -> Bool
== String
"JSON"
    Type
_ -> Bool
False