{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
-- | Render TCT as HTML5.
module Language.TCT.Write.HTML5 where
html5TreesCell ts
html5IndentToken :: Tokens -> Html
-html5IndentToken (Seq.viewl -> EmptyL) = ""
-html5IndentToken toks@(Seq.viewl -> Cell pos _ _ :< _) =
- goTokens toks `S.evalState` linePos pos
- where
- indent = Text.replicate (columnPos pos - 1) " "
- go :: Cell Token -> S.State Int Html
- go tok =
- case unCell tok of
- TokenPlain txt -> do
- lin <- S.get
- let lines = Text.splitOn "\n" txt
- let lnums = H.toMarkup :
- [ \line -> do
- H.toMarkup '\n'
- H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
- H.toMarkup indent
- H.toMarkup line
- | lnum <- [lin+1..]
- ]
- S.put (lin - 1 + L.length lines)
- return $ mconcat $ L.zipWith ($) lnums lines
- TokenTag v ->
- return $
- H.span ! HA.class_ "tag" $ do
- H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
- H.toMarkup v
- TokenEscape c -> return $ H.toMarkup ['\\',c]
- TokenLink lnk ->
- return $
- H.a ! HA.href (attrValue lnk) $
- H.toMarkup lnk
- TokenPair (PairElem name attrs) ts -> do
- h <- goTokens ts
- return $ do
- let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
- H.span ! HA.class_ cl $ do
- whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
- whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
- whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
- where
- html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
- o,c :: Html
- (o,c) =
- if Seq.null ts
- then
- ( "<"<>html5name<>html5Attrs attrs<>"/>"
- , mempty )
- else
- ( "<"<>html5name<>html5Attrs attrs<>">"
- , "</"<>html5name<>">" )
- TokenPair grp ts -> do
- h <- goTokens ts
- return $ do
- let (o,c) = pairBorders grp ts
- H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
- H.span ! HA.class_ "pair-open" $ H.toMarkup o
- H.span ! HA.class_ "pair-content" $ h
- H.span ! HA.class_ "pair-close" $ H.toMarkup c
- goTokens :: Tokens -> S.State Int Html
- goTokens ts = do
- ts' <- go`mapM`ts
- return $ foldr (<>) mempty ts'
+html5IndentToken toks =
+ case Seq.viewl toks of
+ EmptyL -> ""
+ Cell pos _ _ :< _ ->
+ goTokens toks `S.evalState` linePos pos
+ where
+ indent = Text.replicate (columnPos pos - 1) " "
+ go :: Cell Token -> S.State Int Html
+ go tok =
+ case unCell tok of
+ TokenPlain txt -> do
+ lin <- S.get
+ let lines = Text.splitOn "\n" txt
+ let lnums = H.toMarkup :
+ [ \line -> do
+ H.toMarkup '\n'
+ H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
+ H.toMarkup indent
+ H.toMarkup line
+ | lnum <- [lin+1..]
+ ]
+ S.put (lin - 1 + L.length lines)
+ return $ mconcat $ L.zipWith ($) lnums lines
+ TokenTag v ->
+ return $
+ H.span ! HA.class_ "tag" $ do
+ H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
+ H.toMarkup v
+ TokenEscape c -> return $ H.toMarkup ['\\',c]
+ TokenLink lnk ->
+ return $
+ H.a ! HA.href (attrValue lnk) $
+ H.toMarkup lnk
+ TokenPair (PairElem name attrs) ts -> do
+ h <- goTokens ts
+ return $ do
+ let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
+ H.span ! HA.class_ cl $ do
+ whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
+ whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
+ whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
+ where
+ html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
+ o,c :: Html
+ (o,c) =
+ if Seq.null ts
+ then
+ ( "<"<>html5name<>html5Attrs attrs<>"/>"
+ , mempty )
+ else
+ ( "<"<>html5name<>html5Attrs attrs<>">"
+ , "</"<>html5name<>">" )
+ TokenPair grp ts -> do
+ h <- goTokens ts
+ return $ do
+ let (o,c) = pairBorders grp ts
+ H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
+ H.span ! HA.class_ "pair-open" $ H.toMarkup o
+ H.span ! HA.class_ "pair-content" $ h
+ H.span ! HA.class_ "pair-close" $ H.toMarkup c
+ goTokens :: Tokens -> S.State Int Html
+ goTokens ts = do
+ ts' <- go`mapM`ts
+ return $ foldr (<>) mempty ts'
html5Attrs :: Attrs -> Html
html5Attrs = foldMap html5Attr