From 5fd50c2a1271234a31a1683d0e4bcb7f65804ca8 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Tue, 19 May 2015 11:22:15 -0700 Subject: [PATCH] compile Yesod.Shakespeare --- yesod-core/Yesod/Core/Widget.hs | 54 ++++++++++-------------------- yesod-core/Yesod/Shakespeare.hs | 58 +++++++++++++++++++++++++++------ yesod-core/yesod-core.cabal | 2 ++ 3 files changed, 68 insertions(+), 46 deletions(-) diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs index 70acaf8e..050a5a80 100644 --- a/yesod-core/Yesod/Core/Widget.hs +++ b/yesod-core/Yesod/Core/Widget.hs @@ -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 . (:) diff --git a/yesod-core/Yesod/Shakespeare.hs b/yesod-core/Yesod/Shakespeare.hs index fbdfea8c..38c868d4 100644 --- a/yesod-core/Yesod/Shakespeare.hs +++ b/yesod-core/Yesod/Shakespeare.hs @@ -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 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 66d8b96d..2577fb7e 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -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