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 $ 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" $
 183                                 H.toMarkup $ "#"<>v
 184         go (TokenEscape c) = return $ H.toMarkup ['\\',c]
 185         go (TokenLink lnk) = do
 186                 return $
 187                         H.a ! HA.href (attrValue lnk) $
 188                                 H.toMarkup lnk
 189         go (TokenGroup (GroupElem name attrs) t) = do
 190                 h <- go t
 191                 return $ do
 192                         let cl = mconcat ["group-GroupElem", " group-elem-", attrValue name]
 193                         H.span ! HA.class_ cl $ do
 194                                 H.span ! HA.class_ "group-open"    $ H.toMarkup o
 195                                 H.span ! HA.class_ "group-content" $ h
 196                                 H.span ! HA.class_ "group-close"   $ H.toMarkup c
 197                 where
 198                 h_name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
 199                 o,c :: Html
 200                 (o,c) =
 201                         case t of
 202                          Tokens ts | Seq.null ts ->
 203                                 ( "<"<>h_name<>h_Attrs attrs<>"/>"
 204                                 , "" )
 205                          _ ->
 206                                 ( "<"<>h_name<>h_Attrs attrs<>">"
 207                                 , "</"<>h_name<>">" )
 208         go (TokenGroup grp t) = do
 209                 h <- go t
 210                 return $ do
 211                         let (o,c) = groupBorders grp t
 212                         H.span ! HA.class_ (mconcat ["group-", attrValue grp]) $ do
 213                                 H.span ! HA.class_ "group-open"    $ H.toMarkup o
 214                                 H.span ! HA.class_ "group-content" $ h
 215                                 H.span ! HA.class_ "group-close"   $ H.toMarkup c
 216         go (Tokens ts) = do
 217                 ts' <- go`mapM`ts
 218                 return $ foldr (<>) mempty ts'
 219
 220 h_Attrs :: Attrs -> Html
 221 h_Attrs = foldMap h_Attr
 222
 223 h_Attr :: (Text,Attr) -> Html
 224 h_Attr (attr_white,Attr{..}) = do
 225         H.toMarkup attr_white
 226         H.span ! HA.class_ "attr-name" $
 227                 H.toMarkup attr_name
 228         H.toMarkup attr_open
 229         H.span ! HA.class_ "attr-value" $
 230                 H.toMarkup attr_value
 231         H.toMarkup attr_close
 232
 233 t_Token :: Token -> Text
 234 t_Token (TokenPlain t) = t
 235 t_Token (TokenTag v) = "#"<>v
 236 t_Token (TokenEscape c) = Text.pack ['\\',c]
 237 t_Token (TokenLink lnk) = lnk
 238 t_Token (TokenGroup grp t) = o<>t_Token t<>c
 239         where (o,c) = groupBorders grp t
 240 t_Token (Tokens ts) = foldMap t_Token ts
 241
 242 t_Value :: Text -> Text
 243 t_Value v = v
 244
 245 treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
 246 treePosLastCell t = S.evalState (go`mapM`t) (1,1)
 247         where
 248         go :: Tree (Cell k) (Cell a) ->
 249               S.State (Int, Int) (Tree (Pos, Cell k) (Pos, Cell a))
 250         go (Tree0 cell) = do
 251                 lastPos <- S.get
 252                 S.put $ posEndCell cell
 253                 return $ Tree0 (lastPos,cell)
 254         go (TreeN cell ts) = do
 255                 lastPos <- S.get
 256                 S.put $ posEndCell cell
 257                 ts' <- go`mapM`ts
 258                 return $ TreeN (lastPos,cell) ts'