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