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