{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
+import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
-import Data.Foldable (null, foldl')
+import Data.Foldable (Foldable(..))
import Data.Function (($), (.), const, id)
import Data.Functor ((<$>), (<$))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
-import Data.Maybe (Maybe(..), fromMaybe)
-import Data.Monoid (Monoid(..))
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.Monoid (Monoid(..), First(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (ViewL(..))
+import Data.Sequence (ViewL(..), (|>))
import Data.String (String)
import Data.Text (Text)
import Data.Tuple (snd)
-import GHC.Exts (toList)
+import Prelude (Num(..))
import Text.Read (readMaybe)
import Text.Show (Show(..))
+import qualified Control.Monad.Trans.State as S
import qualified Data.List as List
+import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Text.Megaparsec.Perm as P
import Language.TCT hiding (Parser)
-import Language.TCT.Write.XML (XML,XMLs,XmlLeaf(..))
-import Language.DTC.Document (Nat(..), Nat1(..))
+import Language.XML
import qualified Language.DTC.Document as DTC
import qualified Language.DTC.Sym as DTC
import qualified Language.RNC.Sym as RNC
-import qualified Language.TCT.Write.XML as XML
+
+-- * Type 'State'
+type State = DTC.Pos
-- * Type 'Parser'
-type Parser = P.Parsec Error XMLs
+-- type Parser = P.Parsec Error XMLs
+type Parser = S.StateT State (P.Parsec Error XMLs)
instance RNC.Sym_Rule Parser where
-- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
instance RNC.Sym_RNC Parser where
none = P.label "none" $ P.eof
any = P.label "any" $ p_satisfyMaybe $ const $ Just ()
- anyElem p = P.dbg "anyElem" $ P.label "anyElem" $ do
+ anyElem p = P.label "anyElem" $ do
(n,ts) <- P.token check $ Just expected
parserXMLs (p n) ts
where
, Set.singleton $ P.Tokens $ pure expected )
element n p = do
ts <- P.token check $ Just expected
- parserXMLs p ts
+ xp <- S.get
+ let nameOrFigureName
+ | n == "figure"
+ -- NOTE: special case renaming the current DTC.Pos
+ -- using the @type attribute to have positions like this:
+ -- section1.Quote1
+ -- section1.Example1
+ -- section1.Quote2
+ -- instead of:
+ -- section1.figure1
+ -- section1.figure2
+ -- section1.figure3
+ , Just ty <- getFirst $ (`foldMap` ts) $ \case
+ Tree0 (unCell -> XmlAttr "type" ty) -> First $ Just ty
+ _ -> 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)
+ , DTC.posAncestorsWithFigureNames =
+ DTC.posAncestorsWithFigureNames xp |>
+ (nameOrFigureName,anc nameOrFigureName)
+ , DTC.posPrecedingsSiblings = mempty
+ }
+ parserXMLs p ts <* S.put xp
+ { 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
+ }
where
expected = TreeN (cell0 n) mempty
check (TreeN (unCell -> e) ts) | e == n = Right ts
v <- P.token check $ Just expected
parserXMLs p v
where
- expected = Tree0 (cell0 $ XML.XmlAttr n "")
+ expected = Tree0 (cell0 $ XmlAttr n "")
check (TreeN (unCell -> e) ts) | e == n = Right ts
- check (Tree0 (Cell bp ep (XML.XmlAttr k v))) | k == n =
- Right $ Seq.singleton $ Tree0 $ Cell bp ep $ XML.XmlText v
+ check (Tree0 (Cell bp ep (XmlAttr k v))) | k == n =
+ Right $ Seq.singleton $ Tree0 $ Cell bp ep $ XmlText v
check t = Left
( Just $ P.Tokens $ pure t
, Set.singleton $ P.Tokens $ pure expected )
EmptyL -> P.failure Nothing ex
where
ex = Set.singleton $ P.Tokens $ pure expected
- expected = Tree0 (cell0 $ XML.XmlComment "")
+ expected = Tree0 (cell0 $ XmlComment "")
text = do
P.token check (Just expected)
<* fixPos
where
- expected = Tree0 (cell0 $ XML.XmlText "")
- check (Tree0 (unCell -> XML.XmlText t)) = Right t
+ expected = Tree0 (cell0 $ XmlText "")
+ check (Tree0 (unCell -> XmlText t)) = Right t
check t = Left
( Just $ P.Tokens $ pure t
, Set.singleton $ P.Tokens $ pure expected )
(<|?>) = (P.<|?>)
f <$*> a = f P.<$?> ([],P.some a)
f <|*> a = f P.<|?> ([],P.some a)
-instance DTC.Sym_DTC Parser
+instance DTC.Sym_DTC Parser where
+ position = S.get
readDTC ::
DTC.Sym_DTC Parser =>
XMLs ->
Either (P.ParseError (P.Token XMLs) Error) DTC.Document
-readDTC = parseXMLs (P.initialPos "") DTC.document
+readDTC = parseXMLs def (P.initialPos "") DTC.document
parseXMLs ::
DTC.Sym_DTC Parser =>
+ State ->
P.SourcePos -> Parser a -> XMLs ->
Either (P.ParseError (P.Token XMLs) Error) a
-parseXMLs pos p i =
- snd $ P.runParser' (p <* RNC.none)
+parseXMLs st pos p i =
+ snd $
+ P.runParser' ((`S.evalStateT` st) $ p <* RNC.none)
P.State
{ P.stateInput = i
, P.statePos = pure $
, P.stateTokensProcessed = 0
}
--- | @parserXMLs pos p xs@ returns a 'Parser' parsing @xs@ with @p@.
+-- | @parserXMLs st pos p xs@ returns a 'Parser' parsing @xs@ with @p@ from state @st@.
parserXMLs ::
DTC.Sym_DTC Parser =>
Parser a -> XMLs -> Parser a
parserXMLs p xs = do
pos <- P.getPosition
- case parseXMLs pos p xs of
+ st <- S.get
+ case parseXMLs st pos p xs of
Left (P.TrivialError (posErr:|_) un ex) -> do
P.setPosition posErr
P.failure un ex
sourcePos (Pos l c) | l>0 && c>0 = Just $ P.SourcePos "" (P.mkPos l) (P.mkPos c)
sourcePos _ = Nothing
--- ** Type 'XMLs'
instance P.Stream XMLs where
type Token XMLs = XML
type Tokens XMLs = XMLs
sourcephile / git / doclang.git / blobdiff