{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module: IHP.Router.IHP
Description: IHP-flavoured wrapper around the @ihp-router@ DSL splice

The @ihp-router@ package ships an IHP-free @[routes|…|]@ quasi-quoter
that emits 'HasPath' instances and a parameterised
@\<ctrlLower>Trie :: (Ctrl -> Application) -> RouteTrie@ binding per
controller. Plain WAI users wire that binding into
'IHP.Router.Middleware.routeTrieMiddleware' with their own dispatch
function.

This module is the IHP-specific shim that composes on top:

  * 'routes' \/ 'routesDec' — IHP-flavoured quoter. Emits everything
    'IHP.Router.DSL.TH.genericEmit' produces, plus a 'CanRoute'
    instance per controller (whose @toControllerRoute@ wraps
    @\<ctrlLower>Trie runAction'@ in a 'ControllerRouteTrie') and, for
    lowercase-header blocks, a @webRoutes :: [ControllerRoute app]@
    binding ready for @FrontController.controllers@.
  * 'instance UrlCapture (Id' table)' — IHP's primary-key-driven
    capture. Lives here (not in @ihp-router@) because it needs
    'IHP.ModelSupport.PrimaryKey'.

User code accesses the IHP-flavoured quoter as
@import IHP.Router.DSL (routes)@, which re-exports from this module.
The user-visible import surface is unchanged from before the
extraction.
-}
module IHP.Router.IHP
    ( routes
    , routesDec
    , ihpRoutesDec
    , ihpEmit
    ) where

import Prelude
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as ByteString.Char8
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (Typeable)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH (Q, Dec, Name)
import qualified Language.Haskell.TH.Quote as TH

import IHP.Router.Capture (UrlCapture (..))
import qualified IHP.ModelSupport as ModelSupport
import IHP.Router.DSL.TH
    ( ParsedBlock (..)
    , HeaderForm (..)
    , ControllerInfo (..)
    , parseAndReify
    , genericEmit
    , trieValueName
    )

