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)
   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.Int (Int)
  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 html5Document :: Trees (Cell Node) -> Html
  39 html5Document 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 :: Int
  83  ,   state_italic :: Bool
  84  } deriving (Eq, Show)
  85 instance Default State where
  86         def = State
  87          { state_pos    = pos1
  88          , state_indent = 1
  89          , state_italic = False
  90          }
  91 instance Pretty State
  92
  93 -- * Class 'Html5ify'
  94 class Html5ify a where
  95         html5ify :: a -> Html5
  96 instance Html5ify () where
  97         html5ify = mempty
  98 instance Html5ify Char where
  99         html5ify = \case
 100          '\n' -> do
 101                 (indent, lnum) <-
 102                         liftStateMarkup $ do
 103                                 s@State{state_pos=Pos line _col, state_indent} <- S.get
 104                                 S.put $ s{state_pos=Pos (line + 1) state_indent}
 105                                 return (state_indent, line + 1)
 106                 html5 '\n'
 107                 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
 108                 html5 $ List.replicate (indent - 1) ' '
 109          c -> do
 110                 liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
 111                         s{state_pos=Pos line (col + 1)}
 112                 html5 c
 113 instance Html5ify String where
 114         html5ify = mapM_ html5ify
 115 instance Html5ify TL.Text where
 116         html5ify t
 117          | TL.null t = mempty
 118          | otherwise =
 119                 let (h,ts) = TL.span (/='\n') t in
 120                 case TL.uncons ts of
 121                  Nothing -> do
 122                         liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
 123                                 s{state_pos=Pos line (col + int (TL.length h))}
 124                         html5 h
 125                  Just (_n,ts') -> do
 126                         html5 h
 127                          -- NOTE: useless to increment the pos_column for h,
 128                          --       since the following '\n' will reset the pos_column.
 129                         html5ify '\n'
 130                         html5ify ts'
 131 instance Html5ify Pos where
 132         html5ify new@(Pos lineNew colNew) = do
 133                 old@(Pos lineOld colOld) <-
 134                         liftStateMarkup $ do
 135                                 s <- S.get
 136                                 S.put s{state_pos=new}
 137                                 return $ state_pos s
 138                 case lineOld`compare`lineNew of
 139                  LT -> do
 140                         forM_ [lineOld+1..lineNew] $ \lnum -> do
 141                                 html5 '\n'
 142                                 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
 143                         html5 $ List.replicate (colNew - 1) ' '
 144                  EQ | colOld <= colNew -> do
 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                  NodeGroup -> html5ify ts
 156                 ----------------------
 157                  NodeToken t -> html5ify t
 158                 ----------------------
 159                  NodePara -> do
 160                         ind <-
 161                                 liftStateMarkup $ do
 162                                         s <- S.get
 163                                         S.put $ s{state_indent = pos_column bp}
 164                                         return $ state_indent s
 165                         r <- html5ify ts
 166                         liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind}
 167                         return r
 168                 ----------------------
 169                  NodeText t -> do
 170                         ind <-
 171                                 liftStateMarkup $ do
 172                                         s <- S.get
 173                                         S.put $ s{state_indent = pos_column bp}
 174                                         return $ state_indent s
 175                         r <- html5ify t
 176                         liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind}
 177                         return r
 178                 ----------------------
 179                  NodeHeader hdr ->
 180                         case hdr of
 181                          HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon"
 182                          HeaderGreat n wh -> html5Header "" "" n wh ">" "" "great"
 183                          HeaderEqual n wh -> html5Header "" "" n wh "=" "" "equal"
 184                          HeaderBar   n wh -> html5Header "" "" n wh "|" "" "bar"
 185                          HeaderDot   n    -> html5Header "" "" n "" "." "" "dot"
 186                          HeaderDotSlash n -> html5Header "./" "" (fromString n) "" "" "" "dotslash"
 187                          HeaderDash       -> html5Header "" "" "" "" "-" " " "dash"
 188                          HeaderDashDash   -> html5Header "" "" "" "" "--" " " "dashdash"
 189                          HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash"
 190                          HeaderSection lvl -> do
 191                                 H.section $$ do
 192                                         H.span ! HA.class_ "section-title" $$ do
 193                                                 H.span ! HA.class_ "section-mark" $$ do
 194                                                         html5ify $ List.replicate lvl '#'
 195                                                 case Seq.viewl ts of
 196                                                  title :< _ -> h lvl $$ html5ify title
 197                                                  _ -> return ()
 198                                         html5ify $
 199                                                 case Seq.viewl ts of
 200                                                  _ :< ts' -> ts'
 201                                                  _ -> ts
 202                                 where
 203                                 h 1 = H.h1
 204                                 h 2 = H.h2
 205                                 h 3 = H.h3
 206                                 h 4 = H.h4
 207                                 h 5 = H.h5
 208                                 h 6 = H.h6
 209                                 h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
 210                                 h _ = undefined
 211                         where
 212                         html5Header :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
 213                         html5Header markBegin whmb name whn markEnd whme cl = do
 214                                 H.span ! HA.class_ (mconcat $ ["header header-",cl] <>
 215                                  if TL.null name then [] else [" header-name-",attrify name]) $$ do
 216                                         when (markBegin/="") $
 217                                                 H.span ! HA.class_ "header-mark" $$ html5ify markBegin
 218                                         html5ify whmb
 219                                         when (name/="") $
 220                                                 H.span ! HA.class_ "header-name" $$ html5ify name
 221                                         html5ify whn
 222                                         when (markEnd/="") $
 223                                                 H.span ! HA.class_ "header-mark" $$ html5ify markEnd
 224                                         html5ify whme
 225                                         H.span ! HA.class_ "header-value" $$
 226                                                 html5ify ts
 227                 ----------------------
 228                  NodePair pair ->
 229                         case pair of
 230                          PairElem name attrs -> do
 231                                 H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
 232                                         H.span ! HA.class_ "pair-open" $$ o
 233                                         when (not $ null ts) $ do
 234                                                 H.span ! HA.class_ "pair-content" $$ html5ify ts
 235                                                 H.span ! HA.class_ "pair-close" $$ c
 236                                 where
 237                                 html5Name =
 238                                         H.span ! HA.class_ "elem-name" $$
 239                                                 html5ify name
 240                                 o,c :: Html5
 241                                 (o,c)
 242                                  | null ts =
 243                                         ( "<"<>html5Name<>html5ify attrs<>"/>"
 244                                         , mempty )
 245                                  | otherwise =
 246                                         ( "<"<>html5Name<>html5ify attrs<>">"
 247                                         , "</"<>html5Name<>">" )
 248                          _ -> do
 249                                 H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do
 250                                         let (o,c) = pairBorders pair ts
 251                                         H.span ! HA.class_ "pair-open"    $$ html5ify o
 252                                         H.span ! HA.class_ "pair-content" $$ em $ html5ify ts
 253                                         H.span ! HA.class_ "pair-close"   $$ html5ify c
 254                         where
 255                         em :: Html5 -> Html5
 256                         em h =
 257                                 case pair of
 258                                  p | p == PairSlash
 259                                   || p == PairFrenchquote
 260                                   || p == PairDoublequote -> do
 261                                         State{..} <- liftStateMarkup $ S.get
 262                                         liftStateMarkup $ S.modify' $ \s -> s{state_italic = not state_italic}
 263                                         r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h
 264                                         liftStateMarkup $ S.modify' $ \s -> s{state_italic}
 265                                         return r
 266                                  _ -> h
 267                 ----------------------
 268                  NodeLower name attrs -> do
 269                         H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do
 270                                 H.span ! HA.class_ "header-mark" $$ html5ify '<'
 271                                 H.span ! HA.class_ "header-name" $$ html5ify name
 272                                 html5ify attrs
 273                                 html5ify ts
 274 instance Html5ify Token where
 275         html5ify tok =
 276                 case tok of
 277                  TokenText t -> html5ify t
 278                  TokenTag v ->
 279                         H.span ! HA.class_ "tag" $$ do
 280                                 H.span ! HA.class_ "tag-open" $$
 281                                         html5ify '#'
 282                                 html5ify v
 283                  TokenEscape c -> html5ify ['\\', c]
 284                  TokenLink l -> do
 285                         H.a ! HA.href (attrify l) $$
 286                                 html5ify l
 287 instance Html5ify ElemAttrs where
 288         html5ify = mapM_ html5ify
 289 instance Html5ify (White,ElemAttr) where
 290         html5ify (elemAttr_white,ElemAttr{..}) = do
 291                 html5ify elemAttr_white
 292                 H.span ! HA.class_ "attr-name" $$
 293                         html5ify elemAttr_name
 294                 html5ify elemAttr_open
 295                 H.span ! HA.class_ "attr-value" $$
 296                         html5ify elemAttr_value
 297                 html5ify elemAttr_close