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