Hdoc/TCT/Write/HTML5.hs

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