{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module IHP.ViewSupport
( HtmlWithContext
, Layout
, Html
, View (..)
, currentViewId
, forEach
, isActivePath
, isActivePathOrSub
, css
, onClick
, onLoad
, theRequest
, viewContext
, addStyle
, ViewFetchHelpMessage
, param
, fetch
, query
, isActiveController
, nl2br
, stripTags
, theCSSFramework
, fromCSSFramework
) where
import IHP.Prelude
import qualified Text.Blaze
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 qualified IHP.ControllerSupport as ControllerSupport
import IHP.FlashMessages.Types
import IHP.HtmlSupport.QQ (hsx)
import IHP.HtmlSupport.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
beforeRender :: (?context :: ControllerContext) => theView -> IO ()
beforeRender theView
view = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
html :: (?context :: ControllerContext, ?view :: theView) => theView -> Html5.Html
json :: theView -> JSON.Value
json = Text -> theView -> Value
forall a. Text -> a
error Text
"Not implemented"
{-# INLINE currentViewId #-}
currentViewId :: (?view :: view, Typeable view) => Text
currentViewId :: Text
currentViewId =
case [Text]
moduleParts of
[Text
_, Text
"View", Text
controllerName, Text
viewName] -> Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall b a. b -> Either a b -> b
Either.fromRight (Text -> Text
forall a. Text -> a
error Text
"currentViewId: Failed to parse controller name") (Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toDashed Text
controllerName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall b a. b -> Either a b -> b
Either.fromRight (Text -> Text
forall a. Text -> a
error Text
"currentViewId: Failed to parse view name") (Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toDashed Text
viewName)
[Text]
_ -> Text -> Text
forall a. Text -> a
error (Text
"currentViewId: Failed to read view id for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
moduleName)
where
constructor :: TyCon
constructor = TypeRep -> TyCon
Typeable.typeRepTyCon (view -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf view
?view::view
?view)
moduleName :: Text
moduleName :: Text
moduleName = String -> Text
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
isActivePath :: (?context :: ControllerContext, PathString controller) => controller -> Bool
isActivePath :: controller -> Bool
isActivePath controller
route =
let
currentPath :: ByteString
currentPath = Request -> ByteString
Wai.rawPathInfo Request
(?context::ControllerContext) => Request
theRequest ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Wai.rawQueryString Request
(?context::ControllerContext) => Request
theRequest
in
ByteString
currentPath ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (controller -> Text
forall a. PathString a => a -> Text
pathToString controller
route)
isActivePathOrSub :: (?context :: ControllerContext, PathString controller) => controller -> Bool
isActivePathOrSub :: controller -> Bool
isActivePathOrSub controller
route =
let
currentPath :: ByteString
currentPath = Request -> ByteString
Wai.rawPathInfo Request
(?context::ControllerContext) => Request
theRequest
in
Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (controller -> Text
forall a. PathString a => a -> Text
pathToString controller
route) ByteString -> ByteString -> Bool
`ByteString.isPrefixOf` ByteString
currentPath
isActiveController :: forall controller context. (?context :: ControllerContext, Typeable controller) => Bool
isActiveController :: Bool
isActiveController =
let
(ActionType TypeRep
actionType) = (?context::ControllerContext, Typeable ActionType) => ActionType
forall value.
(?context::ControllerContext, Typeable value) =>
value
fromFrozenContext @ActionType
in
(Proxy controller -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep @Proxy @controller (Proxy controller
forall k (t :: k). Proxy t
Proxy @controller)) TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
actionType
css :: QuasiQuoter
css = QuasiQuoter
plain
onClick :: AttributeValue -> Attribute
onClick = AttributeValue -> Attribute
A.onclick
onLoad :: AttributeValue -> Attribute
onLoad = AttributeValue -> Attribute
A.onload
theRequest :: (?context :: ControllerContext) => Wai.Request
theRequest :: Request
theRequest =
let
requestContext :: RequestContext
requestContext = ControllerContext -> RequestContext
forall k (x :: k) r a. HasField x r a => r -> a
getField @"requestContext" ?context::ControllerContext
ControllerContext
?context
request :: Request
request = RequestContext -> 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 = action -> Text
forall action. HasPath action => action -> Text
pathTo
viewContext :: (?context :: ControllerContext) => ControllerContext
viewContext :: ControllerContext
viewContext = ?context::ControllerContext
ControllerContext
?context
{-# INLINE viewContext #-}
addStyle :: (ConvertibleStrings string Text) => string -> Html5.Markup
addStyle :: string -> Markup
addStyle string
style = Markup -> Markup
Html5.style (Text -> Markup
Html5.preEscapedText (string -> Text
forall a b. ConvertibleStrings a b => a -> b
cs string
style))
{-# INLINE addStyle #-}
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 :: a
param = Text -> a
forall a. Text -> a
error Text
"unreachable"
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 :: a
fetch = Text -> a
forall a. Text -> a
error Text
"unreachable"
query :: a
query = Text -> a
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 = Text -> Bool
forall a. Text -> a
error Text
"unreachable"
fromCSSFramework :: (?context :: ControllerContext, KnownSymbol field, HasField field CSSFramework (CSSFramework -> appliedFunction)) => Proxy field -> appliedFunction
fromCSSFramework :: Proxy field -> appliedFunction
fromCSSFramework Proxy field
field = let cssFramework :: CSSFramework
cssFramework = CSSFramework
(?context::ControllerContext) => CSSFramework
theCSSFramework in (Proxy field -> CSSFramework -> CSSFramework -> appliedFunction
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 :: CSSFramework
theCSSFramework = ?context::ControllerContext
ControllerContext
?context
ControllerContext
-> (ControllerContext -> FrameworkConfig) -> FrameworkConfig
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> ControllerContext -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
FrameworkConfig.getFrameworkConfig
FrameworkConfig
-> (FrameworkConfig -> CSSFramework) -> CSSFramework
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "cssFramework" -> FrameworkConfig -> CSSFramework
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "cssFramework" (Proxy "cssFramework")
Proxy "cssFramework"
#cssFramework
nl2br :: (Sequences.Textual text, ToHtml text) => text -> Html5.Html
nl2br :: text -> Markup
nl2br text
content = text
content
text -> (text -> [text]) -> [text]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> text -> [text]
forall t. Textual t => t -> [t]
Sequences.lines
[text] -> ([text] -> [Markup]) -> [Markup]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> (text -> Markup) -> [text] -> [Markup]
forall a b. (a -> b) -> [a] -> [b]
map (\text
line -> [hsx|{line}<br/>|])
[Markup] -> ([Markup] -> Markup) -> Markup
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> [Markup] -> Markup
forall a. Monoid a => [a] -> a
mconcat
instance {-# OVERLAPPABLE #-} HasField "requestContext" viewContext RequestContext => FrameworkConfig.ConfigProvider viewContext where
getFrameworkConfig :: viewContext -> FrameworkConfig
getFrameworkConfig viewContext
viewContext = viewContext
viewContext
viewContext -> (viewContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestContext" -> viewContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext
RequestContext
-> (RequestContext -> FrameworkConfig) -> FrameworkConfig
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "frameworkConfig" -> RequestContext -> FrameworkConfig
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "frameworkConfig" (Proxy "frameworkConfig")
Proxy "frameworkConfig"
#frameworkConfig
type Html = HtmlWithContext ControllerContext