Language/TCT/HTML5.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ViewPatterns #-}
   3 module Language.TCT.HTML5 where
   4
   5 -- import Data.Char (Char)
   6 -- import Data.Eq (Eq(..))
   7 -- import Data.Int
   8 -- import Data.Text.Lazy.Builder (Buildable(..))
   9 -- import qualified Data.ByteString.Lazy as BSL
  10 -- import qualified Data.Char as Char
  11 -- import qualified Data.Text.Lazy as TL
  12 -- import qualified Data.Text.Lazy.Builder as TL
  13 import Control.Monad (Monad(..), forM_, mapM)
  14 import Data.Bool
  15 import Data.Foldable (sum)
  16 import Data.Function (($), (.), const, id)
  17 import Data.Eq (Eq(..))
  18 import Data.Functor ((<$>))
  19 import Data.Maybe (Maybe(..))
  20 import Data.Monoid (Monoid(..))
  21 import Data.Int (Int)
  22 import Data.Ord (Ord(..))
  23 import Data.Semigroup (Semigroup(..))
  24 import Data.String (IsString(..))
  25 import Data.Text (Text)
  26 import Prelude (Num(..), undefined)
  27 import Text.Show (Show(..))
  28 import Data.Sequence (ViewL(..))
  29 import qualified Data.List as L
  30 import qualified Data.Text as T
  31 import qualified Data.Sequence as Seq
  32
  33 import qualified Control.Monad.Trans.State as S
  34 -- import qualified Text.Blaze.Html  as H
  35 -- import qualified Data.ByteString as BS
  36 -- import qualified Data.ByteString.Lazy as BSL
  37 import Text.Blaze as B
  38 import Text.Blaze.Html (Html)
  39 import qualified Text.Blaze.Html5 as H
  40 import qualified Text.Blaze.Html5.Attributes  as HA
  41
  42 import Language.TCT.Tree
  43 import Language.TCT.Read.Tree
  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 html5 :: TCT Text -> Html
  55 html5 tct = do
  56         H.docType
  57         H.html $ do
  58                 H.head $ do
  59                         H.meta ! HA.httpEquiv "Content-Type"
  60                                ! HA.content "text/html; charset=UTF-8"
  61                         case L.find (\case Tree (Key _ _ KeySection{}) _ns -> True; _ -> False) tct of
  62                          Just (Tree (Key _ _ (KeySection _lvl)) (Seq.viewl -> Tree (Value _ _ title) _:<_)) ->
  63                                 H.title $ toMarkup $ t_Value title
  64                          _ -> return ()
  65                         -- link ! rel "Chapter" ! title "SomeTitle">
  66                         H.link ! HA.rel "stylesheet"
  67                                ! HA.type_ "text/css"
  68                                ! HA.href "tct-text.css"
  69                 H.body $ do
  70                         forM_ (treePosLastCell tct) $ h_TreeCell
  71                         {-
  72                         div ! id "header" $ "Syntax"
  73                         p "This is an example of BlazeMarkup syntax."
  74                         ul $ mapM_ (li . toMarkup . show) [1::Int, 2, 3]
  75                         -}
  76
  77 h_Text :: Text -> Html
  78 h_Text = toMarkup
  79
  80 h_Spaces :: Int -> Html
  81 h_Spaces 0  = return ()
  82 h_Spaces sp = H.span $ h_Text $ T.replicate sp " "
  83
  84 h_fill :: Pos -> Pos -> Html
  85 h_fill (l0,c0) (l1,c1) | l0 < l1 = do
  86         toMarkup $
  87                 T.replicate (l1 - l0) "\n" <>
  88                 T.replicate c1 " "
  89 h_fill (l0,c0) (l1,c1) | l0 == l1 && c0 <= c1 = do
  90         toMarkup $ T.replicate (c1 - c1) " "
  91 h_fill _ _ = undefined
  92
  93 h_TreeCell :: Tree (Pos,Cell Text) -> Html
  94 h_TreeCell (Tree c@(posLast, Key pos posEnd (KeySection lvl))
  95                  (Seq.viewl -> Tree (_, Value posTitle _ title) _:<cs)) = do
  96         toMarkup $ indentCell c
  97         H.section $ do
  98                 H.span ! HA.class_ "section-title" $ do
  99                         H.span $ h_Text $ T.replicate lvl "#" <> " "
 100                         h lvl $ h_Value posTitle title
 101                 forM_ cs $ h_TreeCell
 102         where
 103         h 1 = H.h1
 104         h 2 = H.h2
 105         h 3 = H.h3
 106         h 4 = H.h4
 107         h 5 = H.h5
 108         h 6 = H.h6
 109         h n | n > 0 = H.span ! HA.class_ ("h h"`mappend`fromString (show n))
 110         h _ = undefined
 111 h_TreeCell (Tree c@(_,cell) cs) = do
 112         toMarkup $ indentCell c
 113         h_Cell cell
 114         forM_ cs $ h_TreeCell
 115
 116 indentCell :: (Pos,Cell Text) -> Text
 117 indentCell ((lineLast,colLast),posCell -> (line,col))
 118  | lineLast < line = T.replicate (line - lineLast) "\n" <> T.replicate (col - 1) " "
 119  | lineLast == line
 120  && colLast <= col = T.replicate (col - colLast) " "
 121  | otherwise = undefined
 122
 123 h_Cell :: Cell Text -> Html
 124 h_Cell (Key pos posEnd key) = do
 125         case key of
 126          KeyColon n -> h_Key n ':' "colon"
 127          KeyGreat n -> h_Key n '>' "great"
 128          KeyEqual n -> h_Key n '=' "equal"
 129          KeyBar   n -> h_Key n '|' "bar"
 130          KeyDash    -> toMarkup ("- "::Text)
 131         where
 132         h_Key nam mark cl = do
 133                 -- h_Spaces $ colPos posEnd - (colPos pos + T.length nam + 1)
 134                 H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",fromString $ T.unpack nam]) $ do
 135                         toMarkup nam
 136                         H.span ! HA.class_ "key-mark" $ toMarkup mark
 137 h_Cell (Key pos posEnd k) = do
 138         -- h_Spaces pos
 139         H.pre $ toMarkup $ show k
 140 h_Cell (Value pos posEnd v) = h_Value pos v
 141
 142 indentValue :: Pos -> Text -> Html
 143 indentValue pos v =
 144         let lines = T.splitOn "\n" v in
 145         let lnums = toMarkup :
 146                  [ \line -> do
 147                         toMarkup '\n'
 148                         H.a ! HA.id ("line-"`mappend`fromString (show lnum)) $ return ()
 149                         toMarkup pad
 150                         toMarkup line
 151                  | lnum <- [linePos pos+1..]
 152                  ] in
 153         mconcat $ L.zipWith ($) lnums lines
 154         where pad = T.replicate (colPos pos - 1) " "
 155
 156 h_Value :: Pos -> Text -> Html
 157 h_Value pos v = indentValue pos v
 158 {-
 159 h_Value pos (Tag v) =
 160         H.span ! HA.class_ "tag" $
 161                 toMarkup $ T.concat ["#",v,if T.all isTagNameShortChar v then "" else "#"]
 162 h_Value pos (Values vs) = do
 163         forM_ vs (h_Value pos)
 164 h_Value pos v = H.pre $ toMarkup $ show v
 165 -}
 166
 167 t_Value :: Text -> Text
 168 t_Value v = v
 169 {-
 170 t_Value (Tag v) = T.concat ["#",v,if T.all isTagNameShortChar v then "" else "#"]
 171 t_Value v = T.pack $ show v
 172 -}
 173
 174 treePosLastCell :: Forest (Cell Text) -> Forest (Pos,Cell Text)
 175 treePosLastCell t = S.evalState (go`mapM`t) (1,1)
 176         where
 177         go (Tree cell cells) = do
 178                 lastPos <- S.get
 179                 S.put $ posEndCell cell
 180                 cells' <- go`mapM`cells
 181                 return $ Tree (lastPos,cell) cells'
 182
 183 colValue :: Value -> Column
 184 colValue = \case
 185          Plain t    -> T.length t
 186          Tag t      -> T.length t + (if T.all isTagNameShortChar t then 0 else 1)
 187          Values vs  -> sum $ colValue <$> vs
 188          Group _g v -> 2 + colValue v