]> Git — Sourcephile - doclang.git/blob - Hdoc/TCT/Write/HTML5.hs
Update to megaparsec-7 and new symantic-xml
[doclang.git] / Hdoc / TCT / Write / HTML5.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE ViewPatterns #-}
5 module Hdoc.TCT.Write.HTML5 where
6
7 import Control.Monad (Monad(..), forM_, mapM_, join)
8 import Data.Bool
9 import Data.Char (Char)
10 import Data.Default.Class (Default(..))
11 import Data.Eq (Eq(..))
12 import Data.Foldable (Foldable(..))
13 import Data.Function (($), (.))
14 import Data.Functor.Compose (Compose(..))
15 import Data.List.NonEmpty (NonEmpty(..))
16 import Data.Maybe (Maybe(..), maybe)
17 import Data.Monoid (Monoid(..))
18 import Data.Ord (Ord(..), Ordering(..))
19 import Data.Semigroup (Semigroup(..))
20 import Data.Sequence (ViewL(..))
21 import Data.String (String, IsString(..))
22 import Prelude (Num(..), undefined, error)
23 import Text.Blaze ((!))
24 import Text.Blaze.Html (Html)
25 import Text.Show (Show(..))
26 import qualified Control.Monad.Trans.RWS.Strict as RWS
27 import qualified Data.List as List
28 import qualified Data.Sequence as Seq
29 import qualified Data.Text.Lazy as TL
30 import qualified Language.Symantic.XML as XML
31 import qualified Text.Blaze.Html5 as H
32 import qualified Text.Blaze.Html5.Attributes as HA
33 import qualified Text.Blaze.Internal as Blaze
34
35 -- import Hdoc.TCT.Debug
36 import Hdoc.TCT
37 import Hdoc.TCT.Utils
38 import Control.Monad.Utils
39 import Text.Blaze.Utils
40 import Text.Blaze.XML ()
41 import qualified Hdoc.TCT.Write.Plain as Plain
42
43 writeHTML5 :: Trees (Cell Node) -> Html
44 writeHTML5 body = do
45 H.docType
46 H.html $ do
47 H.head $ do
48 H.meta ! HA.httpEquiv "Content-Type"
49 ! HA.content "text/html; charset=UTF-8"
50 whenJust (titleFrom body) $ \t ->
51 H.title $
52 H.toMarkup $ Plain.text def t
53 -- link ! rel "Chapter" ! title "SomeTitle">
54 H.link ! HA.rel "stylesheet"
55 ! HA.type_ "text/css"
56 ! HA.href "style/tct-html5.css"
57 let (html5Body, State{}, ()) =
58 runComposeRWS def def $
59 html5ify body
60 H.body $ do
61 H.a ! HA.id "line-1" $ return ()
62 html5Body
63
64 titleFrom :: Roots -> Maybe Root
65 titleFrom tct =
66 List.find (\case
67 Tree (unSourced -> NodeHeader HeaderSection{}) _ts -> True
68 _ -> False) tct >>=
69 \case
70 Tree (unSourced -> NodeHeader (HeaderSection _lvl))
71 (Seq.viewl -> title:<_) -> Just title
72 _ -> Nothing
73
74 -- * Type 'Html5'
75 type Html5 = ComposeRWS Reader Writer State Blaze.MarkupM ()
76
77 instance IsString Html5 where
78 fromString = mapM_ html5ify
79
80 html5 :: H.ToMarkup a => a -> Html5
81 html5 = Compose . return . H.toMarkup
82
83 -- ** Type 'Reader'
84 data Reader = Reader
85 { reader_indent :: Html5
86 , reader_italic :: Bool
87 , reader_ext_html :: String
88 } -- deriving (Eq, Show)
89 instance Default Reader where
90 def = Reader
91 { reader_indent = ""
92 , reader_italic = False
93 , reader_ext_html = ".html"
94 }
95
96 -- ** Type 'Writer'
97 type Writer = ()
98
99 -- ** Type 'State'
100 newtype State = State
101 { state_pos :: LineColumn
102 } -- deriving (Eq, Show)
103 instance Default State where
104 def = State
105 { state_pos = def
106 }
107
108 -- * Class 'Html5ify'
109 class Html5ify a where
110 html5ify :: a -> Html5
111 instance Html5ify () where
112 html5ify = mempty
113 instance Html5ify Char where
114 html5ify = \case
115 '\n' -> do
116 st@State{state_pos=LineColumn line _col, ..} <- composeLift RWS.get
117 composeLift $ RWS.put st{state_pos=LineColumn (line <> pos1) pos1}
118 html5 '\n'
119 H.a ! HA.id ("line-"<>attrify (line <> pos1)) $$ return ()
120 join $ composeLift $ RWS.asks reader_indent
121 c -> do
122 composeLift $ RWS.modify $ \s@State{state_pos=LineColumn line col} ->
123 s{state_pos=LineColumn line (col <> pos1)}
124 html5 c
125 instance Html5ify String where
126 html5ify = mapM_ html5ify
127 instance Html5ify TL.Text where
128 html5ify t
129 | TL.null t = mempty
130 | otherwise =
131 let (h,ts) = TL.span (/='\n') t in
132 case TL.uncons ts of
133 Nothing -> do
134 composeLift $ RWS.modify $ \s@State{state_pos} ->
135 s{state_pos=state_pos{colNum = colNum state_pos <> num (TL.length h)}}
136 html5 h
137 Just (_n,ts') -> do
138 html5 h
139 -- NOTE: useless to increment the 'colNum' for h,
140 -- since the following '\n' will reset the 'colNum'.
141 html5ify '\n'
142 html5ify ts'
143 instance Html5ify LineColumn where
144 html5ify new = do
145 Reader{reader_indent} <- composeLift RWS.ask
146 st@State{state_pos=old} <- composeLift RWS.get
147 let lineOld = lineInt old
148 let colOld = colInt old
149 case lineOld`compare`lineNew of
150 LT -> do
151 forM_ [lineOld+1..lineNew] $ \lnum -> do
152 html5 '\n'
153 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
154 composeLift $ RWS.put st{state_pos=LineColumn (lineNum new) pos1}
155 reader_indent
156 mid <- composeLift $ RWS.gets state_pos
157 html5 $ List.replicate (colNew - colInt mid) ' '
158 composeLift $ RWS.put st{state_pos=new}
159 EQ | colOld <= colNew -> do
160 composeLift $ RWS.put st{state_pos=new}
161 html5 $ List.replicate (colNew - colOld) ' '
162 _ -> error $ "html5ify: non-ascending LineColumn:"
163 <> "\n old: " <> show old
164 <> "\n new: " <> show new
165 where
166 lineNew = lineInt new
167 colNew = colInt new
168 instance Html5ify Roots where
169 html5ify = mapM_ html5ify
170 instance Html5ify Root where
171 html5ify (Tree (Sourced (FileRange{fileRange_begin=bp}:|_) nod) ts) = do
172 html5ify bp
173 case nod of
174 ----------------------
175 NodeLower name attrs -> do
176 H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do
177 H.span ! HA.class_ "header-mark" $$ html5ify '<'
178 H.span ! HA.class_ "header-name" $$ html5ify name
179 html5ify attrs
180 html5ify ts
181 ----------------------
182 NodeHeader hdr ->
183 case hdr of
184 HeaderGreat n wh -> html5HeaderRepeated "" "" (maybe "" XML.unNCName n) wh ">" "" "great"
185 HeaderBar n wh -> html5HeaderRepeated "" "" (maybe "" XML.unNCName n) wh "|" "" "bar"
186 HeaderColon n wh -> html5Header "" "" (maybe "" XML.unNCName n) wh ":" "" "colon"
187 HeaderEqual n wh -> html5Header "" "" (XML.unNCName n) wh "=" "" "equal"
188 HeaderDot n -> html5Header "" "" n "" "." "" "dot"
189 HeaderDash -> html5Header "" "" "" "" "-" " " "dash"
190 HeaderDashDash -> html5Header "" "" "" "" "--" " " "dashdash"
191 HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash"
192 HeaderSection lvl -> do
193 H.section $$ do
194 H.span ! HA.class_ "section-title" $$ do
195 H.span ! HA.class_ "section-mark" $$ do
196 html5ify $ List.replicate lvl '#'
197 case Seq.viewl ts of
198 title :< _ -> h lvl $$ html5ify title
199 _ -> return ()
200 html5ify $
201 case Seq.viewl ts of
202 _ :< ts' -> ts'
203 _ -> ts
204 where
205 h 1 = H.h1
206 h 2 = H.h2
207 h 3 = H.h3
208 h 4 = H.h4
209 h 5 = H.h5
210 h 6 = H.h6
211 h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
212 h _ = undefined
213 HeaderDotSlash file -> do
214 ext <- composeLift $ RWS.asks reader_ext_html
215 if null ext
216 then html5ify file
217 else
218 H.a ! HA.class_ "header-dotslash"
219 ! HA.href (attrify $ file<>ext) $$
220 html5ify file
221 where
222 html5Head :: TL.Text -> White -> TL.Text -> White -> TL.Text -> White -> H.AttributeValue -> Html5
223 html5Head markBegin whmb name whn markEnd whme cl = do
224 H.span ! HA.class_ (mconcat $ ["header header-",cl] <>
225 if TL.null name then [] else [" header-name-",attrify name]) $$ do
226 when (markBegin/="") $
227 H.span ! HA.class_ "header-mark" $$ html5ify markBegin
228 html5ify whmb
229 when (name/="") $
230 H.span ! HA.class_ "header-name" $$ html5ify name
231 html5ify whn
232 when (markEnd/="") $
233 H.span ! HA.class_ "header-mark" $$ html5ify markEnd
234 html5ify whme
235 html5Header markBegin whmb name whn markEnd whme cl = do
236 html5Head markBegin whmb name whn markEnd whme cl
237 H.span ! HA.class_ "header-value" $$
238 html5ify ts
239 html5HeaderRepeated :: TL.Text -> White -> TL.Text -> White -> TL.Text -> White -> H.AttributeValue -> Html5
240 html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
241 localComposeRWS (\ro ->
242 ro{ reader_indent = do
243 reader_indent ro
244 midLC <- composeLift $ RWS.gets state_pos
245 html5ify $ List.replicate (colInt bp - colInt midLC) ' '
246 html5Head markBegin whmb name whn markEnd whme cl
247 }) $
248 html5Header markBegin whmb name whn markEnd whme cl
249 ----------------------
250 NodeText t -> do
251 localComposeRWS (\ro ->
252 ro{ reader_indent = do
253 reader_indent ro
254 midLC <- composeLift $ RWS.gets state_pos
255 html5ify $ List.replicate (colInt bp - colInt midLC) ' '
256 }) $
257 html5ify t
258 ----------------------
259 NodePara -> do
260 localComposeRWS (\ro ->
261 ro{ reader_indent = do
262 reader_indent ro
263 midLC <- composeLift $ RWS.gets state_pos
264 html5ify $ List.replicate (colInt bp - colInt midLC) ' '
265 }) $
266 html5ify ts
267 ----------------------
268 NodeToken t -> html5ify t <> html5ify ts
269 ----------------------
270 NodePair pair ->
271 case pair of
272 PairElem name attrs -> do
273 H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
274 H.span ! HA.class_ "pair-open" $$ o
275 unless (null ts) $ do
276 H.span ! HA.class_ "pair-content" $$ html5ify ts
277 H.span ! HA.class_ "pair-close" $$ c
278 where
279 html5Name =
280 H.span ! HA.class_ "elem-name" $$
281 html5ify name
282 o,c :: Html5
283 (o,c)
284 | null ts =
285 ( "<"<>html5Name<>html5ify attrs<>"/>"
286 , mempty )
287 | otherwise =
288 ( "<"<>html5Name<>html5ify attrs<>">"
289 , "</"<>html5Name<>">" )
290 _ -> do
291 H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do
292 let (o,c) = pairBorders pair ts
293 H.span ! HA.class_ "pair-open" $$ html5ify o
294 H.span ! HA.class_ "pair-content" $$ em $ html5ify ts
295 H.span ! HA.class_ "pair-close" $$ html5ify c
296 where
297 em :: Html5 -> Html5
298 em h =
299 case pair of
300 p | p == PairSlash
301 || p == PairFrenchquote
302 || p == PairDoublequote -> do
303 Reader{reader_italic} <- composeLift RWS.ask
304 localComposeRWS (\ro -> ro{reader_italic = not reader_italic}) $
305 H.em ! HA.class_ (if reader_italic then "even" else "odd") $$ h
306 _ -> h
307 instance Html5ify Token where
308 html5ify tok =
309 case tok of
310 TokenText t -> html5ify t
311 TokenAt b v ->
312 H.span ! HA.class_ "at" $$ do
313 when b $
314 H.span ! HA.class_ "at-back" $$
315 html5ify '~'
316 H.span ! HA.class_ "at-open" $$
317 html5ify '@'
318 html5ify v
319 TokenTag b v ->
320 H.span ! HA.class_ "tag" $$ do
321 when b $
322 H.span ! HA.class_ "tag-back" $$
323 html5ify '~'
324 H.span ! HA.class_ "tag-open" $$
325 html5ify '#'
326 html5ify v
327 TokenEscape c -> html5ify ['\\', c]
328 TokenLink l -> do
329 H.a ! HA.href (attrify l) $$
330 html5ify l
331 instance Html5ify ElemName where
332 html5ify = html5ify . show
333 instance Html5ify ElemAttrs where
334 html5ify = mapM_ html5ify
335 instance Html5ify (White,ElemAttr) where
336 html5ify (elemAttr_white,ElemAttr{..}) = do
337 html5ify elemAttr_white
338 H.span ! HA.class_ "attr-name" $$
339 html5ify elemAttr_name
340 html5ify elemAttr_open
341 H.span ! HA.class_ "attr-value" $$
342 html5ify elemAttr_value
343 html5ify elemAttr_close