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          KeyLower name attrs -> do
 138                 H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do
 139                         H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
 140                         H.span ! HA.class_ "key-name" $ H.toMarkup name
 141                         h_Attrs attrs
 142                         h_TreesCell ts
 143         where
 144         h_Key :: Text -> White -> Text -> White -> H.AttributeValue -> Html
 145         h_Key name whn mark whm cl = do
 146                 -- h_Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
 147                 H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
 148                         when (name/="") $
 149                                 H.span ! HA.class_ "key-name" $ H.toMarkup name
 150                         H.toMarkup whn
 151                         H.span ! HA.class_ "key-mark" $ H.toMarkup mark
 152                         H.toMarkup whm
 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