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, which is the preferred way to construct
-- widgets.

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

      -- * Widget actions
      MonadWidget,
      WidgetWriter,

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

      -- * Widget lenses
      wBody,
      wHead,
      wScript,
      wScriptLinks,
      wSection,
      wStyle,
      wStyleLinks,
      wTitle,

      -- * Mapping
      flattenBody,
      mapLinksA,
      mapLinksM
    )
    where

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, foldMap)
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 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 does
-- not denote effects of its own.
--
-- To construct widgets through a writer monad, you can use the @add*@
-- functions like 'addSection' or 'addStyle':
--
-- > do addSection "header" (H.h1 "My fancy header")
-- >    addStyle $ html ? do
-- >        background yellow
-- >        color black
--
-- 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 url h =
    Widget {
      _wBody        :: h,           -- ^ Markup body.
      _wHead        :: Html,        -- ^ Head content.
      _wScript      :: JStat,       -- ^ Inline scripts.
      _wScriptLinks :: Set url,     -- ^ External scripts.
      _wStyle       :: Css,         -- ^ Stylesheet.
      _wStyleLinks  :: Set url,     -- ^ External stylesheets.
      _wTitle       :: Last [Text]  -- ^ Page title chunks (outermost first).
    }
    deriving (Foldable, Functor, Typeable)

instance (Ord url) => Applicative (Widget url) where
    pure x =
        Widget { _wBody        = x,
                 _wHead        = mempty,
                 _wScript      = mempty,
                 _wScriptLinks = mempty,
                 _wStyle       = return (),
                 _wStyleLinks  = mempty,
                 _wTitle       = mempty }

    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 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 :: h -> WidgetWriter url h ()
addBody = scribe wBody


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

addHead :: Html -> WidgetWriter url h ()
addHead = scribe wHead


-- | Construct a widget with the given script.

addScript :: JStat -> WidgetWriter url h ()
addScript = scribe wScript


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

addScriptLink :: url -> WidgetWriter url h ()
addScriptLink url = scribe wScriptLinks (S.singleton url)


-- | Construct a widget with the given body section.

addSection :: (Eq k) => k -> h -> WidgetWriter url (k -> h) ()
addSection k = scribe (wSection k)


-- | Construct a widget with the given stylesheet.

addStyle :: Css -> WidgetWriter url h ()
addStyle = scribe wStyle


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

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'.  The
-- most recently set title wins.

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 url h) 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 :: (MonadWidget url h 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 url h) JStat
wScript l w = (\x -> w { _wScript = x }) <$> l (_wScript w)


-- | Lens into a widget's external scripts.

wScriptLinks :: Lens' (Widget url h) (Set url)
wScriptLinks l w = (\x -> w { _wScriptLinks = x }) <$> l (_wScriptLinks w)


-- | Lens into a specific section of a widget.

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 url h) Css
wStyle l w = (\x -> w { _wStyle = x }) <$> l (_wStyle w)


-- | Lens into a widget's external styles.

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 url h) (Last [Text])
wTitle l w = (\x -> w { _wTitle = x }) <$> l (_wTitle w)