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, unless)
   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 document :: Trees (Cell Node) -> Html
  38 document 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                 ----------------------
 156                  NodeGroup -> html5ify ts
 157                 ----------------------
 158                  NodeLower name attrs -> do
 159                         H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do
 160                                 H.span ! HA.class_ "header-mark" $$ html5ify '<'
 161                                 H.span ! HA.class_ "header-name" $$ html5ify name
 162                                 html5ify attrs
 163                                 html5ify ts
 164                 ----------------------
 165                  NodeHeader hdr ->
 166                         case hdr of
 167                          HeaderGreat n wh -> html5HeaderRepeated "" "" n wh ">" "" "great"
 168                          HeaderBar   n wh -> html5HeaderRepeated "" "" n wh "|" "" "bar"
 169                          HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon"
 170                          HeaderEqual n wh -> html5Header "" "" n wh "=" "" "equal"
 171                          HeaderDot   n    -> html5Header "" "" n "" "." "" "dot"
 172                          HeaderDotSlash n -> html5Header "./" "" (fromString n) "" "" "" "dotslash"
 173                          HeaderDash       -> html5Header "" "" "" "" "-" " " "dash"
 174                          HeaderDashDash   -> html5Header "" "" "" "" "--" " " "dashdash"
 175                          HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash"
 176                          HeaderSection lvl -> do
 177                                 H.section $$ do
 178                                         H.span ! HA.class_ "section-title" $$ do
 179                                                 H.span ! HA.class_ "section-mark" $$ do
 180                                                         html5ify $ List.replicate lvl '#'
 181                                                 case Seq.viewl ts of
 182                                                  title :< _ -> h lvl $$ html5ify title
 183                                                  _ -> return ()
 184                                         html5ify $
 185                                                 case Seq.viewl ts of
 186                                                  _ :< ts' -> ts'
 187                                                  _ -> ts
 188                                 where
 189                                 h 1 = H.h1
 190                                 h 2 = H.h2
 191                                 h 3 = H.h3
 192                                 h 4 = H.h4
 193                                 h 5 = H.h5
 194                                 h 6 = H.h6
 195                                 h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
 196                                 h _ = undefined
 197                         where
 198                         html5Head :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
 199                         html5Head markBegin whmb name whn markEnd whme cl = do
 200                                 H.span ! HA.class_ (mconcat $ ["header header-",cl] <>
 201                                  if TL.null name then [] else [" header-name-",attrify name]) $$ do
 202                                         when (markBegin/="") $
 203                                                 H.span ! HA.class_ "header-mark" $$ html5ify markBegin
 204                                         html5ify whmb
 205                                         when (name/="") $
 206                                                 H.span ! HA.class_ "header-name" $$ html5ify name
 207                                         html5ify whn
 208                                         when (markEnd/="") $
 209                                                 H.span ! HA.class_ "header-mark" $$ html5ify markEnd
 210                                         html5ify whme
 211                         html5Header markBegin whmb name whn markEnd whme cl = do
 212                                 html5Head markBegin whmb name whn markEnd whme cl
 213                                 H.span ! HA.class_ "header-value" $$
 214                                         html5ify ts
 215                         html5HeaderRepeated :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
 216                         html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
 217                                 State{state_indent} <- liftStateMarkup S.get
 218                                 liftStateMarkup $ S.modify' $ \s ->
 219                                         s{ state_indent = do
 220                                                 state_indent
 221                                                 Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
 222                                                 html5ify $ List.replicate (pos_column bp - colMid) ' '
 223                                                 html5Head markBegin whmb name whn markEnd whme cl
 224                                          }
 225                                 r <- html5Header markBegin whmb name whn markEnd whme cl
 226                                 liftStateMarkup $ S.modify' $ \s -> s{state_indent}
 227                                 return r
 228                 ----------------------
 229                  NodeText t -> do
 230                         State{state_indent} <- liftStateMarkup S.get
 231                         liftStateMarkup $ S.modify' $ \s ->
 232                                 s{ state_indent = do
 233                                         state_indent
 234                                         Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
 235                                         html5ify $ List.replicate (pos_column bp - colMid) ' '
 236                                  }
 237                         r <- html5ify t
 238                         liftStateMarkup $ S.modify' $ \s -> s{state_indent}
 239                         return r
 240                 ----------------------
 241                  NodePara -> do
 242                         State{state_indent} <- liftStateMarkup S.get
 243                         liftStateMarkup $ S.modify' $ \s ->
 244                                 s{ state_indent = do
 245                                         state_indent
 246                                         Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
 247                                         html5ify $ List.replicate (pos_column bp - colMid) ' '
 248                                  }
 249                         r <- html5ify ts
 250                         liftStateMarkup $ S.modify' $ \s -> s{state_indent}
 251                         return r
 252                 ----------------------
 253                  NodeToken t -> html5ify t <> html5ify ts
 254                 ----------------------
 255                  NodePair pair ->
 256                         case pair of
 257                          PairElem name attrs -> do
 258                                 H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
 259                                         H.span ! HA.class_ "pair-open" $$ o
 260                                         unless (null ts) $ do
 261                                                 H.span ! HA.class_ "pair-content" $$ html5ify ts
 262                                                 H.span ! HA.class_ "pair-close" $$ c
 263                                 where
 264                                 html5Name =
 265                                         H.span ! HA.class_ "elem-name" $$
 266                                                 html5ify name
 267                                 o,c :: Html5
 268                                 (o,c)
 269                                  | null ts =
 270                                         ( "<"<>html5Name<>html5ify attrs<>"/>"
 271                                         , mempty )
 272                                  | otherwise =
 273                                         ( "<"<>html5Name<>html5ify attrs<>">"
 274                                         , "</"<>html5Name<>">" )
 275                          _ -> do
 276                                 H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do
 277                                         let (o,c) = pairBorders pair ts
 278                                         H.span ! HA.class_ "pair-open"    $$ html5ify o
 279                                         H.span ! HA.class_ "pair-content" $$ em $ html5ify ts
 280                                         H.span ! HA.class_ "pair-close"   $$ html5ify c
 281                         where
 282                         em :: Html5 -> Html5
 283                         em h =
 284                                 case pair of
 285                                  p | p == PairSlash
 286                                   || p == PairFrenchquote
 287                                   || p == PairDoublequote -> do
 288                                         State{..} <- liftStateMarkup $ S.get
 289                                         liftStateMarkup $ S.modify' $ \s -> s{state_italic = not state_italic}
 290                                         r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h
 291                                         liftStateMarkup $ S.modify' $ \s -> s{state_italic}
 292                                         return r
 293                                  _ -> h
 294 instance Html5ify Token where
 295         html5ify tok =
 296                 case tok of
 297                  TokenText t -> html5ify t
 298                  TokenTag v ->
 299                         H.span ! HA.class_ "tag" $$ do
 300                                 H.span ! HA.class_ "tag-open" $$
 301                                         html5ify '#'
 302                                 html5ify v
 303                  TokenEscape c -> html5ify ['\\', c]
 304                  TokenLink l -> do
 305                         H.a ! HA.href (attrify l) $$
 306                                 html5ify l
 307 instance Html5ify ElemAttrs where
 308         html5ify = mapM_ html5ify
 309 instance Html5ify (White,ElemAttr) where
 310         html5ify (elemAttr_white,ElemAttr{..}) = do
 311                 html5ify elemAttr_white
 312                 H.span ! HA.class_ "attr-name" $$
 313                         html5ify elemAttr_name
 314                 html5ify elemAttr_open
 315                 H.span ! HA.class_ "attr-value" $$
 316                         html5ify elemAttr_value
 317                 html5ify elemAttr_close