import Data.Sequence (Seq, ViewL(..), (|>))
import Data.Text (Text)
import Data.Traversable (Traversable(..))
-import Data.Tuple (fst,snd)
import Prelude (undefined, Int, Num(..))
import Text.Show (Show(..))
import qualified Data.List as List
deriving (Eq, Show, Functor)
instance Traversable (Tree k) where
- traverse f (TreeN k ts) = TreeN k <$> traverse (traverse f) ts
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 k) = f k
mapTreeWithKey = go Nothing
where
go _k f (TreeN k ts) = TreeN k (go (Just k) f <$> ts)
- go k f (Tree0 a) = Tree0 (f k a)
+ go k f (Tree0 a) = Tree0 (f k a)
+
+mapTreeKey :: (k -> l) -> (Maybe k -> a -> b) -> Tree k a -> Tree l b
+mapTreeKey fk fv = go Nothing
+ where
+ go _k (TreeN k ts) = TreeN (fk k) $ go (Just k) <$> ts
+ go k (Tree0 a) = Tree0 (fv k a)
traverseTreeWithKey :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b)
traverseTreeWithKey = go Nothing
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 (Tree0 a) = [Text.pack (show a)]
pretty (TreeN k ts0) = Text.pack (show k) : prettySubTrees ts0
where
prettySubTrees s =
shift first other = List.zipWith (<>) (first : List.repeat other)
-- * Type 'Pos'
-type Pos = (Line,Column)
+data Pos = Pos {-# UNPACK #-} !Line {-# UNPACK #-} !Column
+ deriving (Eq, Show)
posTree :: Tree (Cell k) (Cell a) -> Pos
posTree (TreeN c _) = posCell c
posEndTree (TreeN c _) = posEndCell c
posEndTree (Tree0 c) = posEndCell c
+pos0 :: Pos
+pos0 = Pos 0 0
+pos1 :: Pos
+pos1 = Pos 1 1
-- ** Type 'Line'
-- | Line in the source file, counting from 1.
type Line = Int
linePos :: Pos -> Line
-linePos = fst
+linePos (Pos l _) = l
-- ** Type 'Column'
-- | Column in the source file, counting from 1.
type Column = Int
columnPos :: Pos -> Column
-columnPos = snd
+columnPos (Pos _ c) = c
-- * Type 'Row'
-- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'.
-- which is useful to indicate matches/errors/warnings/whatever,
-- or outputing in a format somehow preserving
-- the original input style.
-data Cell a = Cell Pos Pos a
+data Cell a = Cell {-# UNPACK #-} !Pos {-# UNPACK #-} !Pos a
deriving (Eq, Show)
unCell :: Cell a -> a
posCell :: Cell a -> Pos
posCell (Cell pos _ _) = pos
-
posEndCell :: Cell a -> Pos
posEndCell (Cell _ pos _) = pos
lineCell :: Cell a -> Line
-lineCell = fst . posCell
+lineCell = linePos . posCell
columnCell :: Cell a -> Column
-columnCell = snd . posCell
+columnCell = columnPos . posCell
+
+cell0 :: a -> Cell a
+cell0 = Cell pos0 pos0
+cell1 :: a -> Cell a
+cell1 = Cell pos1 pos1
-- * Type 'Key'
-data Key = KeyColon Name White -- ^ @name:@ begin 'Cell'
- | KeyEqual Name White -- ^ @name=@ begin 'Value'
- | KeyBar Name White -- ^ @name|@ continue 'Value'
- | KeyGreat Name White -- ^ @name>@ continue 'Cell'
- | KeyLower Name Attrs -- ^ @<name a=b@ begin HereDoc
- | KeyDash -- ^ @- @ begin item
- | KeySection LevelSection -- ^ @### @ begin section
+data Key = KeyColon !Name !White -- ^ @name: @ begin 'Cell'
+ | KeyEqual !Name !White -- ^ @name=@ begin 'Value'
+ | KeyBar !Name !White -- ^ @name|@ continue 'Value'
+ | KeyGreat !Name !White -- ^ @name>@ continue 'Cell'
+ | KeyLower !Name !Attrs -- ^ @<name a=b@ begin HereDoc
+ | KeyDot !Name -- ^ @1. @ begin item
+ | KeyDash -- ^ @- @ begin item
+ | KeyDashDash -- ^ @-- @ begin item
+ | KeySection !LevelSection -- ^ @### @ begin section
deriving (Eq, Show)
-- ** Type 'Name'
-- | @appendRow rows row@ appends @row@ to @rows@.
--
--- [@rows@] parent 'Rows', from closed to farest (non-strictly descending)
+-- [@rows@] parent 'Rows', from closest to farest (non-strictly descending)
-- [@row@] next 'Row', from leftest column to rightest (non-stricly ascending)
appendRow :: Rows -> Row -> Rows
appendRow [] row = List.reverse row
appendRow parents [] = parents
-appendRow ps@(parent:parents) rs@(row:rows) =
- trac ("appendRow: ps=" <> show ps) $
- trac ("appendRow: rs=" <> show rs) $
+appendRow rows@(parent:parents) row@(cell:cells) =
+ trac ("appendRow: rows=" <> show rows) $
+ trac ("appendRow: row=" <> show row) $
dbg "appendRow" $
let colParent = columnPos $ posTree parent in
- let colRow = columnPos $ posTree row in
+ let colRow = columnPos $ posTree cell in
case dbg "colParent" colParent`compare`dbg "colRow" colRow of
LT ->
- case (dbg "parent" parent,dbg "row" row) of
+ case (dbg "parent" parent,dbg "cell" cell) of
(Tree0{}, TreeN{}) -> eq
(Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
(Tree0 p, Tree0 r) -> appendTree0 p r
_ -> lt
EQ ->
- case (dbg "parent" parent,dbg "row" row) of
+ case (dbg "parent" parent,dbg "cell" cell) of
(Tree0 p, Tree0 r) -> appendTree0 p r
(_, TreeN (unCell -> KeySection sectionRow) _)
- | Just (sectionParent, secPar:secPars) <- collapseSection colRow ps ->
+ | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
- LT -> appendRow (row:secPar:secPars) rows
- EQ -> appendRow (row:insertChild secPar secPars) rows
+ LT -> appendRow (cell:secPar:secPars) cells
+ EQ -> appendRow (cell:insertChild secPar secPars) cells
GT -> gt
(TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
(TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
(TreeN{}, Tree0{}) -> eq
GT -> gt
where
- appendTree0 p r = appendRow (Tree0 (appendCellText p r):parents) rows
- lt = appendRow [] rs <> ps
- eq = appendRow (row:insertChild parent parents) rows
- gt = appendRow (insertChild parent parents) rs
+ appendTree0 p r =
+ case appendCellText p r of
+ Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
+ Just c -> appendRow (Tree0 c : 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 =
_ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
collapseSection _ _ = Nothing
-appendCellText :: Cell Text -> Cell Text -> Cell Text
+appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text)
appendCellText (Cell posPar posEndPar p)
(Cell posRow posEndRow r) =
trac ("appendCellText: p="<>show p) $
trac ("appendCellText: r="<>show r) $
dbg "appendCellText" $
- Cell posPar posEndRow $ p <> pad <> r
+ case linePos posRow - linePos posEndPar of
+ 0 -> Just $ Cell posPar posEndRow $ p <> pad <> r
+ where pad = padding (columnPos posEndPar) (columnPos posRow)
+ 1 -> Just $ Cell posPar posEndRow $ p <> pad <> r
+ where pad = "\n" <> padding (columnPos posPar) (columnPos posRow)
+ _ -> Nothing
where
- pad =
- let ns = linePos posRow - linePos posEndPar in
- if ns == 0
- then padding (columnPos posEndPar) (columnPos posRow)
- else Text.replicate ns "\n" <> padding (columnPos posPar) (columnPos posRow)
padding x y = Text.replicate (y - x) " "
insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
GT -> undefined
collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
-collapseRows [] = undefined
-collapseRows [child] = dbg "collapseRows" $ child
+collapseRows [] = undefined
+collapseRows [child] = dbg "collapseRows" $ child
collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents
-
--- * Type 'TCT'
-type TCT a = Trees (Cell Key) a
sourcephile / git / doclang.git / blobdiff