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