{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Render a TCT file in plain Text.
module Language.TCT.Write.Plain where
import Control.Applicative (liftA2)
-import Control.Monad (Monad(..), mapM)
+import Control.Monad (Monad(..))
import Data.Bool
+import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
-import Data.Function (($), (.), id)
+import Data.Function (($))
import Data.Functor ((<$>))
-import Data.Int (Int,Int64)
+import Data.Int (Int)
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
-import Data.Ord (Ord(..))
+import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (ViewL(..), ViewR(..))
-import Data.String (String)
-import Data.Text (Text)
-import Data.TreeSeq.Strict (Tree(..),Trees)
-import GHC.Exts (IsString(..))
-import Prelude (Num(..), undefined, Integral(..))
+import Data.Sequence (ViewL(..))
+import Data.String (String, IsString(..))
+import Prelude (Num(..), error)
import Text.Show (Show(..))
-import qualified Control.Monad.Trans.Reader as R
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.List as List
import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TLB
+import qualified Data.Sequence as Seq
+
+import Language.TCT
+import Language.TCT.Utils
+-- import Language.TCT.Debug
-import Language.TCT.Tree
-import Language.TCT.Cell
-import Language.TCT.Token
-import Language.TCT.Elem
+writePlain :: Roots -> TL.Text
+writePlain doc = text (setStart doc def) doc
-- * Type 'Plain'
-type Plain = R.Reader State TL.Text
+type Plain = S.State State TLB.Builder
+ -- NOTE: To get maximum performance when building lazy Text values using a builder,
+ -- associate mappend calls to the right.
+ -- NOTE: (Semigroup.<>) associates to the right.
instance IsString Plain where
- fromString = return . fromString
+ fromString = plainify
instance Semigroup Plain where
(<>) = liftA2 (<>)
instance Monoid Plain where
mappend = (<>)
runPlain :: Plain -> State -> TL.Text
-runPlain p s = {-TLB.toLazyText .-} R.runReader p s
+runPlain p s = TLB.toLazyText $ S.evalState p s
text :: Plainify a => State -> a -> TL.Text
-text st a = runPlain (plainify a) st
+text s a = runPlain (plainify a) s
--- * Type 'State'
+-- ** Type 'State'
data State
= State
- { state_escape :: Bool
+ { state_escape :: Bool -- FIXME: useful?
+ , state_pos :: Pos
+ -- ^ current position,
+ -- always in sync annotated 'Pos' of the input,
+ -- not with the output (whose colmuns may be shifted left by 'state_unindent')
+ , state_indent :: TL.Text
+ -- ^ indentation, which contain horizontal spaces,
+ -- but also any repeated prefix introduced by 'HeaderBar' or 'HeaderGreat'
+ , state_unindent :: Int
+ -- ^ initial 'pos_column' set by 'setStart',
+ -- useful to shift everything to the left
} deriving (Eq, Show)
instance Default State where
def = State
- { state_escape = True
+ { state_escape = True
+ , state_pos = pos1
+ , state_indent = ""
+ , state_unindent = 1
}
+-- | Set the starting 'Pos' of given 'State'
+-- by using the first 'cell_begin'.
+setStart :: Roots -> State -> State
+setStart ts st = st
+ { state_pos = pos
+ , state_unindent = pos_column pos
+ }
+ where pos =
+ case Seq.viewl ts of
+ EmptyL -> pos1
+ Tree (Cell (Span{span_begin}:|_) _) _ :< _ -> span_begin
+
-- * Class 'Plainify'
class Plainify a where
plainify :: a -> Plain
+instance Plainify () where
+ plainify = mempty
+instance Plainify Char where
+ plainify = \case
+ '\n' -> do
+ S.modify' $ \s@State{state_pos=Pos line _col, state_indent, state_unindent} ->
+ s{state_pos=Pos (line + 1) $ state_unindent + int (TL.length state_indent)}
+ State{..} <- S.get
+ return $ TLB.singleton '\n' <> TLB.fromLazyText state_indent
+ c -> do
+ S.modify' $ \s@State{state_pos=Pos line col} ->
+ s{state_pos=Pos line (col + 1)}
+ return $ TLB.singleton c
instance Plainify String where
- plainify = return . fromString
-instance Plainify Text where
- plainify = return . TL.fromStrict
+ plainify = foldMap plainify
instance Plainify TL.Text where
- plainify = return
-instance Plainify (Trees (Cell Key) Tokens) where
- plainify = plainify . treePosLastCell
-instance Plainify (Trees (Pos,Cell Key) (Pos,Tokens)) where
+ plainify t
+ | TL.null t = mempty
+ | otherwise =
+ let (h,ts) = TL.span (/='\n') t in
+ case TL.uncons ts of
+ Nothing -> do
+ S.modify' $ \s@State{state_pos=Pos line col} ->
+ s{state_pos=Pos line $ col + int (TL.length h)}
+ return $ TLB.fromLazyText h
+ Just (_n,ts') ->
+ return (TLB.fromLazyText h) <>
+ -- NOTE: useless to increment the pos_column for h,
+ -- since the following '\n' will reset the pos_column.
+ plainify '\n' <>
+ plainify ts'
+instance Plainify Pos where
+ plainify new@(Pos lineNew colNew) = do
+ State
+ { state_pos=old@(Pos lineOld colOld)
+ , state_indent
+ , state_unindent
+ } <- S.get
+ S.modify' $ \s -> s{state_pos=new}
+ return $ TLB.fromLazyText $
+ case lineNew`compare`lineOld of
+ GT -> lines <> state_indent <> hspaces
+ where
+ lines = TL.replicate (int64 $ lineNew - lineOld) "\n"
+ hspaces = TL.replicate (int64 (colNew - state_unindent) - TL.length state_indent) " "
+ EQ | colNew >= colOld ->
+ TL.replicate (int64 $ colNew - colOld) " "
+ _ -> error $ "plainify: non-ascending Pos:"
+ <> "\n old: " <> show old
+ <> "\n new: " <> show new
+instance Plainify Roots where
plainify = foldMap plainify
-instance Plainify (Tree (Pos,Cell Key) (Pos,Tokens)) where
- plainify (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) =
- plainifyIndentCell (posEnd,pos) <>
- plainify (TL.replicate (int64 lvl) "#") <> " " <>
- (case Seq.viewl ts of
- Tree0 (_,title) :< _ ->
- plainify title
- _ -> "") <>
- plainify
- (case Seq.viewl ts of
- Tree0{} :< ts' -> ts'
- _ -> ts)
- plainify (Tree0 (posEnd,toks)) =
- case Seq.viewl toks of
- EmptyL -> plainify toks
- t0:<_ -> plainifyIndentCell (posEnd,posCell t0) <> plainify toks
- plainify (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
- plainifyIndentCell (posEnd,pos) <>
- plainify (cell, cs)
-instance Plainify (Cell Key, Trees (Pos,Cell Key) (Pos,Tokens)) where
- plainify (Cell _pos _posEnd key, cells) = do
- case key of
- 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 ->
- "<" <>
- plainify name <>
- plainify attrs <>
- plainify cells
- KeySection{} -> undefined
- KeyDotSlash p ->
- plainify ("./"::TL.Text) <>
- plainify p <>
- plainify cells
- where
- textKey :: Text -> White -> TL.Text -> Plain
- textKey name wh mark =
- plainify (textify name <> textify wh <> mark) <>
- plainify cells
-instance Plainify Tokens where
- plainify toks =
- case Seq.viewl toks of
- EmptyL -> ""
- Cell pos _ _ :< _ -> do
- st <- R.ask
- return $ goTokens st toks `S.evalState` linePos pos
+instance Plainify Root where
+ plainify (Tree (Cell (Span{span_begin=bp}:|_) nod) ts) =
+ plainify bp <>
+ case nod of
+ ----------------------
+ NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
+ ----------------------
+ NodeHeader hdr ->
+ case hdr of
+ HeaderGreat{} -> plainHeaderRepeated
+ HeaderBar{} -> plainHeaderRepeated
+ HeaderDotSlash{} -> plainify hdr
+ _ -> plainify hdr <> plainify ts
where
- indent = TL.replicate (int64 $ columnPos pos - 1) " "
- go :: State -> Cell Token -> S.State Int TL.Text
- go st@State{..} 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) -> textify l0 <> mconcat ((\l -> "\n"<>indent<>textify l)<$>ls)
- TokenTag v -> return $ "#"<>textify v
- TokenEscape c -> do
- return $
- if state_escape
- then textify $ Text.pack ['\\',c]
- else TL.singleton c
- TokenLink lnk -> return $ textify lnk
- TokenPair grp ts -> do
- ts' <- goTokens st ts
- return $ textify o<>ts'<>textify c
- where (o,c) = pairBorders grp ts
- goTokens :: State -> Tokens -> S.State Int TL.Text
- goTokens st ts = do
- ts' <- go st`mapM`ts
- return $ foldr (<>) mempty ts'
-instance Plainify Attrs where
- plainify = plainify . textify
-
--- * Class 'Textify'
-class Textify a where
- textify :: a -> TL.Text
-instance Textify Text where
- textify = TL.fromStrict
-instance Textify TL.Text where
- textify = id
-instance Textify Attrs where
- textify = foldMap textify
-instance Textify (Text,Attr) where
- textify (attr_white,Attr{..}) =
- mconcat $ textify <$>
- [ attr_white
- , attr_name
- , attr_open
- , attr_value
- , attr_close
+ plainHeaderRepeated = do
+ State{..} <- S.get
+ h <- plainify hdr
+ S.modify' $ \s -> s{state_indent =
+ state_indent <>
+ TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " <>
+ TLB.toLazyText h
+ }
+ r <- plainify ts
+ S.modify' $ \s -> s{state_indent}
+ return $ h <> r
+ ----------------------
+ NodeText t -> do
+ State{..} <- S.get
+ S.modify' $ \s -> s{state_indent =
+ state_indent <>
+ TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
+ }
+ r <- plainify t
+ S.modify' $ \s -> s{state_indent}
+ return r
+ ----------------------
+ NodePara -> do
+ State{..} <- S.get
+ S.modify' $ \s -> s{state_indent =
+ state_indent <>
+ TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
+ }
+ r <- plainify ts
+ S.modify' $ \s -> s{state_indent}
+ return r
+ ----------------------
+ NodeToken t -> plainify t <> plainify ts
+ ----------------------
+ NodePair p ->
+ plainify o <> plainify ts <> plainify c
+ where (o,c) = pairBorders p ts
+instance Plainify Header where
+ plainify hdr =
+ case hdr of
+ HeaderColon n wh -> plainify n <> plainify wh <> ":"
+ HeaderGreat n wh -> plainify n <> plainify wh <> ">"
+ HeaderEqual n wh -> plainify n <> plainify wh <> "="
+ HeaderBar n wh -> plainify n <> plainify wh <> "|"
+ HeaderDot n -> plainify n <> "."
+ HeaderBrackets n -> "[" <> plainify n <> "]"
+ HeaderDash -> "- "
+ HeaderDashDash -> "-- "
+ HeaderSection lvl -> plainify (List.replicate lvl '#')
+ HeaderDotSlash n -> plainify n
+instance Plainify Token where
+ plainify = \case
+ TokenText t -> plainify t
+ TokenTag t -> plainify '#' <> plainify t
+ TokenLink l -> plainify l
+ TokenEscape c -> do
+ esc <- S.gets state_escape
+ if esc
+ then plainify ['\\', c]
+ else plainify c
+instance Plainify ElemAttrs where
+ plainify = foldMap plainify
+instance Plainify (White,ElemAttr) where
+ plainify (elemAttr_white,ElemAttr{..}) =
+ mconcat $ plainify <$>
+ [ elemAttr_white
+ , elemAttr_name
+ , elemAttr_open
+ , elemAttr_value
+ , elemAttr_close
]
-instance Textify Token where
- textify (TokenPlain txt) = textify txt
- textify (TokenTag v) = "#"<>textify v
- textify (TokenEscape c) = TL.singleton c -- textify $ Text.pack ['\\',c]
- textify (TokenLink lnk) = textify lnk
- textify (TokenPair grp t) = textify o<>textify t<>textify c
- where (o,c) = pairBorders grp t
-instance Textify Tokens where
- textify ts = foldMap (textify . unCell) ts
-
--- * Utilities
-
-plainifyIndentCell :: (Pos,Pos) -> Plain
-plainifyIndentCell (Pos lineLast colLast,Pos line col)
- | lineLast < line =
- return $
- TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
- TL.replicate (int64 $ col - 1) " "
- | lineLast == line && colLast <= col =
- return $
- TL.replicate (int64 $ col - colLast) " "
- | otherwise = undefined
-
--- ** 'Tree'
-treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
-treeRackUpLeft t = go t
- where
- 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
- go (TreeN (Cell pos posEnd c) ts) =
- TreeN
- (Cell (rackUpLeft pos) (rackUpLeft posEnd) c)
- (go <$> ts)
-
-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) Tokens ->
- S.State Pos (Tree (Pos,Cell k) (Pos,Tokens))
- go (Tree0 ts) = do
- lastPos <- S.get
- 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'
--- ** 'Int64'
-int64 :: Integral i => i -> Int64
-int64 = fromInteger . toInteger
+{-
+-- * Class 'RackUpLeft'
+class RackUpLeft a where
+ rackUpLeft :: a -> S.State (Maybe Pos) a
+instance RackUpLeft Pos where
+ rackUpLeft pos@Pos{..} = do
+ S.get >>= \case
+ Nothing -> return pos
+ Just (Pos l0 c0) ->
+ return Pos
+ { pos_line = pos_line - l0 + 1
+ , pos_column = pos_column - c0 + 1
+ }
+instance RackUpLeft (Cell a) where
+ rackUpLeft (Cell bp ep a) = do
+ S.modify' $ \case
+ Nothing -> Just bp
+ p -> p
+ Cell
+ <$> rackUpLeft bp
+ <*> rackUpLeft ep
+ <*> pure a
+instance RackUpLeft a => RackUpLeft (Seq a) where
+ rackUpLeft = mapM rackUpLeft
+instance RackUpLeft a => RackUpLeft (Tree a) where
+ rackUpLeft (Tree n ts) =
+ Tree
+ <$> rackUpLeft n
+ <*> rackUpLeft ts
+-}
sourcephile / git / doclang.git / blobdiff