]> Git — Sourcephile - doclang.git/blob - Language/TCT/Write/HTML5.hs
Add DTC.Index.
[doclang.git] / Language / TCT / Write / HTML5.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ViewPatterns #-}
3 -- | Render TCT as HTML5.
4 module Language.TCT.Write.HTML5 where
5
6 import Control.Monad (Monad(..), forM_, mapM, when)
7 import Data.Bool
8 import Data.Eq (Eq(..))
9 import Data.Foldable (Foldable(..))
10 import Data.Function (($))
11 import Data.Int (Int)
12 import Data.Maybe (Maybe(..))
13 import Data.Monoid (Monoid(..))
14 import Data.Ord (Ord(..))
15 import Data.Semigroup (Semigroup(..))
16 import Data.Sequence (ViewL(..))
17 import Data.String (IsString(..))
18 import Data.Text (Text)
19 import Data.TreeSeq.Strict (Tree(..),Trees)
20 import Prelude (Num(..), undefined)
21 import Text.Blaze ((!))
22 import Text.Blaze.Html (Html)
23 import Text.Show (Show(..))
24 import qualified Control.Monad.Trans.State as S
25 import qualified Data.List as L
26 import qualified Data.Sequence as Seq
27 import qualified Data.Text as Text
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 Text.Blaze.Utils
33 import Language.TCT
34 import Language.TCT.Write.Text
35
36 html5Document :: TCTs -> Html
37 html5Document tct = do
38 H.docType
39 H.html $ do
40 H.head $ do
41 H.meta ! HA.httpEquiv "Content-Type"
42 ! HA.content "text/html; charset=UTF-8"
43 whenJust (tokensTitle tct) $ \ts ->
44 H.title $ H.toMarkup $ L.head $
45 TL.lines (textTokens ts) <> [""]
46 -- link ! rel "Chapter" ! title "SomeTitle">
47 H.link ! HA.rel "stylesheet"
48 ! HA.type_ "text/css"
49 ! HA.href "style/tct-html5.css"
50 H.body $ do
51 H.a ! HA.id ("line-1") $ return ()
52 html5TreesCell (treePosLastCell tct)
53
54 html5TreesCell :: Trees (Pos,Cell Key) (Pos,Tokens) -> Html
55 html5TreesCell = foldMap html5TreeCell
56
57 tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens
58 tokensTitle tct =
59 L.find (\case
60 TreeN (unCell -> KeySection{}) _ts -> True
61 _ -> False) tct >>=
62 \case
63 TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
64 _ -> Nothing
65
66 html5Text :: Text -> Html
67 html5Text = H.toMarkup
68
69 html5Spaces :: Int -> Html
70 html5Spaces 0 = return ()
71 html5Spaces sp = H.span $ html5Text $ Text.replicate sp " "
72
73 html5TreeCell :: Tree (Pos,Cell Key) (Pos,Tokens) -> Html
74 html5TreeCell (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do
75 html5IndentCell (posEnd,pos)
76 H.section $ do
77 H.span ! HA.class_ "section-title" $ do
78 H.span $ html5Text $ Text.replicate lvl "#" <> " "
79 case Seq.viewl ts of
80 Tree0 (_,title) :< _ -> h lvl $ html5IndentToken title
81 _ -> return ()
82 html5TreesCell $
83 case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}
84 where
85 h 1 = H.h1
86 h 2 = H.h2
87 h 3 = H.h3
88 h 4 = H.h4
89 h 5 = H.h5
90 h 6 = H.h6
91 h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
92 h _ = undefined
93 html5TreeCell (Tree0 (posEnd,toks)) =
94 case Seq.viewl toks of
95 EmptyL -> html5IndentToken toks
96 t0:<_ -> html5IndentCell (posEnd,posCell t0) <> html5IndentToken toks
97 html5TreeCell (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
98 html5IndentCell (posEnd,pos) <>
99 html5CellKey cell cs
100
101 html5IndentCell :: (Pos,Pos) -> Html
102 html5IndentCell (Pos lineLast colLast,Pos line col)
103 | lineLast < line = do
104 forM_ [lineLast+1..line] $ \lnum -> do
105 H.toMarkup '\n'
106 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
107 H.toMarkup $ Text.replicate (col - 1) " "
108 | lineLast == line
109 && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " "
110 | otherwise = undefined
111
112 html5CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Tokens) -> Html
113 html5CellKey (Cell _pos _posEnd key) ts = do
114 case key of
115 KeyColon n wh -> html5Key "" "" n wh ":" "" "colon"
116 KeyGreat n wh -> html5Key "" "" n wh ">" "" "great"
117 KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal"
118 KeyBar n wh -> html5Key "" "" n wh "|" "" "bar"
119 KeyDot n -> html5Key "" "" n "" "." "" "dot"
120 KeyDash -> html5Key "" "" "" "" "-" " " "dash"
121 KeyDashDash -> html5Key "" "" "" "" "--" " " "dashdash"
122 KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash"
123 KeyLower name attrs -> do
124 H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do
125 H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
126 H.span ! HA.class_ "key-name" $ H.toMarkup name
127 html5Attrs attrs
128 html5TreesCell ts
129 where
130 html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html
131 html5Key markBegin whmb name whn markEnd whme cl = do
132 -- html5Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
133 H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
134 when (markBegin/="") $
135 H.span ! HA.class_ "key-mark" $ H.toMarkup markBegin
136 H.toMarkup whmb
137 when (name/="") $
138 H.span ! HA.class_ "key-name" $ H.toMarkup name
139 H.toMarkup whn
140 when (markEnd/="") $
141 H.span ! HA.class_ "key-mark" $ H.toMarkup markEnd
142 H.toMarkup whme
143 H.span ! HA.class_ "key-value" $
144 html5TreesCell ts
145
146 html5IndentToken :: Tokens -> Html
147 html5IndentToken toks =
148 case Seq.viewl toks of
149 EmptyL -> ""
150 Cell pos _ _ :< _ ->
151 goTokens toks `S.evalState` linePos pos
152 where
153 indent = Text.replicate (columnPos pos - 1) " "
154 go :: Cell Token -> S.State Int Html
155 go tok =
156 case unCell tok of
157 TokenPlain txt -> do
158 lin <- S.get
159 let lines = Text.splitOn "\n" txt
160 let lnums = H.toMarkup :
161 [ \line -> do
162 H.toMarkup '\n'
163 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
164 H.toMarkup indent
165 H.toMarkup line
166 | lnum <- [lin+1..]
167 ]
168 S.put (lin - 1 + L.length lines)
169 return $ mconcat $ L.zipWith ($) lnums lines
170 TokenTag v ->
171 return $
172 H.span ! HA.class_ "tag" $ do
173 H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
174 H.toMarkup v
175 TokenEscape c -> return $ H.toMarkup ['\\',c]
176 TokenLink lnk ->
177 return $
178 H.a ! HA.href (attrValue lnk) $
179 H.toMarkup lnk
180 TokenPair (PairElem name attrs) ts -> do
181 h <- goTokens ts
182 return $ do
183 let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
184 H.span ! HA.class_ cl $ do
185 whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
186 whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
187 whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
188 where
189 html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
190 o,c :: Html
191 (o,c) =
192 if Seq.null ts
193 then
194 ( "<"<>html5name<>html5Attrs attrs<>"/>"
195 , mempty )
196 else
197 ( "<"<>html5name<>html5Attrs attrs<>">"
198 , "</"<>html5name<>">" )
199 TokenPair grp ts -> do
200 h <- goTokens ts
201 return $ do
202 let (o,c) = pairBorders grp ts
203 H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
204 H.span ! HA.class_ "pair-open" $ H.toMarkup o
205 H.span ! HA.class_ "pair-content" $ h
206 H.span ! HA.class_ "pair-close" $ H.toMarkup c
207 goTokens :: Tokens -> S.State Int Html
208 goTokens ts = do
209 ts' <- go`mapM`ts
210 return $ foldr (<>) mempty ts'
211
212 html5Attrs :: Attrs -> Html
213 html5Attrs = foldMap html5Attr
214
215 html5Attr :: (Text,Attr) -> Html
216 html5Attr (attr_white,Attr{..}) = do
217 H.toMarkup attr_white
218 H.span ! HA.class_ "attr-name" $
219 H.toMarkup attr_name
220 H.toMarkup attr_open
221 H.span ! HA.class_ "attr-value" $
222 H.toMarkup attr_value
223 H.toMarkup attr_close