diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,146 @@ Web-page ======== -This package combines blaze-html, clay, jmacro and web-routes into a +This package combines blaze-html, clay and jmacro into a framework-agnostic library to generate web pages dynamically from individual components. It is inspired by Yesod's widgets, but is more general, more powerful and can be used with other web frameworks. + + +Features +-------- + +The `Widget` type is very expressive. The following features are built +in: + + * works with your web framework of choice, + * fully embedded stylesheet and script languages (jmacro and clay), + * page-specific or external stylesheets and script, + * type-safe routing, + * flexible polymorphic body type, + * monoidal piece-by-piece construction of pages, + * hierarchial titles, + * additional head markup, + * optional lens interface, + * rendering to multiple documents (e.g. separate stylesheet and + script). + +Other features are add-ons: + + * non-HTML bodies (e.g. Pandoc integration), + * multipart bodies aka *sections*, + * page-unique identifier generation. + + +Usage +----- + +This is a brief overview of the process to construct and render a web +page using this library. First of all you will need a few extensions: + + {-# LANGUAGE FlexibleContexts #-} + {-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE QuasiQuotes #-} + +The `OverloadedStrings` extension is optional, but makes writing +blaze-html markup and clay stylesheets a lot more convenient. The +`QuasiQuotes` extension is only required for jmacro, if you need scripts +in your widgets. With that aside the first step is to understand the +`Widget` type: + + Widget url h + +The type argument `url` is your URL type. If you don't use type-safe +routing, then simply use `url = Text`. This is only significant for +external stylesheets and scripts. If you don't use any of them, just +leave it polymorphic. + +The second type argument `h` is the page body type. For now just use +`Html` (from blaze-html), which means that the body of your page will be +simple unstructured HTML markup. + + +### Construction + +`Widget` is a family of monoids. While you could use the `Monoid` +interface directly it's usually much more convenient to use a writer +monad to construct your widgets. In most cases the correct type will be +inferred, but we will specify it regardless: + + myWidget :: (MonadWriter (Widget url Html) m) => m () + +If you are like me, you prefer to write type signatures for your +top-level definitions. A constraint alias is provided for your +convenience. The following type signature is equivalent to the above: + + myWidget :: (MonadWidget url Html m) => m () + +If writer is the only effect you need, there is an even simpler alias +that you can use, which is equivalent to the above as well: + + myWidget :: WidgetWriter url Html () + +Now we can construct the widget piece by piece: + + myWidget = do + setTitle "Hello" + addBody (H.h1 "Hello") + addBody (H.p "Hello world!") + addStyle $ html ? do + background white + color black + +You can build the widget by reducing the writer: + + w :: Widget url Html + w = execWriter myWidget + +This widget can now be rendered to a page. + + +### Rendering + +To render the widget you can use the `renderWidget` function: + + renderWidget :: ([Text] -> Tl.Text) -> Widget Text Html -> Page + +The `Text` type is the strict version, while the `Tl.Text` type is the +lazy version. + +The first argument to this function is the title renderer. Widgets +define an optional title, which is not just a text string, but a list of +text strings. That's because this library supports hierarchial titles +by using the `withTitle` function. We will not cover this here. Just +use `titleMinor`: + + page :: Page + page = renderWidget (titleMinor " - ") w + +Pages are an intermediate step between rendering and delivery. They are +necessary, because this library allows you to render to multiple +documents, for example to a markup document, a stylesheet and a script. +You can then use a clever hash-based routing mechanism to tell clients +to cache stylesheets and scripts forever and reduce the required +bandwidth to a minimum. + + +### Realisation + +To process of finalising a page to an actual set of documents that you +can deliver is referred to as *realisation*. We will simply render to a +single document with an inline stylesheet and no script (because our +widget above doesn't define one). The `realiseInline` function does +exactly that: + + realiseInline :: Page -> Builder + +All we need to do is to apply it to our page: + + document :: Builder + document = realiseInline page + +The `Builder` type is the usual one from blaze-builder. Most web +frameworks use it for efficient bytestring concatenation and provide a +simple interface to deliver those strings to clients. For example WAI +provides the `responseBuilder` function. If you want to save the result +to a file, just use `toLazyByteString` or `toByteStringIO`. diff --git a/Web/Page.hs b/Web/Page.hs --- a/Web/Page.hs +++ b/Web/Page.hs @@ -3,6 +3,16 @@ -- Copyright: (c) 2014 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez +-- +-- This package combines blaze-html, clay and jmacro into a +-- framework-agnostic library to generate web pages dynamically from +-- individual components. It is inspired by Yesod's widgets, but is +-- more general, more powerful and can be used with other web +-- frameworks. +-- +-- See the @README.md@ file for a full list of features and a quick +-- introduction. More detailed documentation can be found in the +-- individual modules. module Web.Page ( -- * Reexports diff --git a/Web/Page/GenId.hs b/Web/Page/GenId.hs new file mode 100644 --- /dev/null +++ b/Web/Page/GenId.hs @@ -0,0 +1,185 @@ +-- | +-- Module: Web.Page.GenId +-- Copyright: (c) 2014 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- This module offers a monad transformer and a class for page-unique +-- identifier generation. To use it, simply add a state monad to your +-- monad stack with a state type that is an instance of the +-- 'HasIdStream' class (you can simply use @'Stream' 'Identifier'@, if +-- you don't need any other state). See the 'newId' action to see the +-- exact type of stack you need. +-- +-- To construct the initial state you can use the predefined 'idsFrom' +-- function. It constructs a stream of unique identifiers from its +-- argument character set. +-- +-- To generate a new identifier use the 'newId' action within your monad +-- stack. The generated identifiers are of type 'Identifier'. There +-- are helper functions for integrating an identifer into markup and the +-- stylesheet. See the DOM helpers and the CSS helpers sections in this +-- module. Also see the documentation for 'Identifier' for more +-- detailed information and an example. +-- +-- Hint: It is perfectly valid to combine a widget writer and an +-- identifier generator, so you don't need to alternate between +-- constructing widgets and generating identifiers. + +module Web.Page.GenId + ( -- * Unique identifiers + Identifier(..), + HasIdStream(..), + idsFrom, + newId, + + -- * DOM helpers + classId, + customId, + dataId, + domId, + + -- * CSS helpers + idRef, + idSel, + classRef, + classSel + ) + where + +import qualified Clay as Css +import qualified Data.Stream as Str +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as Vu +import qualified Text.Blaze.Html5.Attributes as A +import Control.Lens +import Control.Monad.State.Class +import Data.Data +import Data.Stream (Stream(..)) +import Language.Javascript.JMacro (ToJExpr(..), JExpr(..), JVal(..)) +import Text.Blaze.Html + + +-- | Instances of this class are types that embed an identifier stream. + +class HasIdStream a where + -- | Lens into the identifier stream. + idStream :: Lens' a (Stream Identifier) + +instance HasIdStream (Stream Identifier) where + idStream = id + + +-- | Identifiers that can be used with clay, jmacro and blaze-html. +-- +-- An identifier of this type is supposed to be used for DOM ids, +-- classes or similar names. Note that the 'ToJExpr' instance converts +-- it to a JavaScript string, so that you can use it with jQuery or +-- functions like @getElementById@. When using jQuery, remember that it +-- expects selector syntax as in the following example: +-- +-- > myWidget :: +-- > ( HasIdStream s, +-- > MonadState s m, +-- > MonadWidget url (MySection -> Html) m ) +-- > => m () +-- > myWidget = do +-- > myId <- newId +-- > addSection MySection (H.p "My boring paragraph." ! domId myId) +-- > addStyle $ idSel myId ? background gray +-- > addStyle $ idSel myId # ".groovy" ? do +-- > background darkblue +-- > color pink +-- > fontWeight bold +-- > addScriptLink "static/jquery.js" +-- > addScript [jmacro| +-- > fun init -> +-- > window.setTimeout +-- > (\() { +-- > $("#" + `myId`).addClass("groovy"); +-- > $(".groovy").text("My groooovy paragraph!") }) +-- > 2500; +-- > $(init) |] + +newtype Identifier = + Identifier { + identifier :: String + } + deriving (Data, Eq, Ord, Show, ToValue, Typeable) + +instance ToJExpr Identifier where + toJExpr (Identifier name) = ValExpr (JStr name) + + +-- | HTML5 @class@ attribute containing the given identifier. + +classId :: Identifier -> Attribute +classId (Identifier n) = A.class_ (toValue n) + + +-- | Class refinement for the given identifier. + +classRef :: Identifier -> Css.Refinement +classRef = Css.byClass . T.pack . identifier + + +-- | Class selector for the given identifier. + +classSel :: Identifier -> Css.Selector +classSel n = Css.star Css.# classRef n + + +-- | Custom attribute containing the given identifier. + +customId :: Tag -> Identifier -> Attribute +customId attr (Identifier n) = customAttribute attr (toValue n) + + +-- | HTML5 @id@ attribute containing the given identifier. + +domId :: Identifier -> Attribute +domId (Identifier n) = A.id (toValue n) + + +-- | HTML5 data attribute (@data-*@) containing the given identifier. + +dataId :: Tag -> Identifier -> Attribute +dataId attr (Identifier n) = dataAttribute attr (toValue n) + + +-- | Id refinement for the given identifier. + +idRef :: Identifier -> Css.Refinement +idRef = Css.byId . T.pack . identifier + + +-- | Id selector for the given identifier. + +idSel :: Identifier -> Css.Selector +idSel n = Css.star Css.# idRef n + + +-- | Infinite stream of identifiers built from the given character set. +-- The stream is sorted by identifier length, shortest first. + +idsFrom :: [Char] -> Stream Identifier +idsFrom charList = + fmap (Identifier . map (chars Vu.!)) + (Str.iterate next [0]) + + where + chars = Vu.fromList charList + numChars = Vu.length chars + + next [] = [0] + next (x':xs) + | x < numChars = x : xs + | otherwise = 0 : next xs + where + x = succ x' + + +-- | Fetches the next identifier. + +newId :: (HasIdStream a, MonadState a m) => m Identifier +newId = idStream %%= \(Cons x xs) -> (x, xs) diff --git a/Web/Page/Render.hs b/Web/Page/Render.hs --- a/Web/Page/Render.hs +++ b/Web/Page/Render.hs @@ -4,23 +4,24 @@ -- License: BSD3 -- Maintainer: Ertugrul Soeylemez -- --- This module provides the functionality to render web pages. This is --- the process to construct and then render a web page: +-- This module provides the functionality to render web pages. The +-- following is the process to construct and then render a web page: -- --- 1. Use a writer monad to construct a 'Widget', which represents a --- web page component and is usually constructed from multiple --- smaller components, +-- 1. __Construction__: Use a writer monad to construct a 'Widget', +-- which represents a web page component and is usually constructed +-- from multiple smaller components. -- --- 2. use one of the rendering functions to render a widget to a --- 'Page', which represents a rendered web page, but still abstracts --- over the exact set of documents (everything inline or a set of --- separate documents for markup, script and style), +-- 2. __Rendering__: Use one of the rendering functions to render a +-- widget to a 'Page', which represents a rendered web page, but +-- still abstracts over the exact set of documents (everything +-- inline or a set of separate documents for markup, script and +-- style). -- --- 3. turn the page into a set of documents that you can deliver to the --- client, for example by using 'inlinePage'. +-- 3. __Realisation__: Realise the page as a set of documents that you +-- can deliver to the client, for example by using 'realiseInline'. -- -- The motivation for rendering to separate documents is that most web --- pages consist of dynamic markup, but the stylesheet and script is +-- pages consist of dynamic markup, but the stylesheet and script are -- mostly static. The way 'Page' works you can have widgets with -- batteries included and still render to separate documents to utilise -- the client's cache better. @@ -32,19 +33,20 @@ ( -- * Rendering pages Page(..), renderWidget, + titleMajor, + titleMinor, - -- * Single document - inlinePage + -- * Realising pages + realiseInline ) where import qualified Clay -import qualified Data.ByteString.Lazy as Bl -import qualified Data.Map.Strict as M import qualified Data.Text.Lazy as Tl import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A import qualified Text.PrettyPrint.Leijen.Text as Pp +import Blaze.ByteString.Builder (Builder) import Data.Foldable (foldMap) import Data.Monoid import Data.Text (Text) @@ -54,35 +56,38 @@ import Web.Page.Widget --- | Rendered pages. This type supports rendering to multiple documents --- like an HTML document, as explained above. +-- | Rendered pages. This type supports realising a page as multiple +-- documents like an HTML document, a separate script and a separate +-- stylesheet, as explained above. -- -- If you're running a low-traffic site and don't want to afford the -- complexity, then you can just include the stylesheets and scripts --- inline by using the 'inlinePage' function. Except for external +-- inline by using the 'realiseInline' function. Except for external -- script and style URLs this will give you a self-contained document -- that you can deliver to the client. -- -- The 'pageHtml' field is the function that takes the markup for the --- script and the style respectively and returns a lazy bytestring that --- you can send as @text/html@ to the client. The other two fields are --- the rendered script and stylesheet. The markup is UTF-8-encoded, --- which you should indicate in the @content-type@ header, if you --- deliver via HTTP. +-- script and the style respectively and returns a builder that you can +-- send as @text/html@ to the client. The other two fields are the +-- rendered script and stylesheet. The markup is UTF-8-encoded, which +-- you should indicate in the @content-type@ header, if you deliver via +-- HTTP, although a @meta@ element is included as a fallback. data Page = Page { - pageHtml :: Html -> Html -> Bl.ByteString, -- ^ Markup document. - pageScript :: Tl.Text, -- ^ Page script. - pageStyle :: Tl.Text -- ^ Page stylesheet. + pageHtml :: Html -> Html -> Builder, -- ^ Markup document. + pageScript :: Tl.Text, -- ^ Page script. + pageStyle :: Tl.Text -- ^ Page stylesheet. } --- | Render the given page to a single self-contained document, --- including the script and stylesheet inline. +-- | Realise the given page as a single self-contained document, +-- including the script and stylesheet inline. The resulting string is +-- UTF-8-encoded and contains a @meta@ element to indicate that. Read +-- the documentation of 'Page' for details. -inlinePage :: Page -> Bl.ByteString -inlinePage p = pageHtml p scInc stInc +realiseInline :: Page -> Builder +realiseInline p = pageHtml p scInc stInc where Page { pageScript = sc, pageStyle = st @@ -95,16 +100,25 @@ | otherwise = H.style (toHtml st) --- | This is the most general rendering function for widgets. +-- | This is the most general rendering function for widgets. The title +-- renderer receives the title chunks from outermost to innermost. +-- +-- If you use type-safe routing and/or a sectioned or otherwise +-- non-'Html' body type, you should first apply the necessary +-- transformations to perform the routing and/or flattening or +-- conversion of the body. +-- +-- Note that 'Widget' is a family of applicative functors. There are +-- also predefined functions to assist you with this transformation. +-- See the "Web.Page.Route" module and the 'mapLinksA', 'mapLinksM' and +-- 'flattenBody' functions. renderWidget :: - (Ord k) - => [k] -- ^ Sections to render. - -> ([Text] -> Text) -- ^ Title renderer. - -> Widget k Text -- ^ Widget to render. + ([Text] -> Tl.Text) -- ^ Title renderer. + -> Widget Text Html -- ^ Widget to render. -> Page -renderWidget ss renderTitle w = - Page { pageHtml = \scInc stInc -> renderHtml (html scInc stInc), +renderWidget renderTitle w = + Page { pageHtml = \scInc stInc -> renderHtmlBuilder (html scInc stInc), pageScript = Pp.displayT . Pp.renderOneLine . renderJs . _wScript $ w, pageStyle = Clay.renderWith Clay.compact [] . _wStyle $ w } @@ -117,20 +131,17 @@ where bodyH = - foldMap section ss <> + _wBody w <> foldMap scLink (_wScriptLinks w) <> scInc headH = H.title (toHtml title) <> + H.meta ! A.charset "UTF-8" <> _wHead w <> foldMap stLink (_wStyleLinks w) <> stInc - section = - maybe mempty id . - (`M.lookup` _wSections w) - scLink url = H.script mempty ! A.src (toValue url) stLink url = @@ -138,3 +149,27 @@ ! A.href (toValue url) title = renderTitle . maybe [] id . getLast . _wTitle $ w + + +-- | Intercalate the given title chunks using the given separator, +-- highest level title first. For most web sites 'titleMinor' is +-- preferable. +-- +-- >>> titleMajor " - " ["site", "department", "page"] +-- "site - department - page" + +titleMajor :: Text -> [Text] -> Tl.Text +titleMajor sep = Tl.intercalate (Tl.fromStrict sep) . map Tl.fromStrict + + +-- | Intercalate the given title chunks using the given separator, +-- lowest level title first. This is much more common on web sites than +-- 'titleMajor', because it's usually more convenient for the user to +-- have the page title in the leftmost position (think about browser tab +-- captions and title bars). +-- +-- >>> titleMinor " - " ["site", "department", "page"] +-- "page - department - site" + +titleMinor :: Text -> [Text] -> Tl.Text +titleMinor sep = titleMajor sep . reverse diff --git a/Web/Page/Widget.hs b/Web/Page/Widget.hs --- a/Web/Page/Widget.hs +++ b/Web/Page/Widget.hs @@ -6,7 +6,8 @@ -- -- A widget is a self-contained web page component represented by the -- 'Widget' type. This type is a family of monoids, so you can use it --- together with a writer monad. +-- together with a writer monad, which is the preferred way to construct +-- widgets. module Web.Page.Widget ( -- * Page widgets @@ -28,24 +29,29 @@ withTitle, -- * Widget lenses + wBody, wHead, wScript, wScriptLinks, - wSections, + wSection, wStyle, wStyleLinks, - wTitle + wTitle, + + -- * Mapping + flattenBody, + mapLinksA, + mapLinksM ) where -import qualified Data.Map.Strict as M import qualified Data.Set as S import Clay (Css) import Control.Applicative import Control.Lens +import Control.Monad import Control.Monad.Writer.Class -import Data.Foldable (Foldable) -import Data.Map (Map) +import Data.Foldable (Foldable, foldMap) import Data.Monoid import Data.Set (Set) import Data.Text (Text) @@ -56,119 +62,193 @@ -- | Convenient constraint alias for widget actions. -type MonadWidget k url = MonadWriter (Widget k url) +type MonadWidget url h = MonadWriter (Widget url h) -- | A widget is a self-contained fragment of a web page together with -- its scripts and styles. This type is inspired by Yesod's widgets, --- but is supposed to be constructed by using a writer monad and may not --- denote effects of its own. +-- but is supposed to be constructed by using a writer monad and does +-- not denote effects of its own. -- --- To construct widgets through a writer monad, use lens combinators --- like 'scribe' and 'censoring'. Alternatively you can use the @add*@ --- functions like 'addSection' or 'addStyle'. The title is constructed --- by using 'withTitle' and 'setTitle'. This allows you to have a --- hierarchy of titles with a site title, a page title and even a --- component title. +-- To construct widgets through a writer monad, you can use the @add*@ +-- functions like 'addSection' or 'addStyle': -- --- The first type argument is the key type for the individual body --- sections of the resulting document. You can use it for example to --- divide your document into a header, a menu, a content area and a --- footer and each widget can add to them individually. +-- > do addSection "header" (H.h1 "My fancy header") +-- > addStyle $ html ? do +-- > background yellow +-- > color black -- --- The second type argument is the type of URLs. You may use it for --- type-safe routing. +-- Alternatively use can use lens combinators like 'scribe' and +-- 'censoring' together with widget lenses like 'wSection' and 'wStyle': +-- +-- > do scribe (wSection "header") (H.h1 "My fancy header") +-- > scribe wStyle $ html ? do +-- > background yellow +-- > color black +-- +-- The title is constructed by using 'withTitle' and 'setTitle'. This +-- allows you to have a hierarchy of titles with a site title, a page +-- title and even a component title: +-- +-- > withTitle "My site title" $ +-- > withTitle "My department title" $ +-- > setTitle "My page title" +-- > addSection "header" (H.h1 "My page title") +-- +-- The first type argument @url@ is the type of URLs. You may use it +-- for type-safe routing. If you don't use type-safe routing, you can +-- simply use 'Text'. +-- +-- The second type argument @h@ is the body type. For simple pages you +-- can use 'Html', but this widget type allows you to have more +-- complicated bodies, as long as you reduce them to 'Html' at some +-- point. For example this library predefines functions like +-- 'addSection' and 'flattenBody' to allow you to construct individual +-- page sections separately and then merge them. You can use it for +-- example to divide your document into a header, a menu, a content area +-- and a footer, and every widget can contribute to each of those +-- sections separately. +-- +-- Another way to use this is to construct your body using a completely +-- different document type, for example a Pandoc document, then later +-- convert it to 'Html'. -data Widget k url = +data Widget url h = Widget { + _wBody :: h, -- ^ Markup body. _wHead :: Html, -- ^ Head content. _wScript :: JStat, -- ^ Inline scripts. _wScriptLinks :: Set url, -- ^ External scripts. - _wSections :: Map k Html, -- ^ Contents of body sections. _wStyle :: Css, -- ^ Stylesheet. _wStyleLinks :: Set url, -- ^ External stylesheets. _wTitle :: Last [Text] -- ^ Page title chunks (outermost first). } - deriving (Foldable, Typeable) + deriving (Foldable, Functor, Typeable) -instance (Ord k, Ord url) => Monoid (Widget k url) where - mempty = - Widget { _wHead = mempty, +instance (Ord url) => Applicative (Widget url) where + pure x = + Widget { _wBody = x, + _wHead = mempty, _wScript = mempty, _wScriptLinks = mempty, - _wSections = M.empty, _wStyle = return (), _wStyleLinks = mempty, _wTitle = mempty } - mappend w1 w2 = - Widget { _wHead = _wHead w1 <> _wHead w2, - _wScript = _wScript w1 <> _wScript w2, - _wScriptLinks = _wScriptLinks w1 <> _wScriptLinks w2, - _wSections = M.unionWith (<>) (_wSections w1) (_wSections w2), - _wStyle = _wStyle w1 >> _wStyle w2, - _wStyleLinks = _wStyleLinks w1 <> _wStyleLinks w2, - _wTitle = _wTitle w1 <> _wTitle w2 } + wf <*> wx = + Widget { _wBody = _wBody wf (_wBody wx), + _wHead = _wHead wf <> _wHead wx, + _wScript = _wScript wf <> _wScript wx, + _wScriptLinks = _wScriptLinks wf <> _wScriptLinks wx, + _wStyle = _wStyle wf >> _wStyle wx, + _wStyleLinks = _wStyleLinks wf <> _wStyleLinks wx, + _wTitle = _wTitle wf <> _wTitle wx } +instance (Monoid h, Ord url) => Monoid (Widget url h) where + mempty = pure mempty + mappend = liftA2 (<>) + -- | Convenient type alias for polymorphic widget actions. -type WidgetWriter k url a = forall m. (MonadWidget k url m) => m a +type WidgetWriter url h a = forall m. (MonadWidget url h m) => m a -- | Construct a widget with the given body. Use this combinator if you -- don't need sections. -addBody :: (MonadWriter (Widget () url) m) => Html -> m () -addBody = addSection () +addBody :: h -> WidgetWriter url h () +addBody = scribe wBody -- | Construct a widget with the given head markup. -addHead :: (MonadWriter (Widget k url) m) => Html -> m () +addHead :: Html -> WidgetWriter url h () addHead = scribe wHead -- | Construct a widget with the given script. -addScript :: (MonadWriter (Widget k url) m) => JStat -> m () +addScript :: JStat -> WidgetWriter url h () addScript = scribe wScript -- | Construct a widget with the given script link. -addScriptLink :: (MonadWriter (Widget k url) m) => url -> m () +addScriptLink :: url -> WidgetWriter url h () addScriptLink url = scribe wScriptLinks (S.singleton url) -- | Construct a widget with the given body section. -addSection :: (MonadWriter (Widget k url) m) => k -> Html -> m () -addSection k = scribe wSections . M.singleton k +addSection :: (Eq k) => k -> h -> WidgetWriter url (k -> h) () +addSection k = scribe (wSection k) -- | Construct a widget with the given stylesheet. -addStyle :: (MonadWriter (Widget k url) m) => Css -> m () +addStyle :: Css -> WidgetWriter url h () addStyle = scribe wStyle -- | Construct a widget with the given style link. -addStyleLink :: (MonadWriter (Widget k url) m) => url -> m () +addStyleLink :: url -> WidgetWriter url h () addStyleLink url = scribe wStyleLinks (S.singleton url) +-- | Flatten the given widget's body by joining the given sections into +-- a single section. It's valid to list sections more than once. + +flattenBody :: (Monoid h) => [k] -> Widget url (k -> h) -> Widget url h +flattenBody ks = fmap (`foldMap` ks) + + +-- | Map the given action over all URLs in the given widget. + +mapLinksA :: (Applicative f, Ord url) => (url' -> f url) -> Widget url' h -> f (Widget url h) +mapLinksA f w = + liftA2 combine (urlMap $ _wScriptLinks w) (urlMap $ _wStyleLinks w) + + where + combine sc st = + w { _wScriptLinks = sc, + _wStyleLinks = st } + + urlMap = fmap S.fromList . traverse f . S.toList + + +-- | Monadic version of 'mapLinksA'. + +mapLinksM :: (Monad m, Ord url) => (url' -> m url) -> Widget url' h -> m (Widget url h) +mapLinksM f w = + liftM2 combine (urlMap $ _wScriptLinks w) (urlMap $ _wStyleLinks w) + + where + combine sc st = + w { _wScriptLinks = sc, + _wStyleLinks = st } + + urlMap = liftM S.fromList . mapM f . S.toList + + -- | Scribe the title of the widget. Use this function to construct the --- lowest level title. For higher level titles use 'withTitle'. +-- lowest level title. For higher level titles use 'withTitle'. The +-- most recently set title wins. -setTitle :: (MonadWriter (Widget k url) m) => Text -> m () +setTitle :: Text -> WidgetWriter url h () setTitle x = scribe wTitle (Last (Just [x])) +-- | Lens into a widget's body. + +wBody :: Lens' (Widget url h) h +wBody l w = (\x -> w { _wBody = x }) <$> l (_wBody w) + + -- | Lens into a widget's head. -wHead :: Lens' (Widget k url) Html +wHead :: Lens' (Widget url h) Html wHead l w = (\x -> w { _wHead = x }) <$> l (_wHead w) @@ -176,7 +256,7 @@ -- Conceptually this wraps the given widget in a higher level title. -- Use 'setTitle' for the lowest level title. -withTitle :: (MonadWriter (Widget k url) m) => Text -> m a -> m a +withTitle :: (MonadWidget url h m) => Text -> m a -> m a withTitle x = censoring wTitle f where f (Last Nothing) = Last Nothing @@ -185,35 +265,38 @@ -- | Lens into a widget's inline script. -wScript :: Lens' (Widget k url) JStat +wScript :: Lens' (Widget url h) JStat wScript l w = (\x -> w { _wScript = x }) <$> l (_wScript w) -- | Lens into a widget's external scripts. -wScriptLinks :: Lens' (Widget k url) (Set url) +wScriptLinks :: Lens' (Widget url h) (Set url) wScriptLinks l w = (\x -> w { _wScriptLinks = x }) <$> l (_wScriptLinks w) --- | Lens into a widget's body sections. +-- | Lens into a specific section of a widget. -wSections :: Lens' (Widget k url) (Map k Html) -wSections l w = (\x -> w { _wSections = x }) <$> l (_wSections w) +wSection :: (Eq k) => k -> Lens' (Widget url (k -> h)) h +wSection k = wBody . point k + where + point :: (Eq a) => a -> Lens' (a -> b) b + point ix l f = (\y -> (\ix' -> if ix' == ix then y else f ix')) <$> l (f ix) -- | Lens into a widget's inline style. -wStyle :: Lens' (Widget k url) Css +wStyle :: Lens' (Widget url h) Css wStyle l w = (\x -> w { _wStyle = x }) <$> l (_wStyle w) -- | Lens into a widget's external styles. -wStyleLinks :: Lens' (Widget k url) (Set url) +wStyleLinks :: Lens' (Widget url h) (Set url) wStyleLinks l w = (\x -> w { _wStyleLinks = x }) <$> l (_wStyleLinks w) -- | Lens into a widget's title. -wTitle :: Lens' (Widget k url) (Last [Text]) +wTitle :: Lens' (Widget url h) (Last [Text]) wTitle l w = (\x -> w { _wTitle = x }) <$> l (_wTitle w) diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -6,6 +6,8 @@ inherit (hs) cabal; develDepends = with hs; [ + wai + warp ]; in @@ -18,12 +20,15 @@ src = if devel then ./. else pkgs.fetchdarcs { url = ./.; }; buildDepends = with hs; [ + blazeBuilder blazeHtml clay jmacro lens mtl - webRoutes + Stream + text + vector wlPprintText ] ++ (if devel then develDepends else []); }) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -6,38 +6,65 @@ module Main where -import qualified Data.ByteString.Lazy.Char8 as Blc -import qualified Data.Text as T import qualified Text.Blaze.Html5 as H -import Clay +import Clay hiding ((!)) +import Control.Monad.State import Data.Text (Text) import Language.Javascript.JMacro +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import System.IO +import Text.Blaze.Html import Web.Page +import Web.Page.GenId -data Section = Header | Content | Footer - deriving (Eq, Ord, Show) +myWidget :: (HasIdStream a, MonadState a m, MonadWidget Text Html m) => m () +myWidget = do + setTitle "Test page" + myId <- newId -myWidget :: WidgetWriter Section Text () -myWidget = - withTitle "Test site" $ do - setTitle "Test page" - addSection Footer (H.p "copyright crap") - addScript [jmacro| alert("haha") |] - addSection Header (H.h1 "blah") - addStyle $ "html" ? do - background white - color black + addBody $ + H.h1 "My example page" <> + H.p "My boring paragraph." ! domId myId - addScriptLink "/js/blah.js" - addStyleLink "/style/screen.css" + addStyle $ idSel myId ? do + background white + color black + addStyle $ idSel myId # ".groovy" ? do + background darkblue + color pink + fontWeight bold -main :: IO () -main = do - let w = execWriter myWidget - p = renderWidget [Header, Content, Footer] (T.intercalate " - ") w - d = inlinePage p + addScriptLink "static/jquery.js" + addScript [jmacro| + fun init -> + window.setTimeout + (\() { + $("#" + `myId`).addClass("groovy"); + $(".groovy").text("My grooooooovy paragraph!") }) + 1000; - Blc.putStrLn d + $(init) |] + + +handler :: Application +handler req k | pathInfo req == ["static", "jquery.js"] = do + let ctype = (hContentType, "text/javascript; charset=UTF-8") + k (responseFile ok200 [ctype] "static/jquery.js" Nothing) + +handler req k = do + let w = execWriter (evalStateT myWidget (idsFrom ['a'..'z'])) + p = realiseInline (renderWidget (titleMajor ": ") w) + + hdrs = [(hContentType, "text/html; charset=UTF-8")] + + k (responseBuilder ok200 hdrs p) + + +main :: IO () +main = + run 8000 handler diff --git a/web-page.cabal b/web-page.cabal --- a/web-page.cabal +++ b/web-page.cabal @@ -1,21 +1,27 @@ name: web-page -version: 0.1.0 +version: 0.2.0 category: Web synopsis: Monoidally construct web pages maintainer: Ertugrul Söylemez author: Ertugrul Söylemez copyright: (c) 2014 Ertugrul Söylemez +homepage: http://hub.darcs.net/ertes/web-page +bug-reports: http://hub.darcs.net/ertes/web-page/issues license: BSD3 license-file: LICENSE build-type: Simple cabal-version: >= 1.10 extra-source-files: README.md default.nix description: - This package combines blaze-html, clay, jmacro and web-routes into a + This package combines blaze-html, clay and jmacro into a framework-agnostic library to generate web pages dynamically from individual components. It is inspired by Yesod's widgets, but is more general, more powerful and can be used with other web frameworks. + . + See the @README.md@ file for a full list of features and a quick + introduction. More detailed documentation can be found in the + individual modules. flag TestProgram default: False @@ -29,6 +35,7 @@ library build-depends: base >= 4.5 && < 5, + blaze-builder >= 0.3 && < 1, blaze-html >= 0.7 && < 1, bytestring >= 0.10 && < 1, clay >= 0.9 && < 1, @@ -36,19 +43,26 @@ jmacro >= 0.6 && < 1, lens >= 4.4 && < 5, mtl >= 2.1 && < 3, + Stream >= 0.4 && < 1, text >= 1.0 && < 2, + vector >= 0.10 && < 1, wl-pprint-text >= 1.1 && < 2 default-language: Haskell2010 default-extensions: ConstraintKinds DeriveDataTypeable DeriveFoldable + DeriveFunctor FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving OverloadedStrings RankNTypes + TupleSections ghc-options: -W exposed-modules: Web.Page + Web.Page.GenId Web.Page.Render Web.Page.Widget @@ -59,8 +73,12 @@ blaze-html, bytestring, clay, + http-types, jmacro, + mtl, text, + wai, + warp, web-page else buildable: False