{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Render a TCT file in plain Text.
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
-import Data.Int (Int)
-import Data.Int (Int64)
+import Data.Int (Int,Int64)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (ViewL(..))
-import Data.String (String)
+import Data.Sequence (ViewL(..), ViewR(..))
import Data.Text (Text)
+import Data.TreeSeq.Strict (Tree(..),Trees)
import Prelude (Num(..), undefined, Integral(..))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.Text.Lazy as TL
import Language.TCT.Tree
+import Language.TCT.Cell
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
+import Language.TCT.Elem
tl :: Text -> TL.Text
tl = TL.fromStrict
{ config_text_escape = True
}
-text :: Config_Text -> Trees (Cell Key) (Cell Token) -> TL.Text
-text cfg tct = foldMap (t_TreeCell cfg) (treePosLastCell tct)
+text :: Config_Text -> Trees (Cell Key) Tokens -> TL.Text
+text cfg = textTreesCell cfg . treePosLastCell
treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
treeRackUpLeft t = go t
where
- (l0,c0) = posTree t
- rackUpLeft pos = (linePos pos - l0 + 1, columnPos pos - c0 + 1)
+ Pos l0 c0 = posTree t
+ rackUpLeft pos =
+ Pos
+ (linePos pos - l0 + 1)
+ (columnPos pos - c0 + 1)
go :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
go (Tree0 (Cell pos posEnd c)) =
Tree0 $ Cell (rackUpLeft pos) (rackUpLeft posEnd) c
(Cell (rackUpLeft pos) (rackUpLeft posEnd) c)
(go <$> ts)
-treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
-treePosLastCell t = S.evalState (go`mapM`t) (1,1)
+treePosLastCell ::
+ Trees (Cell k) Tokens ->
+ Trees (Pos,Cell k) (Pos,Tokens)
+treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1)
where
- go :: Tree (Cell k) (Cell a) ->
- S.State (Int, Int) (Tree (Pos, Cell k) (Pos, Cell a))
- go (Tree0 cell) = do
+ go :: Tree (Cell k) Tokens ->
+ S.State Pos (Tree (Pos,Cell k) (Pos,Tokens))
+ go (Tree0 ts) = do
lastPos <- S.get
- S.put $ posEndCell cell
- return $ Tree0 (lastPos,cell)
+ case Seq.viewr ts of
+ EmptyR ->
+ return $ Tree0 (lastPos,ts)
+ _ :> cell -> do
+ S.put $ posEndCell cell
+ return $ Tree0 (lastPos,ts)
go (TreeN cell ts) = do
lastPos <- S.get
S.put $ posEndCell cell
ts' <- go`mapM`ts
return $ TreeN (lastPos,cell) ts'
-t_Value :: Text -> TL.Text
-t_Value v = tl v
-
int64 :: Integral i => i -> Int64
int64 = fromInteger . toInteger
-t_TreeCell :: Config_Text -> Tree (Pos,Cell Key) (Pos,Cell Token) -> TL.Text
-t_TreeCell cfg (TreeN c@(_, unCell -> KeySection lvl) ts) =
- t_IndentCell c <>
+textTreeCell ::
+ Config_Text ->
+ Tree (Pos,Cell Key) (Pos,Tokens) ->
+ TL.Text
+textTreeCell cfg (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) =
+ textIndentCell (posEnd,pos) <>
TL.replicate (int64 lvl) "#" <> " " <>
(case Seq.viewl ts of
- Tree0 (_,Cell posTitle _ title) :< _ -> t_IndentToken cfg posTitle title
+ Tree0 (_,title) :< _ ->
+ textIndentToken cfg title
_ -> "") <>
- foldMap (t_TreeCell cfg) (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts})
-t_TreeCell cfg (Tree0 c@(_,cell)) =
- t_IndentCell c <>
- t_CellToken cfg cell
-t_TreeCell cfg (TreeN c@(_,cell) cs) =
- t_IndentCell c <>
- t_CellKey cfg cell cs
-
-t_IndentCell :: (Pos,Cell a) -> TL.Text
-t_IndentCell ((lineLast,colLast),posCell -> (line,col))
+ textTreesCell cfg
+ (case Seq.viewl ts of
+ Tree0{} :< ts' -> ts'
+ _ -> ts)
+textTreeCell cfg (Tree0 (posEnd,toks)) =
+ case Seq.viewl toks of
+ EmptyL -> textIndentToken cfg toks
+ t0:<_ -> textIndentCell (posEnd,posCell t0) <> textIndentToken cfg toks
+textTreeCell cfg (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
+ textIndentCell (posEnd,pos) <>
+ textCellKey cfg cell cs
+
+textIndentCell :: (Pos,Pos) -> TL.Text
+textIndentCell (Pos lineLast colLast,Pos 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) " "
+ | lineLast == line && colLast <= col =
+ TL.replicate (int64 $ col - colLast) " "
| otherwise = undefined
-t_CellKey :: Config_Text -> Cell Key -> Trees (Pos,Cell Key) (Pos,Cell Token) -> TL.Text
-t_CellKey cfg (Cell _pos _posEnd key) cells = do
+textCellKey ::
+ Config_Text ->
+ Cell Key ->
+ Trees (Pos,Cell Key) (Pos,Tokens) ->
+ TL.Text
+textCellKey cfg (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 cfg) cells
+ KeyColon n wh -> textKey n wh ":"
+ KeyGreat n wh -> textKey n wh ">"
+ KeyEqual n wh -> textKey n wh "="
+ KeyBar n wh -> textKey n wh "|"
+ KeyDash -> textKey "" "" "- "
+ KeyDashDash -> textKey "" "" "-- "
KeyLower name attrs ->
- "<" <> tl name <> t_Attrs attrs <>
- foldMap (t_TreeCell cfg) cells
+ "<" <> tl name <> textAttrs attrs <>
+ textTreesCell cfg cells
KeySection{} -> undefined
+ KeyDotSlash p ->
+ "./" <> TL.pack p <>
+ textTreesCell cfg cells
where
- t_Key :: Text -> White -> TL.Text -> TL.Text
- t_Key name wh mark = tl name <> tl wh <> mark <> foldMap (t_TreeCell cfg) cells
-
-t_CellToken :: Config_Text -> Cell Token -> TL.Text
-t_CellToken cfg (Cell pos _posEnd tok) =
- t_IndentToken cfg pos tok
-
-t_IndentToken :: Config_Text -> Pos -> Token -> TL.Text
-t_IndentToken cfg pos tok = go tok `S.evalState` linePos pos
+ textKey :: Text -> White -> TL.Text -> TL.Text
+ textKey name wh mark =
+ tl name <> tl wh <> mark <>
+ textTreesCell cfg cells
+
+textTreesCell ::
+ Config_Text ->
+ Trees (Pos,Cell Key) (Pos,Tokens) ->
+ TL.Text
+textTreesCell cfg = foldMap (textTreeCell cfg)
+
+textIndentToken :: Config_Text -> Tokens -> TL.Text
+textIndentToken _cfg (Seq.viewl -> EmptyL) = ""
+textIndentToken cfg toks@(Seq.viewl -> Cell pos _ _ :< _) =
+ goTokens toks `S.evalState` linePos pos
where
indent = TL.replicate (int64 $ columnPos pos - 1) " "
- go :: Token -> S.State Int TL.Text
- go (TokenPlain txt) = do
- lnum <- S.get
- let lines = Text.splitOn "\n" txt
- S.put (lnum - 1 + L.length lines)
- return $
- case lines of
- [] -> undefined
- (l0:ls) -> tl l0 <> mconcat ((\l -> "\n"<>indent<>tl l)<$>ls)
- go (TokenTag v) = return $ "#"<>tl v
- go (TokenEscape c) =
- return $
- if config_text_escape cfg
- then tl $ Text.pack ['\\',c]
- else TL.singleton c
- go (TokenLink lnk) = return $ tl lnk
- go (TokenPair grp t) = do
- t' <- go t
- return $ tl o<>t'<>tl c
- where (o,c) = pairBorders grp t
- go (Tokens ts) = do
+ go :: Cell Token -> S.State Int TL.Text
+ go tok =
+ case unCell tok of
+ TokenPlain txt -> do
+ lnum <- S.get
+ let lines = Text.splitOn "\n" txt
+ S.put (lnum - 1 + L.length lines)
+ return $
+ case lines of
+ [] -> undefined
+ (l0:ls) -> tl l0 <> mconcat ((\l -> "\n"<>indent<>tl l)<$>ls)
+ TokenTag v -> return $ "#"<>tl v
+ TokenEscape c ->
+ return $
+ if config_text_escape cfg
+ then tl $ Text.pack ['\\',c]
+ else TL.singleton c
+ TokenLink lnk -> return $ tl lnk
+ TokenPair grp ts -> do
+ ts' <- goTokens ts
+ return $ tl o<>ts'<>tl c
+ where (o,c) = pairBorders grp ts
+ goTokens :: Tokens -> S.State Int TL.Text
+ goTokens ts = do
ts' <- go`mapM`ts
return $ foldr (<>) mempty ts'
-t_Attrs :: Attrs -> TL.Text
-t_Attrs = foldMap t_Attr
+textAttrs :: Attrs -> TL.Text
+textAttrs = foldMap textAttr
-t_Attr :: (Text,Attr) -> TL.Text
-t_Attr (attr_white,Attr{..}) =
+textAttr :: (Text,Attr) -> TL.Text
+textAttr (attr_white,Attr{..}) =
mconcat $ tl <$>
[ attr_white
, attr_name
, attr_close
]
-
-t_Token :: Token -> TL.Text
-t_Token (TokenPlain txt) = tl txt
-t_Token (TokenTag v) = "#"<>tl v
-t_Token (TokenEscape c) = TL.singleton c -- tl $ Text.pack ['\\',c]
-t_Token (TokenLink lnk) = tl lnk
-t_Token (TokenPair grp t) = tl o<>t_Token t<>tl c
+textToken :: Token -> TL.Text
+textToken (TokenPlain txt) = tl txt
+textToken (TokenTag v) = "#"<>tl v
+textToken (TokenEscape c) = TL.singleton c -- tl $ Text.pack ['\\',c]
+textToken (TokenLink lnk) = tl lnk
+textToken (TokenPair grp t) = tl o<>textTokens t<>tl c
where (o,c) = pairBorders grp t
-t_Token (Tokens ts) = foldMap t_Token ts
+
+textTokens :: Tokens -> TL.Text
+textTokens ts = foldMap (textToken . unCell) ts
sourcephile / git / doclang.git / blobdiff