{-# 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
, 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
beforeRender :: (?context :: ControllerContext) => theView -> IO ()
beforeRender theView
view = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
html :: (?context :: ControllerContext, ?view :: theView) => theView -> Html5.Html
json :: theView -> JSON.Value
json = forall a. Text -> a
error Text
"Json View for this route is not implemented"
{-# 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)
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
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)
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
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
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
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
viewContext :: (?context :: ControllerContext) => ControllerContext
viewContext :: (?context::ControllerContext) => ControllerContext
viewContext = ?context::ControllerContext
?context
{-# INLINE viewContext #-}
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 #-}
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"
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
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
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://"