Hdoc/TCT/Write/HTML5.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ViewPatterns #-}
   5 module Hdoc.TCT.Write.HTML5 where
   6
   7 import Control.Monad (Monad(..), forM_, mapM_, join)
   8 import Data.Bool
   9 import Data.Char (Char)
  10 import Data.Default.Class (Default(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (Foldable(..))
  13 import Data.Function (($), (.))
  14 import Data.Functor.Compose (Compose(..))
  15 import Data.List.NonEmpty (NonEmpty(..))
  16 import Data.Maybe (Maybe(..), maybe)
  17 import Data.Monoid (Monoid(..))
  18 import Data.Ord (Ord(..), Ordering(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.Sequence (ViewL(..))
  21 import Data.String (String, IsString(..))
  22 import Prelude (Num(..), undefined, error)
  23 import Text.Blaze ((!))
  24 import Text.Blaze.Html (Html)
  25 import Text.Show (Show(..))
  26 import qualified Control.Monad.Trans.RWS.Strict as RWS
  27 import qualified Data.List as List
  28 import qualified Data.Sequence as Seq
  29 import qualified Data.Text.Lazy as TL
  30 import qualified Symantic.XML as XML
  31 import qualified Text.Blaze.Html5 as H
  32 import qualified Text.Blaze.Html5.Attributes as HA
  33 import qualified Text.Blaze.Internal as Blaze
  34
  35 -- import Hdoc.TCT.Debug
  36 import Hdoc.TCT
  37 import Hdoc.TCT.Utils
  38 import Control.Monad.Utils
  39 import Text.Blaze.Utils
  40 import Text.Blaze.XML ()
  41 import qualified Hdoc.TCT.Write.Plain as Plain
  42
  43 writeHTML5 :: Trees (Cell Node) -> Html
  44 writeHTML5 body = do
  45         H.docType
  46         H.html $ do
  47                 H.head $ do
  48                         H.meta ! HA.httpEquiv "Content-Type"
  49                                ! HA.content "text/html; charset=UTF-8"
  50                         whenJust (titleFrom body) $ \t ->
  51                                 H.title $
  52                                         H.toMarkup $ Plain.text def t
  53                         -- link ! rel "Chapter" ! title "SomeTitle">
  54                         H.link ! HA.rel "stylesheet"
  55                                ! HA.type_ "text/css"
  56                                ! HA.href "style/tct-html5.css"
  57                 let (html5Body, State{}, ()) =
  58                         runComposeRWS def def $
  59                         html5ify body
  60                 H.body $ do
  61                         H.a ! HA.id "line-1" $ return ()
  62                         html5Body
  63
  64 titleFrom :: Roots -> Maybe Root
  65 titleFrom tct =
  66         List.find (\case
  67          Tree (unSourced -> NodeHeader HeaderSection{}) _ts -> True
  68          _ -> False) tct >>=
  69         \case
  70          Tree (unSourced -> NodeHeader (HeaderSection _lvl))
  71               (Seq.viewl -> title:<_) -> Just title
  72          _ -> Nothing
  73
  74 -- * Type 'Html5'
  75 type Html5 = ComposeRWS Reader Writer State Blaze.MarkupM ()
  76
  77 instance IsString Html5 where
  78         fromString = mapM_ html5ify
  79
  80 html5 :: H.ToMarkup a => a -> Html5
  81 html5 = Compose . return . H.toMarkup
  82
  83 -- ** Type 'Reader'
  84 data Reader = Reader
  85  { reader_indent   :: Html5
  86  , reader_italic   :: Bool
  87  , reader_ext_html :: String
  88  } -- deriving (Eq, Show)
  89 instance Default Reader where
  90         def = Reader
  91          { reader_indent   = ""
  92          , reader_italic   = False
  93          , reader_ext_html = ".html"
  94          }
  95
  96 -- ** Type 'Writer'
  97 type Writer = ()
  98
  99 -- ** Type 'State'
 100 newtype State = State
 101  { state_pos :: LineColumn
 102  } -- deriving (Eq, Show)
 103 instance Default State where
 104         def = State
 105          { state_pos = def
 106          }
 107
 108 -- * Class 'Html5ify'
 109 class Html5ify a where
 110         html5ify :: a -> Html5
 111 instance Html5ify () where
 112         html5ify = mempty
 113 instance Html5ify Char where
 114         html5ify = \case
 115          '\n' -> do
 116                 st@State{state_pos=LineColumn line _col, ..} <- composeLift RWS.get
 117                 composeLift $ RWS.put st{state_pos=LineColumn (line <> pos1) pos1}
 118                 html5 '\n'
 119                 H.a ! HA.id ("line-"<>attrify (line <> pos1)) $$ return ()
 120                 join $ composeLift $ RWS.asks reader_indent
 121          c -> do
 122                 composeLift $ RWS.modify $ \s@State{state_pos=LineColumn line col} ->
 123                         s{state_pos=LineColumn line (col <> pos1)}
 124                 html5 c
 125 instance Html5ify String where
 126         html5ify = mapM_ html5ify
 127 instance Html5ify TL.Text where
 128         html5ify t
 129          | TL.null t = mempty
 130          | otherwise =
 131                 let (h,ts) = TL.span (/='\n') t in
 132                 case TL.uncons ts of
 133                  Nothing -> do
 134                         composeLift $ RWS.modify $ \s@State{state_pos} ->
 135                                 s{state_pos=state_pos{colNum = colNum state_pos <> num (TL.length h)}}
 136                         html5 h
 137                  Just (_n,ts') -> do
 138                         html5 h
 139                          -- NOTE: useless to increment the 'colNum' for h,
 140                          --       since the following '\n' will reset the 'colNum'.
 141                         html5ify '\n'
 142                         html5ify ts'
 143 instance Html5ify LineColumn where
 144         html5ify new = do
 145                 Reader{reader_indent} <- composeLift RWS.ask
 146                 st@State{state_pos=old} <- composeLift RWS.get
 147                 let lineOld = lineInt old
 148                 let colOld  = colInt  old
 149                 case lineOld`compare`lineNew of
 150                  LT -> do
 151                         forM_ [lineOld+1..lineNew] $ \lnum -> do
 152                                 html5 '\n'
 153                                 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
 154                         composeLift $ RWS.put st{state_pos=LineColumn (lineNum new) pos1}
 155                         reader_indent
 156                         mid <- composeLift $ RWS.gets state_pos
 157                         html5 $ List.replicate (colNew - colInt mid) ' '
 158                         composeLift $ RWS.put st{state_pos=new}
 159                  EQ | colOld <= colNew -> do
 160                         composeLift $ RWS.put st{state_pos=new}
 161                         html5 $ List.replicate (colNew - colOld) ' '
 162                  _ -> error $ "html5ify: non-ascending LineColumn:"
 163                          <> "\n old: " <> show old
 164                          <> "\n new: " <> show new
 165                 where
 166                 lineNew = lineInt new
 167                 colNew  = colInt  new
 168 instance Html5ify Roots where
 169         html5ify = mapM_ html5ify
 170 instance Html5ify Root where
 171         html5ify (Tree (Sourced (FileRange{fileRange_begin=bp}:|_) nod) ts) = do
 172                 html5ify bp
 173                 case nod of
 174                 ----------------------
 175                  NodeLower name attrs -> do
 176                         H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do
 177                                 H.span ! HA.class_ "header-mark" $$ html5ify '<'
 178                                 H.span ! HA.class_ "header-name" $$ html5ify name
 179                                 html5ify attrs
 180                                 html5ify ts
 181                 ----------------------
 182                  NodeHeader hdr ->
 183                         case hdr of
 184                          HeaderGreat n wh -> html5HeaderRepeated "" "" (maybe "" XML.unNCName n) wh ">" "" "great"
 185                          HeaderBar   n wh -> html5HeaderRepeated "" "" (maybe "" XML.unNCName n) wh "|" "" "bar"
 186                          HeaderColon n wh -> html5Header "" "" (maybe "" XML.unNCName n) wh ":" "" "colon"
 187                          HeaderEqual n wh -> html5Header "" "" (XML.unNCName n) wh "=" "" "equal"
 188                          HeaderDot   n    -> html5Header "" "" n "" "." "" "dot"
 189                          HeaderDash       -> html5Header "" "" "" "" "-" " " "dash"
 190                          HeaderDashDash   -> html5Header "" "" "" "" "--" " " "dashdash"
 191                          HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash"
 192                          HeaderSection lvl -> do
 193                                 H.section $$ do
 194                                         H.span ! HA.class_ "section-title" $$ do
 195                                                 H.span ! HA.class_ "section-mark" $$ do
 196                                                         html5ify $ List.replicate lvl '#'
 197                                                 case Seq.viewl ts of
 198                                                  title :< _ -> h lvl $$ html5ify title
 199                                                  _ -> return ()
 200                                         html5ify $
 201                                                 case Seq.viewl ts of
 202                                                  _ :< ts' -> ts'
 203                                                  _ -> ts
 204                                 where
 205                                 h 1 = H.h1
 206                                 h 2 = H.h2
 207                                 h 3 = H.h3
 208                                 h 4 = H.h4
 209                                 h 5 = H.h5
 210                                 h 6 = H.h6
 211                                 h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
 212                                 h _ = undefined
 213                          HeaderDotSlash file -> do
 214                                 ext <- composeLift $ RWS.asks reader_ext_html
 215                                 if null ext
 216                                  then html5ify file
 217                                  else
 218                                         H.a ! HA.class_ "header-dotslash"
 219                                             ! HA.href (attrify $ file<>ext) $$
 220                                                 html5ify file
 221                         where
 222                         html5Head :: TL.Text -> White -> TL.Text -> White -> TL.Text -> White -> H.AttributeValue -> Html5
 223                         html5Head markBegin whmb name whn markEnd whme cl = do
 224                                 H.span ! HA.class_ (mconcat $ ["header header-",cl] <>
 225                                  if TL.null name then [] else [" header-name-",attrify name]) $$ do
 226                                         when (markBegin/="") $
 227                                                 H.span ! HA.class_ "header-mark" $$ html5ify markBegin
 228                                         html5ify whmb
 229                                         when (name/="") $
 230                                                 H.span ! HA.class_ "header-name" $$ html5ify name
 231                                         html5ify whn
 232                                         when (markEnd/="") $
 233                                                 H.span ! HA.class_ "header-mark" $$ html5ify markEnd
 234                                         html5ify whme
 235                         html5Header markBegin whmb name whn markEnd whme cl = do
 236                                 html5Head markBegin whmb name whn markEnd whme cl
 237                                 H.span ! HA.class_ "header-value" $$
 238                                         html5ify ts
 239                         html5HeaderRepeated :: TL.Text -> White -> TL.Text -> White -> TL.Text -> White -> H.AttributeValue -> Html5
 240                         html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
 241                                 localComposeRWS (\ro ->
 242                                         ro{ reader_indent = do
 243                                                 reader_indent ro
 244                                                 midLC <- composeLift $ RWS.gets state_pos
 245                                                 html5ify $ List.replicate (colInt bp - colInt midLC) ' '
 246                                                 html5Head markBegin whmb name whn markEnd whme cl
 247                                          }) $
 248                                         html5Header markBegin whmb name whn markEnd whme cl
 249                 ----------------------
 250                  NodeText t -> do
 251                         localComposeRWS (\ro ->
 252                                 ro{ reader_indent = do
 253                                         reader_indent ro
 254                                         midLC <- composeLift $ RWS.gets state_pos
 255                                         html5ify $ List.replicate (colInt bp - colInt midLC) ' '
 256                                  }) $
 257                                 html5ify t
 258                 ----------------------
 259                  NodePara -> do
 260                         localComposeRWS (\ro ->
 261                                 ro{ reader_indent = do
 262                                         reader_indent ro
 263                                         midLC <- composeLift $ RWS.gets state_pos
 264                                         html5ify $ List.replicate (colInt bp - colInt midLC) ' '
 265                                  }) $
 266                                 html5ify ts
 267                 ----------------------
 268                  NodeToken t -> html5ify t <> html5ify ts
 269                 ----------------------
 270                  NodePair pair ->
 271                         case pair of
 272                          PairElem name attrs -> do
 273                                 H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
 274                                         H.span ! HA.class_ "pair-open" $$ o
 275                                         unless (null ts) $ do
 276                                                 H.span ! HA.class_ "pair-content" $$ html5ify ts
 277                                                 H.span ! HA.class_ "pair-close" $$ c
 278                                 where
 279                                 html5Name =
 280                                         H.span ! HA.class_ "elem-name" $$
 281                                                 html5ify name
 282                                 o,c :: Html5
 283                                 (o,c)
 284                                  | null ts =
 285                                         ( "<"<>html5Name<>html5ify attrs<>"/>"
 286                                         , mempty )
 287                                  | otherwise =
 288                                         ( "<"<>html5Name<>html5ify attrs<>">"
 289                                         , "</"<>html5Name<>">" )
 290                          _ -> do
 291                                 H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do
 292                                         let (o,c) = pairBorders pair ts
 293                                         H.span ! HA.class_ "pair-open"    $$ html5ify o
 294                                         H.span ! HA.class_ "pair-content" $$ em $ html5ify ts
 295                                         H.span ! HA.class_ "pair-close"   $$ html5ify c
 296                         where
 297                         em :: Html5 -> Html5
 298                         em h =
 299                                 case pair of
 300                                  p | p == PairSlash
 301                                   || p == PairFrenchquote
 302                                   || p == PairDoublequote -> do
 303                                         Reader{reader_italic} <- composeLift RWS.ask
 304                                         localComposeRWS (\ro -> ro{reader_italic = not reader_italic}) $
 305                                                 H.em ! HA.class_ (if reader_italic then "even" else "odd") $$ h
 306                                  _ -> h
 307 instance Html5ify Token where
 308         html5ify tok =
 309                 case tok of
 310                  TokenText t -> html5ify t
 311                  TokenAt b v ->
 312                         H.span ! HA.class_ "at" $$ do
 313                                 when b $
 314                                         H.span ! HA.class_ "at-back" $$
 315                                                 html5ify '~'
 316                                 H.span ! HA.class_ "at-open" $$
 317                                         html5ify '@'
 318                                 html5ify v
 319                  TokenTag b v ->
 320                         H.span ! HA.class_ "tag" $$ do
 321                                 when b $
 322                                         H.span ! HA.class_ "tag-back" $$
 323                                                 html5ify '~'
 324                                 H.span ! HA.class_ "tag-open" $$
 325                                         html5ify '#'
 326                                 html5ify v
 327                  TokenEscape c -> html5ify ['\\', c]
 328                  TokenLink l -> do
 329                         H.a ! HA.href (attrify l) $$
 330                                 html5ify l
 331 instance Html5ify ElemName where
 332         html5ify = html5ify . show
 333 instance Html5ify ElemAttrs where
 334         html5ify = mapM_ html5ify
 335 instance Html5ify (White,ElemAttr) where
 336         html5ify (elemAttr_white,ElemAttr{..}) = do
 337                 html5ify elemAttr_white
 338                 H.span ! HA.class_ "attr-name" $$
 339                         html5ify elemAttr_name
 340                 html5ify elemAttr_open
 341                 H.span ! HA.class_ "attr-value" $$
 342                         html5ify elemAttr_value
 343                 html5ify elemAttr_close