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          KeyDot n -> h_Key n "" "." "dot"
 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                         forM_ cells h_TreeCell
 139         where
 140         h_Key :: Text -> White -> Text -> H.AttributeValue -> Html
 141         h_Key name wh mark 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                         H.span ! HA.class_ "key-name" $ H.toMarkup name
 145                         H.toMarkup wh
 146                         H.span ! HA.class_ "key-mark" $ H.toMarkup mark
 147                         H.span ! HA.class_ "key-value" $
 148                                 forM_ cells h_TreeCell
 149
 150 h_CellToken :: Cell Tokens -> Html
 151 h_CellToken (Cell pos _posEnd tok) =
 152         h_IndentToken pos tok
 153
 154 h_IndentToken :: Pos -> Tokens -> Html
 155 h_IndentToken pos toks = goTokens toks `S.evalState` linePos pos
 156         where
 157         indent = TL.replicate (int64 $ columnPos pos - 1) " "
 158         go :: Token -> S.State Int Html
 159         go (TokenPlain txt) = do
 160                 lin <- S.get
 161                 let lines = TL.splitOn "\n" txt
 162                 let lnums = H.toMarkup :
 163                          [ \line -> do
 164                                 H.toMarkup '\n'
 165                                 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
 166                                 H.toMarkup indent
 167                                 H.toMarkup line
 168                          | lnum <- [lin+1..]
 169                          ]
 170                 S.put (lin - 1 + L.length lines)
 171                 return $ mconcat $ L.zipWith ($) lnums lines
 172         go (TokenTag v) = do
 173                 return $
 174                         H.span ! HA.class_ "tag" $ do
 175                                 H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
 176                                 H.toMarkup v
 177         go (TokenEscape c) = return $ H.toMarkup ['\\',c]
 178         go (TokenLink lnk) = do
 179                 return $
 180                         H.a ! HA.href (attrValue lnk) $
 181                                 H.toMarkup lnk
 182         go (TokenPair (PairElem name attrs) ts) = do
 183                 h <- goTokens ts
 184                 return $ do
 185                         let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
 186                         H.span ! HA.class_ cl $ do
 187                                 whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
 188                                 whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
 189                                 whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
 190                 where
 191                 h_name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
 192                 o,c :: Html
 193                 (o,c) =
 194                         case ts of
 195                          Tokens s | Seq.null s ->
 196                                 ( "<"<>h_name<>h_Attrs attrs<>"/>"
 197                                 , mempty )
 198                          _ ->
 199                                 ( "<"<>h_name<>h_Attrs attrs<>">"
 200                                 , "</"<>h_name<>">" )
 201         go (TokenPair grp ts) = do
 202                 h <- goTokens ts
 203                 return $ do
 204                         let (o,c) = pairBorders grp ts
 205                         H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
 206                                 H.span ! HA.class_ "pair-open"    $ H.toMarkup o
 207                                 H.span ! HA.class_ "pair-content" $ h
 208                                 H.span ! HA.class_ "pair-close"   $ H.toMarkup c
 209         goTokens (Tokens ts) = do
 210                 ts' <- go`mapM`ts
 211                 return $ foldr (<>) mempty ts'
 212
 213 h_Attrs :: Attrs -> Html
 214 h_Attrs = foldMap h_Attr
 215
 216 h_Attr :: (Text,Attr) -> Html
 217 h_Attr (attr_white,Attr{..}) = do
 218         H.toMarkup attr_white
 219         H.span ! HA.class_ "attr-name" $
 220                 H.toMarkup attr_name
 221         H.toMarkup attr_open
 222         H.span ! HA.class_ "attr-value" $
 223                 H.toMarkup attr_value
 224         H.toMarkup attr_close