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 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.Tree
  34 import Language.TCT.Token
  35 import Language.TCT.Elem
  36 import Language.TCT.Write.Text
  37
  38 {-
  39 class HTML5able a where
  40         html5Of :: a -> Html
  41
  42 class Textable a where
  43         textOf :: a -> Html
  44 instance HTML5able TCT where
  45 -}
  46
  47 html5 :: Trees (Cell Key) (Cell Tokens) -> Html
  48 html5 tct = do
  49         H.docType
  50         H.html $ do
  51                 H.head $ do
  52                         H.meta ! HA.httpEquiv "Content-Type"
  53                                ! HA.content "text/html; charset=UTF-8"
  54                         whenJust (titleTCT tct) $ \(unCell -> ts) ->
  55                                 H.title $ H.toMarkup $ L.head $
  56                                         Text.lines (TL.toStrict $ t_Tokens ts) <> [""]
  57                         -- link ! rel "Chapter" ! title "SomeTitle">
  58                         H.link ! HA.rel "stylesheet"
  59                                ! HA.type_ "text/css"
  60                                ! HA.href "style/tct-html5-source.css"
  61                 H.body $ do
  62                         H.a ! HA.id ("line-1") $ return ()
  63                         h_TreesCell (treePosLastCell tct)
  64
  65 h_TreesCell :: Trees (Pos,Cell Key) (Pos,Cell Tokens) -> Html
  66 h_TreesCell = foldMap h_TreeCell
  67
  68 titleTCT :: Trees (Cell Key) (Cell a) -> Maybe (Cell a)
  69 titleTCT tct =
  70         L.find (\case
  71          TreeN (unCell -> KeySection{}) _ts -> True
  72          _ -> False) tct >>=
  73         \case
  74          TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
  75          _ -> Nothing
  76
  77 h_Text :: Text -> Html
  78 h_Text = H.toMarkup
  79
  80 h_Spaces :: Int -> Html
  81 h_Spaces 0  = return ()
  82 h_Spaces sp = H.span $ h_Text $ Text.replicate sp " "
  83
  84 h_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Tokens) -> Html
  85 h_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) = do
  86         h_IndentCell c
  87         H.section $ do
  88                 H.span ! HA.class_ "section-title" $ do
  89                         H.span $ h_Text $ Text.replicate lvl "#" <> " "
  90                         case Seq.viewl ts of
  91                          Tree0 (_,Cell posTitle _ title) :< _ -> h lvl $ h_IndentToken posTitle title
  92                          _ -> return ()
  93                 h_TreesCell $
  94                         case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}
  95         where
  96         h 1 = H.h1
  97         h 2 = H.h2
  98         h 3 = H.h3
  99         h 4 = H.h4
 100         h 5 = H.h5
 101         h 6 = H.h6
 102         h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
 103         h _ = undefined
 104 h_TreeCell (Tree0 c@(_,cell)) = do
 105         h_IndentCell c
 106         h_CellToken cell
 107 h_TreeCell (TreeN c@(_,cell) cs) = do
 108         h_IndentCell c
 109         h_CellKey cell cs
 110
 111 h_IndentCell :: (Pos,Cell a) -> Html
 112 h_IndentCell (Pos lineLast colLast,posCell -> 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,Cell 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_CellToken :: Cell Tokens -> Html
 157 h_CellToken (Cell pos _posEnd tok) =
 158         h_IndentToken pos tok
 159
 160 h_IndentToken :: Pos -> Tokens -> Html
 161 h_IndentToken pos toks = goTokens toks `S.evalState` linePos pos
 162         where
 163         indent = Text.replicate (columnPos pos - 1) " "
 164         go :: Token -> S.State Int Html
 165         go (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         go (TokenTag v) = do
 179                 return $
 180                         H.span ! HA.class_ "tag" $ do
 181                                 H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
 182                                 H.toMarkup v
 183         go (TokenEscape c) = return $ H.toMarkup ['\\',c]
 184         go (TokenLink lnk) = do
 185                 return $
 186                         H.a ! HA.href (attrValue lnk) $
 187                                 H.toMarkup lnk
 188         go (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                         case ts of
 201                          Tokens s | Seq.null s ->
 202                                 ( "<"<>h_name<>h_Attrs attrs<>"/>"
 203                                 , mempty )
 204                          _ ->
 205                                 ( "<"<>h_name<>h_Attrs attrs<>">"
 206                                 , "</"<>h_name<>">" )
 207         go (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 ts) = do
 216                 ts' <- go`mapM`ts
 217                 return $ foldr (<>) mempty ts'
 218
 219 h_Attrs :: Attrs -> Html
 220 h_Attrs = foldMap h_Attr
 221
 222 h_Attr :: (Text,Attr) -> Html
 223 h_Attr (attr_white,Attr{..}) = do
 224         H.toMarkup attr_white
 225         H.span ! HA.class_ "attr-name" $
 226                 H.toMarkup attr_name
 227         H.toMarkup attr_open
 228         H.span ! HA.class_ "attr-value" $
 229                 H.toMarkup attr_value
 230         H.toMarkup attr_close