1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ViewPatterns #-}
4 module Language.TCT.Write.HTML5 where
6 import Control.Monad (Monad(..), forM_, mapM_, when)
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(..))
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
33 import Language.TCT.Debug
34 import Language.TCT.Utils
35 import Text.Blaze.Utils
36 import qualified Language.TCT.Write.Plain as Plain
38 html5Document :: Trees (Cell Node) -> Html
39 html5Document body = do
43 H.meta ! HA.httpEquiv "Content-Type"
44 ! HA.content "text/html; charset=UTF-8"
45 whenJust (titleFrom body) $ \t ->
47 H.toMarkup $ Plain.text def t
48 -- link ! rel "Chapter" ! title "SomeTitle">
49 H.link ! HA.rel "stylesheet"
51 ! HA.href "style/tct-html5.css"
52 let (html5Body, State{}) =
56 H.a ! HA.id ("line-1") $ return ()
59 titleFrom :: Roots -> Maybe Root
62 Tree (unCell -> NodeHeader HeaderSection{}) _ts -> True
65 Tree (unCell -> NodeHeader (HeaderSection _lvl))
66 (Seq.viewl -> title:<_) -> Just title
70 type Html5 = StateMarkup State ()
72 instance IsString Html5 where
73 fromString = mapM_ html5ify
75 html5 :: H.ToMarkup a => a -> Html5
76 html5 = Compose . return . H.toMarkup
83 , state_italic :: Bool
85 instance Default State where
89 , state_italic = False
94 class Html5ify a where
95 html5ify :: a -> Html5
96 instance Html5ify () where
98 instance Html5ify Char where
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)
107 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
108 html5 $ List.replicate (indent - 1) ' '
110 liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
111 s{state_pos=Pos line (col + 1)}
113 instance Html5ify String where
114 html5ify = mapM_ html5ify
115 instance Html5ify TL.Text where
119 let (h,ts) = TL.span (/='\n') t in
122 liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
123 s{state_pos=Pos line (col + int (TL.length h))}
127 -- NOTE: useless to increment the pos_column for h,
128 -- since the following '\n' will reset the pos_column.
131 instance Html5ify Pos where
132 html5ify new@(Pos lineNew colNew) = do
133 old@(Pos lineOld colOld) <-
136 S.put s{state_pos=new}
138 case lineOld`compare`lineNew of
140 forM_ [lineOld+1..lineNew] $ \lnum -> do
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
155 NodeGroup -> html5ify ts
156 ----------------------
157 NodeToken t -> html5ify t
158 ----------------------
163 S.put $ s{state_indent = pos_column bp}
164 return $ state_indent s
166 liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind}
168 ----------------------
173 S.put $ s{state_indent = pos_column bp}
174 return $ state_indent s
176 liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind}
178 ----------------------
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
192 H.span ! HA.class_ "section-title" $$ do
193 H.span ! HA.class_ "section-mark" $$ do
194 html5ify $ List.replicate lvl '#'
196 title :< _ -> h lvl $$ html5ify title
209 h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
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
220 H.span ! HA.class_ "header-name" $$ html5ify name
223 H.span ! HA.class_ "header-mark" $$ html5ify markEnd
225 H.span ! HA.class_ "header-value" $$
227 ----------------------
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
238 H.span ! HA.class_ "elem-name" $$
243 ( "<"<>html5Name<>html5ify attrs<>"/>"
246 ( "<"<>html5Name<>html5ify attrs<>">"
247 , "</"<>html5Name<>">" )
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
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}
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
274 instance Html5ify Token where
277 TokenText t -> html5ify t
279 H.span ! HA.class_ "tag" $$ do
280 H.span ! HA.class_ "tag-open" $$
283 TokenEscape c -> html5ify ['\\', c]
285 H.a ! HA.href (attrify 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