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