+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
--- | Render TCT as HTML5.
module Language.TCT.Write.HTML5 where
-import Control.Monad (Monad(..), forM_, mapM, when)
+import Control.Monad (Monad(..), forM_, mapM_, when, unless)
import Data.Bool
+import Data.Char (Char)
+import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
-import Data.Function (($))
-import Data.Int (Int)
+import Data.Function (($), (.))
+import Data.Functor.Compose (Compose(..))
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
-import Data.Ord (Ord(..))
+import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..))
-import Data.String (IsString(..))
-import Data.Text (Text)
-import Data.TreeSeq.Strict (Tree(..),Trees)
-import Prelude (Num(..), undefined)
+import Data.String (String, IsString(..))
+import Prelude (Num(..), undefined, error)
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
-import qualified Data.List as L
+import qualified Data.List as List
import qualified Data.Sequence as Seq
-import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html5 as H
-import qualified Text.Blaze.Html5.Attributes as HA
+import qualified Text.Blaze.Html5.Attributes as HA
-import Text.Blaze.Utils
import Language.TCT
-import Language.TCT.Write.Text
+-- import Language.TCT.Debug
+import Language.TCT.Utils
+import Text.Blaze.Utils
+import qualified Language.TCT.Write.Plain as Plain
-html5Document :: TCTs -> Html
-html5Document tct = do
+writeHTML5 :: Trees (Cell Node) -> Html
+writeHTML5 body = do
H.docType
H.html $ do
H.head $ do
H.meta ! HA.httpEquiv "Content-Type"
! HA.content "text/html; charset=UTF-8"
- whenJust (tokensTitle tct) $ \ts ->
- H.title $ H.toMarkup $ L.head $
- TL.lines (textTokens ts) <> [""]
+ whenJust (titleFrom body) $ \t ->
+ H.title $
+ H.toMarkup $ Plain.text def t
-- link ! rel "Chapter" ! title "SomeTitle">
H.link ! HA.rel "stylesheet"
! HA.type_ "text/css"
! HA.href "style/tct-html5.css"
+ let (html5Body, State{}) =
+ runStateMarkup def $
+ html5ify body
H.body $ do
- H.a ! HA.id ("line-1") $ return ()
- html5TreesCell (treePosLastCell tct)
+ H.a ! HA.id "line-1" $ return ()
+ html5Body
-html5TreesCell :: Trees (Pos,Cell Key) (Pos,Tokens) -> Html
-html5TreesCell = foldMap html5TreeCell
-
-tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens
-tokensTitle tct =
- L.find (\case
- TreeN (unCell -> KeySection{}) _ts -> True
+titleFrom :: Roots -> Maybe Root
+titleFrom tct =
+ List.find (\case
+ Tree (unCell -> NodeHeader HeaderSection{}) _ts -> True
_ -> False) tct >>=
\case
- TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
+ Tree (unCell -> NodeHeader (HeaderSection _lvl))
+ (Seq.viewl -> title:<_) -> Just title
_ -> Nothing
-html5Text :: Text -> Html
-html5Text = H.toMarkup
-
-html5Spaces :: Int -> Html
-html5Spaces 0 = return ()
-html5Spaces sp = H.span $ html5Text $ Text.replicate sp " "
+-- * Type 'Html5'
+type Html5 = StateMarkup State ()
-html5TreeCell :: Tree (Pos,Cell Key) (Pos,Tokens) -> Html
-html5TreeCell (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do
- html5IndentCell (posEnd,pos)
- H.section $ do
- H.span ! HA.class_ "section-title" $ do
- H.span $ html5Text $ Text.replicate lvl "#" <> " "
- case Seq.viewl ts of
- Tree0 (_,title) :< _ -> h lvl $ html5IndentToken title
- _ -> return ()
- html5TreesCell $
- case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}
- where
- h 1 = H.h1
- h 2 = H.h2
- h 3 = H.h3
- h 4 = H.h4
- h 5 = H.h5
- h 6 = H.h6
- h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
- h _ = undefined
-html5TreeCell (Tree0 (posEnd,toks)) =
- case Seq.viewl toks of
- EmptyL -> html5IndentToken toks
- t0:<_ -> html5IndentCell (posEnd,posCell t0) <> html5IndentToken toks
-html5TreeCell (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
- html5IndentCell (posEnd,pos) <>
- html5CellKey cell cs
+instance IsString Html5 where
+ fromString = mapM_ html5ify
-html5IndentCell :: (Pos,Pos) -> Html
-html5IndentCell (Pos lineLast colLast,Pos line col)
- | lineLast < line = do
- forM_ [lineLast+1..line] $ \lnum -> do
- H.toMarkup '\n'
- H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
- H.toMarkup $ Text.replicate (col - 1) " "
- | lineLast == line
- && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " "
- | otherwise = undefined
+html5 :: H.ToMarkup a => a -> Html5
+html5 = Compose . return . H.toMarkup
-html5CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Tokens) -> Html
-html5CellKey (Cell _pos _posEnd key) ts = do
- case key of
- KeyColon n wh -> html5Key "" "" n wh ":" "" "colon"
- KeyGreat n wh -> html5Key "" "" n wh ">" "" "great"
- KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal"
- KeyBar n wh -> html5Key "" "" n wh "|" "" "bar"
- KeyDot n -> html5Key "" "" n "" "." "" "dot"
- KeyDash -> html5Key "" "" "" "" "-" " " "dash"
- KeyDashDash -> html5Key "" "" "" "" "--" " " "dashdash"
- KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash"
- KeyLower name attrs -> do
- H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do
- H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
- H.span ! HA.class_ "key-name" $ H.toMarkup name
- html5Attrs attrs
- html5TreesCell ts
- where
- html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html
- html5Key markBegin whmb name whn markEnd whme cl = do
- -- html5Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
- H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
- when (markBegin/="") $
- H.span ! HA.class_ "key-mark" $ H.toMarkup markBegin
- H.toMarkup whmb
- when (name/="") $
- H.span ! HA.class_ "key-name" $ H.toMarkup name
- H.toMarkup whn
- when (markEnd/="") $
- H.span ! HA.class_ "key-mark" $ H.toMarkup markEnd
- H.toMarkup whme
- H.span ! HA.class_ "key-value" $
- html5TreesCell ts
+-- ** Type 'State'
+data State
+ = State
+ { state_pos :: Pos
+ , state_indent :: Html5
+ , state_italic :: Bool
+ , state_ext_html :: String
+ } -- deriving (Eq, Show)
+instance Default State where
+ def = State
+ { state_pos = pos1
+ , state_indent = ""
+ , state_italic = False
+ , state_ext_html = ".html"
+ }
+-- instance Pretty State
-html5IndentToken :: Tokens -> Html
-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
+-- * Class 'Html5ify'
+class Html5ify a where
+ html5ify :: a -> Html5
+instance Html5ify () where
+ html5ify = mempty
+instance Html5ify Char where
+ html5ify = \case
+ '\n' -> do
+ s@State{state_pos=Pos line _col, ..} <- liftStateMarkup S.get
+ liftStateMarkup $ S.put s{state_pos=Pos (line + 1) 1}
+ html5 '\n'
+ H.a ! HA.id ("line-"<>attrify (line + 1)) $$ return ()
+ state_indent
+ c -> do
+ liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
+ s{state_pos=Pos line (col + 1)}
+ html5 c
+instance Html5ify String where
+ html5ify = mapM_ html5ify
+instance Html5ify TL.Text where
+ html5ify t
+ | TL.null t = mempty
+ | otherwise =
+ let (h,ts) = TL.span (/='\n') t in
+ case TL.uncons ts of
+ Nothing -> do
+ liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
+ s{state_pos=Pos line $ col + int (TL.length h)}
+ html5 h
+ Just (_n,ts') -> do
+ html5 h
+ -- NOTE: useless to increment the pos_column for h,
+ -- since the following '\n' will reset the pos_column.
+ html5ify '\n'
+ html5ify ts'
+instance Html5ify Pos where
+ html5ify new@(Pos lineNew colNew) = do
+ s@State
+ { state_pos=old@(Pos lineOld colOld)
+ , state_indent
+ } <- liftStateMarkup S.get
+ case lineOld`compare`lineNew of
+ LT -> do
+ forM_ [lineOld+1..lineNew] $ \lnum -> do
+ html5 '\n'
+ H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
+ liftStateMarkup $ S.put s{state_pos=Pos lineNew 1}
+ state_indent
+ Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+ html5 $ List.replicate (colNew - colMid) ' '
+ liftStateMarkup $ S.put s{state_pos=new}
+ EQ | colOld <= colNew -> do
+ liftStateMarkup $ S.put s{state_pos=new}
+ html5 $ List.replicate (colNew - colOld) ' '
+ _ -> error $ "html5ify: non-ascending Pos:"
+ <> "\n old: " <> show old
+ <> "\n new: " <> show new
+instance Html5ify Roots where
+ html5ify = mapM_ html5ify
+instance Html5ify Root where
+ html5ify (Tree (Cell (Span{span_begin=bp}:|_) nod) ts) = do
+ html5ify bp
+ case nod of
+ ----------------------
+ NodeLower name attrs -> do
+ H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do
+ H.span ! HA.class_ "header-mark" $$ html5ify '<'
+ H.span ! HA.class_ "header-name" $$ html5ify name
+ html5ify attrs
+ html5ify ts
+ ----------------------
+ NodeHeader hdr ->
+ case hdr of
+ HeaderGreat n wh -> html5HeaderRepeated "" "" n wh ">" "" "great"
+ HeaderBar n wh -> html5HeaderRepeated "" "" n wh "|" "" "bar"
+ HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon"
+ HeaderEqual n wh -> html5Header "" "" n wh "=" "" "equal"
+ HeaderDot n -> html5Header "" "" n "" "." "" "dot"
+ HeaderDash -> html5Header "" "" "" "" "-" " " "dash"
+ HeaderDashDash -> html5Header "" "" "" "" "--" " " "dashdash"
+ HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash"
+ HeaderSection lvl -> do
+ H.section $$ do
+ H.span ! HA.class_ "section-title" $$ do
+ H.span ! HA.class_ "section-mark" $$ do
+ html5ify $ List.replicate lvl '#'
+ case Seq.viewl ts of
+ title :< _ -> h lvl $$ html5ify title
+ _ -> return ()
+ html5ify $
+ case Seq.viewl ts of
+ _ :< ts' -> ts'
+ _ -> ts
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
-
-html5Attr :: (Text,Attr) -> Html
-html5Attr (attr_white,Attr{..}) = do
- H.toMarkup attr_white
- H.span ! HA.class_ "attr-name" $
- H.toMarkup attr_name
- H.toMarkup attr_open
- H.span ! HA.class_ "attr-value" $
- H.toMarkup attr_value
- H.toMarkup attr_close
+ h 1 = H.h1
+ h 2 = H.h2
+ h 3 = H.h3
+ h 4 = H.h4
+ h 5 = H.h5
+ h 6 = H.h6
+ h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
+ h _ = undefined
+ HeaderDotSlash file -> do
+ ext <- liftStateMarkup $ S.gets state_ext_html
+ if null ext
+ then html5ify file
+ else
+ H.a ! HA.class_ "header-dotslash"
+ ! HA.href (attrify $ file<>ext) $$
+ html5ify file
+ where
+ html5Head :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
+ html5Head markBegin whmb name whn markEnd whme cl = do
+ H.span ! HA.class_ (mconcat $ ["header header-",cl] <>
+ if TL.null name then [] else [" header-name-",attrify name]) $$ do
+ when (markBegin/="") $
+ H.span ! HA.class_ "header-mark" $$ html5ify markBegin
+ html5ify whmb
+ when (name/="") $
+ H.span ! HA.class_ "header-name" $$ html5ify name
+ html5ify whn
+ when (markEnd/="") $
+ H.span ! HA.class_ "header-mark" $$ html5ify markEnd
+ html5ify whme
+ html5Header markBegin whmb name whn markEnd whme cl = do
+ html5Head markBegin whmb name whn markEnd whme cl
+ H.span ! HA.class_ "header-value" $$
+ html5ify ts
+ html5HeaderRepeated :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
+ html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
+ State{state_indent} <- liftStateMarkup S.get
+ liftStateMarkup $ S.modify' $ \s ->
+ s{ state_indent = do
+ state_indent
+ Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+ html5ify $ List.replicate (pos_column bp - colMid) ' '
+ html5Head markBegin whmb name whn markEnd whme cl
+ }
+ r <- html5Header markBegin whmb name whn markEnd whme cl
+ liftStateMarkup $ S.modify' $ \s -> s{state_indent}
+ return r
+ ----------------------
+ NodeText t -> do
+ State{state_indent} <- liftStateMarkup S.get
+ liftStateMarkup $ S.modify' $ \s ->
+ s{ state_indent = do
+ state_indent
+ Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+ html5ify $ List.replicate (pos_column bp - colMid) ' '
+ }
+ r <- html5ify t
+ liftStateMarkup $ S.modify' $ \s -> s{state_indent}
+ return r
+ ----------------------
+ NodePara -> do
+ State{state_indent} <- liftStateMarkup S.get
+ liftStateMarkup $ S.modify' $ \s ->
+ s{ state_indent = do
+ state_indent
+ Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+ html5ify $ List.replicate (pos_column bp - colMid) ' '
+ }
+ r <- html5ify ts
+ liftStateMarkup $ S.modify' $ \s -> s{state_indent}
+ return r
+ ----------------------
+ NodeToken t -> html5ify t <> html5ify ts
+ ----------------------
+ NodePair pair ->
+ case pair of
+ PairElem name attrs -> do
+ H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
+ H.span ! HA.class_ "pair-open" $$ o
+ unless (null ts) $ do
+ H.span ! HA.class_ "pair-content" $$ html5ify ts
+ H.span ! HA.class_ "pair-close" $$ c
+ where
+ html5Name =
+ H.span ! HA.class_ "elem-name" $$
+ html5ify name
+ o,c :: Html5
+ (o,c)
+ | null ts =
+ ( "<"<>html5Name<>html5ify attrs<>"/>"
+ , mempty )
+ | otherwise =
+ ( "<"<>html5Name<>html5ify attrs<>">"
+ , "</"<>html5Name<>">" )
+ _ -> do
+ H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do
+ let (o,c) = pairBorders pair ts
+ H.span ! HA.class_ "pair-open" $$ html5ify o
+ H.span ! HA.class_ "pair-content" $$ em $ html5ify ts
+ H.span ! HA.class_ "pair-close" $$ html5ify c
+ where
+ em :: Html5 -> Html5
+ em h =
+ case pair of
+ p | p == PairSlash
+ || p == PairFrenchquote
+ || p == PairDoublequote -> do
+ State{..} <- liftStateMarkup $ S.get
+ liftStateMarkup $ S.modify' $ \s -> s{state_italic = not state_italic}
+ r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h
+ liftStateMarkup $ S.modify' $ \s -> s{state_italic}
+ return r
+ _ -> h
+instance Html5ify Token where
+ html5ify tok =
+ case tok of
+ TokenText t -> html5ify t
+ TokenTag v ->
+ H.span ! HA.class_ "tag" $$ do
+ H.span ! HA.class_ "tag-open" $$
+ html5ify '#'
+ html5ify v
+ TokenEscape c -> html5ify ['\\', c]
+ TokenLink l -> do
+ H.a ! HA.href (attrify l) $$
+ html5ify l
+instance Html5ify ElemAttrs where
+ html5ify = mapM_ html5ify
+instance Html5ify (White,ElemAttr) where
+ html5ify (elemAttr_white,ElemAttr{..}) = do
+ html5ify elemAttr_white
+ H.span ! HA.class_ "attr-name" $$
+ html5ify elemAttr_name
+ html5ify elemAttr_open
+ H.span ! HA.class_ "attr-value" $$
+ html5ify elemAttr_value
+ html5ify elemAttr_close