module Language.TCT.HTML5.Source where
import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..), forM_, mapM, when)
+import Control.Monad (Monad(..), forM_, mapM)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import qualified Data.List as L
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
-import qualified Text.Blaze.Internal as B
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
+import qualified Data.Text.Lazy as TL
import Text.Blaze.Utils
import Language.TCT.Tree
import Language.TCT.Token
import Language.TCT.Elem
+import Language.TCT.Text
{-
class HTML5able a where
H.meta ! HA.httpEquiv "Content-Type"
! HA.content "text/html; charset=UTF-8"
whenJust (titleTCT tct) $ \(unCell -> t) ->
- H.title $ H.toMarkup $ L.head $ Text.lines (t_Token t) <> [""]
+ H.title $ H.toMarkup $ L.head $ Text.lines (TL.toStrict $ t_Token t) <> [""]
-- link ! rel "Chapter" ! title "SomeTitle">
H.link ! HA.rel "stylesheet"
! HA.type_ "text/css"
H.a ! HA.id ("line-1") $ return ()
forM_ (treePosLastCell tct) $ h_TreeCell
-treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
-treePosLastCell t = S.evalState (go`mapM`t) (1,1)
- where
- go :: Tree (Cell k) (Cell a) ->
- S.State (Int, Int) (Tree (Pos, Cell k) (Pos, Cell a))
- go (Tree0 cell) = do
- lastPos <- S.get
- S.put $ posEndCell cell
- return $ Tree0 (lastPos,cell)
- go (TreeN cell ts) = do
- lastPos <- S.get
- S.put $ posEndCell cell
- ts' <- go`mapM`ts
- return $ TreeN (lastPos,cell) ts'
-
titleTCT :: Trees (Cell Key) (Cell a) -> Maybe (Cell a)
titleTCT tct =
L.find (\case
H.span ! HA.class_ "attr-value" $
H.toMarkup attr_value
H.toMarkup attr_close
-
-t_Token :: Token -> Text
-t_Token (TokenPlain t) = t
-t_Token (TokenTag v) = "#"<>v
-t_Token (TokenEscape c) = Text.pack ['\\',c]
-t_Token (TokenLink lnk) = lnk
-t_Token (TokenGroup grp t) = o<>t_Token t<>c
- where (o,c) = groupBorders grp t
-t_Token (Tokens ts) = foldMap t_Token ts
-
-t_Value :: Text -> Text
-t_Value v = v
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- | Render a TCT file in plain Text.
+module Language.TCT.Text where
+
+import Control.Monad (Monad(..), mapM)
+import Data.Bool
+import Data.Eq (Eq(..))
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
+import Data.Int (Int)
+import Data.Int (Int64)
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
+import Data.Semigroup (Semigroup(..))
+import Data.Sequence (ViewL(..))
+import Data.String (String)
+import Data.Text (Text)
+import Prelude (Num(..), undefined, Integral(..))
+import Text.Show (Show(..))
+import qualified Control.Monad.Trans.State as S
+import qualified Data.List as L
+import qualified Data.Sequence as Seq
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
+
+import Language.TCT.Tree
+import Language.TCT.Token
+import Language.TCT.Elem hiding (trac,dbg)
+
+import Debug.Trace (trace)
+trac :: String -> a -> a
+-- trac _m x = x
+trac m x = trace m x
+dbg :: Show a => String -> a -> a
+dbg m x = trac (m <> ": " <> show x) x
+
+tl :: Text -> TL.Text
+tl = TL.fromStrict
+
+text :: Trees (Cell Key) (Cell Token) -> TL.Text
+text tct = foldMap t_TreeCell (treePosLastCell tct)
+
+t_Value :: Text -> TL.Text
+t_Value v = tl v
+
+int64 :: Integral i => i -> Int64
+int64 = fromInteger . toInteger
+
+t_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Token) -> TL.Text
+t_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) =
+ t_IndentCell c <>
+ TL.replicate (int64 lvl) "#" <> " " <>
+ (case Seq.viewl ts of
+ Tree0 (_,Cell posTitle _ title) :< _ -> t_IndentToken posTitle title
+ _ -> "") <>
+ foldMap t_TreeCell (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts})
+t_TreeCell (Tree0 c@(_,cell)) =
+ t_IndentCell c <>
+ t_CellToken cell
+t_TreeCell (TreeN c@(_,cell) cs) =
+ t_IndentCell c <>
+ t_CellKey cell cs
+
+t_IndentCell :: (Pos,Cell a) -> TL.Text
+t_IndentCell ((lineLast,colLast),posCell -> (line,col))
+ | lineLast < line =
+ TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
+ TL.replicate (int64 $ col - 1) " "
+ | lineLast == line
+ && colLast <= col = TL.replicate (int64 $ col - colLast) " "
+ | otherwise = undefined
+
+t_CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Cell Token) -> TL.Text
+t_CellKey (Cell _pos _posEnd key) cells = do
+ case key of
+ KeyColon n wh -> t_Key n wh ":"
+ KeyGreat n wh -> t_Key n wh ">"
+ KeyEqual n wh -> t_Key n wh "="
+ KeyBar n wh -> t_Key n wh "|"
+ KeyDash -> "- " <> foldMap t_TreeCell cells
+ KeyLower name attrs ->
+ "<" <> tl name <> t_Attrs attrs <>
+ foldMap t_TreeCell cells
+ where
+ t_Key :: Text -> White -> TL.Text -> TL.Text
+ t_Key name wh mark = tl name <> tl wh <> mark <> foldMap t_TreeCell cells
+
+t_CellToken :: Cell Token -> TL.Text
+t_CellToken (Cell pos _posEnd tok) =
+ t_IndentToken pos tok
+
+t_Token :: Token -> TL.Text
+t_Token (TokenPlain txt) = tl txt
+t_Token (TokenTag v) = "#"<>tl v
+t_Token (TokenEscape c) = tl $ Text.pack ['\\',c]
+t_Token (TokenLink lnk) = tl lnk
+t_Token (TokenGroup grp t) = tl o<>t_Token t<>tl c
+ where (o,c) = groupBorders grp t
+t_Token (Tokens ts) = foldMap t_Token ts
+
+t_IndentToken :: Pos -> Token -> TL.Text
+t_IndentToken pos tok = go tok `S.evalState` linePos pos
+ where
+ indent = TL.replicate (int64 $ columnPos pos - 1) " "
+ go :: Token -> S.State Int TL.Text
+ go (TokenPlain txt) = do
+ lin <- S.get
+ let lines = Text.splitOn "\n" txt
+ let lnums = tl : -- TODO: fmap
+ [ \line -> "\n"<>indent<>tl line
+ | _lnum <- [lin+1..]
+ ]
+ S.put (lin - 1 + L.length lines)
+ return $ mconcat $ L.zipWith ($) lnums lines
+ go (TokenTag v) = return $ "#"<>tl v
+ go (TokenEscape c) = return $ tl $ Text.pack ['\\',c]
+ go (TokenLink lnk) = return $ tl lnk
+ go (TokenGroup grp t) = do
+ t' <- go t
+ return $ tl o<>t'<>tl c
+ where (o,c) = groupBorders grp t
+ go (Tokens ts) = do
+ ts' <- go`mapM`ts
+ return $ foldr (<>) mempty ts'
+
+t_Attrs :: Attrs -> TL.Text
+t_Attrs = foldMap t_Attr
+
+t_Attr :: (Text,Attr) -> TL.Text
+t_Attr (attr_white,Attr{..}) =
+ mconcat $ tl <$>
+ [ attr_white
+ , attr_name
+ , attr_open
+ , attr_value
+ , attr_close
+ ]
+
+treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
+treePosLastCell t = S.evalState (go`mapM`t) (1,1)
+ where
+ go :: Tree (Cell k) (Cell a) ->
+ S.State (Int, Int) (Tree (Pos, Cell k) (Pos, Cell a))
+ go (Tree0 cell) = do
+ lastPos <- S.get
+ S.put $ posEndCell cell
+ return $ Tree0 (lastPos,cell)
+ go (TreeN cell ts) = do
+ lastPos <- S.get
+ S.put $ posEndCell cell
+ ts' <- go`mapM`ts
+ return $ TreeN (lastPos,cell) ts'
+
+{-
+t_TreeCell :: [Key] -> Tree (Cell Key) (Cell Token) -> TL.Text
+t_TreeCell path (TreeN (unCell -> key@KeySection{}) ts) =
+ case Seq.viewl ts of
+ Tree0 (Cell _posTitle _ (TokenPlain title)) :< _ ->
+ D.section ! DA.name (attrValue title) $
+ d_content
+ Tree0 (Cell _posTitle _ title) :< _ ->
+ D.section $ do
+ D.name $ d_Token (key:path) title
+ d_content
+ _ -> D.section d_content
+ where
+ d_content = forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ d_TreeCell (key:path)
+t_TreeCell path (Tree0 cell) = d_CellToken path cell
+t_TreeCell path (TreeN cell ts) = d_CellKey path cell ts
+
+t_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Token) -> TL.Text
+t_CellKey path (Cell _pos _posEnd key) cells = do
+ case key of
+ KeyColon n _wh -> d_Key n
+ KeyGreat n _wh -> d_Key n
+ KeyEqual n _wh -> d_Key n
+ KeyBar n _wh -> d_Key n
+ KeyDash -> "- " <> foldMap (d_TreeCell (key:path)) cells
+ {-
+ KeyLower name attrs -> do
+ B.Content $ "<"<>B.toMarkup name
+ d_Attrs attrs
+ forM_ cells $ d_TreeCell path
+ -}
+ where
+ d_Key :: Text -> TL.Text
+ d_Key name = do
+ B.CustomParent (B.Text name) $
+ forM_ cells $ d_TreeCell (key:path)
+
+t_CellToken :: [Key] -> Cell Token -> TL.Text
+t_CellToken path (Cell _pos _posEnd tok) =
+ -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellToken: path:" path of
+ case dbg "d_CellToken: path" path of
+ KeySection{}:_ ->
+ case tok of
+ TokenGroup GroupElem{} _t -> d_Token path tok
+ _ -> D.para $ d_Token path tok
+ _ -> d_Token path tok
+-}
sourcephile / git / doclang.git / commitdiff