Widget.hs

-- |
-- Module:     Web.Page.Widget
-- Copyright:  (c) 2014 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <ertesx@gmx.de>
--
-- 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.

module Web.Page.Widget
    ( -- * Page widgets
      Widget(..),

      -- * Widget actions
      MonadWidget,
      WidgetWriter,

      -- * Constructing widgets
      addBody,
      addHead,
      addScript,
      addScriptLink,
      addSection,
      addStyle,
      addStyleLink,
      setTitle,
      withTitle,

      -- * Widget lenses
      wHead,
      wScript,
      wScriptLinks,
      wSections,
      wStyle,
      wStyleLinks,
      wTitle
    )
    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.Writer.Class
import Data.Foldable (Foldable)
import Data.Map (Map)
import Data.Monoid
import Data.Set (Set)
import Data.Text (Text)
import Data.Typeable
import Language.Javascript.JMacro (JStat)
import Text.Blaze.Html


-- | Convenient constraint alias for widget actions.

type MonadWidget k url = MonadWriter (Widget k url)


-- | 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.
--
-- 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.
--
-- 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.
--
-- The second type argument is the type of URLs.  You may use it for
-- type-safe routing.

data Widget k url =
    Widget {
      _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)

instance (Ord k, Ord url) => Monoid (Widget k url) where
    mempty =
        Widget { _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 }


-- | Convenient type alias for polymorphic widget actions.

type WidgetWriter k url a = forall m. (MonadWidget k url 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 ()


-- | Construct a widget with the given head markup.

addHead :: (MonadWriter (Widget k url) m) => Html -> m ()
addHead = scribe wHead


-- | Construct a widget with the given script.

addScript :: (MonadWriter (Widget k url) m) => JStat -> m ()
addScript = scribe wScript


-- | Construct a widget with the given script link.

addScriptLink :: (MonadWriter (Widget k url) m) => url -> m ()
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


-- | Construct a widget with the given stylesheet.

addStyle :: (MonadWriter (Widget k url) m) => Css -> m ()
addStyle = scribe wStyle


-- | Construct a widget with the given style link.

addStyleLink :: (MonadWriter (Widget k url) m) => url -> m ()
addStyleLink url = scribe wStyleLinks (S.singleton url)


-- | Scribe the title of the widget.  Use this function to construct the
-- lowest level title.  For higher level titles use 'withTitle'.

setTitle :: (MonadWriter (Widget k url) m) => Text -> m ()
setTitle x = scribe wTitle (Last (Just [x]))


-- | Lens into a widget's head.

wHead :: Lens' (Widget k url) Html
wHead l w = (\x -> w { _wHead = x }) <$> l (_wHead w)


-- | Prepend the given title chunk to the given widget action.
-- 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 x = censoring wTitle f
    where
    f (Last Nothing)   = Last Nothing
    f (Last (Just xs)) = Last (Just (x:xs))


-- | Lens into a widget's inline script.

wScript :: Lens' (Widget k url) 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 l w = (\x -> w { _wScriptLinks = x }) <$> l (_wScriptLinks w)


-- | Lens into a widget's body sections.

wSections :: Lens' (Widget k url) (Map k Html)
wSections l w = (\x -> w { _wSections = x }) <$> l (_wSections w)


-- | Lens into a widget's inline style.

wStyle :: Lens' (Widget k url) 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 l w = (\x -> w { _wStyleLinks = x }) <$> l (_wStyleLinks w)


-- | Lens into a widget's title.

wTitle :: Lens' (Widget k url) (Last [Text])
wTitle l w = (\x -> w { _wTitle = x }) <$> l (_wTitle w)