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