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