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