{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.TCT.Write.Plain where
-import Control.Applicative (Applicative(..), liftA2)
-import Control.Monad (Monad(..), mapM)
+import Control.Applicative (liftA2)
+import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Int (Int)
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (Seq)
+import Data.Sequence (ViewL(..))
import Data.String (String, IsString(..))
-import Data.Tuple (fst)
import Prelude (Num(..), error)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
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
+
+writePlain :: Roots -> TL.Text
+writePlain doc = text (setStart doc def) doc
-- * Type 'Plain'
type Plain = S.State State TLB.Builder
mappend = (<>)
runPlain :: Plain -> State -> TL.Text
-runPlain p s = TLB.toLazyText $ fst $ S.runState 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
-
-plainDocument :: Roots -> TL.Text
-plainDocument = text def
+text s a = runPlain (plainify a) s
-- ** Type 'State'
data State
= State
- { state_escape :: Bool -- FIXME: useful?
- , state_pos :: Pos
- , state_indent :: Int
+ { 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_pos = pos1
- , state_indent = 1
+ { 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
instance Plainify Char where
plainify = \case
'\n' -> do
- S.modify $ \s@State{state_pos=Pos line _col, state_indent} ->
- s{state_pos=Pos (line + 1) state_indent}
- indent <- S.gets state_indent
- return $ TLB.singleton '\n' <> fromString (List.replicate (indent - 1) ' ')
+ 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.modify' $ \s@State{state_pos=Pos line col} ->
s{state_pos=Pos line (col + 1)}
return $ TLB.singleton c
instance Plainify String where
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))}
+ 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) <>
plainify ts'
instance Plainify Pos where
plainify new@(Pos lineNew colNew) = do
- old@(Pos lineOld colOld) <- S.gets state_pos
- S.modify $ \s -> s{state_pos=new}
- case lineOld`compare`lineNew of
- LT ->
- return $
- fromString (List.replicate (lineNew - lineOld) '\n') <>
- fromString (List.replicate (colNew - 1) ' ')
- EQ | colOld <= colNew ->
- return $
- fromString (List.replicate (colNew - colOld) ' ')
- _ -> error $ "plainify: non-ascending Pos:"
- <> "\n old: " <> show old
- <> "\n new: " <> show new
+ 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 Root where
- plainify (Tree (Cell bp _ep nod) ts) =
+ plainify (Tree (Cell (Span{span_begin=bp}:|_) nod) ts) =
plainify bp <>
case nod of
- NodePara -> do
- ind <- S.gets state_indent
- S.modify $ \s -> s{state_indent = pos_column bp}
- r <- plainify ts
- S.modify $ \s -> s{state_indent=ind}
- return r
- NodeGroup -> plainify ts
- NodeHeader h -> plainify h <> plainify ts
- NodeToken t -> plainify t
+ ----------------------
+ 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
+ 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
- ind <- S.gets state_indent
- S.modify $ \s -> s{state_indent = pos_column bp}
+ 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=ind}
+ 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) | null ts = pairBordersWithoutContent p
- | otherwise = pairBorders p
- NodeLower n as ->
- "<" <> plainify n <> plainify as <> plainify ts
+ where (o,c) = pairBorders p ts
instance Plainify Header where
plainify hdr =
case hdr of
HeaderDash -> "- "
HeaderDashDash -> "-- "
HeaderSection lvl -> plainify (List.replicate lvl '#')
- HeaderDotSlash n -> "./" <> plainify n
+ HeaderDotSlash n -> plainify n
instance Plainify Token where
plainify = \case
TokenText t -> plainify t
, elemAttr_close
]
+{-
-- * Class 'RackUpLeft'
class RackUpLeft a where
rackUpLeft :: a -> S.State (Maybe Pos) a
}
instance RackUpLeft (Cell a) where
rackUpLeft (Cell bp ep a) = do
- S.modify $ \case
+ S.modify' $ \case
Nothing -> Just bp
p -> p
Cell
Tree
<$> rackUpLeft n
<*> rackUpLeft ts
+-}
sourcephile / git / doclang.git / blobdiff