{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances  #-}
{-|
Module: IHP.ViewSupport
Description: Provides functions to be used in all views
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.ViewSupport
( HtmlWithContext
, Layout
, Html
, View (..)
, currentViewId
, forEach
, isActivePath
, isActivePathOrSub
, css
, onClick
, onLoad
, theRequest
, viewContext
, addStyle
, ViewFetchHelpMessage
, param
, fetch
, query
, isActiveController
, isActiveAction
, nl2br
, stripTags
, theCSSFramework
, fromCSSFramework
, liveReloadWebsocketUrl
) where

import IHP.Prelude
import qualified Text.Blaze.Html5 as Html5
import IHP.ControllerSupport
import IHP.ModelSupport
import qualified Data.Aeson as JSON
import qualified Data.Text as Text
import qualified Data.Typeable as Typeable
import qualified Text.Inflections as Inflector
import qualified Data.Either as Either
import GHC.TypeLits as T
import qualified Data.ByteString as ByteString
import IHP.RouterSupport hiding (get)
import qualified Network.Wai as Wai
import Text.Blaze.Html5.Attributes as A
import IHP.HSX.QQ (hsx)
import IHP.HSX.ToHtml
import qualified Data.Sequences as Sequences
import qualified IHP.Controller.RequestContext
import qualified IHP.View.CSSFramework as CSSFramework ()
import IHP.View.Types
import qualified IHP.FrameworkConfig as FrameworkConfig
import IHP.Controller.Context


class View theView where
    -- | Hook which is called before the render is called
    beforeRender :: (?context :: ControllerContext) => theView -> IO ()
    beforeRender theView
view = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- Renders the view as html
    html :: (?context :: ControllerContext, ?view :: theView) => theView -> Html5.Html

    -- | Renders the view to a JSON
    json :: theView -> JSON.Value
    json = forall a. Text -> a
error Text
"Json View for this route is not implemented"

-- | Returns a string to be used as a html id attribute for the current view.
-- E.g. when calling @currentViewId@ while rendering the view @Web.View.Projects.Show@, this will return @"projects-show"@
--
-- Useful to automatically scope certain css rules to a specific view.
-- Example:
--
-- > module Web.View.Projects.Show where
-- > render = [hsx|<div id={currentViewId}>Hello World!</div>|]
--
-- This will render @<div id="projects-show">Hello World!</div>@
{-# INLINE currentViewId #-}
currentViewId :: (?view :: view, Typeable view) => Text
currentViewId :: forall view. (?view::view, Typeable view) => Text
currentViewId =
        case [Text]
moduleParts of
            [Text
_, Text
"View", Text
controllerName, Text
viewName] -> forall b a. b -> Either a b -> b
Either.fromRight (forall a. Text -> a
error Text
"currentViewId: Failed to parse controller name") (Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toDashed Text
controllerName) forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> forall b a. b -> Either a b -> b
Either.fromRight (forall a. Text -> a
error Text
"currentViewId: Failed to parse view name") (Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toDashed Text
viewName)
            [Text]
_ -> forall a. Text -> a
error (Text
"currentViewId: Failed to read view id for " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs Text
moduleName)
    where
        constructor :: TyCon
constructor = TypeRep -> TyCon
Typeable.typeRepTyCon (forall a. Typeable a => a -> TypeRep
Typeable.typeOf ?view::view
?view)

        -- Module name: Web.View.Projects.Show
        moduleName :: Text
        moduleName :: Text
moduleName = forall a b. ConvertibleStrings a b => a -> b
cs (TyCon -> String
Typeable.tyConModule TyCon
constructor)

        moduleParts :: [Text]
        moduleParts :: [Text]
moduleParts = Text -> Text -> [Text]
Text.splitOn Text
"." Text
moduleName

-- | Returns @True@ when the current request path matches the path given as argument. Takes into account the search query: @?name=value@
--
-- __Example:__ The browser has requested the url @\/Projects@.
--
-- >>> isActivePath "/Projects"
-- True
--
-- Returns @True@ because @"\/Projects"@ is the current requested path.
--
-- >>> isActivePath "/Users"
-- False
--
-- Returns false because @"/Users"@ is not @"/Projects"@
--
-- __Example:__ The browser has requested the url @\/Projects@.
--
-- >>> isActivePath "/Projects/1"
-- False
--
-- This function returns @False@ when a sub-path is request. Use 'isActivePathOrSub' if you want this example to return @True@.
isActivePath :: (?context :: ControllerContext, PathString controller) => controller -> Bool
isActivePath :: forall controller.
(?context::ControllerContext, PathString controller) =>
controller -> Bool
isActivePath controller
route =
    let
        currentPath :: ByteString
currentPath = Request -> ByteString
Wai.rawPathInfo (?context::ControllerContext) => Request
theRequest forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Wai.rawQueryString (?context::ControllerContext) => Request
theRequest
    in
        ByteString
currentPath forall a. Eq a => a -> a -> Bool
== forall a b. ConvertibleStrings a b => a -> b
cs (forall a. PathString a => a -> Text
pathToString controller
route)

-- | Returns @True@ when the current request path starts with the path given as argument.
--
-- __Example:__ The browser has requested the url @\/Projects/1@.
--
-- >>> isActivePathOrSub "/Projects"
-- True
--
-- __Example:__ The browser has requested the url @\/Projects@.
--
-- >>> isActivePathOrSub "/Projects"
-- True
--
-- Also see 'isActivePath'.
isActivePathOrSub :: (?context :: ControllerContext, PathString controller) => controller -> Bool
isActivePathOrSub :: forall controller.
(?context::ControllerContext, PathString controller) =>
controller -> Bool
isActivePathOrSub controller
route =
    let
        currentPath :: ByteString
currentPath = Request -> ByteString
Wai.rawPathInfo (?context::ControllerContext) => Request
theRequest
    in
        forall a b. ConvertibleStrings a b => a -> b
cs (forall a. PathString a => a -> Text
pathToString controller
route) ByteString -> ByteString -> Bool
`ByteString.isPrefixOf` ByteString
currentPath

-- | Returns @True@ when the given type matches the type of the currently executed controller action
--
-- __Example:__ The browser has requested @\/Posts@ and the @Posts@ action of the @PostsController@ is called.
--
-- >>> isActiveController @PostsController
-- True
--
-- Returns @True@ because the current action is part of the @PostsController@
isActiveController :: forall controller. (?context :: ControllerContext, Typeable controller) => Bool
isActiveController :: forall {k} (controller :: k).
(?context::ControllerContext, Typeable controller) =>
Bool
isActiveController =
    let
        (ActionType TypeRep
actionType) = forall value.
(?context::ControllerContext, Typeable value) =>
value
fromFrozenContext @ActionType
    in
        (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep @Proxy @controller (forall {k} (t :: k). Proxy t
Proxy @controller)) forall a. Eq a => a -> a -> Bool
== TypeRep
actionType

-- | Returns @True@ when the given action matches the path of the currently executed action
--
-- __Example:__ The browser has requested @\/PostsAction@.
--
-- >>> isActiveAction PostsAction
-- True
--
-- Returns @True@ because the current path is the same as the path to the action, does not take into account the search query.
-- Use 'isActivePath' if you need to match path and search query.
isActiveAction :: forall controllerAction. (?context::ControllerContext, HasPath controllerAction) => controllerAction -> Bool
isActiveAction :: forall controllerAction.
(?context::ControllerContext, HasPath controllerAction) =>
controllerAction -> Bool
isActiveAction controllerAction
controllerAction =
    let
        currentPath :: ByteString
currentPath = Request -> ByteString
Wai.rawPathInfo (?context::ControllerContext) => Request
theRequest
    in
        ByteString
currentPath forall a. Eq a => a -> a -> Bool
== forall a b. ConvertibleStrings a b => a -> b
cs (forall controller. HasPath controller => controller -> Text
pathTo controllerAction
controllerAction)

css :: QuasiQuoter
css = QuasiQuoter
plain

onClick :: AttributeValue -> Attribute
onClick = AttributeValue -> Attribute
A.onclick
onLoad :: AttributeValue -> Attribute
onLoad = AttributeValue -> Attribute
A.onload

-- | Returns the current request
theRequest :: (?context :: ControllerContext) => Wai.Request
theRequest :: (?context::ControllerContext) => Request
theRequest =
    let
        requestContext :: RequestContext
requestContext = forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"requestContext" ?context::ControllerContext
?context
        request :: Request
request = forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"request" RequestContext
requestContext
    in Request
request
{-# INLINE theRequest #-}

class PathString a where
    pathToString :: a -> Text

instance PathString Text where
    pathToString :: Text -> Text
pathToString Text
path = Text
path

instance {-# OVERLAPPABLE #-} HasPath action => PathString action where
    pathToString :: action -> Text
pathToString = forall controller. HasPath controller => controller -> Text
pathTo

-- | Alias for @?context@
viewContext :: (?context :: ControllerContext) => ControllerContext
viewContext :: (?context::ControllerContext) => ControllerContext
viewContext = ?context::ControllerContext
?context
{-# INLINE viewContext #-}

-- | Adds an inline style element to the html.
--
-- This helps to work around the issue, that our HSX parser cannot deal with CSS yet.
--
-- __Example:__
--
-- > myStyle = addStyle "#my-div { color: blue; }"
-- > [hsx|{myStyle}<div id="my-div">Hello World</div>|]
--
-- This will render like:
--
-- > <style>
-- >     #my-div { color: blue; }
-- > </style>
-- > <div id="my-div">Hello World</div>
addStyle :: (ConvertibleStrings string Text) => string -> Html5.Markup
addStyle :: forall string. ConvertibleStrings string Text => string -> Markup
addStyle string
style = Markup -> Markup
Html5.style (Text -> Markup
Html5.preEscapedText (forall a b. ConvertibleStrings a b => a -> b
cs string
style))
{-# INLINE addStyle #-}

-- | This class provides helpful compile-time error messages when you use common
-- controller functions inside of your views.
class ViewParamHelpMessage where
    param :: a

instance (T.TypeError (T.Text "‘param‘ can only be used inside your controller actions.\nYou have to run the ‘param \"my_param\"‘ call inside your controller and then pass the resulting value to your view.\n\nController Example:\n\n    module Web.Controller.Projects\n\n    instance Controller ProjectsController where\n        action ProjectsAction = do\n            let showDetails = param \"showDetails\"\n            render ProjectsView { showDetails }\n\nView Example:\n\n    module Web.View.Projects.Index\n\n    data ProjectsView = ProjectsView { showDetails :: Bool }\n    instance View ProjectsView where\n        html ProjectsView { .. } = [hsx|Show details: {showDetails}|]\n\n")) => ViewParamHelpMessage where
    param :: forall a. a
param = forall a. Text -> a
error Text
"unreachable"

-- | This class provides helpful compile-time error messages when you use common
-- controller functions inside of your views.
class ViewFetchHelpMessage where
    fetch :: a
    query :: a
instance (T.TypeError (T.Text "‘fetch‘ or ‘query‘ can only be used inside your controller actions. You have to call it from your controller action and then pass the result to the view.")) => ViewFetchHelpMessage where
    fetch :: forall a. a
fetch = forall a. Text -> a
error Text
"unreachable"
    query :: forall a. a
query = forall a. Text -> a
error Text
"unreachable"

instance (T.TypeError (T.Text "Looks like you forgot to pass a " :<>: (T.ShowType (GetModelByTableName record)) :<>: T.Text " id to this data constructor.")) => Eq (Id' (record :: T.Symbol) -> controller) where
    Id' record -> controller
a == :: (Id' record -> controller) -> (Id' record -> controller) -> Bool
== Id' record -> controller
b = forall a. Text -> a
error Text
"unreachable"

fromCSSFramework :: (?context :: ControllerContext, KnownSymbol field, HasField field CSSFramework (CSSFramework -> appliedFunction)) => Proxy field -> appliedFunction
fromCSSFramework :: forall (field :: Symbol) appliedFunction.
(?context::ControllerContext, KnownSymbol field,
 HasField field CSSFramework (CSSFramework -> appliedFunction)) =>
Proxy field -> appliedFunction
fromCSSFramework Proxy field
field = let cssFramework :: CSSFramework
cssFramework = (?context::ControllerContext) => CSSFramework
theCSSFramework in (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy field
field CSSFramework
cssFramework) CSSFramework
cssFramework

theCSSFramework :: (?context :: ControllerContext) => CSSFramework
theCSSFramework :: (?context::ControllerContext) => CSSFramework
theCSSFramework = ?context::ControllerContext
?context.frameworkConfig.cssFramework

-- | Replaces all newline characters with a @<br>@ tag. Useful for displaying preformatted text.
--
-- >>> nl2br "Hello\nWorld!"
-- [hsx|Hello<br/>World!|]
nl2br :: (Sequences.Textual text, ToHtml text) => text -> Html5.Html
nl2br :: forall text. (Textual text, ToHtml text) => text -> Markup
nl2br text
content = text
content
    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall t. Textual t => t -> [t]
Sequences.lines
    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. (a -> b) -> [a] -> [b]
map (\text
line -> [hsx|{line}<br/>|])
    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Monoid a => [a] -> a
mconcat

type Html = HtmlWithContext ControllerContext

-- | The URL for the dev-mode live reload server. Typically "ws://localhost:8001"
liveReloadWebsocketUrl :: (?context :: ControllerContext) => Text
liveReloadWebsocketUrl :: (?context::ControllerContext) => Text
liveReloadWebsocketUrl = ?context::ControllerContext
?context.frameworkConfig.ideBaseUrl
    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Text -> Text -> Text
Text.replace Text
"http://" Text
"ws://"
    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Text -> Text -> Text
Text.replace Text
"https://" Text
"wss://"