-{-# LANGUAGE BangPatterns #-}
{-# 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 Data.Text.Lazy as TL
import qualified Text.Megaparsec as P
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.TCT hiding (Parser, ErrorRead)
+import Language.XML
import qualified Language.DTC.Document as DTC
-import qualified Language.DTC.Sym as Sym
-import qualified Language.TCT.Write.XML as XML
+import qualified Language.DTC.Sym as DTC
+import qualified Language.RNC.Sym as RNC
+
+-- * Type 'State'
+type State = DTC.Pos
-- * Type 'Parser'
-type Parser = P.Parsec Error XMLs
+-- type Parser = P.Parsec ErrorRead XMLs
+type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
-instance Sym.Sym_RNC Parser where
- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
- -- rule _n = id
+instance RNC.Sym_Rule Parser where
+ -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
+ rule _n = id
+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
- expected = TreeN (cell0 "") mempty
- check (TreeN (unCell -> n) ts) = Right (n,ts)
+ expected = Tree (cell0 $ XmlElem "") mempty
+ check (Tree (unCell -> XmlElem n) ts) = Right (n,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
- 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
+ expected = Tree (cell0 $ XmlElem n) mempty
+ check (Tree (unCell -> XmlElem e) ts) | e == n = Right ts
check t = Left
( Just $ P.Tokens $ pure t
, Set.singleton $ P.Tokens $ pure expected )
v <- P.token check $ Just expected
parserXMLs p v
where
- expected = Tree0 (cell0 $ XML.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
+ 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 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 )
- int = Sym.rule "int" $ Sym.text >>= \t ->
- case readMaybe (Text.unpack t) of
+ int = RNC.rule "int" $ RNC.text >>= \t ->
+ case readMaybe (TL.unpack t) of
Just i -> return i
Nothing -> P.fancyFailure $
- Set.singleton $ P.ErrorCustom $ Error_Not_Int t
- nat = Sym.rule "nat" $ Sym.int >>= \i ->
+ Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Int t
+ nat = RNC.rule "nat" $ RNC.int >>= \i ->
if i >= 0
then return $ Nat i
else P.fancyFailure $ Set.singleton $
- P.ErrorCustom $ Error_Not_Nat i
- nat1 = Sym.rule "nat1" $ Sym.int >>= \i ->
+ P.ErrorCustom $ ErrorRead_Not_Nat i
+ nat1 = RNC.rule "nat1" $ RNC.int >>= \i ->
if i > 0
then return $ Nat1 i
else P.fancyFailure $ Set.singleton $
- P.ErrorCustom $ Error_Not_Nat1 i
- choice = P.choice
- try = P.try
-
- type Perm Parser = P.PermParser XMLs Parser
+ P.ErrorCustom $ ErrorRead_Not_Nat1 i
+ (<|>) = (P.<|>)
+ many = P.many
+ some = P.some
+ optional = P.optional
+ option = P.option
+ choice = P.choice
+ try = P.try
+type instance RNC.Perm Parser = P.PermParser XMLs Parser
+instance RNC.Sym_Interleaved Parser where
interleaved = P.makePermParser
(<$$>) = (P.<$$>)
(<||>) = (P.<||>)
(<|?>) = (P.<|?>)
f <$*> a = f P.<$?> ([],P.some a)
f <|*> a = f P.<|?> ([],P.some a)
-instance Sym.Sym_DTC Parser
+instance DTC.Sym_DTC Parser where
+ position = S.get
readDTC ::
- Sym.Sym_DTC Parser =>
+ DTC.Sym_DTC Parser =>
XMLs ->
- Either (P.ParseError (P.Token XMLs) Error) DTC.Document
-readDTC = parseXMLs (P.initialPos "") Sym.document
+ Either (P.ParseError (P.Token XMLs) ErrorRead) DTC.Document
+readDTC = parseXMLs def (P.initialPos "") DTC.document
parseXMLs ::
- Sym.Sym_DTC Parser =>
+ 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 <* Sym.none)
+ Either (P.ParseError (P.Token XMLs) ErrorRead) a
+parseXMLs st pos p i =
+ snd $
+ P.runParser' ((`S.evalStateT` st) $ p <* RNC.none)
P.State
{ P.stateInput = i
, P.statePos = pure $
case Seq.viewl i of
- Tree0 c :< _ -> sourcePosCell c
- TreeN c _ :< _ -> sourcePosCell c
+ Tree c _ :< _ -> sourcePosCell c
_ -> pos
, P.stateTabWidth = P.pos1
, 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 ::
- Sym.Sym_DTC Parser =>
+ 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
P.positionAt1 (Proxy::Proxy XMLs) pos t
sourcePosCell :: Cell a -> P.SourcePos
-sourcePosCell c =
+sourcePosCell (cell_begin -> bp) =
P.SourcePos ""
- (P.mkPos $ lineCell c)
- (P.mkPos $ columnCell c)
+ (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
--- ** Type 'XMLs'
instance P.Stream XMLs where
type Token XMLs = XML
type Tokens XMLs = XMLs
Tree0 (unCell -> XmlComment{}) :< ts -> P.take1_ ts
t:<ts -> Just (t,ts)
EmptyL -> Nothing
- positionAt1 _s pos t =
- fromMaybe pos $ sourcePos $
- case t of
- TreeN c _ -> posCell c
- Tree0 c -> posCell c
+ positionAt1 _s pos =
+ fromMaybe pos . sourcePos .
+ cell_begin . unTree
positionAtN s pos ts =
case Seq.viewl ts of
t :< _ -> P.positionAt1 s pos t
_ -> pos
- advance1 _s _indent pos t =
+ advance1 _s _indent pos =
-- WARNING: the end of a 'Cell' is not necessarily
-- the beginning of the next 'Cell'.
- fromMaybe pos $ sourcePos $
- case t of
- TreeN c _ -> posEndCell c
- Tree0 c -> posEndCell c
+ fromMaybe pos . sourcePos .
+ cell_end . unTree
advanceN s = foldl' . P.advance1 s
takeN_ n s
| n <= 0 = Just (mempty, s)
showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
where
showTree :: XML -> String
- showTree = \case
- Tree0 c -> showCell c showXmlLeaf
- TreeN c _ts -> showCell c showXmlName
+ showTree (Tree a _ts) =
+ showCell a $ \case
+ XmlElem n -> "<"<>show n<>">"
+ XmlAttr n _v -> show n<>"="
+ 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
-
- showXmlLeaf = \case
- XmlAttr n _v -> show n<>"="
- XmlText _t -> "text"
- XmlComment _c -> "comment"
- showXmlName n = "<"<>show n<>">"
--- ** Type 'Error'
-data Error
- = Error_EndOfInput
- | Error_Not_Int Text
- | Error_Not_Nat Int
- | Error_Not_Nat1 Int
- -- | Error_Unexpected P.sourcePos XML
+-- ** Type 'ErrorRead'
+data ErrorRead
+ = ErrorRead_EndOfInput
+ | ErrorRead_Not_Int TL.Text
+ | ErrorRead_Not_Nat Int
+ | ErrorRead_Not_Nat1 Int
+ -- | ErrorRead_Unexpected P.sourcePos XML
deriving (Eq,Ord,Show)
-instance P.ShowErrorComponent Error where
+instance P.ShowErrorComponent ErrorRead where
showErrorComponent = show
sourcephile / git / doclang.git / blobdiff