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