Language/TCT/Write/HTML5.hs

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