Add --output option.

[doclang.git] / Language / DTC / Read / TCT.hs

diff --git a/Language/DTC/Read/TCT.hs b/Language/DTC/Read/TCT.hs
index dc8db78b4b8fe56927ef23e93e7b0d8678a5f236..5bfc220067d992aef6b33b2b6fa6e5b1d72f938d 100644 (file)
--- a/Language/DTC/Read/TCT.hs
+++ b/Language/DTC/Read/TCT.hs
@@ -19,7 +19,7 @@ import Data.Function (($), (.), const, id)
 import Data.Functor ((<$>), (<$))
 import Data.Int (Int)
 import Data.List.NonEmpty (NonEmpty(..))
-import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.Maybe (Maybe(..), maybe)
 import Data.Monoid (Monoid(..), First(..))
 import Data.Ord (Ord(..))
 import Data.Proxy (Proxy(..))
@@ -57,19 +57,20 @@ instance RNC.Sym_Rule Parser where
        rule _n = id
 instance RNC.Sym_RNC Parser where
        none = P.label "none" $ P.eof
+       fail = P.label "fail" $ P.failure Nothing mempty
        any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
        anyElem p = P.label "anyElem" $ do
                (n,ts) <- P.token check $ Just expected
                parserXMLs (p n) ts
                where
-               expected = Tree (cell0 $ XmlElem "") mempty
-               check (Tree (unCell -> XmlElem n) ts) = Right (n,ts)
+               expected = Tree (cell0 $ XmlElem "*") mempty
+               check (Tree (unCell -> XmlElem e) ts) = Right (e,ts)
                check t = Left
                 ( Just $ P.Tokens $ pure t
                 , Set.singleton $ P.Tokens $ pure expected )
        element n p = do
                ts <- P.token check $ Just expected
-               xp <- S.get
+               pos <- S.get
                let nameOrFigureName
                        | n == "figure"
                        -- NOTE: special case renaming the current DTC.Pos
@@ -86,22 +87,24 @@ instance RNC.Sym_RNC Parser where
                         _ -> First Nothing
                        = xmlLocalName $ ty
                        | otherwise = n
