Language/TCT/Write/HTML5.hs

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