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 document :: Trees (Cell Node) -> Html
  39 document 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 n -> 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 file = "./"<>n
 206                         where
 207                         html5Head :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
 208                         html5Head markBegin whmb name whn markEnd whme cl = do
 209                                 H.span ! HA.class_ (mconcat $ ["header header-",cl] <>
 210                                  if TL.null name then [] else [" header-name-",attrify name]) $$ do
 211                                         when (markBegin/="") $
 212                                                 H.span ! HA.class_ "header-mark" $$ html5ify markBegin
 213                                         html5ify whmb
 214                                         when (name/="") $
 215                                                 H.span ! HA.class_ "header-name" $$ html5ify name
 216                                         html5ify whn
 217                                         when (markEnd/="") $
 218                                                 H.span ! HA.class_ "header-mark" $$ html5ify markEnd
 219                                         html5ify whme
 220                         html5Header markBegin whmb name whn markEnd whme cl = do
 221                                 html5Head markBegin whmb name whn markEnd whme cl
 222                                 H.span ! HA.class_ "header-value" $$
 223                                         html5ify ts
 224                         html5HeaderRepeated :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
 225                         html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
 226                                 State{state_indent} <- liftStateMarkup S.get
 227                                 liftStateMarkup $ S.modify' $ \s ->
 228                                         s{ state_indent = do
 229                                                 state_indent
 230                                                 Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
 231                                                 html5ify $ List.replicate (pos_column bp - colMid) ' '
 232                                                 html5Head markBegin whmb name whn markEnd whme cl
 233                                          }
 234                                 r <- html5Header markBegin whmb name whn markEnd whme cl
 235                                 liftStateMarkup $ S.modify' $ \s -> s{state_indent}
 236                                 return r
 237                 ----------------------
 238                  NodeText t -> do
 239                         State{state_indent} <- liftStateMarkup S.get
 240                         liftStateMarkup $ S.modify' $ \s ->
 241                                 s{ state_indent = do
 242                                         state_indent
 243                                         Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
 244                                         html5ify $ List.replicate (pos_column bp - colMid) ' '
 245                                  }
 246                         r <- html5ify t
 247                         liftStateMarkup $ S.modify' $ \s -> s{state_indent}
 248                         return r
 249                 ----------------------
 250                  NodePara -> do
 251                         State{state_indent} <- liftStateMarkup S.get
 252                         liftStateMarkup $ S.modify' $ \s ->
 253                                 s{ state_indent = do
 254                                         state_indent
 255                                         Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
 256                                         html5ify $ List.replicate (pos_column bp - colMid) ' '
 257                                  }
 258                         r <- html5ify ts
 259                         liftStateMarkup $ S.modify' $ \s -> s{state_indent}
 260                         return r
 261                 ----------------------
 262                  NodeToken t -> html5ify t <> html5ify ts
 263                 ----------------------
 264                  NodePair pair ->
 265                         case pair of
 266                          PairElem name attrs -> do
 267                                 H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
 268                                         H.span ! HA.class_ "pair-open" $$ o
 269                                         unless (null ts) $ do
 270                                                 H.span ! HA.class_ "pair-content" $$ html5ify ts
 271                                                 H.span ! HA.class_ "pair-close" $$ c
 272                                 where
 273                                 html5Name =
 274                                         H.span ! HA.class_ "elem-name" $$
 275                                                 html5ify name
 276                                 o,c :: Html5
 277                                 (o,c)
 278                                  | null ts =
 279                                         ( "<"<>html5Name<>html5ify attrs<>"/>"
 280                                         , mempty )
 281                                  | otherwise =
 282                                         ( "<"<>html5Name<>html5ify attrs<>">"
 283                                         , "</"<>html5Name<>">" )
 284                          _ -> do
 285                                 H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do
 286                                         let (o,c) = pairBorders pair ts
 287                                         H.span ! HA.class_ "pair-open"    $$ html5ify o
 288                                         H.span ! HA.class_ "pair-content" $$ em $ html5ify ts
 289                                         H.span ! HA.class_ "pair-close"   $$ html5ify c
 290                         where
 291                         em :: Html5 -> Html5
 292                         em h =
 293                                 case pair of
 294                                  p | p == PairSlash
 295                                   || p == PairFrenchquote
 296                                   || p == PairDoublequote -> do
 297                                         State{..} <- liftStateMarkup $ S.get
 298                                         liftStateMarkup $ S.modify' $ \s -> s{state_italic = not state_italic}
 299                                         r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h
 300                                         liftStateMarkup $ S.modify' $ \s -> s{state_italic}
 301                                         return r
 302                                  _ -> h
 303 instance Html5ify Token where
 304         html5ify tok =
 305                 case tok of
 306                  TokenText t -> html5ify t
 307                  TokenTag v ->
 308                         H.span ! HA.class_ "tag" $$ do
 309                                 H.span ! HA.class_ "tag-open" $$
 310                                         html5ify '#'
 311                                 html5ify v
 312                  TokenEscape c -> html5ify ['\\', c]
 313                  TokenLink l -> do
 314                         H.a ! HA.href (attrify l) $$
 315                                 html5ify l
 316 instance Html5ify ElemAttrs where
 317         html5ify = mapM_ html5ify
 318 instance Html5ify (White,ElemAttr) where
 319         html5ify (elemAttr_white,ElemAttr{..}) = do
 320                 html5ify elemAttr_white
 321                 H.span ! HA.class_ "attr-name" $$
 322                         html5ify elemAttr_name
 323                 html5ify elemAttr_open
 324                 H.span ! HA.class_ "attr-value" $$
 325                         html5ify elemAttr_value
 326                 html5ify elemAttr_close