compile Yesod.Shakespeare
This commit is contained in:
Greg Weber
parent
aabb126d63
commit
5fd50c2a12
@ -10,7 +10,6 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
@ -46,6 +45,7 @@ module Yesod.Core.Widget
|
||||
, handlerToWidget
|
||||
-- * Internal
|
||||
, asWidgetT
|
||||
, tellWidget
|
||||
|
||||
-- * Formerly Yesod.Core.Types
|
||||
, ScriptLoadPosition(..)
|
||||
@ -74,7 +74,7 @@ module Yesod.Core.Widget
|
||||
) where
|
||||
|
||||
import Control.Applicative (Applicative(..))
|
||||
import Control.Monad (liftM, ap, forM)
|
||||
import Control.Monad (liftM, ap)
|
||||
import Control.Monad.Base (MonadBase (liftBase))
|
||||
import Control.Monad.Catch (MonadCatch (..))
|
||||
import Control.Monad.Catch (MonadMask (..))
|
||||
@ -97,65 +97,47 @@ import Control.Monad.Trans.RWS ( RWST )
|
||||
import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )
|
||||
import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )
|
||||
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Blaze.ByteString.Builder (Builder)
|
||||
import Data.Conduit (Flush (Chunk), Producer, ConduitM)
|
||||
import Data.Conduit.Internal (Pipe(..))
|
||||
import Data.Conduit.Lazy (MonadActive, monadActive)
|
||||
import Data.List (foldl', nub)
|
||||
import Data.Monoid
|
||||
import Data.Semigroup (Semigroup)
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Blaze.Html.Renderer.Text as RenderText
|
||||
import Text.Blaze.Html (preEscapedToMarkup, toHtml, Html)
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import Text.Blaze.Html (preEscapedToMarkup, Html)
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
||||
import Yesod.Routes.Class
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Map as Map
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
|
||||
|
||||
import Data.Text.Lazy.Builder (fromLazyText, toLazyText)
|
||||
import System.Log.FastLogger (toLogStr)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
||||
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Class.Handler
|
||||
import Yesod.Core.Class.Yesod (Yesod)
|
||||
import Yesod.Core.Handler (getUrlRenderParams, toTextUrl, invalidArgs, permissionDenied, setSession, lookupSession, deleteSession, RedirectUrl, withUrlRenderer, sendChunk, getRequest, getYesod, sendResponse, selectRep, provideRep)
|
||||
import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..), ToFlushBuilder(..), typeJavascript, typeHtml, typeCss)
|
||||
import Yesod.Core.Handler (setSession, lookupSession, deleteSession, withUrlRenderer, sendChunk)
|
||||
import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..), ToFlushBuilder(..), typeHtml)
|
||||
import Data.Map (Map, unionWith)
|
||||
import qualified Data.Aeson as J
|
||||
|
||||
-- templating types
|
||||
class ToWidgetBuilder a where
|
||||
toWidgetBuilder :: a -> Builder
|
||||
|
||||
type Render url = url -> [(Text, Text)] -> Text
|
||||
type Translate msg = msg -> Html
|
||||
type HtmlUrl url = Render url -> Html
|
||||
type HtmlUrlI18n msg url = Translate msg -> Render url -> Html
|
||||
|
||||
|
||||
|
||||
------------------------------------
|
||||
-- Original Yesod.Core.Widget
|
||||
------------------------------------
|
||||
preEscapedLazyText :: TL.Text -> Html
|
||||
preEscapedLazyText = preEscapedToMarkup
|
||||
|
||||
class ToWidget site a where
|
||||
toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
|
||||
|
||||
instance render ~ RY site => ToWidget site (render -> Html) where
|
||||
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
|
||||
toWidget x = tellWidget $ GWData (Body x) mempty mempty mempty mempty mempty mempty
|
||||
instance render ~ RY site => ToWidget site (render -> CssBuilder) where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
|
||||
toWidget x = tellWidget $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
|
||||
instance ToWidget site CssBuilder where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
|
||||
toWidget x = tellWidget $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
|
||||
instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
|
||||
toWidget = liftWidgetT
|
||||
instance ToWidget site Html where
|
||||
@ -173,9 +155,9 @@ class ToWidgetMedia site a where
|
||||
-> a
|
||||
-> m ()
|
||||
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
|
||||
toWidgetMedia media x = tellWidget $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
|
||||
instance ToWidgetMedia site CssBuilder where
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
|
||||
toWidgetMedia media x = tellWidget $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
|
||||
|
||||
class ToWidgetBody site a where
|
||||
toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
|
||||
@ -189,12 +171,12 @@ class ToWidgetHead site a where
|
||||
toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
|
||||
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Html) where
|
||||
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
|
||||
toWidgetHead = tellWidget . GWData mempty mempty mempty mempty mempty mempty . Head
|
||||
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitle :: MonadWidget m => Html -> m ()
|
||||
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
|
||||
setTitle x = tellWidget $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Link to the specified local stylesheet.
|
||||
addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
|
||||
@ -205,7 +187,7 @@ addStylesheetAttrs :: MonadWidget m
|
||||
=> Route (HandlerSite m)
|
||||
-> [(Text, Text)]
|
||||
-> m ()
|
||||
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
addStylesheetAttrs x y = tellWidget $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemote :: MonadWidget m => Text -> m ()
|
||||
@ -213,7 +195,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
|
||||
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
|
||||
addStylesheetRemoteAttrs x y = tellWidget $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
|
||||
|
||||
addStylesheetEither :: MonadWidget m
|
||||
=> Either (Route (HandlerSite m)) Text
|
||||
@ -231,7 +213,7 @@ addScript = flip addScriptAttrs []
|
||||
|
||||
-- | Link to the specified local script.
|
||||
addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
|
||||
addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
addScriptAttrs x y = tellWidget $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemote :: MonadWidget m => Text -> m ()
|
||||
@ -239,10 +221,10 @@ addScriptRemote = flip addScriptRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
|
||||
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
addScriptRemoteAttrs x y = tellWidget $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
|
||||
tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
|
||||
tell w = liftWidgetT $ WidgetT $ const $ return ((), w)
|
||||
tellWidget :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
|
||||
tellWidget w = liftWidgetT $ WidgetT $ const $ return ((), w)
|
||||
|
||||
toUnique :: x -> UniqueList x
|
||||
toUnique = UniqueList . (:)
|
||||
|
||||
@ -1,5 +1,11 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Yesod.Shakespeare (
|
||||
, whamlet
|
||||
whamlet
|
||||
, whamletFile
|
||||
-- * Special Hamlet quasiquoter/TH for Widgets
|
||||
, ihamletToRepHtml
|
||||
@ -43,11 +49,42 @@ module Yesod.Shakespeare (
|
||||
, renderCssUrl
|
||||
) where
|
||||
|
||||
import Yesod.Core.Widget
|
||||
import Control.Monad (liftM, forM)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Text.Shakespeare.I18N
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.List (foldl', nub)
|
||||
import Text.Blaze.Html (preEscapedToMarkup, toHtml, Html)
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Data.Text.Lazy.Builder (fromLazyText, toLazyText)
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
||||
import Data.Monoid (Last(..), mempty)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
instance ToWidgetBuilder Javascript where
|
||||
toWidgetBuilder = unJavascript
|
||||
import qualified Text.Hamlet as NP
|
||||
import Text.Julius (Javascript(..), JavascriptUrl, renderJavascript, renderJavascriptUrl, julius)
|
||||
import Text.Hamlet (hamlet, shamlet, xhamlet)
|
||||
import Text.Lucius (Css, renderCss, CssUrl, renderCssUrl, lucius)
|
||||
import Text.Cassius (cassius)
|
||||
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Widget
|
||||
import Yesod.Core.Class.Handler (HandlerSite, MonadHandler)
|
||||
import Yesod.Core.Handler (getUrlRenderParams, toTextUrl, invalidArgs, permissionDenied, RedirectUrl, withUrlRenderer, getRequest, getYesod, sendResponse)
|
||||
import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..), typeJavascript, typeCss)
|
||||
import Yesod.Routes.Class (Route)
|
||||
|
||||
type Translate msg = msg -> Html
|
||||
type HtmlUrlI18n msg url = Translate msg -> Render url -> Html
|
||||
type Render url = url -> [(Text, Text)] -> Text
|
||||
type HtmlUrl url = Render url -> Html
|
||||
|
||||
preEscapedLazyText :: TL.Text -> Html
|
||||
preEscapedLazyText = preEscapedToMarkup
|
||||
|
||||
whamlet :: QuasiQuoter
|
||||
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
||||
@ -123,9 +160,9 @@ $doctype 5
|
||||
-- from Yesod.Core.Class.Yesod
|
||||
------------------------------
|
||||
type AddStaticContent site = Text -- ^ filename extension
|
||||
-> Text -- ^ mime-type
|
||||
-> L.ByteString -- ^ content
|
||||
-> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
|
||||
-> Text -- ^ mime-type
|
||||
-> L.ByteString -- ^ content
|
||||
-> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
|
||||
|
||||
-- | Convert a widget to a 'PageContent'.
|
||||
-- not bound to the Yesod typeclass
|
||||
@ -137,7 +174,8 @@ type AddStaticContent site = Text -- ^ filename extension
|
||||
widgetToPageContentUnbound addStaticContent jsLoader w = do
|
||||
master <- getYesod
|
||||
hd <- HandlerT return
|
||||
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
|
||||
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style mJS' (Head head')) <- lift $ unWidgetT w hd
|
||||
let jscript = fmap (\x -> Javascript . x) mJS'
|
||||
let title = maybe mempty unTitle mTitle
|
||||
scripts = runUniqueList scripts'
|
||||
stylesheets = runUniqueList stylesheets'
|
||||
@ -289,9 +327,9 @@ instance render ~ RY site => ToWidget site (render -> Css) where
|
||||
instance ToWidget site Css where
|
||||
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
|
||||
instance render ~ RY site => ToWidget site (render -> Javascript) where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
|
||||
toWidget x = tellWidget $ GWData mempty mempty mempty mempty mempty (Just $ unJavascript . x) mempty
|
||||
instance ToWidget site Javascript where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
|
||||
toWidget x = tellWidget $ GWData mempty mempty mempty mempty mempty (Just $ const $ unJavascript x) mempty
|
||||
instance render ~ RY site => ToWidgetMedia site (render -> Css) where
|
||||
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
|
||||
instance ToWidgetMedia site Css where
|
||||
|
||||
@ -68,6 +68,7 @@ library
|
||||
, word8
|
||||
, auto-update
|
||||
, semigroups
|
||||
, shakespeare
|
||||
|
||||
exposed-modules: Yesod.Core
|
||||
Yesod.Core.Content
|
||||
@ -79,6 +80,7 @@ library
|
||||
Yesod.Core.Types
|
||||
Yesod.Core.Unsafe
|
||||
Yesod.Routes.TH.Types
|
||||
Yesod.Shakespeare
|
||||
other-modules: Yesod.Core.Internal.Session
|
||||
Yesod.Core.Internal.Request
|
||||
Yesod.Core.Class.Handler
|
||||
|
||||
Loading…
Reference in New Issue
Block a user