Remove some Cell from Tree.

diff --git a/Language/TCT/Read.hs b/Language/TCT/Read.hs
index 1b13d2c0d3c15334b03f44f395565c404b475e34..c88655ada08fe49c160d921d79ba24ed2f5f657f 100644 (file)
--- a/Language/TCT/Read.hs
+++ b/Language/TCT/Read.hs
@@ -13,7 +13,7 @@ import Data.Functor ((<$>))
 import Data.Maybe (Maybe(..))
 import Data.Semigroup (Semigroup(..))
 import Data.Text (Text)
-import Data.Traversable (sequence)
+import Data.Traversable (Traversable(..))
 import Data.Tuple (fst, snd)
 import Prelude (fromIntegral)
 import System.IO (FilePath)
@@ -27,22 +27,19 @@ import Language.TCT.Read.Token
 
 import Debug.Trace (trace)
 
-readTCT ::
+readTreeCell ::
  FilePath -> Text ->
  Either (P.ParseError (P.Token Text) P.Dec)
         (Trees (Cell Key) (Cell Tokens))
-readTCT inp txt = do
+readTreeCell inp txt = do
        tct <- P.runParser (p_Trees <* P.eof) inp txt
-       sequence $ (<$> tct) {-(<$> trace (show $ PrettyTree tct) tct)-} $ \tr ->
+       (`traverse` tct) {- $ (<$> trace (show $ PrettyTree tct) tct)-} $ \tr ->
                sequence $ (`mapTreeWithKey`tr) $ \key (Cell pos posEnd t) ->
                        case key of
                         -- Verbatim Keys
-                        Just (unCell -> KeyBar{}) ->
-                               Right $ Cell pos posEnd $ tokens [TokenPlain t]
-                        Just (unCell -> KeyLower{}) ->
-                               Right $ Cell pos posEnd $ tokens [TokenPlain t]
-                        Just (unCell -> KeyEqual{}) ->
-                               Right $ Cell pos posEnd $ tokens [TokenPlain t]
+                        Just (unCell -> KeyBar{})   -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
+                        Just (unCell -> KeyLower{}) -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
+                        Just (unCell -> KeyEqual{}) -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
                         -- Token Keys
                         _ ->
                                Cell pos posEnd <$>
@@ -54,6 +51,29 @@ readTCT inp txt = do
                                                p_Tokens <* P.eof
                                         ) inp (StreamCell t)
 
+readTree ::
+ FilePath -> Text ->
+ Either (P.ParseError (P.Token Text) P.Dec)
+        (Trees Key Tokens)
+readTree inp txt = do
+       tct <- P.runParser (p_Trees <* P.eof) inp txt
+       (`traverse` tct) $ \tr ->
+               sequence $ (\f -> mapTreeKey unCell f tr) $ \key (Cell pos _posEnd t) ->
+                       case unCell <$> key of
+                        -- Verbatim Keys
+                        Just KeyBar{}   -> Right $ tokens [TokenPlain t]
+                        Just KeyLower{} -> Right $ tokens [TokenPlain t]
+                        Just KeyEqual{} -> Right $ tokens [TokenPlain t]
+                        -- Token Keys
+                        _ ->
+                               P.runParser (do
+                                       P.setTabWidth $ P.unsafePos $ fromIntegral $ columnPos pos
+                                       P.setPosition $ P.SourcePos inp
+                                        (P.unsafePos $ fromIntegral $ linePos   pos)
+                                        (P.unsafePos $ fromIntegral $ columnPos pos)
+                                       p_Tokens <* P.eof
+                                ) inp (StreamCell t)
+
 -- * Type 'StreamCell'
 -- | Wrap 'Text' to have a 'P.Stream' instance
 -- whose 'P.updatePos' method abuses the tab width state

diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs
index 17b4d688574429ad7913cf98393046c1928d8e71..87131415760dc57dd2925f75da897fed86df052d 100644 (file)
--- a/Language/TCT/Read/Tree.hs
+++ b/Language/TCT/Read/Tree.hs
@@ -183,6 +183,6 @@ p_Rows rows =
 p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
 p_Trees = unRoot . collapseRows <$> p_Rows [root]
        where
-       root = TreeN (Cell pos0 pos0 KeyDash) mempty
+       root = TreeN (cell0 KeyDash) mempty
        unRoot (TreeN (unCell -> KeyDash) roots) = roots
        unRoot _ = undefined

diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs
index 9058e3169d1cd45e9721f8ef137e36d20046de87..cdc6d156b9e29ce778df16d36f0468e8d1fafa66 100644 (file)
--- a/Language/TCT/Tree.hs
+++ b/Language/TCT/Tree.hs
@@ -44,6 +44,12 @@ mapTreeWithKey = go Nothing
        go _k f (TreeN k ts) = TreeN k (go (Just k) f <$> ts)
        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
        where
@@ -88,6 +94,8 @@ 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.
@@ -128,6 +136,8 @@ 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'

diff --git a/Language/TCT/Write/DTC.hs b/Language/TCT/Write/DTC.hs
index 894b87b4fce0f3e49caa1dcb10d5ad613b40662d..8e0fef48e11b6b3040d4ac7e0b9afe04c375094b 100644 (file)
--- a/Language/TCT/Write/DTC.hs
+++ b/Language/TCT/Write/DTC.hs
@@ -44,7 +44,7 @@ trac m x = trace m x
 dbg :: Show a => String -> a -> a
 dbg m x = trac (m <> ": " <> show x) x
 
-dtc :: Trees (Cell Key) (Cell Tokens) -> DTC
+dtc :: Trees Key Tokens -> DTC
 dtc ts = do
        let lang = "fr"
        D.xmlModel "./schema/dtc.rnc"
@@ -53,8 +53,8 @@ dtc ts = do
        D.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
        D.document $
                case Seq.viewl ts of
-                TreeN (unCell -> KeySection{})
-                      (Seq.viewl -> Tree0 (unCell -> Write.t_Tokens -> TL.toStrict -> title) :< head)
+                TreeN KeySection{}
+                      (Seq.viewl -> Tree0 (Write.t_Tokens -> TL.toStrict -> title) :< head)
                       :< body -> do
                        d_Trees [] (mangleHead title head)
                        d_Trees [] body
@@ -63,16 +63,16 @@ dtc ts = do
        where
        mangleHead ::
         Text ->
-        Trees (Cell Key) (Cell Tokens) ->
-        Trees (Cell Key) (Cell Tokens)
+        Trees Key Tokens ->
+        Trees Key Tokens
        mangleHead title head =
                let mi =
                        (`Seq.findIndexL` head) $ \case
-                        TreeN (unCell -> KeyColon "about" _) _ -> True
+                        TreeN (KeyColon "about" _) _ -> True
                         _ -> False in
                case mi of
                 Nothing ->
-                       TreeN (cell0 (KeyColon "about" ""))
+                       TreeN (KeyColon "about" "")
                              (Seq.fromList names)
                        <| head
                 Just i -> Seq.adjust f i head
@@ -82,12 +82,11 @@ dtc ts = do
                where
                names = name <$> Text.splitOn "\n" title
                name =
-                       TreeN (cell0 (KeyColon "name" "")) .
-                       Seq.singleton .
-                       Tree0 . cell0 .
-                       Tokens . Seq.singleton . TokenPlain
+                       TreeN (KeyColon "name" "") .
+                       Seq.singleton . Tree0 . Tokens .
+                       Seq.singleton . TokenPlain
 
