1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RecordWildCards #-}
3 {-# LANGUAGE ViewPatterns #-}
4 -- | Render a TCT source file in HTML5.
5 module Language.TCT.HTML5.Source where
7 import Control.Applicative (Applicative(..))
8 import Control.Monad (Monad(..), forM_, mapM, when)
10 import Data.Eq (Eq(..))
11 import Data.Foldable (Foldable(..))
12 import Data.Function (($))
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
33 import Text.Blaze.Utils
34 import Language.TCT.Tree
35 import Language.TCT.Token
36 import Language.TCT.Elem
39 class HTML5able a where
42 class Textable a where
44 instance HTML5able TCT where
47 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
48 whenJust Nothing _f = pure ()
49 whenJust (Just a) f = f a
51 html5 :: Trees (Cell Key) (Cell Token) -> Html
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"
63 ! HA.href "style/tct-html5-source.css"
65 H.a ! HA.id ("line-1") $ return ()
66 forM_ (treePosLastCell tct) $ h_TreeCell
68 treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
69 treePosLastCell t = S.evalState (go`mapM`t) (1,1)
71 go :: Tree (Cell k) (Cell a) ->
72 S.State (Int, Int) (Tree (Pos, Cell k) (Pos, Cell a))
75 S.put $ posEndCell cell
76 return $ Tree0 (lastPos,cell)
77 go (TreeN cell ts) = do
79 S.put $ posEndCell cell
81 return $ TreeN (lastPos,cell) ts'
83 titleTCT :: Trees (Cell Key) (Cell a) -> Maybe (Cell a)
86 TreeN (unCell -> KeySection{}) _ts -> True
89 TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
92 h_Text :: Text -> Html
95 h_Spaces :: Int -> Html
96 h_Spaces 0 = return ()
97 h_Spaces sp = H.span $ h_Text $ Text.replicate sp " "
99 h_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Token) -> Html
100 h_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) = do
103 H.span ! HA.class_ "section-title" $ do
104 H.span $ h_Text $ Text.replicate lvl "#" <> " "
106 Tree0 (_,Cell posTitle _ title) :< _ -> h lvl $ h_IndentToken posTitle title
108 forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ h_TreeCell
116 h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
118 h_TreeCell (Tree0 c@(_,cell)) = do
121 h_TreeCell (TreeN c@(_,cell) cs) = do
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
130 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
131 H.toMarkup $ Text.replicate (col - 1) " "
133 && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " "
134 | otherwise = undefined
136 h_CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Cell Token) -> Html
137 h_CellKey (Cell _pos _posEnd key) cells = do
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"
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
151 forM_ cells h_TreeCell
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
159 H.span ! HA.class_ "key-mark" $ H.toMarkup mark
160 forM_ cells h_TreeCell
162 h_CellToken :: Cell Token -> Html
163 h_CellToken (Cell pos _posEnd tok) =
164 h_IndentToken pos tok
166 h_IndentToken :: Pos -> Token -> Html
167 h_IndentToken pos tok = go tok `S.evalState` linePos pos
169 indent = Text.replicate (columnPos pos - 1) " "
170 go :: Token -> S.State Int Html
171 go (TokenPlain txt) = do
173 let lines = Text.splitOn "\n" txt
174 let lnums = H.toMarkup :
177 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
182 S.put (lin - 1 + L.length lines)
183 return $ mconcat $ L.zipWith ($) lnums lines
186 H.span ! HA.class_ "tag" $ do
187 H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
189 go (TokenEscape c) = return $ H.toMarkup ['\\',c]
190 go (TokenLink lnk) = do
192 H.a ! HA.href (attrValue lnk) $
194 go (TokenGroup (GroupElem name attrs) t) = 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
203 h_name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
207 Tokens ts | Seq.null ts ->
208 ( "<"<>h_name<>h_Attrs attrs<>"/>"
211 ( "<"<>h_name<>h_Attrs attrs<>">"
212 , "</"<>h_name<>">" )
213 go (TokenGroup grp t) = 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
223 return $ foldr (<>) mempty ts'
225 h_Attrs :: Attrs -> Html
226 h_Attrs = foldMap h_Attr
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" $
234 H.span ! HA.class_ "attr-value" $
235 H.toMarkup attr_value
236 H.toMarkup attr_close
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
247 t_Value :: Text -> Text