]> Git — Sourcephile - doclang.git/blob - Language/TCT/Write/HTML5.hs
Factorize XML utilities.
[doclang.git] / Language / TCT / Write / HTML5.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RecordWildCards #-}
3 {-# LANGUAGE ViewPatterns #-}
4 -- | Render TCT as HTML5.
5 module Language.TCT.Write.HTML5 where
6
7 import Control.Monad (Monad(..), forM_, mapM, when)
8 import Data.Bool
9 import Data.Eq (Eq(..))
10 import Data.Foldable (Foldable(..))
11 import Data.Function (($))
12 import Data.Int (Int)
13 import Data.Maybe (Maybe(..))
14 import Data.Monoid (Monoid(..))
15 import Data.Ord (Ord(..))
16 import Data.Semigroup (Semigroup(..))
17 import Data.Sequence (ViewL(..))
18 import Data.String (IsString(..))
19 import Data.Text (Text)
20 import Data.TreeSeq.Strict (Tree(..),Trees)
21 import Prelude (Num(..), undefined)
22 import Text.Blaze ((!))
23 import Text.Blaze.Html (Html)
24 import Text.Show (Show(..))
25 import qualified Control.Monad.Trans.State as S
26 import qualified Data.List as L
27 import qualified Data.Sequence as Seq
28 import qualified Data.Text as Text
29 import qualified Data.Text.Lazy as TL
30 import qualified Text.Blaze.Html5 as H
31 import qualified Text.Blaze.Html5.Attributes as HA
32
33 import Text.Blaze.Utils
34 import Language.TCT
35 import Language.TCT.Write.Text
36
37 html5Document :: TCTs -> Html
38 html5Document tct = do
39 H.docType
40 H.html $ do
41 H.head $ do
42 H.meta ! HA.httpEquiv "Content-Type"
43 ! HA.content "text/html; charset=UTF-8"
44 whenJust (tokensTitle tct) $ \ts ->
45 H.title $ H.toMarkup $ L.head $
46 TL.lines (textTokens ts) <> [""]
47 -- link ! rel "Chapter" ! title "SomeTitle">
48 H.link ! HA.rel "stylesheet"
49 ! HA.type_ "text/css"
50 ! HA.href "style/tct-html5.css"
51 H.body $ do
52 H.a ! HA.id ("line-1") $ return ()
53 html5TreesCell (treePosLastCell tct)
54
55 html5TreesCell :: Trees (Pos,Cell Key) (Pos,Tokens) -> Html
56 html5TreesCell = foldMap html5TreeCell
57
58 tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens
59 tokensTitle tct =
60 L.find (\case
61 TreeN (unCell -> KeySection{}) _ts -> True
62 _ -> False) tct >>=
63 \case
64 TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
65 _ -> Nothing
66
67 html5Text :: Text -> Html
68 html5Text = H.toMarkup
69
70 html5Spaces :: Int -> Html
71 html5Spaces 0 = return ()
72 html5Spaces sp = H.span $ html5Text $ Text.replicate sp " "
73
74 html5TreeCell :: Tree (Pos,Cell Key) (Pos,Tokens) -> Html
75 html5TreeCell (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do
76 html5IndentCell (posEnd,pos)
77 H.section $ do
78 H.span ! HA.class_ "section-title" $ do
79 H.span $ html5Text $ Text.replicate lvl "#" <> " "
80 case Seq.viewl ts of
81 Tree0 (_,title) :< _ -> h lvl $ html5IndentToken title
82 _ -> return ()
83 html5TreesCell $
84 case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}
85 where
86 h 1 = H.h1
87 h 2 = H.h2
88 h 3 = H.h3
89 h 4 = H.h4
90 h 5 = H.h5
91 h 6 = H.h6
92 h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
93 h _ = undefined
94 html5TreeCell (Tree0 (posEnd,toks)) =
95 case Seq.viewl toks of
96 EmptyL -> html5IndentToken toks
97 t0:<_ -> html5IndentCell (posEnd,posCell t0) <> html5IndentToken toks
98 html5TreeCell (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
99 html5IndentCell (posEnd,pos) <>
100 html5CellKey cell cs
101
102 html5IndentCell :: (Pos,Pos) -> Html
103 html5IndentCell (Pos lineLast colLast,Pos line col)
104 | lineLast < line = do
105 forM_ [lineLast+1..line] $ \lnum -> do
106 H.toMarkup '\n'
107 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
108 H.toMarkup $ Text.replicate (col - 1) " "
109 | lineLast == line
110 && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " "
111 | otherwise = undefined
112
113 html5CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Tokens) -> Html
114 html5CellKey (Cell _pos _posEnd key) ts = do
115 case key of
116 KeyColon n wh -> html5Key "" "" n wh ":" "" "colon"
117 KeyGreat n wh -> html5Key "" "" n wh ">" "" "great"
118 KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal"
119 KeyBar n wh -> html5Key "" "" n wh "|" "" "bar"
120 KeyDot n -> html5Key "" "" n "" "." "" "dot"
121 KeyDash -> html5Key "" "" "" "" "-" " " "dash"
122 KeyDashDash -> html5Key "" "" "" "" "--" " " "dashdash"
123 KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash"
124 KeyLower name attrs -> do
125 H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do
126 H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
127 H.span ! HA.class_ "key-name" $ H.toMarkup name
128 html5Attrs attrs
129 html5TreesCell ts
130 where
131 html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html
132 html5Key markBegin whmb name whn markEnd whme cl = do
133 -- html5Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
134 H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
135 when (markBegin/="") $
136 H.span ! HA.class_ "key-mark" $ H.toMarkup markBegin
137 H.toMarkup whmb
138 when (name/="") $
139 H.span ! HA.class_ "key-name" $ H.toMarkup name
140 H.toMarkup whn
141 when (markEnd/="") $
142 H.span ! HA.class_ "key-mark" $ H.toMarkup markEnd
143 H.toMarkup whme
144 H.span ! HA.class_ "key-value" $
145 html5TreesCell ts
146
147 html5IndentToken :: Tokens -> Html
148 html5IndentToken (Seq.viewl -> EmptyL) = ""
149 html5IndentToken toks@(Seq.viewl -> Cell pos _ _ :< _) =
150 goTokens toks `S.evalState` linePos pos
151 where
152 indent = Text.replicate (columnPos pos - 1) " "
153 go :: Cell Token -> S.State Int Html
154 go tok =
155 case unCell tok of
156 TokenPlain txt -> do
157 lin <- S.get
158 let lines = Text.splitOn "\n" txt
159 let lnums = H.toMarkup :
160 [ \line -> do
161 H.toMarkup '\n'
162 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
163 H.toMarkup indent
164 H.toMarkup line
165 | lnum <- [lin+1..]
166 ]
167 S.put (lin - 1 + L.length lines)
168 return $ mconcat $ L.zipWith ($) lnums lines
169 TokenTag v ->
170 return $
171 H.span ! HA.class_ "tag" $ do
172 H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
173 H.toMarkup v
174 TokenEscape c -> return $ H.toMarkup ['\\',c]
175 TokenLink lnk ->
176 return $
177 H.a ! HA.href (attrValue lnk) $
178 H.toMarkup lnk
179 TokenPair (PairElem name attrs) ts -> do
180 h <- goTokens ts
181 return $ do
182 let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
183 H.span ! HA.class_ cl $ do
184 whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
185 whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
186 whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
187 where
188 html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
189 o,c :: Html
190 (o,c) =
191 if Seq.null ts
192 then
193 ( "<"<>html5name<>html5Attrs attrs<>"/>"
194 , mempty )
195 else
196 ( "<"<>html5name<>html5Attrs attrs<>">"
197 , "</"<>html5name<>">" )
198 TokenPair grp ts -> do
199 h <- goTokens ts
200 return $ do
201 let (o,c) = pairBorders grp ts
202 H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
203 H.span ! HA.class_ "pair-open" $ H.toMarkup o
204 H.span ! HA.class_ "pair-content" $ h
205 H.span ! HA.class_ "pair-close" $ H.toMarkup c
206 goTokens :: Tokens -> S.State Int Html
207 goTokens ts = do
208 ts' <- go`mapM`ts
209 return $ foldr (<>) mempty ts'
210
211 html5Attrs :: Attrs -> Html
212 html5Attrs = foldMap html5Attr
213
214 html5Attr :: (Text,Attr) -> Html
215 html5Attr (attr_white,Attr{..}) = do
216 H.toMarkup attr_white
217 H.span ! HA.class_ "attr-name" $
218 H.toMarkup attr_name
219 H.toMarkup attr_open
220 H.span ! HA.class_ "attr-value" $
221 H.toMarkup attr_value
222 H.toMarkup attr_close