-- | Captures for IHP 'Id' values route through the table's primary-key type.
-- This works for any table whose 'ModelSupport.PrimaryKey' has a 'UrlCapture'
-- instance — 'UUID', 'Int', 'Integer', 'Text', etc.
--
-- Lives in the IHP shim so that @ihp-router@ can ship without dragging
-- in 'IHP.ModelSupport'. Plain WAI users get the base instances on
-- 'Text' \/ 'Int' \/ 'UUID' etc. from "IHP.Router.Capture"; IHP apps
-- get this orphan in scope automatically through @import IHP.RouterPrelude@.
instance
    ( Typeable table
    , Typeable (ModelSupport.PrimaryKey table)
    , UrlCapture (ModelSupport.PrimaryKey table)
    ) => UrlCapture (ModelSupport.Id' table) where
    parseCapture :: ByteString -> Maybe (Id' table)
parseCapture ByteString
bs = PrimaryKey table -> Id' table
forall (table :: Symbol). PrimaryKey table -> Id' table
ModelSupport.Id (PrimaryKey table -> Id' table)
-> Maybe (PrimaryKey table) -> Maybe (Id' table)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. UrlCapture a => ByteString -> Maybe a
parseCapture @(ModelSupport.PrimaryKey table) ByteString
bs
    {-# INLINE parseCapture #-}
    renderCapture :: Id' table -> Text
renderCapture (ModelSupport.Id PrimaryKey table
pk) = PrimaryKey table -> Text
forall a. UrlCapture a => a -> Text
renderCapture PrimaryKey table
pk
    {-# INLINE renderCapture #-}

-- | The IHP-flavoured @[routes|…|]@ quasi-quoter. Behaves identically
-- to the pre-extraction quoter — re-exports the same 'routesDec' that
-- composes 'genericEmit' with the IHP-specific 'ihpEmit'.
--
-- Use as a top-level declaration in @Web/Routes.hs@:
--
-- > [routes|webRoutes
-- > GET    /Posts                 PostsAction
-- > GET    /ShowPost?postId       ShowPostAction
-- > |]
-- >
-- > instance FrontController WebApplication where
-- >     controllers = webRoutes
routes :: TH.QuasiQuoter
routes :: QuasiQuoter
routes = TH.QuasiQuoter
    { quoteExp :: String -> Q Exp
TH.quoteExp  = \String
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
        ( String
"routes: the [routes|…|] quoter must be used as a top-level "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"declaration, not an expression. "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Put the binding name in the header line:\n\n"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"    [routes|webRoutes\n"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"    GET /posts PostsIndexAction\n"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"    |]\n\n"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"TH can't emit class instances from expression splices, so "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"expression-form usage isn't supported." )
    , quotePat :: String -> Q Pat
TH.quotePat  = \String
_ -> String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"routes: use as a top-level declaration"
    , quoteType :: String -> Q Type
TH.quoteType = \String
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"routes: use as a top-level declaration"
    , quoteDec :: String -> Q [Dec]
TH.quoteDec  = String -> Q [Dec]
routesDec
    }

-- | Underlying TH function for the IHP-flavoured 'routes' quoter.
-- Composes 'genericEmit' (HasPath + per-controller @\<ctrlLower>Trie@
-- bindings) with 'ihpEmit' (IHP @CanRoute@ instance + lowercase-header
-- binding).
routesDec :: String -> Q [Dec]
routesDec :: String -> Q [Dec]
routesDec String
source = do
    block <- String -> Q ParsedBlock
parseAndReify String
source
    generic <- genericEmit block
    ihp <- ihpEmit block
    pure (generic <> ihp)

-- | Alias for 'routesDec'. Exposed so callers that already use the
-- generic 'IHP.Router.DSL.TH.genericRoutesDec' have a matching named
-- entry point on the IHP-flavoured side.
ihpRoutesDec :: String -> Q [Dec]
ihpRoutesDec :: String -> Q [Dec]
ihpRoutesDec = String -> Q [Dec]
routesDec

-- | Emit the IHP-flavoured declarations on top of whatever 'genericEmit'
-- produces:
--
--   * one @instance CanRoute Ctrl@ per controller, whose
--     @toControllerRoute@ wraps @\<ctrlLower>Trie runAction'@ in a
--     'ControllerRouteTrie';
--   * for a lowercase-header block: a top-level
--     @webRoutes :: [ControllerRoute app]@ binding that includes
--     @webSocketRoute \@T \"\/path\"@ entries for each @WS@ route in
--     the block alongside the regular @parseRoute \@Ctrl@ entries.
ihpEmit :: ParsedBlock -> Q [Dec]
ihpEmit :: ParsedBlock -> Q [Dec]
ihpEmit ParsedBlock { HeaderForm
pbHeader :: HeaderForm
pbHeader :: ParsedBlock -> HeaderForm
pbHeader, [(ControllerInfo, [ValidatedRoute])]
pbGroups :: [(ControllerInfo, [ValidatedRoute])]
pbGroups :: ParsedBlock -> [(ControllerInfo, [ValidatedRoute])]
pbGroups, [(Name, ByteString)]
pbWsRoutes :: [(Name, ByteString)]
pbWsRoutes :: ParsedBlock -> [(Name, ByteString)]
pbWsRoutes } = do
    canRouteDecs <- ((ControllerInfo, [ValidatedRoute]) -> Q Dec)
-> [(ControllerInfo, [ValidatedRoute])] -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(ControllerInfo
ctrl, [ValidatedRoute]
_) -> ControllerInfo -> Q Dec
emitCanRoute ControllerInfo
ctrl) [(ControllerInfo, [ValidatedRoute])]
pbGroups
    bindingDecs <- case pbHeader of
        HeaderLowercase Text
name ->
            Text -> [ControllerInfo] -> [(Name, ByteString)] -> Q [Dec]
emitNamedBinding Text
name (((ControllerInfo, [ValidatedRoute]) -> ControllerInfo)
-> [(ControllerInfo, [ValidatedRoute])] -> [ControllerInfo]
forall a b. (a -> b) -> [a] -> [b]
map (ControllerInfo, [ValidatedRoute]) -> ControllerInfo
forall a b. (a, b) -> a
fst [(ControllerInfo, [ValidatedRoute])]
pbGroups) [(Name, ByteString)]
pbWsRoutes
        HeaderForm
_ -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    pure (canRouteDecs <> bindingDecs)

---------------------------------------------------------------------------
-- IHP-specific TH names (resolved at splice use-site)
---------------------------------------------------------------------------

canRouteClass, parseRoutePrimeFn, toControllerRouteFn :: Name
canRouteClass :: Name
canRouteClass       = String -> Name
TH.mkName String
"CanRoute"
parseRoutePrimeFn :: Name
parseRoutePrimeFn   = String -> Name
TH.mkName String
"parseRoute'"
toControllerRouteFn :: Name
toControllerRouteFn = String -> Name
TH.mkName String
"toControllerRoute"

controllerRouteTrieCon, runActionPrimeFn :: Name
controllerRouteTrieCon :: Name
controllerRouteTrieCon = String -> Name
TH.mkName String
"ControllerRouteTrie"
runActionPrimeFn :: Name
runActionPrimeFn       = String -> Name
TH.mkName String
"runAction'"

---------------------------------------------------------------------------
-- Code generation — CanRoute
---------------------------------------------------------------------------

-- | Emit the IHP-flavoured @instance CanRoute Controller@. The body
-- of @toControllerRoute@ references the generic top-level binding
-- emitted by 'IHP.Router.DSL.TH.emitTrieValue' —
-- @\<ctrlLower>Trie runAction'@ — so the generic and IHP halves share
-- one trie expression per controller.
emitCanRoute :: ControllerInfo -> Q Dec
emitCanRoute :: ControllerInfo -> Q Dec
emitCanRoute ControllerInfo
ctrl = do
    let trieValE :: Exp
trieValE = Exp -> Exp -> Exp
TH.AppE
            (Name -> Exp
TH.VarE (Name -> Name
trieValueName (ControllerInfo -> Name
ciTypeName ControllerInfo
ctrl)))
            (Name -> Exp
TH.VarE Name
runActionPrimeFn)
    -- parseRoute' is unused (the trie owns dispatch) but CanRoute still
    -- requires it. Emit `fail "..."` — MonadFail is in base so no extra
    -- import is needed at the call site.
    let parseRouteDecl :: Dec
parseRouteDecl = Name -> [Clause] -> Dec
TH.FunD Name
parseRoutePrimeFn
            [[Pat] -> Body -> [Dec] -> Clause
TH.Clause []
                (Exp -> Body
TH.NormalB
                    (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'fail)
                        (Lit -> Exp
TH.LitE (String -> Lit
TH.StringL
                            String
"routes: parseRoute' is unused; dispatch goes through the trie"))))
                []]
        toControllerRouteDecl :: Dec
toControllerRouteDecl = Name -> [Clause] -> Dec
TH.FunD Name
toControllerRouteFn
            [[Pat] -> Body -> [Dec] -> Clause
TH.Clause []
                (Exp -> Body
TH.NormalB
                    (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.ConE Name
controllerRouteTrieCon) Exp
trieValE))
                []]
    Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
TH.InstanceD Maybe Overlap
forall a. Maybe a
Nothing []
        (Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT Name
canRouteClass) (Name -> Type
TH.ConT (ControllerInfo -> Name
ciTypeName ControllerInfo
ctrl)))
        [Dec
parseRouteDecl, Dec
toControllerRouteDecl])

---------------------------------------------------------------------------
-- Code generation — named binding for lowercase-header form
---------------------------------------------------------------------------

-- | Emit a top-level binding named by the user. Given the header
-- @webRoutes@, HTTP controllers @[PostsController, UsersController]@,
-- and a WS route @WS \/chat ChatApp@:
--
-- > webRoutes =
-- >     [ parseRoute @PostsController
-- >     , parseRoute @UsersController
-- >     , webSocketRoute @ChatApp "\/chat"
-- >     ]
--
-- The binding is polymorphic in the application type; when splatted into
-- 'FrontController.controllers' for a concrete app, GHC infers the right
-- @app@.
--
-- @parseRoute@ carries implicit-parameter constraints ('?request',
-- '?respond', '?application', plus 'Controller', 'CanRoute',
-- 'InitControllerContext', and 'Typeable'); @webSocketRoute@ carries
-- the same implicits but swaps 'Controller' \/ 'CanRoute' for 'WSApp'.
-- GHC cannot abstract those at the use site, so we emit an explicit
-- signature enumerating all of them.
emitNamedBinding :: Text -> [ControllerInfo] -> [(Name, ByteString)] -> Q [Dec]
emitNamedBinding :: Text -> [ControllerInfo] -> [(Name, ByteString)] -> Q [Dec]
emitNamedBinding Text
bindingTxt [ControllerInfo]
ctrls [(Name, ByteString)]
wsBindings = do
    let valName :: Name
valName = String -> Name
TH.mkName (Text -> String
Text.unpack Text
bindingTxt)
        appTyVarName :: Name
appTyVarName = String -> Name
TH.mkName String
"app"
        appTy :: Type
appTy = Name -> Type
TH.VarT Name
appTyVarName
        parseRouteName :: Name
parseRouteName = String -> Name
TH.mkName String
"parseRoute"
        webSocketRouteName :: Name
webSocketRouteName = String -> Name
TH.mkName String
"webSocketRoute"

        httpEntries :: [Exp]
httpEntries =
            [ Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE Name
parseRouteName) (Name -> Type
TH.ConT (ControllerInfo -> Name
ciTypeName ControllerInfo
c))
            | ControllerInfo
c <- [ControllerInfo]
ctrls
            ]
        wsEntries :: [Exp]
wsEntries =
            [ Exp -> Exp -> Exp
TH.AppE
                (Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE Name
webSocketRouteName) (Name -> Type
TH.ConT Name
wsTy))
                (Exp -> Type -> Exp
TH.SigE
                    (Lit -> Exp
TH.LitE (String -> Lit
TH.StringL (ByteString -> String
ByteString.Char8.unpack ByteString
path)))
                    (Name -> Type
TH.ConT (String -> Name
TH.mkName String
"ByteString")))
            | (Name
wsTy, ByteString
path) <- [(Name, ByteString)]
wsBindings
            ]
        bindingExp :: Exp
bindingExp = [Exp] -> Exp
TH.ListE ([Exp]
httpEntries [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<> [Exp]
wsEntries)

        implicitReqTy :: Type
implicitReqTy  = String -> Type -> Type
TH.ImplicitParamT String
"request"  (Name -> Type
TH.ConT (String -> Name
TH.mkName String
"Request"))
        implicitResTy :: Type
implicitResTy  = String -> Type -> Type
TH.ImplicitParamT String
"respond"  (Name -> Type
TH.ConT (String -> Name
TH.mkName String
"Respond"))
        implicitAppTy :: Type
implicitAppTy  = String -> Type -> Type
TH.ImplicitParamT String
"application" Type
appTy
        initContextTy :: Type
initContextTy  = Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT (String -> Name
TH.mkName String
"InitControllerContext")) Type
appTy
        typeableAppTy :: Type
typeableAppTy  = Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''Typeable) Type
appTy
        perCtrl :: ControllerInfo -> [Type]
