Language/TCT/Write/HTML5.hs

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