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 $ Text.lines (TL.toStrict $ t_Tokens ts) <> [""]
  61                         -- link ! rel "Chapter" ! title "SomeTitle">
  62                         H.link ! HA.rel "stylesheet"
  63                                ! HA.type_ "text/css"
  64                                ! HA.href "style/tct-html5-source.css"
  65                 H.body $ do
  66                         H.a ! HA.id ("line-1") $ return ()
  67                         forM_ (treePosLastCell tct) $ h_TreeCell
  68
  69 titleTCT :: Trees (Cell Key) (Cell a) -> Maybe (Cell a)
  70 titleTCT tct =
  71         L.find (\case
  72          TreeN (unCell -> KeySection{}) _ts -> True
  73          _ -> False) tct >>=
  74         \case
  75          TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
  76          _ -> Nothing
  77
  78 h_Text :: Text -> Html
  79 h_Text = H.toMarkup
  80
  81 h_Spaces :: Int -> Html
  82 h_Spaces 0  = return ()
  83 h_Spaces sp = H.span $ h_Text $ Text.replicate sp " "
  84
  85 h_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Tokens) -> Html
  86 h_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) = do
  87         h_IndentCell c
  88         H.section $ do
  89                 H.span ! HA.class_ "section-title" $ do
  90                         H.span $ h_Text $ Text.replicate lvl "#" <> " "
  91                         case Seq.viewl ts of
  92                          Tree0 (_,Cell posTitle _ title) :< _ -> h lvl $ h_IndentToken posTitle title
  93                          _ -> return ()
  94                 forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ h_TreeCell
  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) cells = 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          KeyDash -> do
 130                 H.toMarkup ("- "::Text)
 131                 forM_ cells h_TreeCell
 132          KeyLower name attrs -> do
 133                 H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do
 134                         H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
 135                         H.span ! HA.class_ "key-name" $ H.toMarkup name
 136                         h_Attrs attrs
 137                         forM_ cells h_TreeCell
 138         where
 139         h_Key :: Text -> White -> Text -> H.AttributeValue -> Html
 140         h_Key name wh mark cl = do
 141                 -- h_Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
 142                 H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
 143                         H.span ! HA.class_ "key-name" $ H.toMarkup name
 144                         H.toMarkup wh
 145                         H.span ! HA.class_ "key-mark" $ H.toMarkup mark
 146                         H.span ! HA.class_ "key-value" $
 147                                 forM_ cells h_TreeCell
 148
 149 h_CellToken :: Cell Tokens -> Html
 150 h_CellToken (Cell pos _posEnd tok) =
 151         h_IndentToken pos tok
 152
 153 h_IndentToken :: Pos -> Tokens -> Html
 154 h_IndentToken pos toks = goTokens toks `S.evalState` linePos pos
 155         where
 156         indent = Text.replicate (columnPos pos - 1) " "
 157         go :: Token -> S.State Int Html
 158         go (TokenPlain txt) = do
 159                 lin <- S.get
 160                 let lines = Text.splitOn "\n" txt
 161                 let lnums = H.toMarkup :
 162                          [ \line -> do
 163                                 H.toMarkup '\n'
 164                                 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
 165                                 H.toMarkup indent
 166                                 H.toMarkup line
 167                          | lnum <- [lin+1..]
 168                          ]
 169                 S.put (lin - 1 + L.length lines)
 170                 return $ mconcat $ L.zipWith ($) lnums lines
 171         go (TokenTag v) = do
 172                 return $
 173                         H.span ! HA.class_ "tag" $ do
 174                                 H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
 175                                 H.toMarkup v
 176         go (TokenEscape c) = return $ H.toMarkup ['\\',c]
 177         go (TokenLink lnk) = do
 178                 return $
 179                         H.a ! HA.href (attrValue lnk) $
 180                                 H.toMarkup lnk
 181         go (TokenPair (PairElem name attrs) ts) = do
 182                 h <- goTokens ts
 183                 return $ do
 184                         let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
 185                         H.span ! HA.class_ cl $ do
 186                                 whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
 187                                 whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
 188                                 whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
 189                 where
 190                 h_name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
 191                 o,c :: Html
 192                 (o,c) =
 193                         case ts of
 194                          Tokens s | Seq.null s ->
 195                                 ( "<"<>h_name<>h_Attrs attrs<>"/>"
 196                                 , mempty )
 197                          _ ->
 198                                 ( "<"<>h_name<>h_Attrs attrs<>">"
 199                                 , "</"<>h_name<>">" )
 200         go (TokenPair grp ts) = do
 201                 h <- goTokens ts
 202                 return $ do
 203                         let (o,c) = pairBorders grp ts
 204                         H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
 205                                 H.span ! HA.class_ "pair-open"    $ H.toMarkup o
 206                                 H.span ! HA.class_ "pair-content" $ h
 207                                 H.span ! HA.class_ "pair-close"   $ H.toMarkup c
 208         goTokens (Tokens ts) = do
 209                 ts' <- go`mapM`ts
 210                 return $ foldr (<>) mempty ts'
 211
 212 h_Attrs :: Attrs -> Html
 213 h_Attrs = foldMap h_Attr
 214
 215 h_Attr :: (Text,Attr) -> Html
 216 h_Attr (attr_white,Attr{..}) = do
 217         H.toMarkup attr_white
 218         H.span ! HA.class_ "attr-name" $
 219                 H.toMarkup attr_name
 220         H.toMarkup attr_open
 221         H.span ! HA.class_ "attr-value" $
 222                 H.toMarkup attr_value
 223         H.toMarkup attr_close