-               let anc name = maybe 1 (+1) $ Map.lookup name $ DTC.posPrecedingsSiblings xp
-               S.put xp
-                { DTC.posAncestors = DTC.posAncestors xp |> (n,anc n)
+               let anc name = maybe 1 (+1) $ Map.lookup name $ DTC.posPrecedingsSiblings pos
+               S.put pos
+                { DTC.posAncestors = DTC.posAncestors pos |> (n,anc n)
                 , DTC.posAncestorsWithFigureNames =
-                       DTC.posAncestorsWithFigureNames xp |>
+                       DTC.posAncestorsWithFigureNames pos |>
                        (nameOrFigureName,anc nameOrFigureName)
                 , DTC.posPrecedingsSiblings = mempty
                 }
-               parserXMLs p ts <* S.put xp
+               res <- parserXMLs p ts
+               S.put pos
                 { DTC.posPrecedingsSiblings=
                        (if n /= nameOrFigureName
                        then Map.insertWith (\_new old -> old + 1) nameOrFigureName 1
                        else id) $
                        Map.insertWith (\_new old -> old + 1) n 1 $
-                       DTC.posPrecedingsSiblings xp
+                       DTC.posPrecedingsSiblings pos
                 }
+               return res
                where
                expected = Tree (cell0 $ XmlElem n) mempty
                check (Tree (unCell -> XmlElem e) ts) | e == n = Right ts
@@ -113,9 +116,8 @@ instance RNC.Sym_RNC Parser where
                parserXMLs p v
                where
                expected = Tree0 (cell0 $ XmlAttr n "")
-               check (Tree (unCell -> XmlElem e) ts) | e == n = Right ts
-               check (Tree0 (Cell bp ep (XmlAttr k v))) | k == n =
-                       Right $ Seq.singleton $ Tree0 $ Cell bp ep $ XmlText v
+               check (Tree0 (Cell sp (XmlAttr k v))) | k == n =
+                       Right $ Seq.singleton $ Tree0 $ Cell sp $ XmlText v
                check t = Left
                 ( Just $ P.Tokens $ pure t
                 , Set.singleton $ P.Tokens $ pure expected )
@@ -191,8 +193,11 @@ parseXMLs st pos p i =
                 { P.stateInput = i
                 , P.statePos = pure $
                        case Seq.viewl i of
-                        Tree c _ :< _ -> sourcePosCell c
-                        _ -> pos
+                        Tree (Cell (Span{span_begin=bp}:|_) _) _ :< _ ->
+                               P.SourcePos "" -- FIXME: put a FilePath
+                                (P.mkPos $ pos_line bp)
+                                (P.mkPos $ pos_column bp)
+                        EmptyL -> pos
                 , P.stateTabWidth = P.pos1
                 , P.stateTokensProcessed = 0
                 }
@@ -231,41 +236,28 @@ fixPos = do
         t :< _ -> P.setPosition $
                P.positionAt1 (Proxy::Proxy XMLs) pos t
 
-sourcePosCell :: Cell a -> P.SourcePos
-sourcePosCell (cell_begin -> bp) =
-       P.SourcePos ""
-        (P.mkPos $ pos_line bp)
-        (P.mkPos $ pos_column bp)
-
-sourcePos :: Pos -> Maybe P.SourcePos
-sourcePos (Pos l c) | l>0 && c>0 = Just $ P.SourcePos "" (P.mkPos l) (P.mkPos c)
-sourcePos _ = Nothing
-
 instance P.Stream XMLs where
        type Token  XMLs = XML
        type Tokens XMLs = XMLs
        take1_ s =
                case Seq.viewl s of
-                Tree0 (unCell -> XmlComment{}) :< ts -> P.take1_ ts
+                Tree (unCell -> XmlComment{}) _ :< ts -> P.take1_ ts
                 t:<ts  -> Just (t,ts)
                 EmptyL -> Nothing
-       positionAt1 _s pos =
-               fromMaybe pos . sourcePos .
-               cell_begin . unTree
+       positionAt1 _s pos (Tree (Cell (Span{span_begin=Pos l c}:|_) _n) _ts) =
+               P.SourcePos (P.sourceName pos) (P.mkPos l) (P.mkPos c)
        positionAtN s pos ts =
                case Seq.viewl ts of
                 t :< _ -> P.positionAt1 s pos t
-                _ -> pos
-       advance1 _s _indent pos =
+                EmptyL -> pos
+       advance1 _s _indent pos (Tree (Cell (Span{span_end=Pos l c}:|_) _n) _ts) =
                -- WARNING: the end of a 'Cell' is not necessarily
                -- the beginning of the next 'Cell'.
-               fromMaybe pos . sourcePos .
-               cell_end . unTree
+               P.SourcePos (P.sourceName pos) (P.mkPos l) (P.mkPos c)
        advanceN s = foldl' . P.advance1 s
-       takeN_ n s
-        | n <= 0    = Just (mempty, s)
-        | null s    = Nothing
-        | otherwise = Just (Seq.splitAt n s) -- FIXME: handle XmlComment
+       takeN_ n s | n <= 0    = Just (mempty, s)
+                  | null s    = Nothing
+                  | otherwise = Just (Seq.splitAt n s) -- FIXME: handle XmlComment and XmlInclude
        tokensToChunk _s = Seq.fromList
        chunkToTokens _s = toList
        chunkLength _s   = Seq.length
@@ -281,8 +273,10 @@ instance P.ShowToken XML where
                         XmlText _t    -> "text"
                         XmlComment _c -> "comment"
                
-               showCell (Cell (Pos 0 0) (Pos 0 0) a) f = f a
-               showCell (Cell bp ep a) f = f a<>" at "<>show bp<>"-"<>show ep
+               showCell (Cell path@(Span{span_file} :| _) a) f =
+                       if null span_file
+                       then f a
+                       else f a <> foldMap (\p -> "\n in "<>show p) path
 
 -- ** Type 'ErrorRead'
 data ErrorRead