Language/TCT/HTML5/Source.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 -- | Render a TCT source file in HTML5.
   5 module Language.TCT.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.Internal as B
  30 import qualified Text.Blaze.Html5 as H
  31 import qualified Text.Blaze.Html5.Attributes  as HA
  32
  33 import Text.Blaze.Utils
  34 import Language.TCT.Tree
  35 import Language.TCT.Token
  36 import Language.TCT.Elem
  37
  38 {-
  39 class HTML5able a where
  40         html5Of :: a -> Html
  41
  42 class Textable a where
  43         textOf :: a -> Html
  44 instance HTML5able TCT where
  45 -}
  46
  47 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
  48 whenJust Nothing _f = pure ()
  49 whenJust (Just a) f = f a
  50
  51 html5 :: Trees (Cell Key) (Cell Token) -> Html
  52 html5 tct = do
  53         H.docType
  54         H.html $ do
  55                 H.head $ do
  56                         H.meta ! HA.httpEquiv "Content-Type"
  57                                ! HA.content "text/html; charset=UTF-8"
  58                         whenJust (titleTCT tct) $ \(unCell -> t) ->
  59                                 H.title $ H.toMarkup $ L.head $ Text.lines (t_Token t) <> [""]
  60                         -- link ! rel "Chapter" ! title "SomeTitle">
  61                         H.link ! HA.rel "stylesheet"
  62                                ! HA.type_ "text/css"
  63                                ! HA.href "style/tct-html5-source.css"
  64                 H.body $ do
  65                         H.a ! HA.id ("line-1") $ return ()
  66                         forM_ (treePosLastCell tct) $ h_TreeCell
  67
  68 treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
  69 treePosLastCell t = S.evalState (go`mapM`t) (1,1)
  70         where
  71         go :: Tree (Cell k) (Cell a) ->
  72               S.State (Int, Int) (Tree (Pos, Cell k) (Pos, Cell a))
  73         go (Tree0 cell) = do
  74                 lastPos <- S.get
  75                 S.put $ posEndCell cell
  76                 return $ Tree0 (lastPos,cell)
  77         go (TreeN cell ts) = do
  78                 lastPos <- S.get
  79                 S.put $ posEndCell cell
  80                 ts' <- go`mapM`ts
  81                 return $ TreeN (lastPos,cell) ts'
  82
  83 titleTCT :: Trees (Cell Key) (Cell a) -> Maybe (Cell a)
  84 titleTCT tct =
  85         L.find (\case
  86          TreeN (unCell -> KeySection{}) _ts -> True
  87          _ -> False) tct >>=
  88         \case
  89          TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
  90          _ -> Nothing
  91
  92 h_Text :: Text -> Html
  93 h_Text = H.toMarkup
  94
  95 h_Spaces :: Int -> Html
  96 h_Spaces 0  = return ()
  97 h_Spaces sp = H.span $ h_Text $ Text.replicate sp " "
  98
  99 h_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Token) -> Html
 100 h_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) = do
 101         h_IndentCell c
 102         H.section $ do
 103                 H.span ! HA.class_ "section-title" $ do
 104                         H.span $ h_Text $ Text.replicate lvl "#" <> " "
 105                         case Seq.viewl ts of
 106                          Tree0 (_,Cell posTitle _ title) :< _ -> h lvl $ h_IndentToken posTitle title
 107                          _ -> return ()
 108                 forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ h_TreeCell
 109         where
 110         h 1 = H.h1
 111         h 2 = H.h2
 112         h 3 = H.h3
 113         h 4 = H.h4
 114         h 5 = H.h5
 115         h 6 = H.h6
 116         h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
 117         h _ = undefined
 118 h_TreeCell (Tree0 c@(_,cell)) = do
 119         h_IndentCell c
 120         h_CellToken cell
 121 h_TreeCell (TreeN c@(_,cell) cs) = do
 122         h_IndentCell c
 123         h_CellKey cell cs
 124
 125 h_IndentCell :: (Pos,Cell a) -> Html
 126 h_IndentCell ((lineLast,colLast),posCell -> (line,col))
 127  | lineLast < line = do
 128         forM_ [lineLast+1..line] $ \lnum -> do
 129                 H.toMarkup '\n'
 130                 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
 131         H.toMarkup $ Text.replicate (col - 1) " "
 132  | lineLast == line
 133  && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " "
 134  | otherwise = undefined
 135
 136 h_CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Cell Token) -> Html
 137 h_CellKey (Cell _pos _posEnd key) cells = do
 138         case key of
 139          KeyColon n wh -> h_Key n wh ":" "colon"
 140          KeyGreat n wh -> h_Key n wh ">" "great"
 141          KeyEqual n wh -> h_Key n wh "=" "equal"
 142          KeyBar   n wh -> h_Key n wh "|" "bar"
 143          KeyDash -> do
 144                 H.toMarkup ("- "::Text)
 145                 forM_ cells h_TreeCell
 146          KeyLower name attrs -> do
 147                 H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do
 148                         H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
 149                         H.span ! HA.class_ "key-name" $ H.toMarkup name
 150                         h_Attrs attrs
 151                         forM_ cells h_TreeCell
 152         where
 153         h_Key :: Text -> White -> Text -> H.AttributeValue -> Html
 154         h_Key name wh mark cl = do
 155                 -- h_Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
 156                 H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
 157                         H.span ! HA.class_ "key-name" $ H.toMarkup name
 158                         H.toMarkup wh
 159                         H.span ! HA.class_ "key-mark" $ H.toMarkup mark
 160                         forM_ cells h_TreeCell
 161
 162 h_CellToken :: Cell Token -> Html
 163 h_CellToken (Cell pos _posEnd tok) =
 164         h_IndentToken pos tok
 165
 166 h_IndentToken :: Pos -> Token -> Html
 167 h_IndentToken pos tok = go tok `S.evalState` linePos pos
 168         where
 169         indent = Text.replicate (columnPos pos - 1) " "
 170         go :: Token -> S.State Int Html
 171         go (TokenPlain txt) = do
 172                 lin <- S.get
 173                 let lines = Text.splitOn "\n" txt
 174                 let lnums = H.toMarkup :
 175                          [ \line -> do
 176                                 H.toMarkup '\n'
 177                                 H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
 178                                 H.toMarkup indent
 179                                 H.toMarkup line
 180                          | lnum <- [lin+1..]
 181                          ]
 182                 S.put (lin - 1 + L.length lines)
 183                 return $ mconcat $ L.zipWith ($) lnums lines
 184         go (TokenTag v) = do
 185                 return $
 186                         H.span ! HA.class_ "tag" $ do
 187                                 H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
 188                                 H.toMarkup v
 189         go (TokenEscape c) = return $ H.toMarkup ['\\',c]
 190         go (TokenLink lnk) = do
 191                 return $
 192                         H.a ! HA.href (attrValue lnk) $
 193                                 H.toMarkup lnk
 194         go (TokenGroup (GroupElem name attrs) t) = do
 195                 h <- go t
 196                 return $ do
 197                         let cl = mconcat ["group-GroupElem", " group-elem-", attrValue name]
 198                         H.span ! HA.class_ cl $ do
 199                                 whenMarkup o $ H.span ! HA.class_ "group-open" $ o
 200                                 whenMarkup h $ H.span ! HA.class_ "group-content" $ h
 201                                 whenMarkup c $ H.span ! HA.class_ "group-close" $ c
 202                 where
 203                 h_name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
 204                 o,c :: Html
 205                 (o,c) =
 206                         case t of
 207                          Tokens ts | Seq.null ts ->
 208                                 ( "<"<>h_name<>h_Attrs attrs<>"/>"
 209                                 , mempty )
 210                          _ ->
 211                                 ( "<"<>h_name<>h_Attrs attrs<>">"
 212                                 , "</"<>h_name<>">" )
 213         go (TokenGroup grp t) = do
 214                 h <- go t
 215                 return $ do
 216                         let (o,c) = groupBorders grp t
 217                         H.span ! HA.class_ (mconcat ["group-", fromString $ show grp]) $ do
 218                                 H.span ! HA.class_ "group-open"    $ H.toMarkup o
 219                                 H.span ! HA.class_ "group-content" $ h
 220                                 H.span ! HA.class_ "group-close"   $ H.toMarkup c
 221         go (Tokens ts) = do
 222                 ts' <- go`mapM`ts
 223                 return $ foldr (<>) mempty ts'
 224
 225 h_Attrs :: Attrs -> Html
 226 h_Attrs = foldMap h_Attr
 227
 228 h_Attr :: (Text,Attr) -> Html
 229 h_Attr (attr_white,Attr{..}) = do
 230         H.toMarkup attr_white
 231         H.span ! HA.class_ "attr-name" $
 232                 H.toMarkup attr_name
 233         H.toMarkup attr_open
 234         H.span ! HA.class_ "attr-value" $
 235                 H.toMarkup attr_value
 236         H.toMarkup attr_close
 237
 238 t_Token :: Token -> Text
 239 t_Token (TokenPlain t) = t
 240 t_Token (TokenTag v) = "#"<>v
 241 t_Token (TokenEscape c) = Text.pack ['\\',c]
 242 t_Token (TokenLink lnk) = lnk
 243 t_Token (TokenGroup grp t) = o<>t_Token t<>c
 244         where (o,c) = groupBorders grp t
 245 t_Token (Tokens ts) = foldMap t_Token ts
 246
 247 t_Value :: Text -> Text
 248 t_Value v = v