Language/TCT/HTML5/Source.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ViewPatterns #-}
   3 -- | Render a TCT source file in HTML5.
   4 module Language.TCT.HTML5.Source where
   5
   6 -- import Data.Char (Char)
   7 -- import Data.Eq (Eq(..))
   8 -- import Data.Int
   9 -- import Data.Text.Lazy.Builder (Buildable(..))
  10 -- import qualified Data.ByteString.Lazy as BSL
  11 -- import qualified Data.Char as Char
  12 -- import qualified Data.Text.Lazy as TL
  13 -- import qualified Data.Text.Lazy.Builder as TL
  14 import Control.Applicative (Applicative(..))
  15 import Control.Monad (Monad(..), forM_, mapM)
  16 import Data.Bool
  17 import Data.Eq (Eq(..))
  18 import Data.Foldable (sum)
  19 import Data.Function (($), (.), const, id)
  20 import Data.Functor ((<$>))
  21 import Data.Int (Int)
  22 import Data.Maybe (Maybe(..))
  23 import Data.Monoid (Monoid(..))
  24 import Data.Ord (Ord(..))
  25 import Data.Semigroup (Semigroup(..))
  26 import Data.Sequence (ViewL(..))
  27 import Data.String (IsString(..))
  28 import Data.Text (Text)
  29 import Prelude (Num(..), undefined)
  30 import Text.Blaze ((!))
  31 import Text.Blaze.Html (Html)
  32 import Text.Show (Show(..))
  33 import qualified Control.Monad.Trans.State as S
  34 import qualified Data.List as L
  35 import qualified Data.Sequence as Seq
  36 import qualified Data.Text as T
  37 import qualified Text.Blaze.Html5 as H
  38 import qualified Text.Blaze.Html5.Attributes  as HA
  39
  40 import Language.TCT.Tree
  41 import Language.TCT.Markup
  42 import Language.TCT.Read.Tree
  43 import Language.TCT.Read.Markup
  44
  45 {-
  46 class HTML5able a where
  47         html5Of :: a -> Html
  48
  49 class Textable a where
  50         textOf :: a -> Html
  51 instance HTML5able TCT where
  52 -}
  53
  54 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
  55 whenJust Nothing _f = pure ()
  56 whenJust (Just a) f = f a
  57
  58 html5 :: Trees (Cell Key) (Cell Markup) -> Html
  59 html5 tct = do
  60         H.docType
  61         H.html $ do
  62                 H.head $ do
  63                         H.meta ! HA.httpEquiv "Content-Type"
  64                                ! HA.content "text/html; charset=UTF-8"
  65                         whenJust (titleTCT tct) $ \(unCell -> t) ->
  66                                 H.title $ H.toMarkup $ t_Markup t
  67                         -- link ! rel "Chapter" ! title "SomeTitle">
  68                         H.link ! HA.rel "stylesheet"
  69                                ! HA.type_ "text/css"
  70                                ! HA.href "tct-text.css"
  71                 H.body $ do
  72                         H.a ! HA.id ("line-1") $ return ()
  73                         forM_ (treePosLastCell tct) $ h_TreeCell
  74
  75 titleTCT :: Trees (Cell Key) (Cell a) -> Maybe (Cell a)
  76 titleTCT tct =
  77         L.find (\case
  78          TreeN (unCell -> KeySection{}) _ts -> True
  79          _ -> False) tct >>=
  80         \case
  81          TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
  82          _ -> Nothing
  83
  84 h_Text :: Text -> Html
  85 h_Text = H.toMarkup
  86
  87 h_Spaces :: Int -> Html
  88 h_Spaces 0  = return ()
  89 h_Spaces sp = H.span $ h_Text $ T.replicate sp " "
  90
  91 h_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Markup) -> Html
  92 h_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) = do
  93         h_IndentCell c
  94         H.section $ do
  95                 H.span ! HA.class_ "section-title" $ do
  96                         H.span $ h_Text $ T.replicate lvl "#" <> " "
  97                         case Seq.viewl ts of
  98                          Tree0 (_,Cell posTitle _ title) :< _ -> h lvl $ h_Markup posTitle title
  99                          _ -> return ()
 100                 forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ h_TreeCell
 101         where
 102         h 1 = H.h1
 103         h 2 = H.h2
 104         h 3 = H.h3
 105         h 4 = H.h4
 106         h 5 = H.h5
 107         h 6 = H.h6
 108         h n | n > 0 = H.span ! HA.class_ ("h h"`mappend`fromString (show n))
 109         h _ = undefined
 110 h_TreeCell (Tree0 c@(_,cell)) = do
 111         h_IndentCell c
 112         h_CellMarkup cell
 113 h_TreeCell (TreeN c@(_,cell) cs) = do
 114         h_IndentCell c
 115         h_CellKey cell
 116         forM_ cs $ h_TreeCell
 117
 118 h_IndentCell :: (Pos,Cell a) -> Html
 119 h_IndentCell ((lineLast,colLast),posCell -> (line,col))
 120  | lineLast < line = do
 121         forM_ [lineLast+1..line] $ \lnum -> do
 122                 H.toMarkup '\n'
 123                 H.a ! HA.id ("line-"`mappend`fromString (show lnum)) $ return ()
 124         H.toMarkup $ T.replicate (col - 1) " "
 125  | lineLast == line
 126  && colLast <= col = H.toMarkup $ T.replicate (col - colLast) " "
 127  | otherwise = undefined
 128
 129 h_CellKey :: Cell Key -> Html
 130 h_CellKey (Cell pos posEnd key) = do
 131         case key of
 132          KeyColon n -> h_Key n ':' "colon"
 133          KeyGreat n -> h_Key n '>' "great"
 134          KeyEqual n -> h_Key n '=' "equal"
 135          KeyBar   n -> h_Key n '|' "bar"
 136          KeyDash    -> H.toMarkup ("- "::Text)
 137         where
 138         h_Key nam mark cl = do
 139                 -- h_Spaces $ colPos posEnd - (colPos pos + T.length nam + 1)
 140                 H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",fromString $ T.unpack nam]) $ do
 141                         H.toMarkup nam
 142                         H.span ! HA.class_ "key-mark" $ H.toMarkup mark
 143 {-
 144 h_CellKey (TreeN (Cell pos posEnd k) _) = do
 145         -- h_Spaces pos
 146         H.pre $ H.toMarkup $ show k
 147 -}
 148
 149 h_CellText :: Cell Text -> Html
 150 h_CellText (Cell pos posEnd a) = h_IndentText pos a
 151
 152 h_CellMarkup :: Cell Markup -> Html
 153 h_CellMarkup (Cell pos posEnd (MarkupPlain t)) =
 154         h_IndentText pos t
 155
 156 h_IndentText :: Pos -> Text -> Html
 157 h_IndentText pos v =
 158         let lines = T.splitOn "\n" v in
 159         let lnums = H.toMarkup :
 160                  [ \line -> do
 161                         H.toMarkup '\n'
 162                         H.a ! HA.id ("line-"`mappend`fromString (show lnum)) $ return ()
 163                         H.toMarkup pad
 164                         H.toMarkup line
 165                  | lnum <- [linePos pos+1..]
 166                  ] in
 167         mconcat $ L.zipWith ($) lnums lines
 168         where pad = T.replicate (columnPos pos - 1) " "
 169
 170 h_Markup :: Pos -> Markup -> Html
 171 h_Markup pos (MarkupPlain v) = h_IndentText pos v
 172 {-
 173 h_Markup pos (Tag v) =
 174         H.span ! HA.class_ "tag" $
 175                 toMarkup $ T.concat ["#",v,if T.all isTagNameShortChar v then "" else "#"]
 176 h_Markup pos (Values vs) = do
 177         forM_ vs (h_Markup pos)
 178 h_Markup pos v = H.pre $ toMarkup $ show v
 179 -}
 180
 181 t_Markup :: Markup -> Text
 182 t_Markup (MarkupPlain t) = t
 183 t_Value :: Text -> Text
 184 t_Value v = v
 185 {-
 186 t_Value (Tag v) = T.concat ["#",v,if T.all isTagNameShortChar v then "" else "#"]
 187 t_Value v = T.pack $ show v
 188 -}
 189
 190 treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
 191 treePosLastCell t = S.evalState (go`mapM`t) (1,1)
 192         where
 193         go (Tree0 cell) = do
 194                 lastPos <- S.get
 195                 S.put $ posEndCell cell
 196                 return $ Tree0 (lastPos,cell)
 197         go (TreeN cell ts) = do
 198                 lastPos <- S.get
 199                 S.put $ posEndCell cell
 200                 ts' <- go`mapM`ts
 201                 return $ TreeN (lastPos,cell) ts'
 202
 203 {-
 204 colValue :: Value -> Column
 205 colValue = \case
 206          Plain t    -> T.length t
 207          Tag t      -> T.length t + (if T.all isTagNameCharShort t then 0 else 1)
 208          Values vs  -> sum $ colValue <$> vs
 209          Group _g v -> 2 + colValue v
 210 -}