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