front-0.0.0.1: src/Text/Blaze/Front/Renderer.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | A preliminary renderer that produces `JS` components when run using
-- Fay.
--
module Text.Blaze.Front.Renderer where
import qualified Data.ByteString.Char8 as SBC
import Data.List (isInfixOf)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.ByteString as S
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy as TL
import Prelude hiding (span)
import Text.Blaze.Front
import Text.Blaze.Front.Internal
-- import qualified Text.Blaze as B
import qualified Text.Blaze.Html as B
import Bridge
------------------------------------------------------------------------------
-- Rendering
------------------------------------------------------------------------------
-- | Escape predefined XML entities in a text value
--
escapeMarkupEntities :: Text -- ^ Text to escape
-> Builder -- ^ Resulting text builder
escapeMarkupEntities = T.foldr escape mempty
where
escape :: Char -> Builder -> Builder
escape '<' b = TLB.fromText "<" `mappend` b
escape '>' b = TLB.fromText ">" `mappend` b
escape '&' b = TLB.fromText "&" `mappend` b
escape '"' b = TLB.fromText """ `mappend` b
escape '\'' b = TLB.fromText "'" `mappend` b
escape x b = TLB.singleton x `mappend` b
-- | Render a 'ChoiceString'.
--
fromChoiceString :: ChoiceString -- ^ String to render
-> Builder -- ^ String to append
-> Builder -- ^ Resulting string
fromChoiceString (Static s) = (((TLB.fromText . getText) s) `mappend`)
fromChoiceString (String s) = (((escapeMarkupEntities . T.pack) s) `mappend`)
fromChoiceString (Text s) = ((escapeMarkupEntities s) `mappend`)
fromChoiceString (ByteString s) = (((TLB.fromText . T.pack . SBC.unpack) s) `mappend`)
fromChoiceString (PreEscaped x) =
case x of
String s -> (((TLB.fromText . T.pack) s) `mappend`)
Text s -> ((TLB.fromText s) `mappend`)
s -> fromChoiceString s
fromChoiceString (External x) = case x of
-- Check that the sequence "</" is *not* in the external data.
String s -> if "</" `isInfixOf` s then id else (((TLB.fromText . T.pack) s) `mappend`)
Text s -> if "</" `T.isInfixOf` s then id else ((TLB.fromText s) `mappend`)
ByteString s -> if "</" `S.isInfixOf` s then id else (((TLB.fromText . T.pack . SBC.unpack) s) `mappend`)
s -> fromChoiceString s
fromChoiceString (AppendChoiceString x y) =
fromChoiceString x . fromChoiceString y
fromChoiceString EmptyChoiceString = id
-- | Render some 'Markup' to a virtual dom.
--
-- This function is morally pure.
--
render
:: Show act
=> Markup act
-> Builder
-> Builder
render = go 0 id
where
go :: forall act' b. Int
-> (Builder -> Builder)
-> MarkupM act' b
-> Builder -> Builder
go i attrs (Parent _ open close content) =
ind i
. (((TLB.fromText . getText) open) `mappend`)
. attrs . ((TLB.fromText ">\n") `mappend`)
. go (inc i) id content . ind i
. (((TLB.fromText . getText) close) `mappend`)
. ((TLB.singleton '\n') `mappend`)
go i attrs (CustomParent tag content) =
ind i
. ((TLB.singleton '<') `mappend`)
. fromChoiceString tag . (attrs)
. ((TLB.fromText ">\n") `mappend`)
. go (inc i) id content . ind i
. ((TLB.fromText "</") `mappend`)
. fromChoiceString tag
. ((TLB.fromText ">\n") `mappend`)
go i attrs (Leaf _ begin end) =
ind i
. (((TLB.fromText . getText) begin) `mappend`)
. (attrs)
. (((TLB.fromText . getText) end) `mappend`)
. ((TLB.singleton '\n') `mappend`)
go i attrs (CustomLeaf tag close) =
ind i
. ((TLB.singleton '<') `mappend`)
. fromChoiceString tag . attrs
. ((TLB.fromText (if close then " />\n" else ">\n")) `mappend`)
go i attrs (AddAttribute _ key value h) = flip (go i) h $
(((TLB.fromText . getText) key) `mappend`)
. fromChoiceString value
. ((TLB.singleton '"') `mappend`) . attrs
go i attrs (AddCustomAttribute key value h) = flip (go i) h $
((TLB.singleton ' ') `mappend`)
. fromChoiceString key
. ((TLB.fromText "=\"") `mappend`)
. fromChoiceString value
. ((TLB.singleton '"') `mappend`) . attrs
go i _ (Content content) = ind i . fromChoiceString content
. ((TLB.singleton '\n') `mappend`)
go i attrs (Append h1 h2) = go i attrs h1 . go i attrs h2
go _ _ (Empty) = id
go _ _ (MapActions _ _) = id
go i attrs (OnEvent _ h) = go i attrs h -- will be registered later through registerEvent
{-# NOINLINE go #-}
-- Increase the indentation
inc = (+) 4
-- Produce appending indentation
ind i = ((TLB.fromString (replicate i ' ')) `mappend`)
{-# INLINE render #-}
renderHtml
:: Show act
=> Markup act
-> String
renderHtml html = TL.unpack . TLB.toLazyText $ render html TLB.flush
{-# INLINE renderHtml #-}
------------------------------------------------------------------------------
-- Event handler callback construction
------------------------------------------------------------------------------
-- | JS defines the following event types:
data EventType
-- Clipboard Events
= OnCopyE | OnCutE | OnPasteE
-- Keyboard Events
| OnKeyDownE | OnKeyPressE | OnKeyUpE
-- Focus Events
| OnFocusE | OnBlurE
-- Form Events
| OnChangeE | OnInputE | OnSubmitE
-- Mouse Events
| OnClickE | OnDoubleClickE | OnDragE | OnDragEndE | OnDragEnterE
| OnDragExitE | OnDragLeaveE | OnDragOverE | OnDragStartE | OnDropE
| OnMouseDownE | OnMouseEnterE | OnMouseLeaveE | OnMouseMoveE
| OnMouseOutE | OnMouseOverE | OnMouseUpE
-- Touch Events
| OnTouchCancelE | OnTouchEndE | OnTouchMoveE | OnTouchStartE
-- UI Events
| OnScrollE
-- Wheel Events
| OnWheelE
eventName :: EventType -> String
eventName _ = ""
{-eventName ev = case ev of
OnCopyE -> "onCopy"
OnCutE -> "onCut"
OnPasteE -> "onPaste"
OnKeyDownE -> "onKeyDown"
OnKeyPressE -> "onKeyPress"
OnKeyUpE -> "onKeyUp"
OnFocusE -> "onFocus"
OnBlurE -> "onBlur"
OnChangeE -> "onChange"
OnInputE -> "onInput"
OnSubmitE -> "onSubmit"
OnClickE -> "onClick"
OnDoubleClickE -> "onDoubleClick"
OnDragE -> "onDrag"
OnDragEndE -> "onDragEnd"
OnDragEnterE -> "onDragEnter"
OnDragExitE -> "onDragExit"
OnDragLeaveE -> "onDragLeave"
OnDragOverE -> "onDragOver"
OnDragStartE -> "onDragStart"
OnDropE -> "onDrop"
OnMouseDownE -> "onMouseDown"
OnMouseEnterE -> "onMouseEnter"
OnMouseLeaveE -> "onMouseLeave"
OnMouseMoveE -> "onMouseMove"
OnMouseOutE -> "onMouseOut"
OnMouseOverE -> "onMouseOver"
OnMouseUpE -> "onMouseUp"
OnTouchCancelE -> "onTouchCancel"
OnTouchEndE -> "onTouchEnd"
OnTouchMoveE -> "onTouchMove"
OnTouchStartE -> "onTouchStart"
OnScrollE -> "onScroll"
OnWheelE -> "onWheel"-}
data Handler
= IgnoreEvent
| HandleEvent (IO (Bool -> IO ()))
-- ^ Contains an IO action which generates the callback to attach to the event
registerEvents
:: Markup a -> [CallbackAction a] -> [CallbackAction a]
registerEvents x = go x
where
go :: MarkupM a b -> [CallbackAction a] -> [CallbackAction a]
go (MapActions _ _) = id
go (Parent _ _ _ content) = go content
go (CustomParent _ content) = go content
go (Leaf _ _ _) = id
go (CustomLeaf _ _) = id
go (Content _) = id
go (Append a b) = (go a) . (go b)
go (AddAttribute _ _ _ a) = go a
go (AddCustomAttribute _ _ a) = go a
go Empty = id
go (OnEvent eh a) = ((reg eh) :) . (go a)
reg x' = CallbackAction x'
renderNewMarkup :: Show act => Markup act -> B.Html
renderNewMarkup = B.preEscapedToHtml . T.pack . renderHtml