-d_Trees :: [Key] -> Trees (Cell Key) (Cell Tokens) -> DTC
+d_Trees :: [Key] -> Trees Key Tokens -> DTC
 d_Trees path ts =
        case () of
         _ | (ul,ts') <- gatherUL ts, not (null ul) -> do
@@ -102,26 +101,23 @@ d_Trees path ts =
         _ ->
                return ()
 
-gatherUL ::
- Trees (Cell Key) (Cell Tokens) ->
- ( Trees (Cell Key) (Cell Tokens)
- , Trees (Cell Key) (Cell Tokens) )
+gatherUL :: Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
 gatherUL ts =
        let (lis, ts') = spanLIs ts in
        foldl' accumLIs (mempty,ts') lis
        where
        spanLIs = Seq.spanl $ \case
-                TreeN (unCell -> KeyDash) _ -> True
-                Tree0 (unCell -> Tokens toks) ->
+                TreeN KeyDash _ -> True
+                Tree0 (Tokens toks) ->
                        (`any` toks) $ \case
                         TokenPair (PairElem "li" _) _ -> True
                         _ -> False
                 _ -> False
        accumLIs acc@(oks,kos) t =
                case t of
-                TreeN (unCell -> KeyDash) _ -> (oks|>t,kos)
-                Tree0 (Cell pos posEnd (Tokens toks)) ->
-                       let mk = Tree0 . Cell pos posEnd . Tokens in
+                TreeN KeyDash _ -> (oks|>t,kos)
+                Tree0 (Tokens toks) ->
+                       let mk = Tree0 . Tokens in
                        let (ok,ko) =
                                (`Seq.spanl` toks) $ \case
                                 TokenPair (PairElem "li" _) _ -> True
@@ -135,26 +131,23 @@ gatherUL ts =
                 TokenPlain{} -> False
                 _ -> True
 
-gatherOL ::
- Trees (Cell Key) (Cell Tokens) ->
- ( Trees (Cell Key) (Cell Tokens)
- , Trees (Cell Key) (Cell Tokens) )
+gatherOL :: Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
 gatherOL ts =
        let (lis, ts') = spanLIs ts in
        foldl' accumLIs (mempty,ts') lis
        where
        spanLIs = Seq.spanl $ \case
-                TreeN (unCell -> KeyDot{}) _ -> True
-                Tree0 (unCell -> Tokens toks) ->
+                TreeN KeyDot{} _ -> True
+                Tree0 (Tokens toks) ->
                        (`any` toks) $ \case
                         TokenPair (PairElem "li" _) _ -> True
                         _ -> False
                 _ -> False
        accumLIs acc@(oks,kos) t =
                case t of
-                TreeN (unCell -> KeyDot{}) _ -> (oks|>t,kos)
-                Tree0 (Cell pos posEnd (Tokens toks)) ->
-                       let mk = Tree0 . Cell pos posEnd . Tokens in
+                TreeN KeyDot{} _ -> (oks|>t,kos)
+                Tree0 (Tokens toks) ->
+                       let mk = Tree0 . Tokens in
                        let (ok,ko) =
                                (`Seq.spanl` toks) $ \case
                                 TokenPair (PairElem "li" _) _ -> True
@@ -168,10 +161,10 @@ gatherOL ts =
                 TokenPlain{} -> False
                 _ -> True
 
-d_Tree :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
-d_Tree path (TreeN (unCell -> key@KeySection{}) ts) =
+d_Tree :: [Key] -> Tree Key Tokens -> DTC
+d_Tree path (TreeN key@KeySection{} ts) =
        case Seq.viewl children of
-        Tree0 (Cell _posTitle _ (toList -> [TokenPlain title])) :< body ->
+        Tree0 (toList -> [TokenPlain title]) :< body ->
                d_attrs (mangleAttrs title attrs) $
                case Text.splitOn "\n" title of
                 t0:t1 ->
@@ -183,7 +176,7 @@ d_Tree path (TreeN (unCell -> key@KeySection{}) ts) =
                 [] ->
                        D.section ! DA.name (attrValue title) $
                                d_content body
-        Tree0 (Cell _posTitle _ title) :< body ->
+        Tree0 title :< body ->
                d_attrs (mangleAttrs (TL.toStrict $ Write.t_Tokens title) attrs) $
                D.section $ do
                        D.name $ d_Tokens (key:path) title
@@ -196,19 +189,29 @@ d_Tree path (TreeN (unCell -> key@KeySection{}) ts) =
        d_content cs     = d_Trees (key:path) cs
        mangleAttrs :: Text -> Attributes -> Attributes
        mangleAttrs title = Map.insertWith (\_new old -> old) "id" title
-d_Tree path (Tree0 cell) = d_CellTokens path cell
-d_Tree path (TreeN cell@(unCell -> KeyColon{}) ts) =
+d_Tree path (Tree0 ts) =
+       case path of
+        [] ->
+               case ts of
+                (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
+                _ -> D.para $ d_Tokens path ts
+        KeySection{}:_ ->
+               case ts of
+                (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
+                _ -> D.para $ d_Tokens path ts
+        _ -> d_Tokens path ts
+d_Tree path (TreeN cell@KeyColon{} ts) =
        let (attrs,children) = partitionAttributesChildren ts in
-       d_attrs attrs $ d_CellKey path cell children
-d_Tree path (TreeN cell ts) = d_CellKey path cell ts
+       d_attrs attrs $ d_Key path cell children
+d_Tree path (TreeN cell ts) = d_Key path cell ts
 
-d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Tokens) -> DTC
-d_CellKey path (Cell _pos _posEnd key) cells = do
+d_Key :: [Key] -> Key -> Trees Key Tokens -> DTC
+d_Key path key cells = do
        case key of
-        KeyColon n _wh -> d_Key n
-        KeyGreat n _wh -> d_Key n
-        KeyEqual n _wh -> d_Key n
-        KeyBar   n _wh -> d_Key n
+        KeyColon n _wh -> d_key n
+        KeyGreat n _wh -> d_key n
+        KeyEqual n _wh -> d_key n
+        KeyBar   n _wh -> d_key n
         KeyDot _n -> D.li $ d_Trees (key:path) cells
         KeyDash   -> D.li $ d_Trees (key:path) cells
         {-
@@ -218,27 +221,13 @@ d_CellKey path (Cell _pos _posEnd key) cells = do
                forM_ cells $ d_Tree path
         -}
        where
-       d_Key :: Text -> DTC
-       d_Key name | null cells =
+       d_key :: Text -> DTC
+       d_key name | null cells =
                B.CustomLeaf (B.Text name) True mempty
-       d_Key name =
+       d_key name =
                B.CustomParent (B.Text name) $
                        d_Trees (key:path) cells
 
-d_CellTokens :: [Key] -> Cell Tokens -> DTC
-d_CellTokens path (Cell _pos _posEnd ts) =
-       -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellTokens: path:" path of
-       case dbg "d_CellTokens: path" path of
-        [] ->
-               case ts of
-                (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
-                _ -> D.para $ d_Tokens path ts
-        KeySection{}:_ ->
-               case ts of
-                (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
-                _ -> D.para $ d_Tokens path ts
-        _ -> d_Tokens path ts
-
 d_Tokens :: [Key] -> Tokens -> DTC
 d_Tokens _path tok = goTokens tok
        where
@@ -288,8 +277,8 @@ d_attrs = flip $ Map.foldrWithKey $ \n v ->
        B.AddCustomAttribute (B.Text n) (B.Text v)
 
 partitionAttributesChildren ::
- Trees (Cell Key) (Cell Tokens) ->
- (Attributes, Trees (Cell Key) (Cell Tokens))
+ Trees Key Tokens ->
+ (Attributes, Trees Key Tokens)
 partitionAttributesChildren ts = (attrs,children)
        where
        attrs :: Attributes
@@ -297,16 +286,17 @@ partitionAttributesChildren ts = (attrs,children)
                foldr (\t acc ->
                        case t of
                         Tree0{} -> acc
-                        TreeN (unCell -> KeyEqual n _wh) a -> Map.insert n v acc
+                        TreeN (KeyEqual n _wh) a -> Map.insert n v acc
                                where
                                v = TL.toStrict $
                                        Write.text Write.config_text{Write.config_text_escape = False} $
-                                       Write.treeRackUpLeft <$> a
+                                       mapTreeKey cell1 (\_path -> cell1) <$> a
+                                       -- Write.treeRackUpLeft <$> a
                         TreeN{} -> acc
                 ) mempty ts
        children = Seq.filter (\t ->
                case t of
                 Tree0{} -> True
-                TreeN (unCell -> KeyEqual{}) _cs -> False
+                TreeN KeyEqual{} _cs -> False
                 TreeN{} -> True
                 ) ts

diff --git a/Language/TCT/Write/HTML5/Source.hs b/Language/TCT/Write/HTML5/Source.hs
index 81e963aa00c9f55b8670ae1f1c91b53bbfaf77c2..cfde66061c96e280e43b1ffeeee74f6d6ec1a126 100644 (file)
--- a/Language/TCT/Write/HTML5/Source.hs
+++ b/Language/TCT/Write/HTML5/Source.hs
@@ -57,7 +57,8 @@ html5 tct = do
                        H.meta ! HA.httpEquiv "Content-Type"
                               ! HA.content "text/html; charset=UTF-8"
                        whenJust (titleTCT tct) $ \(unCell -> ts) ->
-                               H.title $ H.toMarkup $ L.head $ Text.lines (TL.toStrict $ t_Tokens ts) <> [""]
+                               H.title $ H.toMarkup $ L.head $
+                                       Text.lines (TL.toStrict $ t_Tokens ts) <> [""]
                        -- link ! rel "Chapter" ! title "SomeTitle">
                        H.link ! HA.rel "stylesheet"
                               ! HA.type_ "text/css"

diff --git a/Language/TCT/Write/Text.hs b/Language/TCT/Write/Text.hs
index 4219b0e1e2b8cd386a2d5fdd29d8344b4aa864e0..18419c00ad49cd4d74622be64b7ca7d5bae2ee20 100644 (file)
--- a/Language/TCT/Write/Text.hs
+++ b/Language/TCT/Write/Text.hs
@@ -113,8 +113,8 @@ t_IndentCell (Pos lineLast colLast,posCell -> Pos line col)
  | lineLast < line =
        TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
        TL.replicate (int64 $ col - 1) " "
- | lineLast == line
- && colLast <= col = TL.replicate (int64 $ col - colLast) " "
+ | lineLast == line && colLast <= col =
+       TL.replicate (int64 $ col - colLast) " "
  | otherwise = undefined
 
 t_CellKey :: Config_Text -> Cell Key -> Trees (Pos,Cell Key) (Pos,Cell Tokens) -> TL.Text