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