{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Yesod.Trans.TH
  ( defaultYesodInstanceExcept
  ) where

import Yesod.Site.Util
import Yesod.Trans.Class

import Data.Coerce
import Yesod.Core
  ( Approot (..)
  , guessApproot
  , HtmlUrl
  , RenderRoute (..)
  , ScriptLoadPosition (..)
  , Yesod (..)
  )

import Language.Haskell.TH

coerceHtmlUrl
  :: SiteCompatible site site'
  => HtmlUrl (Route site) -> HtmlUrl (Route site')
coerceHtmlUrl :: HtmlUrl (Route site) -> HtmlUrl (Route site')
coerceHtmlUrl HtmlUrl (Route site)
url = HtmlUrl (Route site)
url HtmlUrl (Route site)
-> ((Route site' -> [(Text, Text)] -> Text) -> Render (Route site))
-> HtmlUrl (Route site')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Route site' -> [(Text, Text)] -> Text)
-> (Route site -> Route site') -> Render (Route site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Route site -> Route site'
coerce)

-- | Fills in an instance for the 'Yesod' class for a 'SiteTrans' wrapper with
-- implementations which just invoke the base class, *except* for those implementations
-- which are defined on the instance itself.
--
-- This is useful for 'SiteTrans' implementations that want to modify some of
-- the 'Yesod' behaviour of the site, but mostly want to delegate behaviour to
-- the base site. Instead of writing out a whole 'Yesod' instance, you can just
-- override the class methods that you need. The rest will be filled in with
-- working implementations that do what you expect.
defaultYesodInstanceExcept
  :: Q Exp -- ^ How to go from the wrapped site to the base site.
           -- If the instance is for a type of the form 't site', then this
           -- should be an expression of type 't site -> site'. This operation
           -- is necessary to use some of the default implementations.
  -> Q [Dec] -- ^ The partial 'Yesod' instance. Should just be a since @instance@
             -- declaration, except that its body can be as empty as you like. For
             -- example:
             --
             -- @
             -- defaultYesodInstanceExcept [| myLowerer |] [d|
             --   instance (Yesod site) => Yesod (MyWrapper site) where
             --     yesodMiddleware = ... -- insert some middleware
             --
             --     -- But everything else should be defined in the default way
             --   |]
             -- @
             --
             -- This declaration will include the custom definition for
             -- 'yesodMiddleware', as well as implementations for the other
             -- class methods that just delegate to the base class.
  -> Q [Dec]
defaultYesodInstanceExcept :: Q Exp -> Q [Dec] -> Q [Dec]
defaultYesodInstanceExcept Q Exp
baseSite Q [Dec]
partialInstanceQ = do
  [InstanceD Maybe Overlap
overlap Cxt
ctxt Type
instanceHead [Dec]
exceptions] <- Q [Dec]
partialInstanceQ
  [Dec]
defaultImplementations <- Q [Dec]
defaultImplementationsQ

  let fullBody :: [Dec]
fullBody = [Dec]
exceptions [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> ((Dec -> Bool) -> [Dec] -> [Dec]
forall a. (a -> Bool) -> [a] -> [a]
filter (Dec -> [Dec] -> Bool
`undeclaredIn` [Dec]
exceptions) [Dec]
defaultImplementations)

  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
overlap Cxt
ctxt Type
instanceHead [Dec]
fullBody]
  where
    decName :: Dec -> Maybe Name
    decName :: Dec -> Maybe Name
decName (FunD Name
name [Clause]
_) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name
    decName (ValD (VarP Name
name) Body
_ [Dec]
_) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name
    decName Dec
_ = Maybe Name
forall a. Maybe a
Nothing

    undeclaredIn :: Dec -> [Dec] -> Bool
    undeclaredIn :: Dec -> [Dec] -> Bool
undeclaredIn Dec
dec
      | Just Name
name <- Dec -> Maybe Name
decName Dec
dec
      = Bool -> Bool
not (Bool -> Bool) -> ([Dec] -> Bool) -> [Dec] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> Bool) -> [Dec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> (Name -> Bool) -> Maybe Name -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name) (Maybe Name -> Bool) -> (Dec -> Maybe Name) -> Dec -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Maybe Name
decName)
    undeclaredIn Dec
_ = Bool -> [Dec] -> Bool
forall a b. a -> b -> a
const Bool
True

    defaultImplementationsQ :: Q [Dec]
defaultImplementationsQ = [d|
      $(pure $ VarP 'approot) = case $([|approot|]) of
        ApprootRelative -> ApprootRelative
        ApprootStatic t -> ApprootStatic t
        ApprootMaster f -> ApprootMaster (f . $(baseSite))
        ApprootRequest f -> ApprootRequest (f. $(baseSite))
        -- Approot is non-exhaustive, so for API compatibility, we need a
        -- (apparently redundant) fallthrough case
        _ -> guessApproot

      $(pure $ VarP 'errorHandler) = lift . $([|errorHandler|])

      $(pure $ VarP 'defaultLayout) = mapSiteT $([|defaultLayout|])

      $(pure $ VarP 'urlParamRenderOverride) = \site route ->
        $([|urlParamRenderOverride|]) ($(baseSite) site) (coerce route)

      $(pure $ VarP 'isAuthorized) = \route isWrite ->
        lift ($([|isAuthorized|]) (coerce route) isWrite)

      $(pure $ VarP 'isWriteRequest)
        = lift . $([|isWriteRequest|]) . coerce

      $(pure $ VarP 'authRoute)
        = fmap coerce . $([|authRoute|]) . $(baseSite)

      $(pure $ VarP 'cleanPath) = $([|cleanPath|]) . $(baseSite)

      $(pure $ VarP 'joinPath) = $([|joinPath|]) . $(baseSite)

      $(pure $ VarP 'addStaticContent) = \fn mime content -> do
        ret <- lift $ $([|addStaticContent|]) fn mime content
        pure $ case ret of
          Nothing -> Nothing
          Just (Left t) -> Just (Left t)
          Just (Right (route, params))
            -> Just (Right (coerce route, params))

      $(pure $ VarP 'maximumContentLength) = \site mRoute ->
        $([|maximumContentLength|]) ($(baseSite) site) (coerce <$> mRoute)

      $(pure $ VarP 'maximumContentLengthIO) = \site mRoute ->
        $([|maximumContentLengthIO|]) ($(baseSite) site) (coerce <$> mRoute)

      $(pure $ VarP 'makeLogger)
         = $([|makeLogger|]) . $(baseSite)

      $(pure $ VarP 'messageLoggerSource)
        = $([|messageLoggerSource|]) . $(baseSite)

      $(pure $ VarP 'jsLoader) = \site ->
        case $([|jsLoader|]) ($(baseSite) site) of
            BottomOfBody -> BottomOfBody
            BottomOfHeadBlocking -> BottomOfHeadBlocking
            BottomOfHeadAsync async
              -> BottomOfHeadAsync
                  (\urls mHtml ->
                      coerceHtmlUrl $ async urls (coerceHtmlUrl <$> mHtml))

      $(pure $ VarP 'jsAttributes)
        = $([|jsAttributes|]) . $(baseSite)

      $(pure $ VarP 'jsAttributesHandler)
        = lift $([|jsAttributesHandler|])

      $(pure $ VarP 'makeSessionBackend)
        = $([|makeSessionBackend|]) . $(baseSite)

      $(pure $ VarP 'fileUpload)
        = $([|fileUpload|]) . $(baseSite)

      $(pure $ VarP 'shouldLogIO)
        = $([|shouldLogIO|]) . $(baseSite)

      $(pure $ VarP 'yesodMiddleware)
        = mapSiteT $([|yesodMiddleware|])

      $(pure $ VarP 'yesodWithInternalState) = \site mRoute ->
        $([|yesodWithInternalState|]) ($(baseSite) site) (coerce <$> mRoute)

      $(pure $ VarP 'defaultMessageWidget) = \html url ->
        lift $ $([|defaultMessageWidget|]) html (url . coerce)
      |]