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  ,   state_ext_html :: String
  84  } -- deriving (Eq, Show)
  85 instance Default State where
  86         def = State
  87          { state_pos      = pos1
  88          , state_indent   = ""
  89          , state_italic   = False
  90          , state_ext_html = ".html"
  91          }
  92 -- instance Pretty State
  93
  94 -- * Class 'Html5ify'
  95 class Html5ify a where
  96         html5ify :: a -> Html5
  97 instance Html5ify () where
  98         html5ify = mempty
  99 instance Html5ify Char where
 100         html5ify = \case
 101          '\n' -> do
 102                 s@State{state_pos=Pos line _col, ..} <- liftStateMarkup S.get
 103                 liftStateMarkup $ S.put s{state_pos=Pos (line + 1) 1}
 104                 html5 '\n'
 105                 H.a ! HA.id ("line-"<>attrify (line + 1)) $$ return ()
 106                 state_indent
 107          c -> do
 108                 liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
 109                         s{state_pos=Pos line (col + 1)}
 110                 html5 c
 111 instance Html5ify String where
 112         html5ify = mapM_ html5ify
 113 instance Html5ify TL.Text where
 114         html5ify t
 115          | TL.null t = mempty
 116          | otherwise =
 117                 let (h,ts) = TL.span (/='\n') t in
 118                 case TL.uncons ts of
 119                  Nothing -> do
 120                         liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
 121                                 s{state_pos=Pos line $ col + int (TL.length h)}
 122                         html5 h
 123                  Just (_n,ts') -> do
 124                         html5 h
 125                          -- NOTE: useless to increment the pos_column for h,
 126                          --       since the following '\n' will reset the pos_column.
 127                         html5ify '\n'
 128                         html5ify ts'
 129 instance Html5ify Pos where
 130         html5ify new@(Pos lineNew colNew) = do
 131                 s@State
 132                  { state_pos=old@(Pos lineOld colOld)
 133                  , state_indent
 134                  } <- liftStateMarkup S.get
 135                 case lineOld`compare`lineNew of
 136                  LT -> do
 137                         forM_ [lineOld+1..lineNew] $ \lnum -> do
 138                                 html5 '\n'
 139                                 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
 140                         liftStateMarkup $ S.put s{state_pos=Pos lineNew 1}
 141                         state_indent
 142                         Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
 143                         html5 $ List.replicate (colNew - colMid) ' '
 144                         liftStateMarkup $ S.put s{state_pos=new}
 145                  EQ | colOld <= colNew -> do
 146                         liftStateMarkup $ S.put s{state_pos=new}
 147                         html5 $ List.replicate (colNew - colOld) ' '
 148                  _ -> error $ "html5ify: non-ascending Pos:"
 149                          <> "\n old: " <> show old
 150                          <> "\n new: " <> show new
 151 instance Html5ify Roots where
 152         html5ify = mapM_ html5ify
 153 instance Html5ify Root where
 154         html5ify (Tree (Cell bp _ep nod) ts) = do
 155                 html5ify bp
 156                 case nod of
 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                          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                          HeaderDotSlash n -> do
 197                                 ext <- liftStateMarkup $ S.gets state_ext_html
 198                                 if null ext
 199                                  then html5ify file
 200                                  else
 201                                         H.a ! HA.class_ "header-dotslash"
 202                                             ! HA.href (attrify $ file<>ext) $$
 203                                                 html5ify file
 204                                 where file = "./"<>n
 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