perCtrl ControllerInfo
ctrl =
            let ctrlTy :: Type
ctrlTy = Name -> Type
TH.ConT (ControllerInfo -> Name
ciTypeName ControllerInfo
ctrl)
             in [ Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT (String -> Name
TH.mkName String
"Controller")) Type
ctrlTy
                , Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT (String -> Name
TH.mkName String
"CanRoute")) Type
ctrlTy
                , Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''Typeable) Type
ctrlTy
                ]
        perWs :: (Name, b) -> [Type]
perWs (Name
wsTy, b
_) =
            let ty :: Type
ty = Name -> Type
TH.ConT Name
wsTy
             in [ Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT (String -> Name
TH.mkName String
"WSApp")) Type
ty
                , Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''Typeable) Type
ty
                ]
        ctx :: [Type]
ctx = Type
implicitReqTy Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type
implicitResTy Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type
implicitAppTy
            Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type
initContextTy Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type
typeableAppTy
            Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (ControllerInfo -> [Type]) -> [ControllerInfo] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ControllerInfo -> [Type]
perCtrl [ControllerInfo]
ctrls
            [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> ((Name, ByteString) -> [Type]) -> [(Name, ByteString)] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, ByteString) -> [Type]
forall {b}. (Name, b) -> [Type]
perWs [(Name, ByteString)]
wsBindings
        resultTy :: Type
resultTy = Type -> Type -> Type
TH.AppT Type
TH.ListT
            (Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT (String -> Name
TH.mkName String
"ControllerRoute")) Type
appTy)
        bindingTy :: Type
bindingTy = [TyVarBndr Specificity] -> [Type] -> Type -> Type
TH.ForallT [Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV Name
appTyVarName Specificity
TH.SpecifiedSpec] [Type]
ctx Type
resultTy

    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Name -> Type -> Dec
TH.SigD Name
valName Type
bindingTy
        , Name -> [Clause] -> Dec
TH.FunD Name
valName [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [] (Exp -> Body
TH.NormalB Exp
bindingExp) []]
        ]