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 Language.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 :: FilePos
 102  } -- deriving (Eq, Show)
 103 instance Default State where
 104         def = State
 105          { state_pos = pos1
 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=FilePos line _col, ..} <- composeLift RWS.get
 117                 composeLift $ RWS.put st{state_pos=FilePos (line + 1) 1}
 118                 html5 '\n'
 119                 H.a ! HA.id ("line-"<>attrify (line + 1)) $$ return ()
 120                 join $ composeLift $ RWS.asks reader_indent
 121          c -> do
 122                 composeLift $ RWS.modify $ \s@State{state_pos=FilePos line col} ->
 123                         s{state_pos=FilePos line (col + 1)}
 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=FilePos line col} ->
 135                                 s{state_pos=FilePos line $ col + int (TL.length h)}
 136                         html5 h
 137                  Just (_n,ts') -> do
 138                         html5 h
 139                          -- NOTE: useless to increment the filePos_column for h,
 140                          --       since the following '\n' will reset the filePos_column.
 141                         html5ify '\n'
 142                         html5ify ts'
 143 instance Html5ify FilePos where
 144         html5ify new@(FilePos lineNew colNew) = do
 145                 Reader{reader_indent} <- composeLift RWS.ask
 146                 st@State{state_pos=old@(FilePos lineOld colOld)} <- composeLift RWS.get
 147                 case lineOld`compare`lineNew of
 148                  LT -> do
 149                         forM_ [lineOld+1..lineNew] $ \lnum -> do
 150                                 html5 '\n'
 151                                 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
 152                         composeLift $ RWS.put st{state_pos=FilePos lineNew 1}
 153                         reader_indent
 154                         FilePos _lineMid colMid <- composeLift $ RWS.gets state_pos
 155                         html5 $ List.replicate (colNew - colMid) ' '
 156                         composeLift $ RWS.put st{state_pos=new}
 157                  EQ | colOld <= colNew -> do
 158                         composeLift $ RWS.put st{state_pos=new}
 159                         html5 $ List.replicate (colNew - colOld) ' '
 160                  _ -> error $ "html5ify: non-ascending FilePos:"
 161                          <> "\n old: " <> show old
 162                          <> "\n new: " <> show new
 163 instance Html5ify Roots where
 164         html5ify = mapM_ html5ify
 165 instance Html5ify Root where
 166         html5ify (Tree (Sourced (FileRange{fileRange_begin=bp}:|_) nod) ts) = do
 167                 html5ify bp
 168                 case nod of
 169                 ----------------------
 170                  NodeLower name attrs -> do
 171                         H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do
 172                                 H.span ! HA.class_ "header-mark" $$ html5ify '<'
 173                                 H.span ! HA.class_ "header-name" $$ html5ify name
 174                                 html5ify attrs
 175                                 html5ify ts
 176                 ----------------------
 177                  NodeHeader hdr ->
 178                         case hdr of
 179                          HeaderGreat n wh -> html5HeaderRepeated "" "" (maybe "" XML.unNCName n) wh ">" "" "great"
 180                          HeaderBar   n wh -> html5HeaderRepeated "" "" (maybe "" XML.unNCName n) wh "|" "" "bar"
 181                          HeaderColon n wh -> html5Header "" "" (maybe "" XML.unNCName n) wh ":" "" "colon"
 182                          HeaderEqual n wh -> html5Header "" "" (XML.unNCName n) wh "=" "" "equal"
 183                          HeaderDot   n    -> html5Header "" "" n "" "." "" "dot"
 184                          HeaderDash       -> html5Header "" "" "" "" "-" " " "dash"
 185                          HeaderDashDash   -> html5Header "" "" "" "" "--" " " "dashdash"
 186                          HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash"
 187                          HeaderSection lvl -> do
 188                                 H.section $$ do
 189                                         H.span ! HA.class_ "section-title" $$ do
 190                                                 H.span ! HA.class_ "section-mark" $$ do
 191                                                         html5ify $ List.replicate lvl '#'
 192                                                 case Seq.viewl ts of
 193                                                  title :< _ -> h lvl $$ html5ify title
 194                                                  _ -> return ()
 195                                         html5ify $
 196                                                 case Seq.viewl ts of
 197                                                  _ :< ts' -> ts'
 198                                                  _ -> ts
 199                                 where
 200                                 h 1 = H.h1
 201                                 h 2 = H.h2
 202                                 h 3 = H.h3
 203                                 h 4 = H.h4
 204                                 h 5 = H.h5
 205                                 h 6 = H.h6
 206                                 h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
 207                                 h _ = undefined
 208                          HeaderDotSlash file -> do
 209                                 ext <- composeLift $ RWS.asks reader_ext_html
 210                                 if null ext
 211                                  then html5ify file
 212                                  else
 213                                         H.a ! HA.class_ "header-dotslash"
 214                                             ! HA.href (attrify $ file<>ext) $$
 215                                                 html5ify file
 216                         where
 217                         html5Head :: TL.Text -> White -> TL.Text -> White -> TL.Text -> White -> H.AttributeValue -> Html5
 218                         html5Head markBegin whmb name whn markEnd whme cl = do
 219                                 H.span ! HA.class_ (mconcat $ ["header header-",cl] <>
 220                                  if TL.null name then [] else [" header-name-",attrify name]) $$ do
 221                                         when (markBegin/="") $
 222                                                 H.span ! HA.class_ "header-mark" $$ html5ify markBegin
 223                                         html5ify whmb
 224                                         when (name/="") $
 225                                                 H.span ! HA.class_ "header-name" $$ html5ify name
 226                                         html5ify whn
 227                                         when (markEnd/="") $
 228                                                 H.span ! HA.class_ "header-mark" $$ html5ify markEnd
 229                                         html5ify whme
 230                         html5Header markBegin whmb name whn markEnd whme cl = do
 231                                 html5Head markBegin whmb name whn markEnd whme cl
 232                                 H.span ! HA.class_ "header-value" $$
 233                                         html5ify ts
 234                         html5HeaderRepeated :: TL.Text -> White -> TL.Text -> White -> TL.Text -> White -> H.AttributeValue -> Html5
 235                         html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
 236                                 localComposeRWS (\ro ->
 237                                         ro{ reader_indent = do
 238                                                 reader_indent ro
 239                                                 FilePos _lineMid colMid <- composeLift $ RWS.gets state_pos
 240                                                 html5ify $ List.replicate (filePos_column bp - colMid) ' '
 241                                                 html5Head markBegin whmb name whn markEnd whme cl
 242                                          }) $
 243                                         html5Header markBegin whmb name whn markEnd whme cl
 244                 ----------------------
 245                  NodeText t -> do
 246                         localComposeRWS (\ro ->
 247                                 ro{ reader_indent = do
 248                                         reader_indent ro
 249                                         FilePos _lineMid colMid <- composeLift $ RWS.gets state_pos
 250                                         html5ify $ List.replicate (filePos_column bp - colMid) ' '
 251                                  }) $
 252                                 html5ify t
 253                 ----------------------
 254                  NodePara -> do
 255                         localComposeRWS (\ro ->
 256                                 ro{ reader_indent = do
 257                                         reader_indent ro
 258                                         FilePos _lineMid colMid <- composeLift $ RWS.gets state_pos
 259                                         html5ify $ List.replicate (filePos_column bp - colMid) ' '
 260                                  }) $
 261                                 html5ify ts
 262                 ----------------------
 263                  NodeToken t -> html5ify t <> html5ify ts
 264                 ----------------------
 265                  NodePair pair ->
 266                         case pair of
 267                          PairElem name attrs -> do
 268                                 H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
 269                                         H.span ! HA.class_ "pair-open" $$ o
 270                                         unless (null ts) $ do
 271                                                 H.span ! HA.class_ "pair-content" $$ html5ify ts
 272                                                 H.span ! HA.class_ "pair-close" $$ c
 273                                 where
 274                                 html5Name =
 275                                         H.span ! HA.class_ "elem-name" $$
 276                                                 html5ify name
 277                                 o,c :: Html5
 278                                 (o,c)
 279                                  | null ts =
 280                                         ( "<"<>html5Name<>html5ify attrs<>"/>"
 281                                         , mempty )
 282                                  | otherwise =
 283                                         ( "<"<>html5Name<>html5ify attrs<>">"
 284                                         , "</"<>html5Name<>">" )
 285                          _ -> do
 286                                 H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do
 287                                         let (o,c) = pairBorders pair ts
 288                                         H.span ! HA.class_ "pair-open"    $$ html5ify o
 289                                         H.span ! HA.class_ "pair-content" $$ em $ html5ify ts
 290                                         H.span ! HA.class_ "pair-close"   $$ html5ify c
 291                         where
 292                         em :: Html5 -> Html5
 293                         em h =
 294                                 case pair of
 295                                  p | p == PairSlash
 296                                   || p == PairFrenchquote
 297                                   || p == PairDoublequote -> do
 298                                         Reader{reader_italic} <- composeLift RWS.ask
 299                                         localComposeRWS (\ro -> ro{reader_italic = not reader_italic}) $
 300                                                 H.em ! HA.class_ (if reader_italic then "even" else "odd") $$ h
 301                                  _ -> h
 302 instance Html5ify Token where
 303         html5ify tok =
 304                 case tok of
 305                  TokenText t -> html5ify t
 306                  TokenAt b v ->
 307                         H.span ! HA.class_ "at" $$ do
 308                                 when b $
 309                                         H.span ! HA.class_ "at-back" $$
 310                                                 html5ify '~'
 311                                 H.span ! HA.class_ "at-open" $$
 312                                         html5ify '@'
 313                                 html5ify v
 314                  TokenTag b v ->
 315                         H.span ! HA.class_ "tag" $$ do
 316                                 when b $
 317                                         H.span ! HA.class_ "tag-back" $$
 318                                                 html5ify '~'
 319                                 H.span ! HA.class_ "tag-open" $$
 320                                         html5ify '#'
 321                                 html5ify v
 322                  TokenEscape c -> html5ify ['\\', c]
 323                  TokenLink l -> do
 324                         H.a ! HA.href (attrify l) $$
 325                                 html5ify l
 326 instance Html5ify ElemName where
 327         html5ify = html5ify . show
 328 instance Html5ify ElemAttrs where
 329         html5ify = mapM_ html5ify
 330 instance Html5ify (White,ElemAttr) where
 331         html5ify (elemAttr_white,ElemAttr{..}) = do
 332                 html5ify elemAttr_white
 333                 H.span ! HA.class_ "attr-name" $$
 334                         html5ify elemAttr_name
 335                 html5ify elemAttr_open
 336                 H.span ! HA.class_ "attr-value" $$
 337                         html5ify elemAttr_value
 338                 html5ify elemAttr_close