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.Applicative (Applicative(..))
   7 import Control.Monad (Monad(..), forM_, mapM_, when)
   8 import Data.Bool
   9 import Data.Char (Char)
  10 import Data.Default.Class (Default(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (Foldable(..))
  13 import Data.Function (($), (.), id)
  14 import Data.Functor ((<$>))
  15 import Data.Functor.Compose (Compose(..))
  16 import Data.Maybe (Maybe(..))
  17 import Data.Monoid (Monoid(..))
  18 import Data.Ord (Ord(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.Sequence (ViewL(..))
  21 import Data.String (String, IsString(..))
  22 import Data.Text (Text)
  23 import Data.TreeSeq.Strict (Tree(..),Trees)
  24 import Prelude (Num(..), undefined, error)
  25 import Text.Blaze ((!))
  26 import Text.Blaze.Html (Html)
  27 import Text.Show (Show(..))
  28 import qualified Control.Monad.Trans.State as S
  29 import qualified Data.List as List
  30 import qualified Data.Sequence as Seq
  31 import qualified Data.Text as Text
  32 import qualified Data.Text.Lazy as TL
  33 import qualified Text.Blaze.Html5 as H
  34 import qualified Text.Blaze.Html5.Attributes  as HA
  35 -- import Debug.Trace (trace)
  36
  37 import Text.Blaze.Utils
  38 import Language.TCT
  39 import qualified Language.TCT.Write.Plain as Plain
  40
  41 html5Document :: TCTs -> Html
  42 html5Document body = do
  43         H.docType
  44         H.html $ do
  45                 H.head $ do
  46                         H.meta ! HA.httpEquiv "Content-Type"
  47                                ! HA.content "text/html; charset=UTF-8"
  48                         whenJust (tokensTitle body) $ \ts ->
  49                                 H.title $
  50                                         H.toMarkup $ Plain.text def $ List.head $ toList ts
  51                         -- link ! rel "Chapter" ! title "SomeTitle">
  52                         H.link ! HA.rel "stylesheet"
  53                                ! HA.type_ "text/css"
  54                                ! HA.href "style/tct-html5.css"
  55                 let (html5Body, State{}) =
  56                         runStateMarkup def $
  57                         html5ify body
  58                 H.body $ do
  59                         H.a ! HA.id ("line-1") $ return ()
  60                         html5Body
  61
  62 -- * Type 'Html5'
  63 type Html5 = StateMarkup State ()
  64
  65 -- ** Type 'State'
  66 data State
  67  =   State
  68  {   state_pos :: Pos
  69  }
  70 instance Default State where
  71         def = State
  72          { state_pos = pos1
  73          }
  74
  75 -- * Class 'Html5ify'
  76 class Html5ify a where
  77         html5ify :: a -> Html5
  78 instance Html5ify H.Markup where
  79         html5ify = Compose . return
  80 instance Html5ify Html5 where
  81         html5ify = id
  82 instance Html5ify () where
  83         html5ify = mempty
  84 instance Html5ify Char where
  85         html5ify = html5ify . H.toMarkup
  86 instance Html5ify Text where
  87         html5ify = html5ify . H.toMarkup
  88 instance Html5ify TL.Text where
  89         html5ify = html5ify . H.toMarkup
  90 instance Html5ify String where
  91         html5ify = html5ify . H.toMarkup
  92 instance Html5ify (Trees (Cell Key) Tokens) where
  93         html5ify = mapM_ html5ify
  94 instance Html5ify (Tree (Cell Key) Tokens) where
  95         html5ify = \case
  96          TreeN (Cell bp ep k) ts -> html5ify (Cell bp ep (k,ts))
  97          Tree0 ts -> html5ify ts
  98 instance Html5ify a => Html5ify (Cell a) where
  99         html5ify (Cell next@(Pos line col) ep a) = do
 100                 prev@(Pos lineLast colLast) <- liftStateMarkup $ S.gets state_pos
 101                 case () of
 102                  _ | lineLast < line -> do
 103                         forM_ [lineLast+1..line] $ \lnum -> do
 104                                 html5ify '\n'
 105                                 H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
 106                         html5ify $ Text.replicate (col - 1) " "
 107                  _ | lineLast == line && colLast <= col -> do
 108                         html5ify $ Text.replicate (col - colLast) " "
 109                  _ -> error $ "html5ify: non-ascending positions: "
 110                          <> "\n prev: " <> show prev
 111                          <> "\n next: " <> show next
 112                 -- liftStateMarkup $ S.modify $ \s -> s{state_pos=bp}
 113                 liftStateMarkup $ S.modify $ \s -> s{state_pos=ep}
 114                 html5ify a
 115 instance Html5ify (Key, Trees (Cell Key) Tokens) where
 116         html5ify (key, ts) =
 117                 case key of
 118                  KeyPara       -> html5ify ts
 119                  KeyColon n wh -> html5Key "" "" n wh ":" "" "colon"
 120                  KeyGreat n wh -> html5Key "" "" n wh ">" "" "great"
 121                  KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal"
 122                  KeyBar   n wh -> html5Key "" "" n wh "|" "" "bar"
 123                  KeyDot   n    -> html5Key "" "" n "" "." "" "dot"
 124                  KeyDash       -> html5Key "" "" "" "" "-" " " "dash"
 125                  KeyDashDash   -> html5Key "" "" "" "" "--" " " "dashdash"
 126                  KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash"
 127                  KeyLower name attrs -> do
 128                         H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrify name]) $$ do
 129                                 H.span ! HA.class_ "key-mark" $$ html5ify '<'
 130                                 H.span ! HA.class_ "key-name" $$ html5ify name
 131                                 html5ify attrs
 132                                 html5ify ts
 133                  KeySection lvl -> do
 134                         H.section $$ do
 135                                 H.span ! HA.class_ "section-title" $$ do
 136                                         H.span ! HA.class_ "section-mark" $$ do
 137                                                 html5ify $ Text.replicate lvl "#"
 138                                         case Seq.viewl ts of
 139                                          Tree0 title :< _ -> h lvl $$ html5ify title
 140                                          _ -> return ()
 141                                 html5ify $
 142                                         case Seq.viewl ts of
 143                                          Tree0{} :< ts' -> ts'
 144                                          _ -> ts
 145                         where
 146                         h 1 = H.h1
 147                         h 2 = H.h2
 148                         h 3 = H.h3
 149                         h 4 = H.h4
 150                         h 5 = H.h5
 151                         h 6 = H.h6
 152                         h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
 153                         h _ = undefined
 154                 where
 155                 html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html5
 156                 html5Key markBegin whmb name whn markEnd whme cl = do
 157                         H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrify name]) $$ do
 158                                 when (markBegin/="") $
 159                                         H.span ! HA.class_ "key-mark" $$ html5ify markBegin
 160                                 html5ify whmb
 161                                 when (name/="") $
 162                                         H.span ! HA.class_ "key-name" $$ html5ify name
 163                                 html5ify whn
 164                                 when (markEnd/="") $
 165                                         H.span ! HA.class_ "key-mark" $$ html5ify markEnd
 166                                 html5ify whme
 167                                 H.span ! HA.class_ "key-value" $$
 168                                         html5ify ts
 169 instance Html5ify Tokens where
 170         html5ify = mapM_ html5ify
 171 instance Html5ify Token where
 172         html5ify (TreeN (Cell bp ep p) ts) = do
 173                 case p of
 174                  PairElem name attrs -> do
 175                         H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
 176                                 html5ify $ Cell bp bp{columnPos = columnPos bp + lenO} ()
 177                                 when (lenO > 0) $
 178                                         H.span ! HA.class_ "pair-open"    $$ o
 179                                 when (not $ Seq.null ts) $
 180                                         H.span ! HA.class_ "pair-content" $$ html5ify ts
 181                                 html5ify $ Cell ep{columnPos = columnPos ep - lenC} ep ()
 182                                 when (lenC > 0) $
 183                                         H.span ! HA.class_ "pair-close"   $$ c
 184                         where
 185                         html5Name =
 186                                 H.span ! HA.class_ "elem-name" $$
 187                                         html5ify name
 188                         lenName = Text.length name
 189                         lenAttrs = sum $ (<$> attrs) $ \(elemAttr_white,ElemAttr{..}) ->
 190                                 Text.length elemAttr_white +
 191                                 Text.length elemAttr_name +
 192                                 Text.length elemAttr_open +
 193                                 Text.length elemAttr_value +
 194                                 Text.length elemAttr_close
 195                         (lenO,lenC) | Seq.null ts = (1+lenName+lenAttrs+2,0)
 196                                     | otherwise   = (1+lenName+lenAttrs+1,2+lenName+1)
 197                         o,c :: Html5
 198                         (o,c) | Seq.null ts =
 199                                 ( "<"<>html5Name<>html5ify attrs<>"/>"
 200                                 , mempty )
 201                               | otherwise =
 202                                 ( "<"<>html5Name<>html5ify attrs<>">"
 203                                 , "</"<>html5Name<>">" )
 204                  _ -> do
 205                         let (o,c) = pairBorders p ts
 206                         H.span ! HA.class_ ("pair-"<>fromString (show p)) $$ do
 207                                 html5ify $ Cell bp bp{columnPos = columnPos bp + Text.length o} ()
 208                                 H.span ! HA.class_ "pair-open"    $$ html5ify o
 209                                 H.span ! HA.class_ "pair-content" $$ html5ify ts
 210                                 html5ify $ Cell ep{columnPos = columnPos ep - Text.length c} ep ()
 211                                 H.span ! HA.class_ "pair-close"   $$ html5ify c
 212         html5ify (Tree0 tok) = do
 213                 -- html5ify $ Cell bp ep ()
 214                 case tok of
 215                  TokenPhrases ps -> html5ify ps
 216                  TokenRaw t -> html5ify t
 217                         {-do
 218                         lin <- S.get
 219                         let lines = Text.splitOn "\n" txt
 220                         let lnums = html5ify :
 221                                  [ \line -> do
 222                                         html5ify '\n'
 223                                         H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
 224                                         html5ify indent
 225                                         html5ify line
 226                                  | lnum <- [lin+1..]
 227                                  ]
 228                         S.put (lin - 1 + List.length lines)
 229                         return $ mconcat $ List.zipWith ($) lnums lines
 230                         -}
 231                  TokenTag v ->
 232                         H.span ! HA.class_ "tag" $$ do
 233                                 H.span ! HA.class_ "tag-open" $$
 234                                         html5ify '#'
 235                                 html5ify v
 236                  TokenEscape c -> html5ify $ ('\\' :) . pure <$> c
 237                  TokenLink (Cell bp ep lnk) -> do
 238                         html5ify $ Cell bp ep ()
 239                         H.a ! HA.href (attrify lnk) $$
 240                                 html5ify lnk
 241 instance Html5ify Phrases where
 242         html5ify = mapM_ html5ify
 243 instance Html5ify Phrase where
 244         html5ify p =
 245                 case p of
 246                  PhraseWord  t -> html5ify t
 247                  PhraseWhite t -> html5ify t
 248                  PhraseOther t -> html5ify t
 249 instance Html5ify ElemAttrs where
 250         html5ify = mapM_ html5ify
 251 instance Html5ify (White,ElemAttr) where
 252         html5ify (elemAttr_white,ElemAttr{..}) = do
 253                 html5ify elemAttr_white
 254                 H.span ! HA.class_ "attr-name" $$
 255                         html5ify elemAttr_name
 256                 html5ify elemAttr_open
 257                 H.span ! HA.class_ "attr-value" $$
 258                         html5ify elemAttr_value
 259                 html5ify elemAttr_close
 260
 261 -- * Utilities
 262
 263 tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens
 264 tokensTitle tct =
 265         List.find (\case
 266          TreeN (unCell -> KeySection{}) _ts -> True
 267          _ -> False) tct >>=
 268         \case
 269          TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
 270          _ -> Nothing
 271
 272 html5Spaces :: Column -> Html5
 273 html5Spaces 0  = return ()
 274 html5Spaces sp = H.span $$ html5ify $ Text.replicate sp " "