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,posTree 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                  t0 :< _ ->
 126                         goTokens toks `S.evalState` linePos pos
 127                         where
 128                         pos = posTree t0
 129                         indent = Text.replicate (columnPos pos - 1) " "
 130                         go :: Token -> S.State Int Html
 131                         go (TreeN (unCell -> p) ts) =
 132                                 case p of
 133                                  PairElem name attrs -> do
 134                                         h <- goTokens ts
 135                                         return $ do
 136                                                 let cl = mconcat ["pair-PairElem", " pair-elem-", attrify name]
 137                                                 H.span ! HA.class_ cl $ do
 138                                                         whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
 139                                                         whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
 140                                                         whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
 141                                         where
 142                                         html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
 143                                         o,c :: Html
 144                                         (o,c) =
 145                                                 if Seq.null ts
 146                                                 then
 147                                                         ( "<"<>html5name<>html5ify attrs<>"/>"
 148                                                         , mempty )
 149                                                 else
 150                                                         ( "<"<>html5name<>html5ify attrs<>">"
 151                                                         , "</"<>html5name<>">" )
 152                                  _ -> do
 153                                         h <- goTokens ts
 154                                         return $ do
 155                                                 let (o,c) = pairBorders p ts
 156                                                 H.span ! HA.class_ (mconcat ["pair-", fromString $ show p]) $ do
 157                                                         H.span ! HA.class_ "pair-open"    $ H.toMarkup o
 158                                                         H.span ! HA.class_ "pair-content" $ h
 159                                                         H.span ! HA.class_ "pair-close"   $ H.toMarkup c
 160                         go (Tree0 (unCell -> tok)) =
 161                                 case tok of
 162                                  TokenPlain txt -> do
 163                                         lin <- S.get
 164                                         let lines = Text.splitOn "\n" txt
 165                                         let lnums = H.toMarkup :
 166                                                  [ \line -> do
 167                                                         H.toMarkup '\n'
 168                                                         H.a ! HA.id ("line-"<>attrify lnum) $ return ()
 169                                                         H.toMarkup indent
 170                                                         H.toMarkup line
 171                                                  | lnum <- [lin+1..]
 172                                                  ]
 173                                         S.put (lin - 1 + L.length lines)
 174                                         return $ mconcat $ L.zipWith ($) lnums lines
 175                                  TokenTag v ->
 176                                         return $
 177                                                 H.span ! HA.class_ "tag" $ do
 178                                                         H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
 179                                                         H.toMarkup v
 180                                  TokenEscape c -> return $ H.toMarkup ['\\',c]
 181                                  TokenLink lnk ->
 182                                         return $
 183                                                 H.a ! HA.href (attrify lnk) $
 184                                                         H.toMarkup lnk
 185                         goTokens :: Tokens -> S.State Int Html
 186                         goTokens ts = do
 187                                 ts' <- go`mapM`ts
 188                                 return $ foldr (<>) mempty ts'
 189 instance Html5ify Attrs where
 190         html5ify = mapM_ html5ify
 191 instance Html5ify (Text,Attr) where
 192         html5ify (attr_white,Attr{..}) = do
 193                 H.toMarkup attr_white
 194                 H.span ! HA.class_ "attr-name" $
 195                         H.toMarkup attr_name
 196                 H.toMarkup attr_open
 197                 H.span ! HA.class_ "attr-value" $
 198                         H.toMarkup attr_value
 199                 H.toMarkup attr_close
 200
 201 -- * Utilities
 202
 203 tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens
 204 tokensTitle tct =
 205         L.find (\case
 206          TreeN (unCell -> KeySection{}) _ts -> True
 207          _ -> False) tct >>=
 208         \case
 209          TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
 210          _ -> Nothing
 211
 212 html5Spaces :: Int -> Html
 213 html5Spaces 0  = return ()
 214 html5Spaces sp = H.span $ html5ify $ Text.replicate sp " "
 215
 216 html5ifyIndentCell :: (Pos,Pos) -> Html
 217 html5ifyIndentCell (Pos lineLast colLast,Pos line col)
 218  | lineLast < line = do
 219         forM_ [lineLast+1..line] $ \lnum -> do
 220                 H.toMarkup '\n'
 221                 H.a ! HA.id ("line-"<>attrify lnum) $ return ()
 222         H.toMarkup $ Text.replicate (col - 1) " "
 223  | lineLast == line
 224  && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " "
 225  | otherwise = undefined