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