Language/TCT/HTML5/Source.hs

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