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