]> Git — Sourcephile - doclang.git/blob - Language/TCT/Write/HTML5.hs
Fix NodePara parsing.
[doclang.git] / Language / TCT / Write / HTML5.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ViewPatterns #-}
4 module Language.TCT.Write.HTML5 where
5
6 import Control.Monad (Monad(..), forM_, mapM_, when)
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.Int (Int)
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 Language.TCT
33 import Language.TCT.Debug
34 import Language.TCT.Utils
35 import Text.Blaze.Utils
36 import qualified Language.TCT.Write.Plain as Plain
37
38 html5Document :: Trees (Cell Node) -> Html
39 html5Document 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 :: Int
83 , state_italic :: Bool
84 } deriving (Eq, Show)
85 instance Default State where
86 def = State
87 { state_pos = pos1
88 , state_indent = 1
89 , state_italic = False
90 }
91 instance Pretty State
92
93 -- * Class 'Html5ify'
94 class Html5ify a where
95 html5ify :: a -> Html5
96 instance Html5ify () where
97 html5ify = mempty
98 instance Html5ify Char where
99 html5ify = \case
100 '\n' -> do
101 (indent, lnum) <-
102 liftStateMarkup $ do
103 s@State{state_pos=Pos line _col, state_indent} <- S.get
104 S.put $ s{state_pos=Pos (line + 1) state_indent}
105 return (state_indent, line + 1)
106 html5 '\n'
107 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
108 html5 $ List.replicate (indent - 1) ' '
109 c -> do
110 liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
111 s{state_pos=Pos line (col + 1)}
112 html5 c
113 instance Html5ify String where
114 html5ify = mapM_ html5ify
115 instance Html5ify TL.Text where
116 html5ify t
117 | TL.null t = mempty
118 | otherwise =
119 let (h,ts) = TL.span (/='\n') t in
120 case TL.uncons ts of
121 Nothing -> do
122 liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
123 s{state_pos=Pos line (col + int (TL.length h))}
124 html5 h
125 Just (_n,ts') -> do
126 html5 h
127 -- NOTE: useless to increment the pos_column for h,
128 -- since the following '\n' will reset the pos_column.
129 html5ify '\n'
130 html5ify ts'
131 instance Html5ify Pos where
132 html5ify new@(Pos lineNew colNew) = do
133 old@(Pos lineOld colOld) <-
134 liftStateMarkup $ do
135 s <- S.get
136 S.put s{state_pos=new}
137 return $ state_pos s
138 case lineOld`compare`lineNew of
139 LT -> do
140 forM_ [lineOld+1..lineNew] $ \lnum -> do
141 html5 '\n'
142 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
143 html5 $ List.replicate (colNew - 1) ' '
144 EQ | colOld <= colNew -> do
145 html5 $ List.replicate (colNew - colOld) ' '
146 _ -> error $ "html5ify: non-ascending Pos:"
147 <> "\n old: " <> show old
148 <> "\n new: " <> show new
149 instance Html5ify Roots where
150 html5ify = mapM_ html5ify
151 instance Html5ify Root where
152 html5ify (Tree (Cell bp _ep nod) ts) = do
153 html5ify bp
154 case nod of
155 NodeGroup -> html5ify ts
156 ----------------------
157 NodeToken t -> html5ify t
158 ----------------------
159 NodePara -> do
160 ind <-
161 liftStateMarkup $ do
162 s <- S.get
163 S.put $ s{state_indent = pos_column bp}
164 return $ state_indent s
165 r <- html5ify ts
166 liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind}
167 return r
168 ----------------------
169 NodeText t -> do
170 ind <-
171 liftStateMarkup $ do
172 s <- S.get
173 S.put $ s{state_indent = pos_column bp}
174 return $ state_indent s
175 r <- html5ify t
176 liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind}
177 return r
178 ----------------------
179 NodeHeader hdr ->
180 case hdr of
181 HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon"
182 HeaderGreat n wh -> html5Header "" "" n wh ">" "" "great"
183 HeaderEqual n wh -> html5Header "" "" n wh "=" "" "equal"
184 HeaderBar n wh -> html5Header "" "" n wh "|" "" "bar"
185 HeaderDot n -> html5Header "" "" n "" "." "" "dot"
186 HeaderDotSlash n -> html5Header "./" "" (fromString n) "" "" "" "dotslash"
187 HeaderDash -> html5Header "" "" "" "" "-" " " "dash"
188 HeaderDashDash -> html5Header "" "" "" "" "--" " " "dashdash"
189 HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash"
190 HeaderSection lvl -> do
191 H.section $$ do
192 H.span ! HA.class_ "section-title" $$ do
193 H.span ! HA.class_ "section-mark" $$ do
194 html5ify $ List.replicate lvl '#'
195 case Seq.viewl ts of
196 title :< _ -> h lvl $$ html5ify title
197 _ -> return ()
198 html5ify $
199 case Seq.viewl ts of
200 _ :< ts' -> ts'
201 _ -> ts
202 where
203 h 1 = H.h1
204 h 2 = H.h2
205 h 3 = H.h3
206 h 4 = H.h4
207 h 5 = H.h5
208 h 6 = H.h6
209 h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
210 h _ = undefined
211 where
212 html5Header :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
213 html5Header markBegin whmb name whn markEnd whme cl = do
214 H.span ! HA.class_ (mconcat $ ["header header-",cl] <>
215 if TL.null name then [] else [" header-name-",attrify name]) $$ do
216 when (markBegin/="") $
217 H.span ! HA.class_ "header-mark" $$ html5ify markBegin
218 html5ify whmb
219 when (name/="") $
220 H.span ! HA.class_ "header-name" $$ html5ify name
221 html5ify whn
222 when (markEnd/="") $
223 H.span ! HA.class_ "header-mark" $$ html5ify markEnd
224 html5ify whme
225 H.span ! HA.class_ "header-value" $$
226 html5ify ts
227 ----------------------
228 NodePair pair ->
229 case pair of
230 PairElem name attrs -> do
231 H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
232 H.span ! HA.class_ "pair-open" $$ o
233 when (not $ null ts) $ do
234 H.span ! HA.class_ "pair-content" $$ html5ify ts
235 H.span ! HA.class_ "pair-close" $$ c
236 where
237 html5Name =
238 H.span ! HA.class_ "elem-name" $$
239 html5ify name
240 o,c :: Html5
241 (o,c)
242 | null ts =
243 ( "<"<>html5Name<>html5ify attrs<>"/>"
244 , mempty )
245 | otherwise =
246 ( "<"<>html5Name<>html5ify attrs<>">"
247 , "</"<>html5Name<>">" )
248 _ -> do
249 H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do
250 let (o,c) = pairBorders pair ts
251 H.span ! HA.class_ "pair-open" $$ html5ify o
252 H.span ! HA.class_ "pair-content" $$ em $ html5ify ts
253 H.span ! HA.class_ "pair-close" $$ html5ify c
254 where
255 em :: Html5 -> Html5
256 em h =
257 case pair of
258 p | p == PairSlash
259 || p == PairFrenchquote
260 || p == PairDoublequote -> do
261 State{..} <- liftStateMarkup $ S.get
262 liftStateMarkup $ S.modify' $ \s -> s{state_italic = not state_italic}
263 r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h
264 liftStateMarkup $ S.modify' $ \s -> s{state_italic}
265 return r
266 _ -> h
267 ----------------------
268 NodeLower name attrs -> do
269 H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do
270 H.span ! HA.class_ "header-mark" $$ html5ify '<'
271 H.span ! HA.class_ "header-name" $$ html5ify name
272 html5ify attrs
273 html5ify ts
274 instance Html5ify Token where
275 html5ify tok =
276 case tok of
277 TokenText t -> html5ify t
278 TokenTag v ->
279 H.span ! HA.class_ "tag" $$ do
280 H.span ! HA.class_ "tag-open" $$
281 html5ify '#'
282 html5ify v
283 TokenEscape c -> html5ify ['\\', c]
284 TokenLink l -> do
285 H.a ! HA.href (attrify l) $$
286 html5ify l
287 instance Html5ify ElemAttrs where
288 html5ify = mapM_ html5ify
289 instance Html5ify (White,ElemAttr) where
290 html5ify (elemAttr_white,ElemAttr{..}) = do
291 html5ify elemAttr_white
292 H.span ! HA.class_ "attr-name" $$
293 html5ify elemAttr_name
294 html5ify elemAttr_open
295 H.span ! HA.class_ "attr-value" $$
296 html5ify elemAttr_value
297 html5ify elemAttr_close