{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.TCT.Write.Plain where import Control.Applicative (liftA2) 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 (($)) 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 (ViewL(..)) import Data.String (String, IsString(..)) 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 -- * Type 'Plain' 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 = plainify instance Semigroup Plain where (<>) = liftA2 (<>) instance Monoid Plain where mempty = return "" mappend = (<>) runPlain :: Plain -> State -> TL.Text runPlain p s = TLB.toLazyText $ S.evalState p s text :: Plainify a => State -> a -> TL.Text text s a = runPlain (plainify a) s document :: Roots -> TL.Text document doc = text (setStart doc def) doc -- ** Type 'State' data State = State { 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 = "" , 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 = foldMap plainify instance Plainify TL.Text 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 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 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 ] {- -- * 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 -}