]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/HTML5.hs
Automatize localesOf.
[doclang.git] / Language / DTC / Write / HTML5.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE DisambiguateRecordFields #-}
4 {-# LANGUAGE DuplicateRecordFields #-}
5 {-# LANGUAGE ExistentialQuantification #-}
6 {-# LANGUAGE FlexibleInstances #-}
7 {-# LANGUAGE FlexibleContexts #-}
8 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
9 {-# LANGUAGE MultiParamTypeClasses #-}
10 {-# LANGUAGE OverloadedStrings #-}
11 {-# LANGUAGE RecordWildCards #-}
12 {-# LANGUAGE ScopedTypeVariables #-}
13 {-# LANGUAGE TypeApplications #-}
14 {-# LANGUAGE ViewPatterns #-}
15 {-# OPTIONS_GHC -fno-warn-orphans #-}
16 -- | Render a DTC source file in HTML5.
17 module Language.DTC.Write.HTML5 where
18
19 -- import Control.Monad.Trans.Class (MonadTrans(..))
20 -- import Data.Bool
21 -- import Data.Functor.Identity (Identity(..))
22 -- import qualified Data.Map.Strict as Map
23 -- import qualified Data.TreeSeq.Strict as Tree
24 import Control.Applicative (Applicative(..))
25 import Control.Monad (Monad(..), forM_, mapM_, when{-, (>=>)-})
26 import Data.Char (Char)
27 import Data.Eq (Eq(..))
28 import Data.Foldable (Foldable(..))
29 import Data.Function (($), (.))
30 import Data.Functor ((<$>))
31 import Data.Functor.Compose (Compose(..))
32 import Data.Int (Int)
33 import Data.Map.Strict (Map)
34 import Data.Maybe (Maybe(..))
35 import Data.Monoid (Monoid(..))
36 import Data.Ord (Ord(..))
37 import Data.Semigroup (Semigroup(..))
38 import Data.Sequence (Seq)
39 import Data.String (String)
40 import Data.Text (Text)
41 import Data.TreeSeq.Strict (Tree(..))
42 import Data.Tuple (snd)
43 import Prelude (Num(..))
44 import Text.Blaze ((!))
45 import Text.Blaze.Html (Html)
46 import Text.Show (Show(..))
47 import qualified Control.Monad.Trans.State as S
48 import qualified Data.List as List
49 import qualified Data.Text as Text
50 import qualified Data.Text.Lazy as TL
51 import qualified Data.TreeSeq.Strict.Zipper as Tree
52 import qualified Text.Blaze.Html5 as H
53 import qualified Text.Blaze.Html5.Attributes as HA
54 import qualified Text.Blaze.Internal as H
55
56 import Text.Blaze.Utils
57 import Data.Locale hiding (localize)
58 import qualified Data.Locale as Locale
59
60 import Language.DTC.Document (Document)
61 import Language.DTC.Write.XML ()
62 import Language.XML (XmlName(..), XmlPos(..))
63 import qualified Language.DTC.Document as DTC
64 -- import Debug.Trace (trace)
65
66 -- * Type 'Html5'
67 type Html5 = StateMarkup StateHtml5 ()
68
69 -- ** Type 'StateHtml5'
70 data StateHtml5
71 = StateHtml5
72 { styles :: Map Text CSS
73 , scripts :: Map Text Script
74 , localize :: MsgHtml5 -> Html5
75 }
76 stateHtml5 :: StateHtml5
77 stateHtml5 = StateHtml5
78 { styles = mempty
79 , scripts = mempty
80 , localize = html5ify . show
81 }
82 type CSS = Text
83 type Script = Text
84
85 -- ** Class 'Html5ify'
86 class Html5ify a where
87 html5ify :: a -> Html5
88 instance Html5ify Char where
89 html5ify = html5ify . H.toMarkup
90 instance Html5ify Text where
91 html5ify = html5ify . H.toMarkup
92 instance Html5ify String where
93 html5ify = html5ify . H.toMarkup
94 instance Html5ify H.Markup where
95 html5ify = Compose . return
96 instance Html5ify DTC.Title where
97 html5ify (DTC.Title t) = html5ify t
98 instance Html5ify DTC.Ident where
99 html5ify (DTC.Ident i) = html5ify i
100
101
102 html5Document ::
103 Localize ls Html5 MsgHtml5 =>
104 Locales ls =>
105 LocaleIn ls -> Document -> Html
106 html5Document locale DTC.Document{..} = do
107 let (h, StateHtml5{..}) =
108 runStateMarkup stateHtml5 $ do
109 liftStateMarkup $ S.modify $ \s -> s{localize = Locale.localize locale}
110 html5ify body
111 H.docType
112 H.html ! HA.lang (attrValue $ countryCode locale) $ do
113 H.head $ do
114 H.meta ! HA.httpEquiv "Content-Type"
115 ! HA.content "text/html; charset=UTF-8"
116 whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
117 H.title $
118 H.toMarkup $
119 plainify $
120 List.head $
121 (DTC.unTitle <$> ts) <> [[DTC.Plain ""]]
122 -- link ! rel "Chapter" ! title "SomeTitle">
123 H.meta ! HA.name "generator"
124 ! HA.content "tct"
125 H.link ! HA.rel "stylesheet"
126 ! HA.type_ "text/css"
127 ! HA.href "style/dtc-html5.css"
128 forM_ styles $ \style ->
129 H.style ! HA.type_ "text/css" $
130 H.toMarkup style
131 forM_ scripts $ \script ->
132 H.script ! HA.type_ "application/javascript" $
133 H.toMarkup script
134 H.body h
135
136 -- * Type 'BodyZip'
137 -- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT).
138 type BodyZip = Tree.Zipper DTC.BodyKey (Seq DTC.BodyValue)
139 instance Html5ify DTC.Body where
140 html5ify body =
141 forM_ (Tree.zippers body) $
142 html5ify
143
144 instance Html5ify BodyZip where
145 html5ify z =
146 case Tree.current z of
147 TreeN k _ts -> html5BodyKey z k
148 Tree0 vs -> forM_ vs $ html5BodyValue z
149
150 html5BodyKey :: BodyZip -> DTC.BodyKey -> Html5
151 html5BodyKey z = \case
152 DTC.Section{..} ->
153 H.section ! HA.class_ "section"
154 ! HA.id (attrValue pos) $$ do
155 html5CommonAttrs attrs $
156 H.table ! HA.class_ "section-header" $$
157 H.tbody $$
158 H.tr $$ do
159 H.td ! HA.class_ "section-number" $$ do
160 html5SectionNumber $
161 xmlPosAncestors pos
162 H.td ! HA.class_ "section-title" $$ do
163 html5ify title
164 forM_ (Tree.axis_child z) $
165 html5ify
166 html5BodyValue :: BodyZip -> DTC.BodyValue -> Html5
167 html5BodyValue z = \case
168 DTC.Vertical v -> do
169 html5ify v
170 DTC.ToC{..} -> do
171 H.nav ! HA.class_ "toc"
172 ! HA.id (attrValue pos) $$ do
173 H.span ! HA.class_ "toc-name" $$
174 H.a ! HA.href (attrValue pos) $$
175 html5ify MsgHTML5_Table_of_Contents
176 H.ul $$
177 forM_ (Tree.axis_following_sibling z) $
178 html5ToC d
179 where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
180 DTC.ToF{..} -> do
181 H.nav ! HA.class_ "tof"
182 ! HA.id (attrValue pos) $$
183 H.table ! HA.class_ "tof" $$
184 H.tbody $$
185 forM_ (Tree.axis_preceding z) $
186 html5ToF d
187 where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
188 DTC.Figure{..} ->
189 html5CommonAttrs attrs $
190 H.div ! HA.class_ (attrValue $ "figure-"<>type_)
191 ! HA.id (attrValue pos) $$ do
192 H.table ! HA.class_ "figure-caption" $$
193 H.tbody $$
194 H.tr $$ do
195 H.td ! HA.class_ "figure-number" $$ do
196 H.a ! HA.href ("#"<>attrValue pos) $$
197 html5ify type_
198 ": "
199 H.td ! HA.class_ "figure-name" $$
200 html5ify title
201 H.div ! HA.class_ "figure-content" $$ do
202 html5ify verts
203 html5ToC :: Int -> BodyZip -> Html5
204 html5ToC depth z =
205 case Tree.current z of
206 TreeN DTC.Section{..} _ts -> do
207 H.li $$ do
208 H.table ! HA.class_ "toc-entry" $$
209 H.tbody $$
210 H.tr $$ do
211 H.td $$
212 html5SectionRef $ xmlPosAncestors pos
213 H.td $$
214 html5ify title
215 when (depth > 0) $
216 H.ul $$
217 forM_ (Tree.axis_child z) $
218 html5ToC (depth - 1)
219 _ -> pure ()
220 html5ToF :: Int -> BodyZip -> Html5
221 html5ToF depth z =
222 case Tree.current z of
223 Tree0 bs ->
224 forM_ bs $ \case
225 DTC.Figure{..} ->
226 H.tr $$ do
227 H.td ! HA.class_ "figure-number" $$
228 H.a ! HA.href ("#"<>attrValue pos) $$
229 html5ify type_
230 H.td ! HA.class_ "figure-name" $$
231 html5ify title
232 _ -> pure ()
233 _ -> pure ()
234
235 instance Html5ify [DTC.Vertical] where
236 html5ify = mapM_ html5ify
237 instance Html5ify DTC.Vertical where
238 html5ify = \case
239 DTC.Para{..} ->
240 html5CommonAttrs attrs $
241 H.div ! HA.class_ "para"
242 ! HA.id (attrValue pos) $$ do
243 html5ify horis
244 DTC.OL{..} ->
245 html5CommonAttrs attrs $
246 H.ol ! HA.class_ "ol"
247 ! HA.id (attrValue pos) $$ do
248 forM_ items $ \item ->
249 H.li $$ html5ify item
250 DTC.UL{..} ->
251 html5CommonAttrs attrs $
252 H.ul ! HA.class_ "ul"
253 ! HA.id (attrValue pos) $$ do
254 forM_ items $ \item ->
255 H.li $$ html5ify item
256 DTC.RL{..} ->
257 html5CommonAttrs attrs $
258 H.div ! HA.class_ "rl"
259 ! HA.id (attrValue pos) $$ do
260 H.table $$
261 forM_ refs html5ify
262 DTC.Comment t ->
263 html5ify $ H.Comment (H.Text t) ()
264 {-
265 Index{..} ->
266 Artwork{..} ->
267 -}
268 instance Html5ify DTC.Horizontal where
269 html5ify = \case
270 DTC.BR -> html5ify H.br
271 DTC.B hs -> H.strong $$ html5ify hs
272 DTC.Code hs -> H.code $$ html5ify hs
273 DTC.Del hs -> H.del $$ html5ify hs
274 DTC.I hs -> H.i $$ html5ify hs
275 DTC.Note _ -> ""
276 DTC.Q hs -> do
277 "« "::Html5
278 H.i $$ html5ify hs
279 " »"
280 DTC.SC hs -> html5ify hs
281 DTC.Sub hs -> H.sub $$ html5ify hs
282 DTC.Sup hs -> H.sup $$ html5ify hs
283 DTC.U hs -> H.span ! HA.class_ "underline" $$ html5ify hs
284 DTC.Eref{..} ->
285 H.a ! HA.class_ "eref"
286 ! HA.href (attrValue href) $$
287 html5ify text
288 DTC.Iref{..} ->
289 H.a ! HA.class_ "iref"
290 ! HA.href (attrValue to) $$
291 html5ify text
292 DTC.Ref{..} ->
293 H.a ! HA.class_ "ref"
294 ! HA.href ("#"<>attrValue to) $$
295 if null text
296 then html5ify to
297 else html5ify text
298 DTC.Rref{..} ->
299 H.a ! HA.class_ "rref"
300 ! HA.href (attrValue to) $$
301 html5ify text
302 DTC.Plain t -> Compose $ return $ H.toMarkup t
303 instance Html5ify [DTC.Horizontal] where
304 html5ify = mapM_ html5ify
305 instance Html5ify DTC.About where
306 html5ify DTC.About{..} =
307 forM_ titles $ \(DTC.Title title) ->
308 html5ify $ DTC.Q title
309 instance Html5ify DTC.Reference where
310 html5ify DTC.Reference{..} =
311 H.tr $$ do
312 H.td ! HA.class_ "reference-key" $$
313 html5ify id
314 H.td ! HA.class_ "reference-content" $$
315 html5ify about
316
317 html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
318 html5CommonAttrs DTC.CommonAttrs{..} =
319 Compose . (addClass . addId <$>) . getCompose
320 where
321 addClass =
322 case classes of
323 [] -> \x -> x
324 _ -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
325 addId =
326 case id of
327 Nothing -> \x -> x
328 Just (DTC.Ident i) ->
329 H.AddCustomAttribute "id" (H.Text i)
330
331 html5SectionNumber :: [(XmlName,Int)] -> Html5
332 html5SectionNumber = go [] . List.reverse
333 where
334 go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html5
335 go _rs [] = pure ()
336 go rs (a@(_n,cnt):as) = do
337 H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $$
338 html5ify $ show cnt
339 html5ify '.'
340 go (a:rs) as
341
342 html5SectionRef :: [(XmlName,Int)] -> Html5
343 html5SectionRef as =
344 H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $$
345 case as of
346 [(_n,c)] -> do
347 html5ify $ show c
348 html5ify '.'
349 _ ->
350 html5ify $
351 Text.intercalate "." $
352 Text.pack . show . snd <$> as
353
354 textXmlPosAncestors :: [(XmlName,Int)] -> Text
355 textXmlPosAncestors =
356 snd . foldr (\(n,c) (nParent,acc) ->
357 (n,
358 (if Text.null acc
359 then acc
360 else acc <> ".") <>
361 Text.pack
362 (if n == nParent
363 then show c
364 else show n<>show c)
365 )
366 )
367 ("","")
368
369 -- * Class 'Plainify'
370 class Plainify a where
371 plainify :: a -> TL.Text
372 instance Plainify DTC.Horizontal where
373 plainify = \case
374 DTC.BR -> "\n"
375 DTC.B hs -> "*"<>plainify hs<>"*"
376 DTC.Code hs -> "`"<>plainify hs<>"`"
377 DTC.Del hs -> "-"<>plainify hs<>"-"
378 DTC.I hs -> "/"<>plainify hs<>"/"
379 DTC.Note _ -> ""
380 DTC.Q hs -> "« "<>plainify hs<>" »"
381 DTC.SC hs -> plainify hs
382 DTC.Sub hs -> plainify hs
383 DTC.Sup hs -> plainify hs
384 DTC.U hs -> "_"<>plainify hs<>"_"
385 DTC.Eref{..} -> plainify text
386 DTC.Iref{..} -> plainify text
387 DTC.Ref{..} -> plainify text
388 DTC.Rref{..} -> plainify text
389 DTC.Plain t -> TL.fromStrict t
390 instance Plainify [DTC.Horizontal] where
391 plainify = foldMap plainify
392
393 instance AttrValue XmlPos where
394 attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
395
396 -- * Type 'MsgHtml5'
397 data MsgHtml5
398 = MsgHTML5_Table_of_Contents
399 deriving (Show)
400 instance Html5ify MsgHtml5 where
401 html5ify msg = do
402 loc <- liftStateMarkup $ S.gets localize
403 loc msg
404 instance LocalizeIn FR Html5 MsgHtml5 where
405 localizeIn _ MsgHTML5_Table_of_Contents = "Sommaire"
406 instance LocalizeIn EN Html5 MsgHtml5 where
407 localizeIn _ MsgHTML5_Table_of_Contents = "Summary"