module Text.Html.Nice.Writer
(
Markup
, text
, lazyText
, builder
, string
, doctype_
, textRaw
, lazyTextRaw
, builderRaw
, stringRaw
, AddAttr
, (!)
, dynamic
, dynamicRaw
, using
, sub
, mapP
, stream
, Note (..)
, note
, compile
, runMarkup
, makeElement
, makeVoidElement
) where
import Data.Foldable (toList)
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Vector as V
import Text.Html.Nice.Internal
type Children p = [Markup' p] -> [Markup' p]
data MarkupStep p a = MarkupStep
{ msGlobalId :: !Int
, msChildren :: Children p
, msResult :: a
} deriving (Functor, Foldable, Traversable)
newtype Markup p a = Markup (Int -> [Attr p] -> MarkupStep p a)
instance Functor (Markup p) where
fmap f (Markup m) = Markup (\i attr -> fmap f (m i attr))
instance Applicative (Markup p) where
pure a = Markup (\i _ -> MarkupStep i id a)
Markup f <*> Markup x = Markup $ \i attr ->
case f i attr of
MarkupStep j fnodes f' ->
case x j [] of
MarkupStep k xnodes x' ->
MarkupStep k (fnodes . xnodes) (f' x')
instance Monad (Markup p) where
Markup mx >>= f = Markup $ \i attr -> case mx i attr of
MarkupStep j dx a -> case f a of
Markup f' -> case f' j attr of
MarkupStep k dy b -> MarkupStep k (dx . dy) b
compile :: Markup t a -> FastMarkup t
compile m = case runM 0 m of (m', _, _) -> compile_ m'
runMarkup :: Markup t a -> (a, FastMarkup t)
runMarkup m = case runM 0 m of (m', _, a) -> (a, compile_ m')
runM :: Int -> Markup t a -> (Markup' t, Int, a)
runM i (Markup m) = (List (x []), j, a) where MarkupStep j x a = m i []
makeElement :: Text -> Markup p a -> Markup p a
makeElement name m =
Markup $ \i attr -> case runM i m of
(cs, j, a) -> MarkupStep
{ msGlobalId = j
, msChildren = (:) (Node name (V.fromList attr) cs)
, msResult = a
}
makeVoidElement :: Text -> Markup p ()
makeVoidElement name = Markup $ \i attr -> MarkupStep
{ msGlobalId = i
, msChildren = (:) (VoidNode name (V.fromList attr))
, msResult = ()
}
lift :: Markup' t -> Markup t ()
lift m' = Markup $ \i _ -> MarkupStep
{ msGlobalId = i
, msChildren = (m':)
, msResult = ()
}
doctype_ :: Markup p ()
doctype_ = lift Doctype
using :: ToFastMarkup b => (a -> b) -> Markup (a -> FastMarkup r) ()
using f = dynamic (toFastMarkup . f)
dynamic :: p -> Markup p ()
dynamic = lift . Hole DoEscape
dynamicRaw :: p -> Markup p ()
dynamicRaw = lift . Hole Don'tEscape
mapP :: (a -> b) -> Markup a r -> Markup b r
mapP f (Markup m) = Markup $ \i attr -> case m i (foldr addA [] attr) of
ms -> ms { msChildren = \cs -> map (fmap f) (msChildren ms []) ++ cs }
where
addA ((:=) a b) xs = (a := b) : xs
addA _ xs = xs
instance a ~ () => IsString (Markup t a) where
fromString = text . fromString
type MarkupLike a = a
class AddAttr a t | a -> t where
addAttr :: a -> Attr t -> a
instance AddAttr (Markup t a -> Markup t b) t where
addAttr f a x = Markup $ \i attrs ->
case f x of
Markup m -> m i (a:attrs)
instance AddAttr (Markup t a) t where
addAttr f a = Markup $ \i attrs ->
case f of
Markup m -> m i (a:attrs)
(!) :: AddAttr a t => MarkupLike a -> Attr t -> MarkupLike a
(!) = addAttr
infixl 8 !
stream :: Foldable f
=> Markup (a -> n) r
-> Markup (f a -> FastMarkup n) r
stream m =
result <$ dynamicRaw (\fa -> FStream (ListS (toList fa) fm))
where
(result, !fm) = runMarkup m
sub :: Markup n a -> Markup (FastMarkup n) a
sub m = case runMarkup m of
(a, fm) -> a <$ lift (Hole Don'tEscape fm)
data Note a = Note
{ noteId :: !Int
, noted :: FastMarkup a
} deriving (Eq, Show, Functor)
note :: (Markup t a -> Markup t b) -> Markup t a -> Markup t (Note t, b)
note f x = withNote
where
withNote = do
(i, a) <- markup
case runM i markup of
(m', _, _) -> return (Note
{ noteId = i
, noted = compile_ m'
}, a)
markup = Markup $ \i attrs -> case f x of
Markup m ->
case m (i + 1) ("id" := niceId i:attrs) of
ms -> ms { msResult = (i, msResult ms) }
niceId :: Int -> Text
niceId i = T.pack ("nice-" ++ show i)
text :: Text -> Markup t ()
text = lift . Text DoEscape . StrictT
lazyText :: TL.Text -> Markup n ()
lazyText = lift . Text DoEscape . LazyT
builder :: TLB.Builder -> Markup n ()
builder = lift . Text DoEscape . BuilderT
string :: String -> Markup n ()
string = lift . Text DoEscape . BuilderT . TLB.fromString
textRaw :: Text -> Markup t ()
textRaw = lift . Text Don'tEscape . StrictT
lazyTextRaw :: TL.Text -> Markup n ()
lazyTextRaw = lift . Text Don'tEscape . LazyT
builderRaw :: TLB.Builder -> Markup n ()
builderRaw = lift . Text Don'tEscape . BuilderT
stringRaw :: String -> Markup n ()
stringRaw = lift . Text Don'tEscape . BuilderT . TLB.fromString