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)
   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                         forM_ (treePosLastCell tct) $ h_TreeCell
  69
  70 titleTCT :: Trees (Cell Key) (Cell a) -> Maybe (Cell a)
  71 titleTCT tct =
  72         L.find (\case
  73          TreeN (unCell -> KeySection{}) _ts -> True
  74          _ -> False) tct >>=
  75         \case
  76          TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
  77          _ -> Nothing
  78
  79 h_Text :: Text -> Html
  80 h_Text = H.toMarkup
  81
  82 h_Spaces :: Int -> Html
  83 h_Spaces 0  = return ()
  84 h_Spaces sp = H.span $ h_Text $ Text.replicate sp " "
  85
  86 h_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Tokens) -> Html
  87 h_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) = do
  88         h_IndentCell c
  89         H.section $ do
  90                 H.span ! HA.class_ "section-title" $ do
  91                         H.span $ h_Text $ Text.replicate lvl "#" <> " "
  92                         case Seq.viewl ts of
  93                          Tree0 (_,Cell posTitle _ title) :< _ -> h lvl $ h_IndentToken posTitle title
  94                          _ -> return ()
  95                 forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ h_TreeCell
  96         where
  97         h 1 = H.h1
  98         h 2 = H.h2
  99         h 3 = H.h3
 100         h 4 = H.h4
 101         h 5 = H.h5
 102         h 6 = H.h6
 103         h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
 104         h _ = undefined
 105 h_TreeCell (Tree0 c@(_,cell)) = do
 106         h_IndentCell c
 107         h_CellToken cell
 108 h_TreeCell (TreeN c@(_,cell) cs) = do
 109         h_IndentCell c
 110         h_CellKey cell cs
 111
 112 h_IndentCell :: (Pos,Cell a) -> Html
 113 h_IndentCell (Pos lineLast colLast,posCell -> Pos line col)
 114  | lineLast < line = do
 115         forM_ [lineLast+1..line] $ \lnum -> do
 116                 H.toMarkup '\n'
 117                 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
 118         H.toMarkup $ Text.replicate (col - 1) " "
 119  | lineLast == line
 120  && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " "
 121  | otherwise = undefined
 122
 123 h_CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Cell Tokens) -> Html
 124 h_CellKey (Cell _pos _posEnd key) cells = do
 125         case key of
 126          KeyColon n wh -> h_Key n wh ":" "colon"
 127          KeyGreat n wh -> h_Key n wh ">" "great"
 128          KeyEqual n wh -> h_Key n wh "=" "equal"
 129          KeyBar   n wh -> h_Key n wh "|" "bar"
 130          KeyDash -> do
 131                 H.toMarkup ("- "::Text)
 132                 forM_ cells h_TreeCell
 133          KeyDot n -> h_Key n "" "." "dot"
 134          KeyLower name attrs -> do
 135                 H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do
 136                         H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
 137                         H.span ! HA.class_ "key-name" $ H.toMarkup name
 138                         h_Attrs attrs
 139                         forM_ cells h_TreeCell
 140         where
 141         h_Key :: Text -> White -> Text -> H.AttributeValue -> Html
 142         h_Key name wh mark cl = do
 143                 -- h_Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
 144                 H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
 145                         H.span ! HA.class_ "key-name" $ H.toMarkup name
 146                         H.toMarkup wh
 147                         H.span ! HA.class_ "key-mark" $ H.toMarkup mark
 148                         H.span ! HA.class_ "key-value" $
 149                                 forM_ cells h_TreeCell
 150
 151 h_CellToken :: Cell Tokens -> Html
 152 h_CellToken (Cell pos _posEnd tok) =
 153         h_IndentToken pos tok
 154
 155 h_IndentToken :: Pos -> Tokens -> Html
 156 h_IndentToken pos toks = goTokens toks `S.evalState` linePos pos
 157         where
 158         indent = Text.replicate (columnPos pos - 1) " "
 159         go :: Token -> S.State Int Html
 160         go (TokenPlain txt) = do
 161                 lin <- S.get
 162                 let lines = Text.splitOn "\n" txt
 163                 let lnums = H.toMarkup :
 164                          [ \line -> do
 165                                 H.toMarkup '\n'
 166                                 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
 167                                 H.toMarkup indent
 168                                 H.toMarkup line
 169                          | lnum <- [lin+1..]
 170                          ]
 171                 S.put (lin - 1 + L.length lines)
 172                 return $ mconcat $ L.zipWith ($) lnums lines
 173         go (TokenTag v) = do
 174                 return $
 175                         H.span ! HA.class_ "tag" $ do
 176                                 H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
 177                                 H.toMarkup v
 178         go (TokenEscape c) = return $ H.toMarkup ['\\',c]
 179         go (TokenLink lnk) = do
 180                 return $
 181                         H.a ! HA.href (attrValue lnk) $
 182                                 H.toMarkup lnk
 183         go (TokenPair (PairElem name attrs) ts) = do
 184                 h <- goTokens ts
 185                 return $ do
 186                         let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
 187                         H.span ! HA.class_ cl $ do
 188                                 whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
 189                                 whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
 190                                 whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
 191                 where
 192                 h_name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
 193                 o,c :: Html
 194                 (o,c) =
 195                         case ts of
 196                          Tokens s | Seq.null s ->
 197                                 ( "<"<>h_name<>h_Attrs attrs<>"/>"
 198                                 , mempty )
 199                          _ ->
 200                                 ( "<"<>h_name<>h_Attrs attrs<>">"
 201                                 , "</"<>h_name<>">" )
 202         go (TokenPair grp ts) = do
 203                 h <- goTokens ts
 204                 return $ do
 205                         let (o,c) = pairBorders grp ts
 206                         H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
 207                                 H.span ! HA.class_ "pair-open"    $ H.toMarkup o
 208                                 H.span ! HA.class_ "pair-content" $ h
 209                                 H.span ! HA.class_ "pair-close"   $ H.toMarkup c
 210         goTokens (Tokens ts) = do
 211                 ts' <- go`mapM`ts
 212                 return $ foldr (<>) mempty ts'
 213
 214 h_Attrs :: Attrs -> Html
 215 h_Attrs = foldMap h_Attr
 216
 217 h_Attr :: (Text,Attr) -> Html
 218 h_Attr (attr_white,Attr{..}) = do
 219         H.toMarkup attr_white
 220         H.span ! HA.class_ "attr-name" $
 221                 H.toMarkup attr_name
 222         H.toMarkup attr_open
 223         H.span ! HA.class_ "attr-value" $
 224                 H.toMarkup attr_value
 225         H.toMarkup attr_close