Language/TCT/Write/HTML5/Source.hs

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