{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.TreeSeq.Strict where
import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..), ap)
+import Control.Monad (Monad(..))
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Foldable (foldr)
import Data.Function (($), (.))
-import Data.Functor (Functor, (<$>))
-import Data.Maybe (Maybe(..))
+import Data.Functor (Functor(..), (<$>))
+import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..))
-import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Sequence as Seq
-import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
-- * Type 'Tree'
-data Tree k a
- = TreeN !k !(Trees k a)
- | Tree0 !a
- deriving (Eq, Ord, Show, Functor)
-
-instance Traversable (Tree k) where
- traverse f (Tree0 a) = Tree0 <$> f a
- traverse f (TreeN k ts) = TreeN k <$> traverse (traverse f) ts
- sequenceA (Tree0 a) = Tree0 <$> a
- sequenceA (TreeN k ts) = TreeN k <$> traverse sequenceA ts
-instance Foldable (Tree k) where
- foldMap f (TreeN _k ts) = foldMap (foldMap f) ts
- foldMap f (Tree0 a) = f a
-instance Applicative (Tree k) where
- pure = Tree0
- (<*>) = ap
-instance Monad (Tree k) where
- return = Tree0
- Tree0 v >>= f = f v
- TreeN k ts >>= f =
- TreeN k $ (>>= f) <$> ts
-
-isTree0 :: Tree k a -> Bool
-isTree0 Tree0{} = True
-isTree0 _ = False
-
-isTreeN :: Tree k a -> Bool
-isTreeN TreeN{} = True
-isTreeN _ = False
-
-unTree :: Tree a a -> a
-unTree (TreeN k _) = k
-unTree (Tree0 a) = a
-
+data Tree a
+ = Tree { unTree :: !a
+ , subTrees :: !(Trees a)
+ }
+ deriving (Eq, Ord, Show)
+instance Functor Tree where
+ fmap f (Tree a ts) = Tree (f a) (fmap (fmap f) ts)
+instance Applicative Tree where
+ pure a = Tree a mempty
+ Tree f tfs <*> ta@(Tree a tas) =
+ Tree (f a) (fmap (f <$>) tas <> fmap (<*> ta) tfs)
+instance Monad Tree where
+ return = pure
+ Tree a ts >>= f =
+ Tree a' (ts' <> fmap (>>= f) ts)
+ where Tree a' ts' = f a
+instance Foldable Tree where
+ foldMap f (Tree a ts) = f a `mappend` foldMap (foldMap f) ts
+instance Traversable Tree where
+ traverse f (Tree a ts) = Tree <$> f a <*> traverse (traverse f) ts
+ sequenceA (Tree a ts) = Tree <$> a <*> traverse sequenceA ts
+
+tree0 :: a -> Tree a
+tree0 a = Tree a mempty
+
+isTree0 :: Tree a -> Bool
+isTree0 (Tree _ ts) = null ts
+
+isTreeN :: Tree a -> Bool
+isTreeN (Tree _ ts) = not (null ts)
+
+{-
mapWithNode :: (Maybe k -> a -> b) -> Tree k a -> Tree k b
mapWithNode = go Nothing
where
- go _k f (TreeN k ts) = TreeN k (go (Just k) f <$> ts)
+ go _k f (Tree k ts) = Tree k (go (Just k) f <$> ts)
go k f (Tree0 a) = Tree0 (f k a)
mapAlsoNode :: (k -> l) -> (Maybe k -> a -> b) -> Tree k a -> Tree l b
mapAlsoNode fk fv = go Nothing
where
- go _k (TreeN k ts) = TreeN (fk k) $ go (Just k) <$> ts
+ go _k (Tree k ts) = Tree (fk k) $ go (Just k) <$> ts
go k (Tree0 a) = Tree0 (fv k a)
traverseWithNode :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b)
traverseWithNode = go Nothing
where
- go _p f (TreeN k ts) = TreeN k <$> traverse (go (Just k) f) ts
+ go _p f (Tree k ts) = Tree k <$> traverse (go (Just k) f) ts
go p f (Tree0 a) = Tree0 <$> f p a
foldlWithTree :: (b -> Tree k a -> b) -> b -> Tree k a -> b
foldlWithTree f b t =
case t of
- TreeN _k ts -> foldl' (foldlWithTree f) (f b t) ts
+ Tree _k ts -> foldl' (foldlWithTree f) (f b t) ts
Tree0{} -> f b t
bindTree :: Tree k a -> (Tree k a -> Tree l b) -> Tree l b
bindTree t f =
case t of
Tree0{} -> f t
- TreeN _k ks ->
+ Tree _k ks ->
case f t of
u@Tree0{} -> u
- TreeN l ls -> TreeN l $ ls <> ((`bindTree` f) <$> ks)
+ Tree l ls -> Tree l $ ls <> ((`bindTree` f) <$> ks)
bindTrees :: Tree k a -> (Tree k a -> Trees l b) -> Trees l b
bindTrees t f =
case t of
Tree0{} -> f t
- TreeN _k ks ->
+ Tree _k ks ->
f t >>= \fs ->
case fs of
Tree0 b -> Seq.singleton $ Tree0 b
- TreeN l ls -> pure $ TreeN l $ ls <> (ks >>= (`bindTrees` f))
+ Tree l ls -> pure $ Tree l $ ls <> (ks >>= (`bindTrees` f))
joinTrees :: Trees k (Trees k a) -> Trees k a
joinTrees ts =
ts >>= \case
Tree0 s -> s
- TreeN k ks -> Seq.singleton $ TreeN k $ joinTrees ks
+ Tree k ks -> Seq.singleton $ Tree k $ joinTrees ks
+-}
-- * Type 'Trees'
-type Trees k a = Seq (Tree k a)
+type Trees a = Seq (Tree a)
-- * Type 'Pretty'
-newtype Pretty k a = Pretty (Trees k a)
-instance (Show k, Show a) => Show (Pretty k a) where
- show (Pretty t) = Text.unpack $ prettyTrees t
+newtype Pretty a = Pretty a
+instance Show a => Show (Pretty (Trees a)) where
+ show (Pretty t) = TL.unpack $ prettyTrees t
+instance Show a => Show (Pretty (Tree a)) where
+ show (Pretty t) = TL.unpack $ prettyTree t
-prettyTree :: (Show k, Show a) => Tree k a -> Text
-prettyTree = Text.unlines . pretty
+prettyTree :: Show a => Tree a -> TL.Text
+prettyTree = TL.unlines . pretty
-prettyTrees :: (Show k, Show a) => Trees k a -> Text
+prettyTrees :: Show a => Trees a -> TL.Text
prettyTrees = foldr (\t acc -> prettyTree t <> "\n" <> acc) ""
-pretty :: (Show k, Show a) => Tree k a -> [Text]
-pretty (Tree0 a) = [Text.pack (show a)]
-pretty (TreeN k ts0) = Text.pack (show k) : prettySubTrees ts0
+pretty :: Show a => Tree a -> [TL.Text]
+pretty (Tree a ts0) = TL.pack (show a) : prettySubTrees ts0
where
prettySubTrees s =
case Seq.viewl s of
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.TCT.Cell where
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor (Functor)
-import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
--- import Data.Semigroup (Semigroup(..))
-import Data.Sequence (Seq, ViewL(..), ViewR(..))
-import Data.TreeSeq.Strict (Tree(..))
-import Prelude (Int)
+import Data.Semigroup (Semigroup(..))
+import Data.Text (Text)
+import Prelude (Int, Num(..), fromIntegral)
import Text.Show (Show(..), showParen, showString, showChar)
-import qualified Data.Sequence as Seq
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
+
+-- * Type 'Pos'
+-- | Relative position
+data Pos
+ = Pos
+ { pos_line :: {-# UNPACK #-} !LineNum
+ , pos_column :: {-# UNPACK #-} !ColNum
+ } deriving (Eq)
+instance Semigroup Pos where
+ Pos lx cx <> Pos ly cy =
+ Pos (lx+ly) (cx+cy)
+instance Monoid Pos where
+ mempty = Pos 0 0
+ mappend = (<>)
+instance Show Pos where
+ showsPrec _p Pos{..} =
+ showsPrec 11 pos_line .
+ showChar ':' .
+ showsPrec 11 pos_column
+
+-- ** Type 'LineNum'
+type LineNum = Int
+
+-- ** Type 'ColNum'
+type ColNum = Int
-- * Type 'Cell'
--- | NOTE: every 'Cell' as a 'Pos',
--- which is useful to indicate matches/errors/warnings/whatever,
--- or outputing in a format somehow preserving
--- the original input style.
data Cell a
= Cell
- { posCell :: {-# UNPACK #-} !Pos
- , posEndCell :: {-# UNPACK #-} !Pos
- , unCell :: a
- } deriving (Eq, Ord, Functor)
+ { cell_begin :: {-# UNPACK #-} !Pos
+ , cell_end :: {-# UNPACK #-} !Pos
+ , unCell :: !a
+ } deriving (Eq, Functor)
instance Show a => Show (Cell a) where
showsPrec p Cell{..} =
showParen (p >= 10) $
showString "Cell" .
- showChar ' ' . showsPrec 10 posCell .
- showChar ' ' . showsPrec 10 posEndCell .
+ showChar ' ' . showsPrec 10 cell_begin .
+ showChar ' ' . showsPrec 10 cell_end .
showChar ' ' . showsPrec 11 unCell
+instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
+ Cell bx (Pos lx _cx) x <> Cell (Pos ly cy) ey y =
+ Cell bx ey $ x <> fromPad (Pos (ly - lx) cy) <> y
+instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where
+ mempty = cell0 mempty
+ mappend = (<>)
+cell0 :: a -> Cell a
+cell0 = Cell mempty mempty
+
+-- * Class 'FromPad'
+class FromPad a where
+ fromPad :: Pos -> a
+instance FromPad Text where
+ fromPad Pos{..} =
+ Text.replicate pos_line "\n" <>
+ Text.replicate pos_column " "
+instance FromPad TL.Text where
+ fromPad Pos{..} =
+ TL.replicate (fromIntegral pos_line) "\n" <>
+ TL.replicate (fromIntegral pos_column) " "
+
{-
-instance Semigroup a => Semigroup (Cell a) where
+instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
Cell bx ex x <> Cell by ey y =
- Cell (bx`min`by) (ex`max`ey) (x<>y)
-instance (Monoid a, Semigroup a) => Monoid (Cell a) where
- mempty = Cell pos1 pos1 mempty
- mappend = (<>)
+ Cell bx ey $ x <> fromPad by <> y
+instance Applicative Cell where
+ pure = Cell mempty mempty
+ Cell of_ sf f <*> Cell bx ex x =
+ Cell of_ (sf<>bx<>ex) (f x)
+
+cell0 :: a -> Cell a
+cell0 = pure
+
+-- * Class 'Cellified'
+class Cellified a where
+ reachOf :: a -> Pos
+ reachOf a = offsetOf a <> sizeOf a
+ offsetOf :: a -> Pos
+ sizeOf :: a -> Pos
+instance Cellified (Cell a) where
+ offsetOf = cell_begin
+ sizeOf = cell_end
+instance Cellified a => Cellified [a] where
+ reachOf = foldMap reachOf
+ offsetOf = \case
+ [] -> mempty
+ s0 : ss ->
+ if sizeOf s0 == mempty
+ then offsetOf s0 <> offsetOf ss
+ else offsetOf s0
+ sizeOf = foldMap sizeOf
+instance Cellified a => Cellified (Seq a) where
+ reachOf = foldMap reachOf
+ offsetOf s = case Seq.viewl s of
+ EmptyL -> mempty
+ s0 :< ss ->
+ if sizeOf s0 == mempty
+ then offsetOf s0 <> offsetOf ss
+ else offsetOf s0
+ sizeOf = foldMap sizeOf
+instance (Cellified k, Cellified a) => Cellified (Tree k a) where
+ reachOf = \case
+ TreeN k _ts -> reachOf k
+ Tree0 a -> reachOf a
+ offsetOf = \case
+ TreeN k _ts -> offsetOf k
+ Tree0 a -> offsetOf a
+ sizeOf = \case
+ TreeN k _ts -> sizeOf k
+ Tree0 a -> sizeOf a
+-}
+
+{-
+-- * Class 'Cellify'
+class Cellify a where
+ cellify :: a -> Cell a
+instance Cellify Text where
+ cellify t = Cell mempty s t
+ where
+ s =
+ Text.foldl' (\acc -> \case
+ '\n' -> acc{pos_line = pos_line acc + 1}
+ _ -> acc{pos_column = pos_column acc + 1})
+ mempty t
+
+-- * Type 'Pad'
+type Pad = Pos
+
+-- * Type 'Padded'
+data Padded a
+ = Padded
+ { pad :: !Pad
+ , unPad :: !a
+ } deriving (Eq,Show)
+
+
+-- * Type 'Pos'
+-- | Absolute position
+data Pos
+ = Pos
+ { pos_line :: {-# UNPACK #-} !LineNum
+ , pos_column :: {-# UNPACK #-} !ColNum
+ } deriving (Eq, Ord)
+instance Show Pos where
+ showsPrec _p Pos{..} = showsPrec 11 (pos_line,pos_column)
+
+pos1 :: Pos
+pos1 = Pos 1 1
+
-}
-lineCell :: Cell a -> Line
-lineCell = linePos . posCell
-columnCell :: Cell a -> Column
-columnCell = columnPos . posCell
-cell0 :: a -> Cell a
-cell0 = Cell pos0 pos0
+
+
+
+
+{-
+instance Applicative (Cell a) where
+ pure = cell0
+ cf@(Cell bf ef f) <*> ca@(Cell ba ea a) =
+ | isCell0 cf || isCell0 ca = cell0 (f a)
+ Cell bf ea (f a)
+isCell0 :: Cell a -> Bool
+isCell0 (Cell bp ep _) = isPos0 bp && isPos0 ep
+-}
+
+{-
+lineCell :: Cell a -> LineNum
+lineCell = pos_line . cell_begin
+columnCell :: Cell a -> ColNum
+columnCell = pos_column . cell_begin
+
cell1 :: a -> Cell a
cell1 = Cell pos1 pos1
+-}
+{-
posSeq :: Seq (Cell a) -> Maybe (Pos,Pos)
posSeq toks =
case Seq.viewl toks of
EmptyR -> Nothing
_ :> Cell _bp ep _ ->
Just (bp, ep)
-
-{-
posTrees :: Seq (Trees (Cell k) a) -> Maybe (Pos,Pos)
posTrees trees =
case Seq.viewl trees of
Just (Cell bp ep ())
-}
--- * Type 'Pos'
-data Pos
- = Pos
- { linePos :: {-# UNPACK #-} !Line
- , columnPos :: {-# UNPACK #-} !Column
- } deriving (Eq, Ord)
-instance Show Pos where
- showsPrec _p Pos{..} = showsPrec 11 (linePos,columnPos)
{-
-instance Ord Pos where
- Pos lx cx `compare` Pos ly cy =
- compare lx ly <>
- compare cx cy
--}
-
posTree :: Tree (Cell k) (Cell a) -> Pos
-posTree (TreeN c _) = posCell c
-posTree (Tree0 c) = posCell c
+posTree (TreeN c _) = cell_begin c
+posTree (Tree0 c) = cell_begin c
posEndTree :: Tree (Cell k) (Cell a) -> Pos
-posEndTree (TreeN c _) = posEndCell c
-posEndTree (Tree0 c) = posEndCell c
+posEndTree (TreeN c _) = cell_end c
+posEndTree (Tree0 c) = cell_end c
pos0 :: Pos
pos0 = Pos 0 0
-pos1 :: Pos
-pos1 = Pos 1 1
+-}
+{-
+instance Ord Pos where
+ Pos lx cx `compare` Pos ly cy =
+ compare lx ly <>
+ compare cx cy
--- ** Type 'Line'
--- | Line in the source file, counting from 1.
-type Line = Int
+isPos0 :: Pos -> Bool
+isPos0 (Pos 0 0 ) = True
+isPos0 _ = False
+-}
--- ** Type 'Column'
--- | Column in the source file, counting from 1.
-type Column = Int
+{-
+-- ** Class 'CellOf'
+class CellOf a where
+ firstCellOf :: a -> Maybe (Cell ())
+instance CellOf (Cell a) where
+ firstCellOf = Just . (() <$)
+instance CellOf a => CellOf (Seq a) where
+ firstCellOf s =
+ case Seq.viewl s of
+ EmptyL -> Nothing
+ s0 :< ss ->
+ firstCellOf s0 <|>
+ firstCellOf ss
+instance CellOf a => CellOf [a] where
+ firstCellOf = \case
+ [] -> Nothing
+ s0 : ss ->
+ firstCellOf s0 <|>
+ firstCellOf ss
+instance (CellOf k, CellOf a) => CellOf (Tree k a) where
+ firstCellOf = \case
+ Tree0 a -> firstCellOf a
+ TreeN k a -> firstCellOf k <|> firstCellOf a
+-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.TCT.Elem where
+import Data.Bool
+import Control.Monad (Monad(..), mapM)
import Data.Eq (Eq)
+import Data.Function (($), (.))
+import Data.Foldable (toList, null)
+import Data.Int (Int)
import Data.Ord (Ord)
+import Data.Maybe (Maybe(..))
+import Prelude ((+))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
-import Data.Text (Text)
+import Data.Sequence (Seq)
import Text.Show (Show(..))
+import Data.TreeSeq.Strict (Tree(..))
+import qualified Control.Monad.Trans.Reader as R
+import qualified Data.List as List
+import qualified Data.Text.Lazy as TL
+
+import Debug.Trace (trace)
--- import Debug.Trace (trace)
trac :: String -> a -> a
-trac _m x = x
--- trac m x = trace m x
+-- trac _m x = x
+trac = trace
{-# INLINE trac #-}
-dbg :: Show a => String -> a -> a
-dbg m x = trac (m <> ": " <> show x) x
+
+debug :: Pretty a => String -> String -> a -> b -> b
+debug f n a = trac (f <> ": " <> n <> " = " <> R.runReader (pretty a) 2)
+
+dbg :: Pretty a => String -> a -> a
+dbg m x = trac (m <> ": " <> R.runReader (pretty x) 2) x
{-# INLINE dbg #-}
--- * Type 'Elem'
-type Elem = Text
+-- * Class 'Pretty'
+class Pretty a where
+ pretty :: a -> R.Reader Int String
+instance Pretty Int where
+ pretty = return . show
+instance Pretty TL.Text where
+ pretty = return . show
+instance (Pretty a, Pretty b) => Pretty (a,b) where
+ pretty (a,b) = do
+ i <- R.ask
+ a' <- R.local (+2) $ pretty a
+ b' <- R.local (+2) $ pretty b
+ return $
+ "\n" <> List.replicate i ' ' <> "( " <> a' <>
+ "\n" <> List.replicate i ' ' <> ", " <> b' <>
+ "\n" <> List.replicate i ' ' <> ") "
+instance Pretty a => Pretty [a] where
+ pretty [] = return "[]"
+ pretty as = do
+ i <- R.ask
+ s <- R.local (+2) $ mapM pretty as
+ return $
+ "\n" <> List.replicate i ' ' <> "[ " <>
+ List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
+ "\n" <> List.replicate i ' ' <> "] "
+instance Pretty a => Pretty (Seq a) where
+ pretty ss
+ | null ss = return "[]"
+ | otherwise = do
+ let as = toList ss
+ i <- R.ask
+ s <- R.local (+2) $ mapM pretty as
+ return $
+ "\n" <> List.replicate i ' ' <> "[ " <>
+ List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
+ "\n" <> List.replicate i ' ' <> "] "
+instance Pretty a => Pretty (Maybe a) where
+ pretty Nothing = return "Nothing"
+ pretty (Just m) = do
+ s <- pretty m
+ return $ "Just "<>s
+instance Show a => Pretty (Tree a) where
+ pretty (Tree n ts) = do
+ s <- R.local (+2) (pretty ts)
+ return $ "Tree "<>showsPrec 11 n ""<>" "<>s
+
+-- * Type 'ElemName'
+type ElemName = TL.Text
--- ** Type 'Attr'
-data Attr
- = Attr
- { attr_name :: !Text
- , attr_open :: !Text
- , attr_value :: !Text
- , attr_close :: !Text
+-- ** Type 'ElemAttr'
+data ElemAttr
+ = ElemAttr
+ { elemAttr_name :: !TL.Text
+ , elemAttr_open :: !TL.Text
+ , elemAttr_value :: !TL.Text
+ , elemAttr_close :: !TL.Text
}
deriving (Eq,Ord,Show)
-- ** Type 'White'
-type White = Text
+type White = TL.Text
--- ** Type 'Attrs'
-type Attrs = [(White,Attr)]
+-- ** Type 'ElemAttrs'
+type ElemAttrs = [(White,ElemAttr)]
, module Language.TCT.Read
) where
-import Control.Monad (Monad(..), join)
import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..), join)
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.))
-import Data.Functor (Functor(..), (<$>))
-import Data.Foldable (toList)
+import Data.Functor ((<$>), (<$))
+import Data.Foldable (Foldable(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (Seq)
import Data.String (IsString)
-import Data.Text (Text)
import Data.Traversable (Traversable(..))
-import Data.TreeSeq.Strict (Tree)
-import Data.Tuple (snd)
+import Data.TreeSeq.Strict (Tree(..), Trees)
import Data.Void (Void)
import System.IO (FilePath)
import Text.Show (Show(..))
-import qualified Data.Text as Text
-import qualified Text.Megaparsec as P
-import qualified Data.Sequence as Seq
+import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as Tree
+import qualified Text.Megaparsec as P
+-- import qualified Data.List as List
import Language.TCT.Tree
-import Language.TCT.Token
import Language.TCT.Cell
import Language.TCT.Read.Cell
import Language.TCT.Read.Tree
import Debug.Trace (trace)
--- * Type 'TCT'
-type TCT = Tree (Cell Key) Tokens
-
--- * Type 'TCTs'
-type TCTs = Seq TCT
-
-readTCTs ::
- FilePath -> Text ->
- Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) TCTs
-readTCTs inp txt = do
+readTrees ::
+ FilePath -> TL.Text ->
+ Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) (Trees (Cell Node))
+readTrees inp txt = do
trs <- P.runParser (p_Trees <* P.eof) inp txt
- traverse (go Nothing) $ trace ("### TRS ###\n"<>show (Tree.Pretty trs)) trs
+ {-(join <$>) $ -}
+ traverse (go Nothing) $
+ trace ("### TRS ###\n"<>show (Tree.Pretty trs)) trs
where
go ::
- Maybe Key ->
- Tree (Cell Key) (Cell Value) ->
- Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) TCT
- go k (Tree0 v) =
- case k of
- Just KeyBar{} -> Right $ Tree0 $ tokens [Tree0 $ TokenPlain <$> v]
- Just KeyLower{} -> Right $ Tree0 $ tokens [Tree0 $ TokenPlain <$> v]
- Just KeyEqual{} -> Right $ Tree0 $ tokens [Tree0 $ TokenPlain <$> v]
- _ -> Tree0 . parseTokens <$> parseLexemes v
- go _ (TreeN c@(unCell -> key) ts) =
- case key of
- KeyBar{} -> TreeN c <$> traverse (go (Just key)) ts
- KeyLower{} -> TreeN c <$> traverse (go (Just key)) ts
- KeyEqual{} -> TreeN c <$> traverse (go (Just key)) ts
- KeyPara -> do
- ls <-
- (`traverse` Seq.reverse ts) $ \case
- Tree0 v -> parseLexemes v
- TreeN ck@(unCell -> k) vs ->
- (pure . LexemeTree . TreeN ck <$>) $
- traverse (go (Just k)) vs
- let toks = parseTokens $ join $ toList ls
- return $ Tree0 toks
- _ -> TreeN c <$> traverse (go (Just key)) ts
- parseLexemes ::
- Cell Value ->
- Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) [Lexeme]
- parseLexemes (Cell bp _ep v) =
- snd $
- P.runParser'
- (p_Lexemes <* P.eof)
- P.State
- { P.stateInput = v
- , P.statePos = pure $ P.SourcePos inp
- (P.mkPos $ linePos bp)
- (P.mkPos $ columnPos bp)
- , P.stateTabWidth = P.pos1
- , P.stateTokensProcessed = 0
- }
-
--- * Type 'StreamCell'
--- | Wrap 'Text' to have a 'P.Stream' instance
--- whose 'P.advance1' method abuses the tab width state
--- to instead pass the line indent.
--- This in order to report correct 'P.SourcePos'
--- when parsing a 'Cell' containing newlines.
-newtype StreamCell = StreamCell { unStreamCell :: Text }
- deriving (IsString,Eq,Ord)
-instance P.Stream StreamCell where
- type Token StreamCell = Char
- type Tokens StreamCell = StreamCell
- take1_ (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
- takeN_ n (StreamCell t) =
- (\(ts,s) -> (StreamCell ts, StreamCell s)) <$>
- P.takeN_ n t
- takeWhile_ f (StreamCell t) =
- (\(ts,s) -> (StreamCell ts, StreamCell s)) $
- P.takeWhile_ f t
- tokensToChunk _s ts = StreamCell (P.tokensToChunk (Proxy::Proxy Text) ts)
- chunkToTokens _s (StreamCell ch) = P.chunkToTokens (Proxy::Proxy Text) ch
- chunkLength _s (StreamCell ch) = P.chunkLength (Proxy::Proxy Text) ch
- advance1 _s = advance1
- advanceN _s indent pos (StreamCell t) = Text.foldl' (advance1 indent) pos t
-
-advance1 :: P.Pos -> P.SourcePos -> Char -> P.SourcePos
-advance1 indent (P.SourcePos n line col) c =
- case c of
- '\n' -> P.SourcePos n (line <> P.pos1) indent
- _ -> P.SourcePos n line (col <> P.pos1)
+ Maybe Node ->
+ Tree (Cell Node) ->
+ Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void))
+ (Tree (Cell Node))
+ go p t@(Tree c@(Cell bn en nod) ts) =
+ case nod of
+ NodeGroup{} -> Tree c <$> traverse (go (Just nod)) ts
+ NodeHeader{} -> Tree c <$> traverse (go (Just nod)) ts
+ NodeToken{} -> Tree c <$> traverse (go (Just nod)) ts
+ NodePair{} -> Tree c <$> traverse (go (Just nod)) ts
+ NodePara{} -> Tree c <$> traverse (go (Just nod)) ts
+ NodeLower{} -> Right t
+ -- NodeText n | TL.null n -> Right t
+ NodeText n ->
+ case p of
+ Just (NodeHeader HeaderBar{}) -> Right t
+ Just (NodeHeader HeaderEqual{}) -> Right t
+ _ -> do
+ toks <- parseTokens <$> parseLexemes inp (n <$ c)
+ return $
+ case toList toks of
+ [tok] -> tok
+ _ -> Tree (Cell bn en NodeGroup) toks
+ {-
+ NodeHeader _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts
+ NodeToken _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts
+ NodePair _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts
+ NodeLower{} -> Right $ pure t
+ NodeText n | TL.null n -> Right $ pure t
+ NodeText n ->
+ case p of
+ Just (NodeHeader HeaderBar{}) -> Right $ pure t
+ Just (NodeHeader HeaderEqual{}) -> Right $ pure t
+ _ -> do
+ acc <- parseLexemes inp (n <$ c)
+ sn <- traverse (go (Just nod)) ts
+ return $ parseTokens $
+ foldr (\s a -> orientLexemePairAny $ LexemeTree s:a) acc (join sn)
+ -}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
module Language.TCT.Read.Cell where
+import Control.Applicative (Applicative(..))
import Data.Char (Char)
import Data.Either (Either(..))
+import Data.Eq (Eq)
import Data.Function (($), (.))
import Data.Functor ((<$>))
-import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord)
+import Data.Proxy (Proxy(..))
+import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString)
-import Prelude (Num(..), toInteger)
+import Data.Tuple (snd)
+import System.FilePath (FilePath)
import Text.Show (Show)
import qualified Data.Set as Set
+import qualified Data.Text.Lazy as TL
import qualified Text.Megaparsec as P
import Language.TCT.Cell
-- * Type 'Parser'
-- | Convenient alias.
-type Parser e s a =
+type Parser e s a =
+ Parsable e s a =>
+ P.Parsec e s a
+
+-- ** Type 'Parsable'
+type Parsable e s a =
( P.Stream s
, P.Token s ~ Char
, Ord e
, IsString (P.Tokens s)
, P.ShowErrorComponent e
- ) => P.Parsec e s a
+ )
+-- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
p_satisfyMaybe f = check `P.token` Nothing
where
p_Position :: Parser e s Pos
p_Position = (<$> P.getPosition) $ \p ->
Pos
- (intOfPos $ P.sourceLine p)
- (intOfPos $ P.sourceColumn p)
-intOfPos :: P.Pos -> Int
-intOfPos = fromInteger . toInteger . P.unPos
+ { pos_line = P.unPos $ P.sourceLine p
+ , pos_column = P.unPos $ P.sourceColumn p
+ }
+
+p_Cell :: Parser e s a -> Parser e s (Cell a)
+p_Cell pa =
+ (\b a e -> Cell b e a)
+ <$> p_Position
+ <*> pa
+ <*> p_Position
+
+p_LineNum :: Parser e s LineNum
+p_LineNum = P.unPos . P.sourceLine <$> P.getPosition
+
+p_ColNum :: Parser e s ColNum
+p_ColNum = P.unPos . P.sourceColumn <$> P.getPosition
+
+-- | Wrapper around |P.runParser'|
+-- to use given 'Cell' as starting position.
+runParserOnCell ::
+ Parsable e StreamCell a =>
+ FilePath ->
+ Parser e StreamCell a ->
+ Cell TL.Text ->
+ Either (P.ParseError (P.Token StreamCell) e) a
+runParserOnCell inp p (Cell bp _ep s) =
+ snd $ P.runParser' (p <* P.eof)
+ P.State
+ { P.stateInput = StreamCell s
+ , P.statePos = pure $ P.SourcePos inp (P.mkPos $ pos_line bp) indent
+ , P.stateTabWidth = indent
+ , P.stateTokensProcessed = 0
+ }
+ where indent = P.mkPos $ pos_column bp
-p_LineNum :: Parser e s Line
-p_LineNum = intOfPos . P.sourceLine <$> P.getPosition
+-- * Type 'StreamCell'
+-- | Wrap 'TL.Text' to have a 'P.Stream' instance
+-- whose 'P.advance1' method abuses the tab width state
+-- to instead pass the line indent.
+-- This in order to report correct 'P.SourcePos'
+-- when parsing a 'Cell' containing newlines.
+newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
+ deriving (IsString,Eq,Ord)
+instance P.Stream StreamCell where
+ type Token StreamCell = Char
+ type Tokens StreamCell = TL.Text
+ take1_ (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
+ takeN_ n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
+ takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
+ tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text)
+ chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text)
+ chunkLength _s = P.chunkLength (Proxy::Proxy TL.Text)
+ advance1 _s indent (P.SourcePos n line col) c =
+ case c of
+ '\n' -> P.SourcePos n (line <> P.pos1) indent
+ _ -> P.SourcePos n line (col <> P.pos1)
+ advanceN s indent = TL.foldl' (P.advance1 s indent)
-p_ColNum :: Parser e s Column
-p_ColNum = intOfPos . P.sourceColumn <$> P.getPosition
-- * Debug
pdbg :: Show a => String -> Parser e s a -> Parser e s a
--- pdbg m p = P.dbg m p
-pdbg _m p = p
+pdbg = P.dbg
+-- pdbg _m p = p
{-# INLINE pdbg #-}
module Language.TCT.Read.Elem where
import Control.Applicative (Applicative(..), Alternative(..))
-import Control.Monad ((>>))
+import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Function (($))
-import Data.Functor ((<$>))
+import Data.Functor ((<$>), (<$))
+import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
-import Data.Text (Text)
import qualified Data.Char as Char
-import qualified Data.Text as Text
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
+import qualified Data.Text.Lazy as TL
import Language.TCT.Elem
+import Language.TCT.Tree
import Language.TCT.Read.Cell
-p_Attrs :: Parser e s [(Text,Attr)]
-p_Attrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_Attr
-p_Attr :: Parser e s Attr
-p_Attr = P.try p_Attr_Eq <|> p_Attr_Word
-p_Spaces :: Parser e s Text
-p_Spaces = Text.pack <$> P.some (P.satisfy Char.isSpace)
-p_Attr_Eq :: Parser e s Attr
-p_Attr_Eq =
- (\n (o,v,c) -> Attr n ("="<>o) v c)
- <$> p_Word
+-- * Word
+p_Spaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Spaces = P.takeWhileP (Just "Space") Char.isSpace
+p_Spaces1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Spaces1 = P.takeWhile1P (Just "Space") Char.isSpace
+p_HSpaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_HSpaces = P.takeWhileP (Just "HSpace") (==' ')
+p_Digits :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Digits = P.takeWhile1P (Just "Digit") Char.isDigit
+p_AlphaNums :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_AlphaNums = P.takeWhile1P (Just "AlphaNum") Char.isAlphaNum
+{-
+-- NOTE: could be done with TL.Text, which has a less greedy (<>).
+p_Word :: Parser e Text Text
+p_Word = pdbg "Word" $ P.try p_take <|> p_copy
+ where
+ p_take = do
+ P.notFollowedBy $ P.satisfy $ not . Char.isAlphaNum
+ w <- P.takeWhile1P (Just "Word") $ \c ->
+ Char.isAlphaNum c ||
+ c == '_' ||
+ c == '-'
+ guard $ Char.isAlphaNum $ Text.last w
+ return w
+ p_copy =
+ (<>)
+ <$> p_AlphaNums
+ <*> P.option "" (P.try $
+ (<>)
+ <$> ((Text.pack <$>) $ P.some $ P.char '_' <|> P.char '-')
+ <*> p_copy)
+-}
+
+-- * Elem
+p_ElemSingle :: P.Tokens s ~ TL.Text => Parser e s Pair
+p_ElemSingle = pdbg "ElemSingle" $
+ PairElem
+ <$ P.char '<'
+ <*> p_ElemName
+ <*> p_ElemAttrs
+ <* P.string "/>"
+
+p_ElemOpen :: P.Tokens s ~ TL.Text => Parser e s Pair
+p_ElemOpen = pdbg "ElemOpen" $
+ PairElem
+ <$ P.char '<'
+ <*> p_ElemName
+ <*> p_ElemAttrs
+ <* P.char '>'
+
+p_ElemName :: P.Tokens s ~ TL.Text => Parser e s ElemName
+p_ElemName = p_AlphaNums
+ -- TODO: namespace
+
+p_ElemClose :: P.Tokens s ~ TL.Text => Parser e s Pair
+p_ElemClose = pdbg "ElemClose" $
+ (`PairElem` [])
+ <$ P.string "</"
+ <*> p_ElemName
+ <* P.char '>'
+
+{-
+p_ElemOpenOrSingle :: Parser e Text Pair
+p_ElemOpenOrSingle =
+ p_ElemOpen >>= \p ->
+ P.char '>' $> LexemePairOpen p <|>
+ P.string "/>" $> LexemePairAny p
+-}
+
+-- * 'ElemAttr'
+p_ElemAttrs :: P.Tokens s ~ TL.Text => Parser e s [(White,ElemAttr)]
+p_ElemAttrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_ElemAttr
+p_ElemAttr :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
+p_ElemAttr = P.try p_ElemAttrEq <|> p_ElemAttrName
+
+p_ElemAttrEq :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
+p_ElemAttrEq =
+ (\n (o,v,c) -> ElemAttr n ("="<>o) v c)
+ <$> p_ElemName
<* P.char '='
- <*> p_Attr_Value
-p_Attr_Word :: Parser e s Attr
-p_Attr_Word =
- (\(o,v,c) -> Attr "" o v c)
- <$> p_Attr_Value_Word
-p_Attr_Value :: Parser e s (Text,Text,Text)
-p_Attr_Value =
- p_Attr_Value_Quote '\'' <|>
- p_Attr_Value_Quote '"' <|>
- p_Attr_Value_Word
-p_Attr_Value_Quote :: Char -> Parser e s (Text,Text,Text)
-p_Attr_Value_Quote q =
- (\o v c -> (Text.singleton o, Text.pack v, Text.singleton c))
+ <*> p_ElemAttrValue
+p_ElemAttrName :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
+p_ElemAttrName =
+ (\n -> ElemAttr n "" "" "")
+ <$> p_ElemName
+
+p_ElemAttrValue :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
+p_ElemAttrValue =
+ p_ElemAttrValueQuote '\'' <|>
+ p_ElemAttrValueQuote '"' <|>
+ p_ElemAttrValueWord
+
+p_ElemAttrValueQuote :: Char -> P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
+p_ElemAttrValueQuote q =
+ (\o v c -> (TL.singleton o, v, TL.singleton c))
<$> P.char q
- <*> P.many (
- P.notFollowedBy (P.string "/>") >>
- P.satisfy (\c -> Char.isPrint c && c /= '>' && c/=q))
+ <*> P.takeWhile1P (Just "ElemAttrValueQuoted") (/=q)
<*> P.char q
-p_Attr_Value_Word :: Parser e s (Text,Text,Text)
-p_Attr_Value_Word =
- (\v -> ("", Text.pack v, ""))
- <$> P.many (P.satisfy Char.isAlphaNum)
-
-p_Word :: Parser e s Text
-p_Word = pdbg "Word" $
- (<>)
- <$> p_plain
- <*> P.option "" (p_plain <|> p_link)
- where
- p_link = P.try $
- (<>)
- <$> (Text.pack <$> P.some (P.satisfy (\c -> c=='_' || c=='-')))
- <*> p_plain
- p_plain =
- Text.pack
- <$> P.some (P.satisfy $ \c ->
- Char.isLetter c ||
- Char.isNumber c
- )
+p_ElemAttrValueWord :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
+p_ElemAttrValueWord = do
+ w <- P.takeWhile1P (Just "ElemAttrValueWord") $ \c ->
+ Char.isPrint c &&
+ not (Char.isSpace c) &&
+ c /= '\'' &&
+ c /= '"' &&
+ c /= '=' &&
+ c /= '/' &&
+ c /= '<' &&
+ c /= '>'
+ return ("",w,"")
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Read.Token where
--- import Data.Text.Buildable (Buildable(..))
--- import qualified Data.Text.Lazy as TL
--- import qualified Data.Text.Lazy.Builder as Builder
import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
-import Data.Int (Int)
import Data.Eq (Eq(..))
-import Data.Ord (Ord(..))
+import Data.Either (Either(..))
import Data.Foldable (Foldable(..))
-import Data.Sequence (Seq)
import Data.Function (($), (.))
-import Data.Functor ((<$>), ($>), (<$))
+import Data.Functor ((<$>), ($>))
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (ViewL(..), (<|))
-import Data.Text (Text)
-import Data.TreeSeq.Strict (Tree(..))
+import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>))
+import Data.String (String)
+import Data.TreeSeq.Strict (Tree(..), Trees)
import Data.Tuple (fst,snd)
+import Data.Void (Void)
import Prelude (Num(..))
import Text.Show (Show(..))
import qualified Data.Char as Char
+import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
-import qualified System.FilePath as FP
import Language.TCT.Cell
import Language.TCT.Elem
+-- import Language.TCT.Token
+import Language.TCT.Tree
import Language.TCT.Read.Elem
import Language.TCT.Read.Cell
--- * Type 'Row'
--- | In normal order: a list of 'Key's, maybe ended by 'Value', all read on the same line.
-type Row = [Tree (Cell Key) (Cell Value)]
-
--- * Type 'Key'
-data Key
- = KeyColon !Name !White -- ^ @name: @
- | KeyEqual !Name !White -- ^ @name=@
- | KeyBar !Name !White -- ^ @name|@
- | KeyGreat !Name !White -- ^ @name>@
- | KeyLower !Name !Attrs -- ^ @<name a=b@
- | KeyDot !Name -- ^ @1. @
- | KeyDash -- ^ @- @
- | KeyDashDash -- ^ @-- @
- | KeySection !LevelSection -- ^ @# @
- | KeyBrackets !Name -- ^ @[name]@
- | KeyDotSlash !PathFile -- ^ @./file @
- | KeyPara
- deriving (Eq, Ord, Show)
-
--- ** Type 'Name'
-type Name = Text
-
--- ** Type 'Value'
-type Value = Text
-
--- ** Type 'PathFile'
-type PathFile = FP.FilePath
-
--- ** Type 'LevelSection'
-type LevelSection = Int
-
--- * Type 'Rows'
--- | In reverse order: a list of nodes in scope
--- (hence to which the next line can append to).
-type Rows = [Tree (Cell Key) (Cell Value)]
-
--- * Type 'Token'
-type Token = Tree (Cell TokenKey) (Cell TokenValue)
-
--- ** Type 'Tokens'
-type Tokens = Seq Token
-
--- ** Type 'TokenKey'
-type TokenKey = Pair
-data Pair
- = PairHash -- ^ @#value#@
- | PairElem !Elem !Attrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
- | PairStar -- ^ @*value*@
- | PairSlash -- ^ @/value/@
- | PairUnderscore -- ^ @_value_@
- | PairDash -- ^ @-value-@
- | PairBackquote -- ^ @`value`@
- | PairSinglequote -- ^ @'value'@
- | PairDoublequote -- ^ @"value"@
- | PairFrenchquote -- ^ @«value»@
- | PairParen -- ^ @(value)@
- | PairBrace -- ^ @{value}@
- | PairBracket -- ^ @[value]@
- deriving (Eq,Ord,Show)
-
--- ** Type 'TokenValue'
-data TokenValue
- = TokenPlain !Text
- | TokenTag !Tag
- | TokenEscape !Char
- | TokenLink !Text
- | TokenTree (Tree (Cell Key) (Cell Value))
- deriving (Eq,Ord,Show)
-
--- ** Type 'Tag'
-type Tag = Text
+instance Pretty Pair where
+ pretty = return . show
+instance Pretty a => Pretty (Cell a) where
+ pretty (Cell bp ep m) = do
+ s <- pretty m
+ return $ "Cell "<>show bp<>":"<>show ep<>" "<>s
+instance Pretty Lexeme where
+ pretty = return . show
-- * Type 'Pairs'
-- | Right-only Dyck language
type Pairs = (Tokens,[Opening])
+type Tokens = Trees (Cell Node)
-- ** Type 'Opening'
type Opening = (Cell Pair,Tokens)
-appendToken :: Pairs -> Token -> Pairs
-appendToken ps = appendTokens ps . Seq.singleton
+appendToken :: Pairs -> Tree (Cell Node) -> Pairs
+appendToken (ts,[]) tok = (ts|>tok,[])
+appendToken (ts,(p0,t0):ps) tok = (ts,(p0,t0|>tok):ps)
appendTokens :: Pairs -> Tokens -> Pairs
-appendTokens (t,[]) toks = (t<>toks,[])
-appendTokens (t,(p0,t0):ps) toks = (t,(p0,t0<>toks):ps)
+appendTokens (ts,[]) toks = (ts<>toks,[])
+appendTokens (ts,(p0,t0):ps) toks = (ts,(p0,t0<>toks):ps)
+
+appendText :: Pairs -> Cell TL.Text -> Pairs
+appendText ps tok =
+ case ps of
+ (ts,[]) -> (appendTokenText ts tok,[])
+ (ts,(p0,ts0):pss) -> (ts,(p0,appendTokenText ts0 tok):pss)
+
+appendTokenText :: Tokens -> Cell TL.Text -> Tokens
+appendTokenText ts (Cell bn en n)
+ {-
+ | TL.null n = ts
+ | otherwise-} =
+ case Seq.viewr ts of
+ EmptyR -> pure $ Tree0 $ Cell bn en $ NodeToken $ TokenText n
+ is :> Tree (Cell bo _eo nod) st ->
+ case nod of
+ NodeToken (TokenText o) -> is |> i
+ where i = Tree (Cell bo en (NodeToken $ TokenText (o <> n))) st
+ _ -> ts |> Tree0 (Cell bn en $ NodeToken $ TokenText n)
+
+prependTokenText :: Tokens -> Cell TL.Text -> Tokens
+prependTokenText ts (Cell bn en n)
+ {-
+ | TL.null n = ts
+ | otherwise-} =
+ case Seq.viewl ts of
+ EmptyL -> pure $ Tree0 $ Cell bn en $ NodeToken $ TokenText n
+ Tree (Cell _bo eo nod) st :< is ->
+ case nod of
+ NodeToken (TokenText o) -> i <| is
+ where i = Tree (Cell bn eo (NodeToken $ TokenText (n <> o))) st
+ _ -> Tree0 (Cell bn en $ NodeToken $ TokenText n) <| ts
openPair :: Pairs -> Cell Pair -> Pairs
-openPair (t,ms) p = (t,(p,mempty):ms)
+openPair (t,ps) p = (t,(p,mempty):ps)
-- | Close a 'Pair' when there is a matching 'LexemePairClose'.
closePair :: Pairs -> Cell Pair -> Pairs
-closePair ps@(_,[]) (Cell bp ep p) = dbg "closePair" $
- appendToken ps $
- Tree0 $ Cell bp ep $
- TokenPlain $ snd $ pairBorders p tokensPlainEmpty
-closePair (t,(p1,t1):ts) p = dbg "closePair" $
+closePair ps@(_,[]) (Cell bp ep p) = -- dbg "closePair" $
+ appendText ps $ Cell bp ep $ snd $ pairBorders p
+closePair (t,(p1,t1):ts) p = -- dbg "closePair" $
case (p1,p) of
- (Cell bx _ex (PairElem x ax), Cell _by ey (PairElem y ay)) | x == y ->
+ (Cell bx _ex (PairElem nx ax), Cell _by ey (PairElem ny ay)) | nx == ny ->
appendToken (t,ts) $
- TreeN (Cell bx ey $ PairElem x (ax<>ay)) t1
+ Tree (Cell bx ey $ NodePair $ PairElem nx as) t1
+ where as | null ay = ax
+ | otherwise = ax<>ay
(Cell bx _ex x, Cell _by ey y) | x == y ->
appendToken (t,ts) $
- TreeN (Cell bx ey x) t1
+ Tree (Cell bx ey $ NodePair x) t1
_ ->
(`closePair` p) $
appendTokens
closeImpaired acc (Cell bp ep p,toks) = dbg "closeImpaired" $
case p of
-- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'.
+ PairHash | Just (Cell bt et t, ts) <- tagFrom $ toks <> acc ->
+ Tree0 (Cell bt et $ NodeToken $ TokenTag t) <| ts
+ {-
PairHash | (Tree0 (Cell bt et (TokenPlain t))) :< ts <- Seq.viewl $ toks <> acc ->
case Text.span isTagChar t of
("",_) | Text.null t -> toksHash mempty <> toks <> acc
- | otherwise -> Tree0 (Cell bp et (TokenTag t)) <| ts
+ | otherwise -> Tree0 (Cell bp et (TokenTag t)) <| ts
(tag,t') ->
let len = Text.length tag in
Tree0 (Cell bp bt{columnPos = columnPos bt + len} (TokenTag tag)) <|
Tree0 (Cell bt{columnPos = columnPos bt + len + 1} et (TokenPlain t')) <|
ts
- _ -> toksHash tokensPlainEmpty <> toks <> acc
+ -}
+ _ -> prependTokenText (toks <> acc) toksHash
where
- toksHash = tokens1 . Tree0 . Cell bp ep . TokenPlain . fst . pairBorders p
- isTagChar c =
- Char.isAlphaNum c ||
- c=='·' ||
- case Char.generalCategory c of
- Char.DashPunctuation -> True
- Char.ConnectorPunctuation -> True
- _ -> False
+ toksHash :: Cell TL.Text
+ toksHash = Cell bp ep $ fst $ pairBorders p
+
+isTagChar :: Char -> Bool
+isTagChar c =
+ Char.isAlphaNum c ||
+ c=='·' ||
+ case Char.generalCategory c of
+ Char.DashPunctuation -> True
+ Char.ConnectorPunctuation -> True
+ _ -> False
+
+-- * Class 'TagFrom'
+class TagFrom a where
+ tagFrom :: a -> Maybe (Cell Tag, a)
+instance TagFrom Tokens where
+ tagFrom ts =
+ case Seq.viewl ts of
+ EmptyL -> Nothing
+ Tree0 (Cell b0 e0 n) :< ns ->
+ case n of
+ NodeToken (TokenText t) ->
+ case tagFrom $ Cell b0 e0 t of
+ Nothing -> Nothing
+ Just (t0,r0) ->
+ if TL.null (unCell r0)
+ then
+ case tagFrom ns of
+ Just (t1@(Cell b1 _e1 _), r1) | e0 == b1 ->
+ Just (t0<>t1, r1)
+ _ -> Just (t0, n0 <| ns)
+ else Just (t0, n0 <| ns)
+ where n0 = (Tree0 $ NodeToken . TokenText <$> r0)
+ _ -> Nothing
+ _ -> Nothing
+instance TagFrom (Cell TL.Text) where
+ tagFrom (Cell bp ep t)
+ | (w,r) <- TL.span isTagChar t
+ , not $ TL.null w
+ , ew <- pos_column bp + sum (Text.length <$> (TL.toChunks w)) =
+ Just
+ ( Cell bp bp{pos_column=ew} w
+ , Cell bp{pos_column=ew} ep r )
+ tagFrom _ = Nothing
-- | Close remaining 'Pair's at end of parsing.
closePairs :: Pairs -> Tokens
-closePairs (t0,ps) = dbg "closePairs" $
+closePairs (t0,ps) = -- dbg "closePairs" $
t0 <> foldl' closeImpaired mempty ps
appendLexeme :: Lexeme -> Pairs -> Pairs
appendLexeme lex acc =
- dbg "appendLexeme" $
+ -- dbg "appendLexeme" $
case lex of
- LexemePairOpen ps -> foldl' open acc ps
+ LexemePairOpen ps -> foldl' openPair acc ps
+ {-
where
- open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendToken` (Tree0 $ Cell ep ep $ TokenPlain "")
+ open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendToken` (Tree0 $ Cell ep ep $ TokenPhrase $ PhraseWhite "")
open a p = openPair a p
+ -}
LexemePairClose ps -> foldl' closePair acc ps
- LexemePairAny ps -> appendTokens acc $ tokens $ Tree0 . ((\p -> TokenPlain $ fst $ pairBorders p mempty) <$>) <$> ps
- LexemePairBoth ps -> appendTokens acc $ tokens $ (`TreeN`mempty) <$> ps
- LexemeEscape c -> appendToken acc $ Tree0 $ TokenEscape <$> c
- LexemeLink t -> appendToken acc $ Tree0 $ TokenLink <$> t
+ LexemePairAny ps ->
+ appendText acc $ sconcat $
+ ((fst . pairBordersWithoutContent) <$>) <$> ps
+ LexemePairBoth ps -> appendTokens acc $ Seq.fromList $ toList $ Tree0 . (NodePair <$>) <$> ps
+ LexemeEscape c -> appendToken acc $ Tree0 $ NodeToken . TokenEscape <$> c
+ LexemeLink t -> appendToken acc $ Tree0 $ NodeToken . TokenLink <$> t
{-LexemeWhite (unCell -> "") -> acc-}
- LexemeWhite (unCell -> Text.all (==' ') -> True) -> acc
- LexemeWhite cs -> appendToken acc $ Tree0 $ TokenPlain <$> cs
- LexemeAlphaNum cs -> appendToken acc $ Tree0 $ TokenPlain . Text.pack <$> cs
- LexemeAny cs -> appendToken acc $ Tree0 $ TokenPlain . Text.pack <$> cs
- -- LexemeToken ts -> appendTokens acc ts
+ -- LexemeWhite (unCell -> Text.all (==' ') -> True) -> acc
+ LexemeWhite t -> appendText acc t
+ LexemeAlphaNum t -> appendText acc t
+ LexemeOther t -> appendText acc t
+ LexemeTree t -> appendToken acc t
+ LexemeEnd -> acc
+
+{- TODEL
+appendTokenChild :: Pairs -> Tree (Cell Node) -> Pairs
+appendTokenChild pairs tree =
+ debug "appendTokenChild" "pairs" pairs $
+ debug "appendTokenChild" "tree" tree $
+ dbg "appendTokenChild" $
+ go pairs tree
+ where
+ go (ts@(toList -> [unTree -> Cell bo _eo NodeText{}]),[])
+ tok@(Tree (Cell _bn en _n) _ns) =
+ (pure $ Tree (Cell bo en NodePara) (ts |> tok),[])
+ go (ts,[]) tok = (ts |> tok,[])
+ go (ts,(p0,t0):ps) tok = (ts,(p0,t0|>tok):ps)
+-}
appendLexemes :: Pairs -> [Lexeme] -> Pairs
appendLexemes = foldr appendLexeme
-- * Type 'Lexeme'
data Lexeme
- = LexemePairOpen ![Cell Pair]
- | LexemePairClose ![Cell Pair]
- | LexemePairAny ![Cell Pair]
- | LexemePairBoth ![Cell Pair]
+ = LexemePairOpen !(NonEmpty (Cell Pair))
+ | LexemePairClose !(NonEmpty (Cell Pair))
+ | LexemePairAny !(NonEmpty (Cell Pair))
+ | LexemePairBoth !(NonEmpty (Cell Pair))
| LexemeEscape !(Cell Char)
- | LexemeLink !(Cell Text)
- | LexemeWhite !(Cell White)
- | LexemeAlphaNum !(Cell [Char])
- | LexemeAny !(Cell [Char])
- | LexemeTree !(Tree (Cell Key) Tokens)
- deriving (Eq, Ord, Show)
+ | LexemeLink !(Cell TL.Text)
+ | LexemeWhite !(Cell TL.Text)
+ | LexemeAlphaNum !(Cell TL.Text)
+ | LexemeOther !(Cell TL.Text)
+ | LexemeTree !(Tree (Cell Node))
+ | LexemeEnd
+ deriving (Eq, Show)
-- ** Type 'Lexemes'
type Lexemes = Seq Lexeme
parseTokens ps =
closePairs $
appendLexemes mempty $
- dbg "Lexemes" $
- orientLexemePairAny $ LexemeWhite (cell0 "") :
+ -- dbg "Lexemes (post orient)" $
+ orientLexemePairAny $ LexemeEnd :
ps
+parseLexemes ::
+ String ->
+ Cell TL.Text ->
+ Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) [Lexeme]
+parseLexemes inp = runParserOnCell inp (p_Lexemes <* P.eof)
+
-- | Parse 'Lexeme's, returning them in reverse order to apply 'orientLexemePairAny'.
-p_Lexemes :: Parser e s [Lexeme]
+p_Lexemes :: P.Tokens s ~ TL.Text => Parser e s [Lexeme]
p_Lexemes = pdbg "Lexemes" $ go []
where
- go :: [Lexeme] -> Parser e s [Lexeme]
+ go :: P.Tokens s ~ TL.Text => [Lexeme] -> Parser e s [Lexeme]
go acc =
(P.eof $> acc) <|>
(p_Lexeme >>= \next -> go $ orientLexemePairAny $ next:acc)
orientLexemePairAny :: [Lexeme] -> [Lexeme]
orientLexemePairAny = \case
- LexemeAny (Cell _bx ex x):LexemeAny (Cell by _ey y):acc -> LexemeAny (Cell by ex (x<>y)):acc
+ -- LexemeOther (Cell _bx ex x):LexemeOther (Cell by _ey y):acc -> LexemeOther (Cell by ex (x<>y)):acc
-- "
+ t@LexemeTree{}:LexemePairAny p:acc -> t:LexemePairClose p:acc
w@LexemeWhite{}:LexemePairAny p:acc -> w:LexemePairClose p:acc
+ LexemeEnd:LexemePairAny p:acc -> LexemePairClose p:acc
-- "
+ LexemePairAny p:t@LexemeTree{}:acc -> LexemePairOpen p:t:acc
LexemePairAny p:w@LexemeWhite{}:acc -> LexemePairOpen p:w:acc
LexemePairAny p:[] -> LexemePairOpen p:[]
-- ,,,"
- LexemePairAny p:a@LexemeAny{}:w@LexemeWhite{}:acc -> LexemePairOpen p:a:w:acc
- LexemePairAny p:a@LexemeAny{}:[] -> LexemePairOpen p:a:[]
+ LexemePairAny p:a@LexemeOther{}:w@LexemeWhite{}:acc -> LexemePairOpen p:a:w:acc
+ LexemePairAny p:a@LexemeOther{}:[] -> LexemePairOpen p:a:[]
-- ",,,
- w@LexemeWhite{}:a@LexemeAny{}:LexemePairAny p:acc -> w:a:LexemePairClose p:acc
+ w@LexemeWhite{}:a@LexemeOther{}:LexemePairAny p:acc -> w:a:LexemePairClose p:acc
+ LexemeEnd:a@LexemeOther{}:LexemePairAny p:acc -> a:LexemePairClose p:acc
-- ",,,AAA
- an@LexemeAlphaNum{}:a@LexemeAny{}:LexemePairAny p:acc -> an:a:LexemePairClose p:acc
+ an@LexemeAlphaNum{}:a@LexemeOther{}:LexemePairAny p:acc -> an:a:LexemePairClose p:acc
-- ,,,"AAA
- an@LexemeAlphaNum{}:LexemePairAny p:a@LexemeAny{}:acc -> an:LexemePairOpen p:a:acc
+ an@LexemeAlphaNum{}:LexemePairAny p:a@LexemeOther{}:acc -> an:LexemePairOpen p:a:acc
-- ")
c@LexemePairClose{}:LexemePairAny p:acc -> c:LexemePairClose p:acc
acc -> acc
-p_Lexeme :: Parser e s Lexeme
+p_some :: Parser e s a -> Parser e s (NonEmpty a)
+p_some p = NonEmpty.fromList <$> P.some p
+
+p_Lexeme :: P.Tokens s ~ TL.Text => Parser e s Lexeme
p_Lexeme = pdbg "Lexeme" $
P.choice
- [ P.try $ LexemeWhite <$> p_Cell p_Spaces
- , P.try $ LexemePairAny <$> P.some (p_Cell $ p_satisfyMaybe pairAny)
- , P.try $ LexemePairBoth <$> P.some (P.try $ p_Cell p_ElemSingle)
- , P.try $ LexemePairOpen <$> P.some (p_Cell $ p_satisfyMaybe pairOpen <|> P.try p_ElemOpen)
- , P.try $ LexemePairClose <$> P.some (p_Cell $ p_satisfyMaybe pairClose <|> P.try p_ElemClose)
+ [ P.try $ LexemeWhite <$> p_Cell p_Spaces1
+ , P.try $ LexemePairAny <$> p_some (p_Cell $ p_satisfyMaybe pairAny)
+ , P.try $ LexemePairBoth <$> p_some (P.try $ p_Cell p_ElemSingle)
+ , P.try $ LexemePairOpen <$> p_some (p_Cell $ p_satisfyMaybe pairOpen <|> P.try p_ElemOpen)
+ , P.try $ LexemePairClose <$> p_some (p_Cell $ p_satisfyMaybe pairClose <|> P.try p_ElemClose)
, P.try $ LexemeEscape <$> p_Cell p_Escape
, P.try $ LexemeLink <$> p_Cell p_Link
- , P.try $ LexemeAlphaNum <$> p_Cell (P.some p_AlphaNum)
- , LexemeAny <$> p_Cell (pure <$> P.anyChar)
+ , P.try $ LexemeAlphaNum <$> p_Cell (P.takeWhile1P (Just "AlphaNum") Char.isAlphaNum)
+ , LexemeOther <$> p_Cell (TL.singleton <$> P.anyChar)
]
-p_Cell :: Parser e s a -> Parser e s (Cell a)
-p_Cell pa = do
- bp <- p_Position
- a <- pa
- ep <- p_Position
- return $ Cell bp ep a
-
pairAny :: Char -> Maybe Pair
pairAny = \case
'-' -> Just PairDash
'»' -> Just PairFrenchquote
_ -> Nothing
-p_AlphaNum :: Parser e s Char
-p_AlphaNum = P.satisfy Char.isAlphaNum
-
p_Escape :: Parser e s Char
p_Escape = P.char '\\' *> P.satisfy Char.isPrint
-p_Link :: Parser e s Text
+p_Link :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_Link =
P.try (P.char '<' *> p <* P.char '>') <|>
p
where
+ p :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p =
- (\scheme addr -> Text.pack $ scheme <> "//" <> addr)
+ (\scheme addr -> scheme <> "//" <> addr)
<$> P.option "" (P.try p_scheme)
<* P.string "//"
<*> p_addr
+ p_scheme :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_scheme =
(<> ":")
- <$> P.some (P.satisfy $ \c ->
+ <$> (P.takeWhile1P (Just "scheme") $ \c ->
Char.isAlphaNum c
|| c=='_'
|| c=='-'
|| c=='+')
<* P.char ':'
+ p_addr :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_addr =
- P.many $
- P.satisfy $ \c ->
- Char.isAlphaNum c
- || c=='%'
- || c=='/'
- || c=='('
- || c==')'
- || c=='-'
- || c=='_'
- || c=='.'
- || c=='#'
- || c=='?'
- || c=='='
-
-p_ElemSingle :: Parser e s Pair
-p_ElemSingle = pdbg "ElemSingle" $
- PairElem
- <$ P.char '<'
- <*> p_Word
- <*> p_Attrs
- <* P.string "/>"
-
-p_ElemOpen :: Parser e s Pair
-p_ElemOpen = pdbg "ElemOpen" $
- PairElem
- <$ P.char '<'
- <*> p_Word
- <*> p_Attrs
- <* P.char '>'
-
-p_ElemClose :: Parser e s Pair
-p_ElemClose = pdbg "ElemClose" $
- (`PairElem` [])
- <$ P.string "</"
- <*> p_Word
- <* P.char '>'
-
-{-
-p_ElemOpenOrSingle :: Parser e s Pair
-p_ElemOpenOrSingle =
- p_ElemOpen >>= \p ->
- P.char '>' $> LexemePairOpen p <|>
- P.string "/>" $> LexemePairAny p
--}
-
-
-
-
-
-
-
-
+ P.takeWhileP (Just "addr") $ \c ->
+ Char.isAlphaNum c
+ || c=='%'
+ || c=='/'
+ || c=='('
+ || c==')'
+ || c=='-'
+ || c=='_'
+ || c=='.'
+ || c=='#'
+ || c=='?'
+ || c=='='
-- | Build 'Tokens' from many 'Token's.
-tokens :: [Token] -> Tokens
-tokens = Seq.fromList
+tokens :: [Cell Token] -> Tokens
+tokens ts = Seq.fromList $ Tree0 . (NodeToken <$>) <$> ts
-- | Build 'Tokens' from one 'Token'.
-tokens1 :: Token -> Tokens
+tokens1 :: Tree (Cell Node) -> Tokens
tokens1 = Seq.singleton
-tokensPlainEmpty :: Tokens
-tokensPlainEmpty = tokens1 $ Tree0 $ cell1 $ TokenPlain ""
-
-isTokenWhite :: Token -> Bool
-isTokenWhite (Tree0 (unCell -> TokenPlain t)) = Text.all Char.isSpace t
-isTokenWhite _ = False
-
-unTokenElem :: Tokens -> Maybe (Cell (Elem,Attrs,Tokens))
+unTokenElem :: Tokens -> Maybe (Cell (ElemName,ElemAttrs,Tokens))
unTokenElem toks =
- case toList $ Seq.dropWhileR isTokenWhite toks of
- [TreeN (Cell bp ep (PairElem e as)) ts] -> Just (Cell bp ep (e,as,ts))
+ case toList $ {-Seq.dropWhileR isTokenWhite-} toks of
+ [Tree (Cell bp ep (NodePair (PairElem e as))) ts] -> Just (Cell bp ep (e,as,ts))
_ -> Nothing
isTokenElem :: Tokens -> Bool
isTokenElem toks =
- case toList $ Seq.dropWhileR isTokenWhite toks of
- [TreeN (unCell -> PairElem{}) _] -> True
+ case toList $ {-Seq.dropWhileR isTokenWhite-} toks of
+ [Tree (unCell -> NodePair PairElem{}) _] -> True
_ -> False
-pairBorders :: TokenKey -> Tokens -> (Text,Text)
-pairBorders p ts =
- case p of
- PairElem e attrs ->
- if Seq.null ts
- then ("<"<>e<>foldMap f attrs<>"/>","")
- else ("<"<>e<>foldMap f attrs<>">","</"<>e<>">")
- where f (attr_white,Attr{..}) =
- attr_white <>
- attr_name <>
- attr_open <>
- attr_value <>
- attr_close
- PairHash -> ("#","#")
- PairStar -> ("*","*")
- PairSlash -> ("/","/")
- PairUnderscore -> ("_","_")
- PairDash -> ("-","-")
- PairBackquote -> ("`","`")
- PairSinglequote -> ("'","'")
- PairDoublequote -> ("\"","\"")
- PairFrenchquote -> ("«","»")
- PairParen -> ("(",")")
- PairBrace -> ("{","}")
- PairBracket -> ("[","]")
+pairBordersWithoutContent :: Pair -> (TL.Text,TL.Text)
+pairBordersWithoutContent = \case
+ PairElem n as ->
+ ("<"<>n<>foldMap f as<>"/>","")
+ where f (elemAttr_white,ElemAttr{..}) =
+ elemAttr_white <>
+ elemAttr_name <>
+ elemAttr_open <>
+ elemAttr_value <>
+ elemAttr_close
+ p -> pairBorders p
+
+pairBorders :: Pair -> (TL.Text,TL.Text)
+pairBorders = \case
+ PairElem n as -> ("<"<>n<>foldMap f as<>">","</"<>n<>">")
+ where f (elemAttr_white,ElemAttr{..}) =
+ elemAttr_white <>
+ elemAttr_name <>
+ elemAttr_open <>
+ elemAttr_value <>
+ elemAttr_close
+ PairHash -> ("#","#")
+ PairStar -> ("*","*")
+ PairSlash -> ("/","/")
+ PairUnderscore -> ("_","_")
+ PairDash -> ("-","-")
+ PairBackquote -> ("`","`")
+ PairSinglequote -> ("'","'")
+ PairDoublequote -> ("\"","\"")
+ PairFrenchquote -> ("«","»")
+ PairParen -> ("(",")")
+ PairBrace -> ("{","}")
+ PairBracket -> ("[","]")
{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Read.Tree where
+-- import Data.String (IsString(..))
+-- import qualified Data.TreeSeq.Strict as TreeSeq
import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..), void)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>), ($>), (<$))
+import Data.Foldable (toList)
+import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (IsString(..))
-import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..), Trees)
-import Prelude (undefined, Num(..))
-import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Sequence as Seq
-import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import Language.TCT.Cell
+-- import Language.TCT.Token
import Language.TCT.Tree
import Language.TCT.Read.Cell
import Language.TCT.Read.Elem
import Language.TCT.Read.Token
-p_CellKey :: Row -> Parser e s Row
-p_CellKey row = pdbg "CellKey" $ do
+p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
+p_CellHeader row = pdbg "CellHeader" $ do
P.skipMany $ P.char ' '
pos <- p_Position
- key <- pdbg "Key" $
+ header <- pdbg "Header" $
P.choice $
[ P.try $ P.char '-' >>
- P.char ' ' $> KeyDash <|>
- P.string "- " $> KeyDashDash
- , P.try $ KeyDot . Text.pack
- <$> P.some (P.satisfy Char.isDigit)
+ P.char ' ' $> HeaderDash <|>
+ P.string "- " $> HeaderDashDash
+ , P.try $ HeaderDot
+ <$> p_Digits
<* P.char '.'
<* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
, P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
- return $ KeySection $ List.length hs
+ return $ HeaderSection $ List.length hs
, P.try $
- KeyBrackets
+ HeaderBrackets
<$> P.between (P.string "[") (P.string "]") p_Name
<* P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n')))
, P.try $
- (\f -> KeyDotSlash $ "./"<>f)
+ (\f -> HeaderDotSlash $ "./"<>f)
<$ P.string "./"
<*> P.many (P.satisfy (/='\n'))
, do
name <- p_Name
- wh <- Text.pack <$> P.many (P.char ' ')
+ wh <- p_HSpaces
P.choice
- [ P.try $ KeyColon name wh
+ [ P.try $ HeaderColon name wh
<$ P.char ':'
<* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
- , P.char '>' $> KeyGreat name wh
- , P.char '=' $> KeyEqual name wh
- , P.char '|' $> KeyBar name wh
+ , P.char '>' $> HeaderGreat name wh
+ , P.char '=' $> HeaderEqual name wh
+ , P.char '|' $> HeaderBar name wh
]
]
posEnd <- p_Position
- let row' = TreeN (Cell pos posEnd key) mempty : row
- case key of
- KeySection{} -> p_CellEnd row'
- KeyDash{} -> p_Row row'
- KeyDashDash{} -> p_CellText row'
- KeyDot{} -> p_Row row'
- KeyColon{} -> p_Row row'
- KeyBrackets{} -> p_Row row'
- KeyGreat{} -> p_Row row'
- KeyEqual{} -> p_CellEnd row'
- KeyBar{} -> p_CellEnd row'
- KeyDotSlash{} -> p_CellEnd row'
- KeyLower{} -> undefined -- NOTE: handled in 'p_CellLower'
+ let row' = Tree (Cell pos posEnd $ NodeHeader header) mempty : row
+ case header of
+ HeaderSection{} -> p_CellEnd row'
+ HeaderDash{} -> p_Row row'
+ HeaderDashDash{} -> p_CellText row'
+ HeaderDot{} -> p_Row row'
+ HeaderColon{} -> p_Row row'
+ HeaderBrackets{} -> p_Row row'
+ HeaderGreat{} -> p_Row row'
+ HeaderEqual{} -> p_CellEnd row'
+ HeaderBar{} -> p_CellEnd row'
+ HeaderDotSlash{} -> p_CellEnd row'
+ -- HeaderLower{} -> undefined -- NOTE: handled in 'p_CellLower'
+ -- TODO: move to a NodeLower
+ -- HeaderPara -> undefined -- NOTE: only introduced later in 'appendRow'
-p_Name :: Parser e s Name
-p_Name =
+p_Name :: P.Tokens s ~ TL.Text => Parser e s Name
+p_Name = p_AlphaNums
+ {-
(\h t -> Text.pack (h:t))
- <$> (P.satisfy $ \c ->
- Char.isAlphaNum c || c=='_')
- <*> many (P.satisfy $ \c ->
- Char.isAlphaNum c || c=='-' || c=='_')
+ <$> (P.satisfy $ \c -> Char.isAlphaNum c || c=='_')
+ <*> P.takeWhile1P (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_')
+ -}
-p_Line :: Parser e s Text
-p_Line = Text.pack <$> P.many (P.satisfy (/='\n'))
+p_Line :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Line = P.takeWhileP (Just "Line") (/='\n')
-p_CellLower :: forall e s. Row -> Parser e s Row
+p_Line1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Line1 = P.takeWhile1P (Just "Line") (/='\n')
+
+p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_CellLower row = pdbg "CellLower" $ do
- P.skipMany $ P.char ' '
- pos <- p_Position
- void $ P.char '<'
- name <- p_Name
- attrs <- p_attrs
+ indent <- p_HSpaces
+ pos <- p_Position
+ void $ P.char '<'
+ name <- p_Name
+ attrs <- p_ElemAttrs
posClose <- p_Position
let treeHere =
- TreeN (Cell pos posClose $ KeyLower name attrs) .
- Seq.singleton . Tree0
- let treeElem toks (Cell _ p c) =
- let (o,_) = pairBorders (PairElem name attrs) toks in
- Tree0 $ Cell pos p (o<>c)
- let indent = fromString $ List.replicate (columnPos pos - 1) ' '
+ Tree (Cell pos posClose $ NodeLower name attrs) .
+ Seq.singleton . Tree0 . (NodeText <$>)
+ let treeElem hasContent nod (Cell _ p t) =
+ let (o,_) = bs $ PairElem name attrs in
+ Tree0 $ Cell pos p $ nod $ o<>t
+ where
+ bs | hasContent = pairBorders
+ | otherwise = pairBordersWithoutContent
tree <-
- P.try (P.char '>' >> treeElem (tokens [Tree0 $ cell0 $ TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|>
- P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|>
- P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|>
+ P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|>
+ P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|>
+ P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|>
(P.eof $> treeHere (Cell posClose posClose ""))
- return (tree:row)
+ return $ tree : row
where
- p_attrs = P.many $ P.try $
- (,)
- <$> (Text.pack <$> P.some (P.char ' '))
- <*> p_Attr
- p_CellLine :: Parser e s (Cell Text)
- p_CellLine = do
- pos <- p_Position
- content <- p_Line
- posEnd <- p_Position
- return $ Cell pos posEnd content
- p_CellLines :: P.Tokens s -> Parser e s (Cell Text)
- p_CellLines indent = do
- pos <- p_Position
- content <-
- Text.intercalate "\n"
- <$> P.sepBy (P.try p_Line) (P.try $ P.char '\n' >> P.string indent)
- posEnd <- p_Position
- return $ Cell pos posEnd content
- p_CellLinesUntilElemEnd :: P.Tokens s -> Text -> Parser e s (Cell Text)
- p_CellLinesUntilElemEnd indent name = do
- pos <- p_Position
- content <- Text.intercalate "\n" . List.reverse <$> go []
- posEnd <- p_Position
- return $ Cell pos posEnd content
+ p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text)
+ p_CellLine = p_Cell p_Line
+ p_CellLines :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Parser e s (Cell TL.Text)
+ p_CellLines indent =
+ -- TODO: optimize special case indent == "" ?
+ p_Cell $
+ TL.intercalate "\n"
+ <$> P.sepBy (P.try p_Line)
+ (P.try $ P.char '\n' >> P.tokens (==) indent)
+ p_CellLinesUntilElemEnd :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Name -> Parser e s (Cell TL.Text)
+ p_CellLinesUntilElemEnd indent name =
+ p_Cell $ TL.intercalate "\n" . List.reverse <$> go []
+ -- TODO: optimize merging, and maybe case indent == ""
where
- go :: [Text] -> Parser e s [Text]
+ go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text]
go ls =
- P.try ((\w l -> Text.pack w <> "</" <> name <> l : ls)
- <$> P.many (P.char ' ')
- <* P.string (fromString $ "</"<>Text.unpack name)
+ let end = "</" <> name in
+ P.try ((\w l -> w <> end <> l : ls)
+ <$> p_HSpaces
+ <* P.tokens (==) end
<*> p_Line) <|>
(p_Line >>= \l -> P.try $
- P.char '\n' >>
- P.string indent >>
- go (l:ls))
+ P.char '\n'
+ >> P.tokens (==) indent
+ >> go (l:ls))
-p_CellText :: Row -> Parser e s Row
+p_CellText :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_CellText row = pdbg "CellText" $ do
P.skipMany $ P.char ' '
- pos <- p_Position
- line <- Text.pack <$> P.some (P.satisfy (/='\n'))
- posEnd <- p_Position
- return $ Tree0 (Cell pos posEnd line) : row
+ n <- p_Cell $ NodeText <$> p_Line1
+ return $ Tree0 n : row
p_CellSpaces :: Row -> Parser e s Row
p_CellSpaces row = pdbg "CellSpaces" $ do
P.skipSome $ P.char ' '
pos <- p_Position
- return $ Tree0 (Cell pos pos "") : row
+ return $ Tree0 (Cell pos pos $ NodeText "") : row
-p_CellEnd :: Row -> Parser e s Row
-p_CellEnd row = pdbg "Row" $
+p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
+p_CellEnd row = pdbg "CellEnd" $
P.try (p_CellLower row) <|>
P.try (p_CellText row) <|>
p_CellSpaces row <|>
return row
-p_Row :: Row -> Parser e s Row
+p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_Row row = pdbg "Row" $
- P.try (p_CellKey row) <|>
+ P.try (p_CellHeader row) <|>
p_CellEnd row
-p_Rows :: Rows -> Parser e s Rows
+p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows
p_Rows rows =
p_Row [] >>= \row ->
let rows' = appendRow rows (List.reverse row) in
(P.eof $> rows') <|>
- (P.newline >> p_Rows rows')
+ (P.newline >> P.eof $> rows' <|> p_Rows rows')
-p_Trees :: Parser e s (Trees (Cell Key) (Cell Value))
-p_Trees = unRoot . collapseRows <$> p_Rows [root]
+p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node))
+p_Trees = unNodePara . subTrees . collapseRows <$> p_Rows [root]
where
- root = TreeN (cell0 KeyDashDash) mempty
- unRoot (TreeN (unCell -> KeyDashDash) roots) = roots
- unRoot _ = undefined
+ root = Tree (cell0 $ NodeHeader HeaderDashDash) mempty
+ unNodePara :: Trees (Cell Node) -> Trees (Cell Node)
+ unNodePara (toList -> [(Tree (unCell -> NodePara) ts)]) = ts
+ unNodePara ts = ts
{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Token where
-{-
-import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
-import Data.Function (($), (.))
-import Data.Foldable (foldMap, foldr)
-import Data.Maybe (Maybe(..))
-import Data.Semigroup (Semigroup(..))
+import Data.Int (Int)
+import Data.Ord (Ord(..))
import Data.Sequence (Seq)
-import Data.Ord (Ord)
import Data.Text (Text)
-import Data.Text.Buildable (Buildable(..))
-import Data.Text.Lazy.Builder (Builder)
-import Data.TreeSeq.Strict (Tree(..), Trees)
-import GHC.Exts (IsList(..))
+-- import Data.TreeSeq.Strict (Tree(..))
import Text.Show (Show(..))
-import qualified Data.Char as Char
-import qualified Data.Sequence as Seq
-import qualified Data.Text as Text
+import System.FilePath (FilePath)
+import qualified Data.Text.Lazy as TL
import Language.TCT.Cell
import Language.TCT.Elem
+
+
+
+
+{-
+-- * Type 'TCT'
+type TCT = Tree (Padded Key) Tokens
+
+-- * Type 'Key'
+data Key
+ = KeyColon !Name !White -- ^ @name: @
+ | KeyEqual !Name !White -- ^ @name=@
+ | KeyBar !Name !White -- ^ @name|@
+ | KeyGreat !Name !White -- ^ @name>@
+ | KeyLower !Name !ElemAttrs -- ^ @<name a=b@
+ | KeyDot !Name -- ^ @1. @
+ | KeyDash -- ^ @- @
+ | KeyDashDash -- ^ @-- @
+ | KeySection !LevelSection -- ^ @# @
+ | KeyBrackets !Name -- ^ @[name]@
+ | KeyDotSlash !PathFile -- ^ @./file @
+ | KeyPara
+ deriving (Eq, Ord, Show)
+
+-- ** Type 'Name'
+type Name = Text
+
+-- ** Type 'Value'
+type Value = Text
+
+-- ** Type 'PathFile'
+type PathFile = FP.FilePath
+
+-- ** Type 'LevelSection'
+type LevelSection = Int
+
+-- * Type 'Token'
+-- | NOTE: the 'Cell' spans the opening, the content and the closing.
+type Token = Tree (Padded TokenKey) TokenValue
+
+-- ** Type 'Tokens'
+type Tokens = Seq Token
+
+-- ** Type 'TokenKey'
+type TokenKey = Pair
+data Pair
+ = PairElem !ElemName !ElemAttrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
+ | PairHash -- ^ @#value#@
+ | PairStar -- ^ @*value*@
+ | PairSlash -- ^ @/value/@
+ | PairUnderscore -- ^ @_value_@
+ | PairDash -- ^ @-value-@
+ | PairBackquote -- ^ @`value`@
+ | PairSinglequote -- ^ @'value'@
+ | PairDoublequote -- ^ @"value"@
+ | PairFrenchquote -- ^ @«value»@
+ | PairParen -- ^ @(value)@
+ | PairBrace -- ^ @{value}@
+ | PairBracket -- ^ @[value]@
+ deriving (Eq,Ord,Show)
+
+-- ** Type 'TokenValue'
+data TokenValue
+ = TokenPhrases !Phrases
+ | TokenEscape !Char
+ | TokenTag !Tag
+ | TokenLink !Link
+ | TokenTree !TCT
+ | TokenRaw !TL.Text
+ deriving (Eq,Show)
+
+-- * Type 'Phrases'
+type Phrases = Seq (Padded Phrase)
+
+-- ** Type 'Phrase'
+data Phrase
+ = PhraseWord !Text
+ | PhraseWhite !Text
+ | PhraseOther !Text
+ deriving (Eq,Ord,Show)
+
+-- * Type 'Tag'
+type Tag = TL.Text
+-- newtype Tag = Tag Text
+
+type family Sourced a :: *
+type instance Sourced (Padded a) = Padded (Sourced a)
+type instance Sourced [a] = [Sourced a]
+type instance Sourced (Seq a) = Seq (Sourced a)
+type instance Sourced (Tree k a) = Tree (Sourced k) (Sourced a)
+type instance Sourced Key = Cell Key
+type instance Sourced Value = Cell Value
+type instance Sourced TokenKey = Cell TokenKey
+type instance Sourced TokenValue = TokenValue
+type instance Sourced Phrase = Cell Phrase
+
+-- * Type Pos
+class Sourcify a where
+ sourcify :: a -> Sourced a
+instance Sourced a => Sourced [a] where
+ type Sourced = [At a]
+ sourcify = (sourcify <$>)
+-}
+
+{-
instance Buildable Token where
build (TokenPlain t) = build t
build (TokenTag t) = "#"<>build t
unTokens :: Tokens -> Seq Token
unTokens (Tokens ts) = ts
-}
-
-
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE NoOverloadedLists #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
-module Language.TCT.Tree
- ( module Language.TCT.Tree
- , Tree(..)
- , Trees
- ) where
+module Language.TCT.Tree where
import Control.Monad (Monad(..))
+import Data.Bool
+import Data.Char (Char)
import Data.Eq (Eq(..))
+import Data.Foldable (Foldable(..))
import Data.Function (($))
+import Data.Int (Int)
import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
import Data.Ord (Ordering(..), Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence ((|>))
-import Data.Text (Text)
+import Data.Sequence ((|>), (<|), ViewR(..))
import Data.TreeSeq.Strict (Tree(..), Trees)
-import Prelude (undefined, Int, Num(..))
+import Prelude (undefined, Num(..))
+import System.FilePath (FilePath)
import Text.Show (Show(..))
import qualified Data.List as List
-import qualified Data.Text as Text
-import qualified System.FilePath as FP
import qualified Data.Sequence as Seq
+import qualified Data.Text.Lazy as TL
import Language.TCT.Cell
import Language.TCT.Elem
-import Language.TCT.Read.Token
-- import Language.TCT.Token
+-- ** Type 'TCT'
+type Root = Tree Node
+type Roots = Trees Node
+
+pattern Tree0 :: a -> Tree a
+pattern Tree0 a <- Tree a (null -> True)
+ where Tree0 a = Tree a mempty
+
+-- ** Type 'Node'
+data Node
+ = NodeHeader !Header
+ | NodePair !Pair
+ | NodeToken !Token
+ | NodeText !TL.Text
+ | NodeLower !Name !ElemAttrs -- ^ @<name a=b@
+ | NodePara
+ | NodeGroup
+ deriving (Eq,Show)
+
+-- ** Type 'Header'
+data Header
+ = HeaderColon !Name !White -- ^ @name: @
+ | HeaderEqual !Name !White -- ^ @name=@
+ | HeaderBar !Name !White -- ^ @name|@
+ | HeaderGreat !Name !White -- ^ @name>@
+ | HeaderDot !Name -- ^ @1. @
+ | HeaderDash -- ^ @- @
+ | HeaderDashDash -- ^ @-- @
+ | HeaderSection !LevelSection -- ^ @# @
+ | HeaderBrackets !Name -- ^ @[name]@
+ | HeaderDotSlash !FilePath -- ^ @./file @
+ deriving (Eq, Ord, Show)
+
+-- *** Type 'Name'
+type Name = TL.Text
+
+-- *** Type 'LevelSection'
+type LevelSection = Int
+
+-- ** Type 'Pair'
+data Pair
+ = PairElem !ElemName !ElemAttrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
+ | PairHash -- ^ @#value#@
+ | PairStar -- ^ @*value*@
+ | PairSlash -- ^ @/value/@
+ | PairUnderscore -- ^ @_value_@
+ | PairDash -- ^ @-value-@
+ | PairBackquote -- ^ @`value`@
+ | PairSinglequote -- ^ @'value'@
+ | PairDoublequote -- ^ @"value"@
+ | PairFrenchquote -- ^ @«value»@
+ | PairParen -- ^ @(value)@
+ | PairBrace -- ^ @{value}@
+ | PairBracket -- ^ @[value]@
+ deriving (Eq,Ord,Show)
+
+-- ** Type 'Token'
+data Token
+ = TokenText !TL.Text
+ | TokenEscape !Char
+ | TokenLink !Link
+ | TokenTag !Tag
+ deriving (Eq,Show)
+
+-- *** Type 'Tag'
+type Tag = TL.Text
+
+-- *** Type 'Link'
+type Link = TL.Text
+
+-- * Type 'Row'
+-- | In normal order: a list of 'Header's, maybe ended by 'Value', all read on the same line.
+type Row = [Tree (Cell Node)]
+
+-- ** Type 'Rows'
+-- | In reverse order: a list of nodes in scope
+-- (hence to which the next line can append to).
+type Rows = [Tree (Cell Node)]
-- | @appendRow rows row@ appends @row@ to @rows@.
--
-- [@row@] next 'Row', from leftest column to rightest (non-stricly ascending)
appendRow :: Rows -> Row -> Rows
appendRow [] row = List.reverse row
-appendRow parents [] = parents
-appendRow rows@(parent:parents) row@(cell:cells) =
- trac ("appendRow: rows=" <> show rows) $
- trac ("appendRow: row=" <> show row) $
+appendRow rows [] = rows
+appendRow rows@(old@(Tree (Cell bo eo o) os):olds)
+ row@(new@(Tree (Cell bn en n) ns):news) =
+ debug "appendRow" "row" row $
+ debug "appendRow" "rows" rows $
dbg "appendRow" $
- let colParent = columnPos $ posTree parent in
- let colRow = columnPos $ posTree cell in
- case dbg "colParent" colParent `compare`
- dbg "colRow" colRow of
- LT ->
- case (dbg "parent" parent,dbg "cell" cell) of
- (Tree0{}, TreeN{}) -> eq
- -- (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
- -- (TreeN (unCell -> KeyPara) p, Tree0 r) -> appendTree0 p r
- -- (Tree0 p, Tree0 r) -> appendTree0 p r
- _ | Just x <- appendPara -> x
- _ -> lt
+ case dbg "colOld" (pos_column bo) `compare`
+ dbg "colNew" (pos_column bn) of
+ LT -> mergeNodeText lt
EQ ->
- case (dbg "parent" parent,dbg "cell" cell) of
- _ | Just x <- appendPara -> x
- (_, TreeN (unCell -> KeySection sectionRow) _)
- | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
- case dbg "sectionParent" sectionParent `compare`
- dbg "sectionRow" sectionRow of
- LT -> appendRow (cell:secPar:secPars) cells
- EQ -> appendRow (cell:insertChild secPar secPars) cells
+ mergeNodeText $
+ case (o,n) of
+ (_, NodeHeader (HeaderSection secNew))
+ | Just (secOld, s0:ss) <- collapseSection (pos_column bn) rows ->
+ case dbg "secOld" secOld `compare`
+ dbg "secNew" secNew of
+ LT -> appendRow (new:s0:ss) news
+ EQ -> appendRow (new:appendChild ss s0) news
GT -> gt
- (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
- (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
- (Tree0{}, TreeN{}) -> eq
- (TreeN{}, TreeN{}) -> eq
- (TreeN{}, Tree0{}) -> eq
+ (NodeHeader HeaderSection{}, _) -> lt
+ (_, NodeText tn) | TL.null tn -> gt
+ (NodePara, _) | not newPara -> lt
+ _ | newPara -> gt
+ _ -> eq
GT -> gt
where
- appendPara :: Maybe Rows
- appendPara =
- case (parent, cell) of
- ( TreeN (Cell posPar posEndPar KeyPara) pars
- , Tree0 (Cell posRow posEndRow _c) ) ->
- Just $
- if linePos posRow - linePos posEndPar <= 1
- then appendRow (merged : parents) cells
- else appendRow (cell : insertChild parent parents) cells
- where merged = TreeN (Cell posPar posEndRow KeyPara) $ pars |> cell
- ( Tree0 (Cell posPar posEndPar _p)
- , Tree0 (Cell posRow posEndRow _c) ) ->
- Just $
- if linePos posRow - linePos posEndPar <= 1
- then appendRow (merged : parents) cells
- else appendRow (cell : insertChild parent parents) cells
- where merged = TreeN (Cell posPar posEndRow KeyPara) [parent, cell]
- _ -> Nothing
+ newPara = pos_line bn - pos_line eo > 1
+ lt = debug "appendRow" "action" ("lt"::TL.Text) $ List.reverse row <> rows
+ eq = debug "appendRow" "action" ("eq"::TL.Text) $ appendRow (new : appendChild olds old) news
+ gt = debug "appendRow" "action" ("gt"::TL.Text) $ appendRow ( appendChild olds old) row
- {-
- appendTree0 p r =
- case appendCellValue p r of
- Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
- Just t -> appendRow (t : parents) cells
- -}
- lt = appendRow [] row <> rows
- eq = appendRow (cell : insertChild parent parents) cells
- gt = appendRow (insertChild parent parents) row
-- | Find the first section (if any), returning its level, and the path collapsed upto it.
- collapseSection :: Column -> Rows -> Maybe (Int,Rows)
- collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
+ collapseSection :: ColNum -> Rows -> Maybe (LevelSection,Rows)
+ collapseSection col xxs@(x:xs) | pos_column (cell_begin (unTree x)) == col =
case x of
- TreeN (unCell -> KeySection lvl) _ -> Just (lvl, xxs)
+ Tree (unCell -> NodeHeader (HeaderSection lvl)) _ -> Just (lvl, xxs)
_ -> do
(lvl, cs) <- collapseSection col xs
- return (lvl, insertChild x cs)
+ return (lvl, appendChild cs x)
collapseSection _ _ = Nothing
+
+ mergeNodeText :: Rows -> Rows
+ mergeNodeText rs
+ | newPara = rs
+ | otherwise =
+ case (o,n) of
+ (NodeText to, NodeText tn)
+ | null os
+ , not (TL.null to)
+ , not (TL.null tn) ->
+ -- debug "appendRow" "action" ("mergeNodeText"::TL.Text) $
+ dbg "mergeNodeText" $
+ appendRow (merged : olds) news
+ where
+ merged = Tree (Cell bo en $ NodeText $ to<>tp<>tn) ns
+ tp = fromPad Pos
+ { pos_line = pos_line bn - pos_line eo
+ , pos_column = pos_column bn - pos_column bo
+ }
+ _ -> rs
-{-
-appendCellValue :: Cell Value -> Cell Value -> Tree (Cell Key) (Cell Value)
-appendCellValue par@(Cell posPar posEndPar p) row@(Cell posRow posEndRow r) =
- trac ("appendCellValue: p="<>show p) $
- trac ("appendCellValue: r="<>show r) $
- dbg "appendCellValue" $
- case linePos posRow - linePos posEndPar of
- 0 ->
- TreeN (Cell posPar posEndRow KeyPara)
- [ Tree0 par
- , Tree0 row
- ]
- 1 ->
- TreeN (Cell posPar posEndRow KeyPara)
- [ Tree0 par
- , Tree0 row
- ]
- _ -> []
- where
- padding x y = Text.replicate (y - x) " "
- {-
- where
- pad =
- -- return $ LexemeWhite $ Cell posEndPar posRow $
- -- padding (columnPos posEndPar) (columnPos posRow)
- -}
- {-
- -- return $ Cell posPar posEndRow $ p <> pad <> r
- -- return $ Cell posPar posEndRow $ p <> pad <> r
- where
- pad =
- -- return $ LexemeWhite $ Cell posEndPar posRow $
- -- "\n" <>
- padding (columnPos posPar) (columnPos posRow)
- -}
--}
-
-insertChild :: Tree (Cell Key) (Cell Value) -> Rows -> Rows
-insertChild child ps@[] =
- trac ("insertChild: child="<>show child) $
- trac ("insertChild: ps="<>show ps) $
- dbg "insertChild" $
- [child]
-insertChild c@(Tree0 (Cell _bp ep _))
- (p@(Tree0 (Cell bp _ep _)):parents) =
- TreeN (Cell bp ep KeyPara) [p, c] : parents
-insertChild (TreeN (Cell _bp ep _) cs)
- (p@(Tree0 (Cell bp _ep _)):parents) =
- TreeN (Cell bp ep KeyPara) (p Seq.<| cs) : parents
- {-
- undefined
- -- FIXME: this case may be removed.
- case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
- LT -> TreeN KeyMix (Seq.fromList [Tree0 v, child] treesParent |> child) : parents
- EQ -> TreeN KeyMix (Seq.fromList [Tree0 v, child] treesParent |> child) : parents
- GT -> undefined
- -}
-insertChild child ps@(TreeN parent treesParent:parents) =
- trac ("insertChild: child="<>show child) $
- trac ("insertChild: ps="<>show ps) $
- dbg "insertChild" $
- -- FIXME: this case may be removed.
- case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
- LT -> TreeN parent (treesParent |> child) : parents
- EQ -> TreeN parent (treesParent |> child) : parents
- GT -> undefined
-
-collapseRows :: Rows -> Tree (Cell Key) (Cell Value)
-collapseRows [] = undefined
-collapseRows [child] = dbg "collapseRows" $ child
-collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents
-
-
+appendChild :: Rows -> Tree (Cell Node) -> Rows
+appendChild rows new@(Tree (Cell bn en n) ns) =
+ debug "appendChild" "new" new $
+ debug "appendChild" "rows" rows $
+ dbg "appendChild" $
+ case rows of
+ [] -> [new]
+ old@(Tree (Cell bo eo o) os) : olds ->
+ (: olds) $
+ if newPara
+ then
+ case (o,n) of
+ (NodePara,NodePara) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new]
+ (NodePara,_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,Tree (Cell bn en NodePara) $ return new]
+ (_,NodePara) -> Tree (Cell bo en o) $ os|>new
+ (NodeText{},_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new]
+ _ -> Tree (Cell bo en o) $ os|>Tree (Cell bn en NodePara) (return new)
+ else
+ case (o,n) of
+ (NodePara,NodePara) -> Tree (Cell bo en NodePara) $ os<>ns
+ (NodePara,_) -> Tree (Cell bo en NodePara) $ os|>new
+ (_,NodePara) -> Tree (Cell bo en NodePara) $ old<|ns
+ (NodeText{},_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new]
+ _ ->
+ case Seq.viewr os of
+ EmptyR ->
+ Tree (Cell bo en o) $
+ os |> Tree (Cell bn en NodePara) (return new)
+ ls :> Tree (Cell br _er r) rs ->
+ case r of
+ NodePara ->
+ if pos_column br == pos_column bn
+ then Tree (Cell bo en o) $ ls |> Tree (Cell br en NodePara) (rs |> new)
+ else Tree (Cell bo en o) $ os |> Tree (Cell bn en NodePara) (return new)
+ _ -> Tree (Cell bo en o) $ os |> new
+ where newPara = pos_line bn - pos_line eo > 1
+collapseRows :: Rows -> Tree (Cell Node)
+collapseRows rs =
+ debug "collapseRows" "rs" rs $
+ dbg "collapseRows" $
+ case rs of
+ [] -> undefined
+ [child] -> child
+ child:parents -> collapseRows $ appendChild parents child
{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Write.HTML5 where
+import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), forM_, mapM_, when)
import Data.Bool
import Data.Char (Char)
import Language.TCT
import qualified Language.TCT.Write.Plain as Plain
+html5Document :: TCTs -> Html
+html5Document body = do
+ H.docType
+ H.html $ do
+ H.head $ do
+ H.meta ! HA.httpEquiv "Content-Type"
+ ! HA.content "text/html; charset=UTF-8"
+ whenJust (tokensTitle body) $ \ts ->
+ H.title $
+ H.toMarkup $ Plain.text def $ List.head $ toList ts
+ -- link ! rel "Chapter" ! title "SomeTitle">
+ H.link ! HA.rel "stylesheet"
+ ! HA.type_ "text/css"
+ ! HA.href "style/tct-html5.css"
+ let (html5Body, State{}) =
+ runStateMarkup def $
+ html5ify body
+ H.body $ do
+ H.a ! HA.id ("line-1") $ return ()
+ html5Body
+
-- * Type 'Html5'
type Html5 = StateMarkup State ()
html5ify = html5ify . H.toMarkup
instance Html5ify String where
html5ify = html5ify . H.toMarkup
-html5Document :: TCTs -> Html
-html5Document body = do
- H.docType
- H.html $ do
- H.head $ do
- H.meta ! HA.httpEquiv "Content-Type"
- ! HA.content "text/html; charset=UTF-8"
- whenJust (tokensTitle body) $ \ts ->
- H.title $
- H.toMarkup $ Plain.text def $ List.head $ toList ts
- -- link ! rel "Chapter" ! title "SomeTitle">
- H.link ! HA.rel "stylesheet"
- ! HA.type_ "text/css"
- ! HA.href "style/tct-html5.css"
- let (html5Body, State{}) =
- runStateMarkup def $
- html5ify body
- H.body $ do
- H.a ! HA.id ("line-1") $ return ()
- html5Body
instance Html5ify (Trees (Cell Key) Tokens) where
html5ify = mapM_ html5ify
instance Html5ify (Tree (Cell Key) Tokens) where
H.span ! HA.class_ "elem-name" $$
html5ify name
lenName = Text.length name
- lenAttrs = sum $ (<$> attrs) $ \(attr_white,Attr{..}) ->
- Text.length attr_white +
- Text.length attr_name +
- Text.length attr_open +
- Text.length attr_value +
- Text.length attr_close
+ lenAttrs = sum $ (<$> attrs) $ \(elemAttr_white,ElemAttr{..}) ->
+ Text.length elemAttr_white +
+ Text.length elemAttr_name +
+ Text.length elemAttr_open +
+ Text.length elemAttr_value +
+ Text.length elemAttr_close
(lenO,lenC) | Seq.null ts = (1+lenName+lenAttrs+2,0)
| otherwise = (1+lenName+lenAttrs+1,2+lenName+1)
o,c :: Html5
H.span ! HA.class_ "pair-content" $$ html5ify ts
html5ify $ Cell ep{columnPos = columnPos ep - Text.length c} ep ()
H.span ! HA.class_ "pair-close" $$ html5ify c
- html5ify (Tree0 (Cell bp ep t)) = do
- html5ify $ Cell bp ep ()
- case t of
- TokenPlain txt -> html5ify txt
+ html5ify (Tree0 tok) = do
+ -- html5ify $ Cell bp ep ()
+ case tok of
+ TokenPhrases ps -> html5ify ps
+ TokenRaw t -> html5ify t
{-do
lin <- S.get
let lines = Text.splitOn "\n" txt
H.span ! HA.class_ "tag-open" $$
html5ify '#'
html5ify v
- TokenEscape c -> html5ify ['\\',c]
- TokenLink lnk ->
+ TokenEscape c -> html5ify $ ('\\' :) . pure <$> c
+ TokenLink (Cell bp ep lnk) -> do
+ html5ify $ Cell bp ep ()
H.a ! HA.href (attrify lnk) $$
html5ify lnk
-instance Html5ify Attrs where
+instance Html5ify Phrases where
+ html5ify = mapM_ html5ify
+instance Html5ify Phrase where
+ html5ify p =
+ case p of
+ PhraseWord t -> html5ify t
+ PhraseWhite t -> html5ify t
+ PhraseOther t -> html5ify t
+instance Html5ify ElemAttrs where
html5ify = mapM_ html5ify
-instance Html5ify (White,Attr) where
- html5ify (attr_white,Attr{..}) = do
- html5ify attr_white
+instance Html5ify (White,ElemAttr) where
+ html5ify (elemAttr_white,ElemAttr{..}) = do
+ html5ify elemAttr_white
H.span ! HA.class_ "attr-name" $$
- html5ify attr_name
- html5ify attr_open
+ html5ify elemAttr_name
+ html5ify elemAttr_open
H.span ! HA.class_ "attr-value" $$
- html5ify attr_value
- html5ify attr_close
+ html5ify elemAttr_value
+ html5ify elemAttr_close
-- * Utilities
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.TCT.Write.Plain where
-import Control.Applicative (liftA2)
-import Control.Monad (Monad(..))
+import Control.Applicative (Applicative(..), liftA2)
+import Control.Monad (Monad(..), mapM)
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int64)
+import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (ViewL(..))
+import Data.Sequence (Seq, ViewL(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..),Trees)
import qualified Data.Text.Lazy.Builder as TLB
-- import Language.TCT.Tree
--- import Language.TCT.Token
+import Language.TCT.Token
import Language.TCT.Cell
import Language.TCT.Elem
import Language.TCT.Read.Token
-- * Class 'Plainify'
class Plainify a where
plainify :: a -> Plain
+instance Plainify () where
+ plainify = mempty
instance Plainify Char where
plainify = return . TLB.singleton
instance Plainify String where
Pos lineLast colLast <- S.gets state_pos
case () of
_ | lineLast < line -> do
- plainify $ Text.replicate (line - lineLast - 1) "\n"
- plainify $ Text.replicate (col - 1) " "
+ S.modify $ \s -> s{state_pos=ep}
+ plainify (Text.replicate (line - lineLast - 1) "\n")
+ <> plainify (Text.replicate (col - 1) " ")
+ <> plainify a
_ | lineLast == line && colLast <= col -> do
- plainify $ Text.replicate (col - colLast) " "
+ S.modify $ \s -> s{state_pos=ep}
+ plainify (Text.replicate (col - colLast) " ")
+ <> plainify a
_ -> undefined
- -- S.modify $ \s -> s{state_pos=bp}
- S.modify $ \s -> s{state_pos=ep}
- plainify a
instance Plainify (Trees (Cell Key) Tokens) where
plainify = foldMap plainify
instance Plainify (Tree (Cell Key) Tokens) where
plainify attrs <>
plainify ts
KeySection lvl ->
- plainify (TL.replicate (int64 lvl) "#") <> " " <>
+ plainify (TL.replicate (int64 lvl) "#") <>
case Seq.viewl ts of
Tree0 title :< ts' ->
plainify title <>
plainify = foldMap plainify
instance Plainify Token where
plainify = \case
- TreeN (Cell bp ep k) ts -> plainify (Cell bp ep (k,ts))
- Tree0 ts -> plainify ts
-instance Plainify (TokenKey, Tokens) where
- plainify (k,ts) =
+ TreeN (Cell bp ep k) ts ->
+ plainify (Cell bp ep ()) <>
plainify o <> plainify ts <> plainify c
where (o,c) = pairBorders k ts
-instance Plainify TokenValue where
- plainify = \case
- TokenPlain txt -> plainify txt
- {- TODO: remove
- lnum <- S.get
- let lines = Text.splitOn "\n" txt
- S.put (lnum - 1 + List.length lines)
- return $
- case lines of
- [] -> undefined
- (l0:ls) -> plainify l0 <> mconcat ((\l -> "\n"<>indent<>plainify l)<$>ls)
- -}
- TokenTag v -> plainify '#'<>plainify v
- TokenEscape c -> do
- esc <- S.gets state_escape
- if esc
- then plainify ['\\',c]
- else plainify c
- TokenLink lnk -> plainify lnk
-instance Plainify Attrs where
+ Tree0 tok ->
+ -- plainify (Cell bp ep ()) <>
+ case tok of
+ TokenPhrases p -> plainify p
+ TokenRaw t -> plainify t
+ {- TODO: remove
+ lnum <- S.get
+ let lines = Text.splitOn "\n" txt
+ S.put (lnum - 1 + List.length lines)
+ return $
+ case lines of
+ [] -> undefined
+ (l0:ls) -> plainify l0 <> mconcat ((\l -> "\n"<>indent<>plainify l)<$>ls)
+ -}
+ TokenTag v -> plainify $ ("#"<>) <$> v
+ TokenEscape c -> do
+ esc <- S.gets state_escape
+ if esc
+ then plainify $ (('\\' :) . pure) <$> c
+ else plainify c
+ TokenLink lnk -> plainify lnk
+instance Plainify Phrases where
plainify = foldMap plainify
-instance Plainify (Text,Attr) where
- plainify (attr_white,Attr{..}) =
+instance Plainify Phrase where
+ plainify p =
+ case p of
+ PhraseWord t -> plainify t
+ PhraseWhite t -> plainify t
+ PhraseOther t -> plainify t
+instance Plainify ElemAttrs where
+ plainify = foldMap plainify
+instance Plainify (Text,ElemAttr) where
+ plainify (elemAttr_white,ElemAttr{..}) =
mconcat $ plainify <$>
- [ attr_white
- , attr_name
- , attr_open
- , attr_value
- , attr_close
+ [ elemAttr_white
+ , elemAttr_name
+ , elemAttr_open
+ , elemAttr_value
+ , elemAttr_close
]
{-
TokenLink lnk -> plainify lnk
-}
+-- * 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
+ { linePos = linePos - l0 + 1
+ , columnPos = columnPos - 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 k, RackUpLeft a) => RackUpLeft (Tree k a) where
+ rackUpLeft = \case
+ Tree0 a -> Tree0 <$> rackUpLeft a
+ TreeN k ts -> TreeN <$> rackUpLeft k <*> rackUpLeft ts
+
{-
-- * Utilities
plainifyIndentCell :: (Pos,Pos) -> Plain
| 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 ->
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
+import qualified Control.Monad.Trans.State as S
import qualified Language.TCT.Write.Plain as Plain
import qualified System.FilePath as FP
import Language.XML
import qualified Data.TreeSeq.Strict as TreeSeq
+import Debug.Trace (trace)
+import Text.Show (show)
+
+xmlDocument :: TCTs -> XMLs
+xmlDocument trees =
+ -- (`S.evalState` def) $
+ case Seq.viewl trees of
+ TreeN (unCell -> KeySection{}) vs :< ts ->
+ case spanlTokens vs of
+ (titles@(Seq.viewl -> (Seq.viewl -> (posTree -> bp) :< _) :< _), vs') ->
+ let vs'' =
+ case Seq.findIndexL
+ (\case
+ TreeN (unCell -> KeyColon "about" _) _ -> True
+ _ -> False) vs' of
+ Nothing -> TreeN (Cell bp bp $ KeyColon "about" "") mempty <| vs'
+ Just{} -> vs' in
+ xmlify def
+ { inh_titles = titles
+ , inh_figure = True
+ , inh_tree0 = List.repeat xmlPara
+ } vs'' <>
+ xmlify def ts
+ _ -> xmlify def trees
+ _ -> xmlify def trees
+
+{-
+-- * Type 'Xmls'
+type Xmls = S.State State XMLs
+type Xml = S.State State XML
+instance Semigroup Xmls where
+ (<>) = liftA2 (<>)
+instance Monoid Xmls where
+ mempty = return mempty
+ mappend = (<>)
+
+-- * Type 'State'
+data State
+ = State
+ { state_pos :: Pos
+ }
+instance Default State where
+ def = State
+ { state_pos = pos1
+ }
+-}
+
-- * Type 'Inh'
data Inh
= Inh
, not (null body) ->
(<| go inh ts) $
TreeN (Cell bp ep "artwork") $
- maybe id (\v -> (Tree0 (Cell bp ep (XmlAttr "type" v)) <|)) (mimetype n) $
+ maybe id (\v -> (Tree0 (XmlAttr (Cell bp ep ("type", v))) <|)) (mimetype n) $
body >>= xmlify inh{inh_tree0=[]}
TreeN key@(unCell -> KeyColon n _) cs :< ts
case p of
PairBracket | to <- Plain.text def ts
, TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
- Seq.singleton $
+ Seq.singleton .
TreeN (cell "rref") $
xmlAttrs [cell ("to",TL.toStrict to)]
- PairStar -> Seq.singleton $ TreeN (cell "b") $ xmlify inh ts
- PairSlash -> Seq.singleton $ TreeN (cell "i") $ xmlify inh ts
- PairBackquote -> Seq.singleton $ TreeN (cell "code") $ xmlify inh ts
+ PairStar -> Seq.singleton . TreeN (cell "b") $ xmlify inh ts
+ PairSlash -> Seq.singleton . TreeN (cell "i") $ xmlify inh ts
+ PairBackquote -> Seq.singleton . TreeN (cell "code") $ xmlify inh ts
PairFrenchquote ->
- Seq.singleton $
+ Seq.singleton .
TreeN (cell "q") $
+ xmlify inh ts
+ {-
case ts of
(Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) ->
case Seq.viewr ls of
xmlify inh $
rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r)))
_ -> xmlify inh ts
+ -}
PairHash ->
- Seq.singleton $
+ Seq.singleton .
TreeN (cell "ref") $
xmlAttrs [cell ("to",TL.toStrict $ Plain.text def ts)]
PairElem name attrs ->
- Seq.singleton $
+ Seq.singleton .
TreeN (cell $ xmlLocalName name) $
- xmlAttrs (Seq.fromList $ (\(_wh,Attr{..}) ->
- cell (xmlLocalName attr_name,attr_value)) <$> attrs) <>
+ xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) ->
+ cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <>
xmlify inh ts
_ ->
let (o,c) = pairBorders p ts in
- Seq.singleton (Tree0 $ Cell bp bp $ XmlText o) `unionXml`
+ Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell bp bp o) `unionXml`
xmlify inh ts `unionXml`
- Seq.singleton (Tree0 $ Cell ep ep $ XmlText c)
+ Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell ep ep c)
where
cell :: a -> Cell a
cell = Cell bp ep
- xmlify _inh (Tree0 (Cell bp ep tok)) =
+ xmlify inh (Tree0 tok) = do
case tok of
- TokenPlain t -> Seq.singleton $ Tree0 $ cell $ XmlText t
+ TokenPhrases ps -> xmlify inh $ ps
+ TokenEscape c -> Seq.singleton $ Tree0 $ XmlPhrases $ phrasify c
+ TokenRaw t -> Seq.singleton $ Tree0 $ XmlText t
TokenTag t -> Seq.singleton $ TreeN (cell "ref") $ xmlAttrs [cell ("to",t)]
- TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ Text.singleton c
- TokenLink lnk -> Seq.singleton $
- TreeN (cell "eref") $
- xmlAttrs [cell ("to",lnk)]
+ TokenLink (Cell bp ep lnk) ->
+ xmlify (Cell bp ep ()) <>
+ Seq.singleton (TreeN (cell "eref") $ xmlAttrs [cell ("to",lnk)])
where
cell :: a -> Cell a
cell = Cell bp ep
+ {-
+ whites :: Pos -> Pos -> Seq XmlText
+ whites (Pos bLine bCol) (Pos eLine eCol) =
+ case bLine`compate`eLine of
+ LT -> verts <>
+ EQ -> horiz bCol eCol
+ GT ->
+ -}
+instance Xmlify (Cell Phrase) where
+ xmlify _inh t = Seq.singleton $ Tree0 $ XmlPhrases $ Seq.singleton t
mimetype :: Text -> Maybe Text
mimetype "hs" = Just "text/x-haskell"
xmlTitle :: Pos -> XMLs -> XML
xmlTitle = xmlPhantom "title"
xmlName :: Pos -> XMLs -> XML
-xmlName bp (toList -> [Tree0 (unCell -> XmlText t)]) = Tree0 (Cell bp bp $ XmlAttr "name" t)
+xmlName bp (toList -> [Tree0 (XmlText (unCell -> t))]) = Tree0 (XmlAttr $ Cell bp bp ("name", t))
xmlName bp ts = xmlPhantom "name" bp ts
-xmlDocument :: TCTs -> XMLs
-xmlDocument trees =
- case Seq.viewl trees of
- TreeN (unCell -> KeySection{}) vs :< ts ->
- case spanlTokens vs of
- (titles@(Seq.viewl -> (Seq.viewl -> (posTree -> bp) :< _) :< _), vs') ->
- let vs'' =
- case Seq.findIndexL
- (\case
- TreeN (unCell -> KeyColon "about" _) _ -> True
- _ -> False) vs' of
- Nothing -> TreeN (Cell bp bp $ KeyColon "about" "") mempty <| vs'
- Just{} -> vs' in
- xmlify def
- { inh_titles = titles
- , inh_figure = True
- , inh_tree0 = List.repeat xmlPara
- } vs'' <>
- xmlify def ts
- _ -> xmlify def trees
- _ -> xmlify def trees
-
xmlAbout ::
Inh ->
Cell Key -> Seq (Cell (XmlName, Text)) ->
KeyBar n _wh -> d_key n
KeyDot _n -> TreeN (cell "li") $ xmlify inh ts
KeyDash -> TreeN (cell "li") $ xmlify inh ts
- KeyDashDash -> Tree0 $ cell $ XmlComment $ TL.toStrict com
+ KeyDashDash -> Tree0 $ XmlComment $ cell $ TL.toStrict com
where
com :: TL.Text
com =
- Plain.text def $
+ trace ("TS: "<>show ts) $
+ trace ("RS: "<>show (S.evalState (Plain.rackUpLeft ts) Nothing)) $
+ Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing
+ {-
TreeSeq.mapAlsoNode
(cell1 . unCell)
(\_k -> fmap $
TreeSeq.mapAlsoNode
(cell1 . unCell)
(\_k' -> cell1 . unCell)) <$> ts
+ -}
KeyLower n as -> TreeN (cell "artwork") $ xmlify inh ts
KeyBrackets ident ->
let inh' = inh{inh_figure = False} in
xmlify inh ts
xmlAttrs :: Seq (Cell (XmlName,Text)) -> XMLs
-xmlAttrs = ((\(Cell bp ep (n,v)) -> Tree0 (Cell bp ep $ XmlAttr n v)) <$>)
+xmlAttrs = (Tree0 . XmlAttr <$>)
-- | Unify two 'XMLs', merging border 'XmlText's if any.
unionXml :: XMLs -> XMLs -> XMLs
case (Seq.viewr x, Seq.viewl y) of
(xs :> x0, y0 :< ys) ->
case (x0,y0) of
- (Tree0 (Cell bx _ex (XmlText tx)), Tree0 (Cell _by ey (XmlText ty))) ->
+ ( Tree0 (XmlPhrases tx)
+ , Tree0 (XmlPhrases ty) ) ->
+ xs `unionXml`
+ Seq.singleton (Tree0 $ XmlPhrases $ tx <> ty) `unionXml`
+ ys
+ ( Tree0 (XmlText tx)
+ , Tree0 (XmlText ty) ) ->
xs `unionXml`
- Seq.singleton (Tree0 $ Cell bx ey $ XmlText $ tx <> ty) `unionXml`
+ Seq.singleton (Tree0 $ XmlText $ tx <> ty) `unionXml`
ys
_ -> x <> y
(Seq.EmptyR, _) -> y
let (lis, ts') = spanLIs ts in
foldl' accumLIs (mempty,ts') lis
where
+ spanLIs :: TCTs -> (TCTs, TCTs)
spanLIs = Seq.spanl $ \case
TreeN (unCell -> liKey -> True) _ -> True
Tree0 toks ->
_ -> False
-}
_ -> False
+ accumLIs :: (TCTs,TCTs) -> TCT -> (TCTs,TCTs)
accumLIs acc@(oks,kos) t =
case t of
TreeN (unCell -> liKey -> True) _ -> (oks|>t,kos)
Tree0 toks ->
let (ok,ko) =
(`Seq.spanl` toks) $ \case
- TreeN (unCell -> PairElem "li" _) _ -> True
- Tree0 (unCell -> TokenPlain txt) -> Char.isSpace`Text.all`txt
- _ -> False in
- ( if null ok then oks else oks|>Tree0 (rmTokenPlain ok)
+ TreeN (unCell -> PairElem "li" _) _ -> True
+ -- (isTokenWhite -> True) -> True -- TODO: see if this is still useful
+ _ -> False in
+ ( if null ok then oks else oks|>Tree0 (rmTokenWhite ok)
, if null ko then kos else Tree0 ko<|kos )
_ -> acc
- rmTokenPlain =
+ {-
+ rmTokenWhite :: Tokens -> Tokens
+ rmTokenWhite =
Seq.filter $ \case
- (Tree0 (unCell -> TokenPlain{})) -> False
+ (isTokenWhite -> False) -> True
_ -> True
+ -}
spanlKeyColon :: Name -> TCTs -> (TCTs, TCTs)
spanlKeyColon name =
import Text.Show (Show(..), showsPrec, showChar, showString)
import qualified Data.List as List
import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
import Language.TCT.Cell
-- * Type 'XML'
-type XML = Tree (Cell XmlName) (Cell XmlLeaf)
+type XML = Tree (Cell XmlNode)
type XMLs = Seq XML
-- ** Type 'XmlName'
xmlLocalName :: Text -> XmlName
xmlLocalName = XmlName "" ""
--- ** Type 'XmlLeaf'
-data XmlLeaf
- = XmlAttr XmlName Text
- | XmlComment Text
- | XmlText Text
+-- ** Type 'XmlNode'
+data XmlNode
+ = XmlElem XmlName
+ | XmlAttr XmlName TL.Text
+ | XmlComment TL.Text
+ | XmlText TL.Text
deriving (Eq,Ord,Show)
-- * Type 'Rank'
+-- | nth child
type Rank = Int
-- * Type 'Nat'
instance Semigroup MayText where
MayText "" <> y = y
x <> MayText "" = x
- _x <> y = y
+ _x <> y = y
whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
whenMayText (MayText "") _f = pure ()
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
+import qualified Data.Text.Lazy as TL
import qualified System.Environment as Env
import qualified Text.Blaze.Renderer.Utf8 as Blaze
import qualified Text.Blaze.Utils as Blaze
import qualified Text.Blaze.DTC as Blaze.DTC
import qualified Text.Blaze.HTML5 as Blaze.HTML5
-}
-import qualified Language.RNC.Write as RNC
+-- import qualified Language.RNC.Write as RNC
import qualified Language.TCT as TCT
-import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5
-import qualified Language.TCT.Write.XML as TCT.Write.XML
+-- import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5
+-- import qualified Language.TCT.Write.XML as TCT.Write.XML
import qualified Text.Megaparsec as P
import Read
mainWithCommand :: Command -> IO ()
mainWithCommand (CommandTCT ArgsTCT{..}) =
readFile input $ \_fp txt ->
- case TCT.readTCTs input txt of
+ case TCT.readTrees input $ TL.fromStrict txt of
Left err -> error $ P.parseErrorPretty err
Right tct -> do
when (trace_TCT trace) $ do
hPutStrLn stderr "### TCT ###"
hPrint stderr $ Tree.Pretty tct
+ {-
when (trace_XML trace) $ do
hPutStrLn stderr "### XML ###"
let xml = TCT.Write.XML.xmlDocument tct
TctFormatHTML5 ->
Blaze.renderMarkupToByteStringIO BS.putStr $
TCT.Write.HTML5.html5Document tct
+ -}
{-
mainWithCommand (CommandDTC ArgsDTC{..}) =
readFile input $ \_fp txt ->
sourcephile / git / doclang.git / commitdiff