]> Git — Sourcephile - doclang.git/blob - Language/TCT/Write/HTML5/Source.hs
Add key-value CSS class.
[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)
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 $ Text.lines (TL.toStrict $ t_Tokens ts) <> [""]
61 -- link ! rel "Chapter" ! title "SomeTitle">
62 H.link ! HA.rel "stylesheet"
63 ! HA.type_ "text/css"
64 ! HA.href "style/tct-html5-source.css"
65 H.body $ do
66 H.a ! HA.id ("line-1") $ return ()
67 forM_ (treePosLastCell tct) $ h_TreeCell
68
69 titleTCT :: Trees (Cell Key) (Cell a) -> Maybe (Cell a)
70 titleTCT tct =
71 L.find (\case
72 TreeN (unCell -> KeySection{}) _ts -> True
73 _ -> False) tct >>=
74 \case
75 TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
76 _ -> Nothing
77
78 h_Text :: Text -> Html
79 h_Text = H.toMarkup
80
81 h_Spaces :: Int -> Html
82 h_Spaces 0 = return ()
83 h_Spaces sp = H.span $ h_Text $ Text.replicate sp " "
84
85 h_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Tokens) -> Html
86 h_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) = do
87 h_IndentCell c
88 H.section $ do
89 H.span ! HA.class_ "section-title" $ do
90 H.span $ h_Text $ Text.replicate lvl "#" <> " "
91 case Seq.viewl ts of
92 Tree0 (_,Cell posTitle _ title) :< _ -> h lvl $ h_IndentToken posTitle title
93 _ -> return ()
94 forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ h_TreeCell
95 where
96 h 1 = H.h1
97 h 2 = H.h2
98 h 3 = H.h3
99 h 4 = H.h4
100 h 5 = H.h5
101 h 6 = H.h6
102 h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
103 h _ = undefined
104 h_TreeCell (Tree0 c@(_,cell)) = do
105 h_IndentCell c
106 h_CellToken cell
107 h_TreeCell (TreeN c@(_,cell) cs) = do
108 h_IndentCell c
109 h_CellKey cell cs
110
111 h_IndentCell :: (Pos,Cell a) -> Html
112 h_IndentCell ((lineLast,colLast),posCell -> (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,Cell Tokens) -> Html
123 h_CellKey (Cell _pos _posEnd key) cells = 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 KeyDash -> do
130 H.toMarkup ("- "::Text)
131 forM_ cells h_TreeCell
132 KeyLower name attrs -> do
133 H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do
134 H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
135 H.span ! HA.class_ "key-name" $ H.toMarkup name
136 h_Attrs attrs
137 forM_ cells h_TreeCell
138 where
139 h_Key :: Text -> White -> Text -> H.AttributeValue -> Html
140 h_Key name wh mark cl = do
141 -- h_Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
142 H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
143 H.span ! HA.class_ "key-name" $ H.toMarkup name
144 H.toMarkup wh
145 H.span ! HA.class_ "key-mark" $ H.toMarkup mark
146 H.span ! HA.class_ "key-value" $
147 forM_ cells h_TreeCell
148
149 h_CellToken :: Cell Tokens -> Html
150 h_CellToken (Cell pos _posEnd tok) =
151 h_IndentToken pos tok
152
153 h_IndentToken :: Pos -> Tokens -> Html
154 h_IndentToken pos toks = goTokens toks `S.evalState` linePos pos
155 where
156 indent = Text.replicate (columnPos pos - 1) " "
157 go :: Token -> S.State Int Html
158 go (TokenPlain txt) = do
159 lin <- S.get
160 let lines = Text.splitOn "\n" txt
161 let lnums = H.toMarkup :
162 [ \line -> do
163 H.toMarkup '\n'
164 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
165 H.toMarkup indent
166 H.toMarkup line
167 | lnum <- [lin+1..]
168 ]
169 S.put (lin - 1 + L.length lines)
170 return $ mconcat $ L.zipWith ($) lnums lines
171 go (TokenTag v) = do
172 return $
173 H.span ! HA.class_ "tag" $ do
174 H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
175 H.toMarkup v
176 go (TokenEscape c) = return $ H.toMarkup ['\\',c]
177 go (TokenLink lnk) = do
178 return $
179 H.a ! HA.href (attrValue lnk) $
180 H.toMarkup lnk
181 go (TokenPair (PairElem name attrs) ts) = do
182 h <- goTokens ts
183 return $ do
184 let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
185 H.span ! HA.class_ cl $ do
186 whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
187 whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
188 whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
189 where
190 h_name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
191 o,c :: Html
192 (o,c) =
193 case ts of
194 Tokens s | Seq.null s ->
195 ( "<"<>h_name<>h_Attrs attrs<>"/>"
196 , mempty )
197 _ ->
198 ( "<"<>h_name<>h_Attrs attrs<>">"
199 , "</"<>h_name<>">" )
200 go (TokenPair grp ts) = do
201 h <- goTokens ts
202 return $ do
203 let (o,c) = pairBorders grp ts
204 H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
205 H.span ! HA.class_ "pair-open" $ H.toMarkup o
206 H.span ! HA.class_ "pair-content" $ h
207 H.span ! HA.class_ "pair-close" $ H.toMarkup c
208 goTokens (Tokens ts) = do
209 ts' <- go`mapM`ts
210 return $ foldr (<>) mempty ts'
211
212 h_Attrs :: Attrs -> Html
213 h_Attrs = foldMap h_Attr
214
215 h_Attr :: (Text,Attr) -> Html
216 h_Attr (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