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