webwire-0.1.0: WebWire/Widget.hs

-- |
-- Module:     WebWire.Widget
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- HTML widgets, inspired by Yesod.

module WebWire.Widget
    ( -- * Widget type
      Widget(..),

      -- * Adding content
      bodyW,
      hamletW,
      titleW,

      -- * Stylesheets
      cassiusW,
      cssLinkW,
      cssW,

      -- * JavaScript
      jsLinkW,
      jsW,
      juliusW
    )
    where

import qualified Text.Blaze.Html5 as He
import qualified Text.Blaze.Html5.Attributes as Ha
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Monoid
import Data.Text (Text)
import Text.Blaze
import Text.Cassius
import Text.Hamlet
import Text.Julius


-- | A widget is essentially a full HTML page splitted into the actual
-- HTML markup and its dependencies like CSS and JavaScript.

data Widget =
    Widget {
      wgtBody    :: Html,       -- ^ HTML body.
      wgtHeadCSS :: [TL.Text],  -- ^ CSS source code to add.
      wgtHeadJS  :: [TL.Text],  -- ^ JavaScript source code to add.
      wgtLinkCSS :: [Text],     -- ^ CSS links to add.
      wgtLinkJS  :: [Text],     -- ^ JavaScript links to add.
      wgtTitle   :: [Text]      -- ^ Page title parts.
    }


-- | The empty widget is an HTML page with an empty body and no
-- dependencies.  The sum of two widgets is the concatenation of the
-- individual HTML markups and the union of their dependencies, such
-- that external stylesheets or JavaScript files are only included once.

instance Monoid Widget where
    mempty =
        Widget { wgtBody    = mempty,
                 wgtHeadCSS = [],
                 wgtHeadJS  = [],
                 wgtLinkCSS = [],
                 wgtLinkJS  = [],
                 wgtTitle   = [] }

    mappend w1 w2 =
        let ws = [w1, w2] in
        Widget { wgtBody    = mappend (wgtBody w1) (wgtBody w2),
                 wgtHeadCSS = concatMap wgtHeadCSS ws,
                 wgtHeadJS  = concatMap wgtHeadJS ws,
                 wgtLinkCSS = concatMap wgtLinkCSS ws,
                 wgtLinkJS  = concatMap wgtLinkJS ws,
                 wgtTitle   = concatMap wgtTitle ws }


-- | A widget can be converted into HTML with a default page template.
-- This should suffice for simple websites.

instance ToHtml Widget where
    toHtml w =
        let title = T.intercalate ": " (wgtTitle w)
            linkCSS =
                mconcat .
                map (\ref -> He.link ! Ha.rel "stylesheet" ! Ha.type_ "text/css" ! Ha.href (toValue ref)) .
                wgtLinkCSS $ w
            linkJS =
                mconcat .
                map (\ref -> He.script mempty ! Ha.type_ "text/javascript" ! Ha.src (toValue ref)) .
                wgtLinkJS $ w
            headCSS =
                mconcat .
                map (\src -> He.style (toHtml src) ! Ha.type_ "text/css") .
                wgtHeadCSS $ w
            headJS =
                mconcat .
                map (\src -> He.script (toHtml src) ! Ha.type_ "text/javascript") .
                wgtHeadJS $ w
        in
        He.docType `mappend`
        He.head (
            He.title (toHtml title) `mappend`
            linkCSS `mappend` linkJS `mappend`
            headCSS `mappend` headJS) `mappend`
        He.body (wgtBody w)


-- | Widget with an HTML body fragment.

bodyW :: Html -> Widget
bodyW html = mempty { wgtBody = html }


-- | Widget with an inline CSS stylesheet rendered by Cassius or Lucius.

cassiusW :: CssUrl a -> Widget
cassiusW cass = mempty { wgtHeadCSS = [renderCss $ cass (\_ _ -> "/")] }


-- | Widget with an external CSS link.

cssLinkW :: Text -> Widget
cssLinkW src = mempty { wgtLinkCSS = [src] }


-- | Widget with an inline CSS stylesheet.

cssW :: TL.Text -> Widget
cssW src = mempty { wgtHeadCSS = [src] }


-- | Widget with an HTML body fragment from Hamlet.

hamletW :: HtmlUrl a -> Widget
hamletW html = mempty { wgtBody = html (\_ _ -> "/") }


-- | Widget with an external JavaScript link.

jsLinkW :: Text -> Widget
jsLinkW src = mempty { wgtLinkJS = [src] }


-- | Widget with inline JavaScript.

jsW :: TL.Text -> Widget
jsW src = mempty { wgtHeadJS = [src] }


-- | Widget with inline JavaScript rendered by Julius.

juliusW :: JavascriptUrl a -> Widget
juliusW js = mempty { wgtHeadJS = [renderJavascript $ js (\_ _ -> "/")] }


-- | Widget with a title segment.

titleW :: Text -> Widget
titleW title = mempty { wgtTitle = [title] }