-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
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, maybe)
-import Data.Monoid (Monoid(..))
+import Data.Maybe (Maybe(..), 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 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 hiding (Parser, ErrorRead)
import Language.XML
import qualified Language.DTC.Document as DTC
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 = S.StateT XmlPos (P.Parsec Error XMLs)
+-- type Parser = P.Parsec ErrorRead XMLs
+type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
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
+ 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 = TreeN (cell0 "") mempty
- check (TreeN (unCell -> 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 )
- position = S.get
element n p = do
ts <- P.token check $ Just expected
- xp <- S.get
- S.put xp
- { xmlPosAncestors = (n,maybe 1 (+1) $ Map.lookup n $ xmlPosPrecedingsSiblings xp):xmlPosAncestors xp
- , xmlPosPrecedingsSiblings = mempty
+ pos <- 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 pos
+ S.put pos
+ { DTC.posAncestors = DTC.posAncestors pos |> (n,anc n)
+ , DTC.posAncestorsWithFigureNames =
+ DTC.posAncestorsWithFigureNames pos |>
+ (nameOrFigureName,anc nameOrFigureName)
+ , DTC.posPrecedingsSiblings = mempty
}
- parserXMLs p ts <* S.put xp
- { xmlPosPrecedingsSiblings =
+ 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 $
- xmlPosPrecedingsSiblings xp
+ DTC.posPrecedingsSiblings pos
}
+ return res
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 )
parserXMLs p v
where
expected = Tree0 (cell0 $ XmlAttr n "")
- check (TreeN (unCell -> 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 )
( Just $ P.Tokens $ pure t
, Set.singleton $ P.Tokens $ pure expected )
int = RNC.rule "int" $ RNC.text >>= \t ->
- case readMaybe (Text.unpack t) of
+ case readMaybe (TL.unpack t) of
Just i -> return i
Nothing -> P.fancyFailure $
- Set.singleton $ P.ErrorCustom $ Error_Not_Int t
+ 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
+ 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
+ P.ErrorCustom $ ErrorRead_Not_Nat1 i
(<|>) = (P.<|>)
many = P.many
some = P.some
(<|?>) = (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
- XmlPos { xmlPosAncestors = []
- , xmlPosPrecedingsSiblings = mempty
- }
- (P.initialPos "")
- DTC.document
+ Either (P.ParseError (P.Token XMLs) ErrorRead) DTC.Document
+readDTC = parseXMLs def (P.initialPos "") DTC.document
parseXMLs ::
DTC.Sym_DTC Parser =>
- XmlPos ->
+ State ->
P.SourcePos -> Parser a -> XMLs ->
- Either (P.ParseError (P.Token XMLs) Error) a
-parseXMLs xp pos p i =
+ Either (P.ParseError (P.Token XMLs) ErrorRead) a
+parseXMLs st pos p i =
snd $
- P.runParser' ((`S.evalStateT` xp) $ p <* RNC.none)
+ 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
- _ -> 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
}
--- | @parserXMLs xp pos p xs@ returns a 'Parser' parsing @xs@ with @p@ from position @xp@.
+-- | @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
- xp <- S.get
- case parseXMLs xp 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
t :< _ -> P.setPosition $
P.positionAt1 (Proxy::Proxy XMLs) pos t
-sourcePosCell :: Cell a -> P.SourcePos
-sourcePosCell c =
- P.SourcePos ""
- (P.mkPos $ lineCell c)
- (P.mkPos $ columnCell c)
-
-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 t =
- fromMaybe pos $ sourcePos $
- case t of
- TreeN c _ -> posCell c
- Tree0 c -> posCell c
+ 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 t =
+ 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 $
- case t of
- TreeN c _ -> posEndCell c
- Tree0 c -> posEndCell c
+ 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
showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
where
showTree :: XML -> String
- showTree = \case
- Tree0 c -> showCell c showXmlLeaf
- TreeN c _ts -> showCell c showXmlName
-
- 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
+ showTree (Tree a _ts) =
+ showCell a $ \case
+ XmlElem n -> "<"<>show n<>">"
+ XmlAttr n _v -> show n<>"="
+ XmlText _t -> "text"
+ XmlComment _c -> "comment"
- showXmlLeaf = \case
- XmlAttr n _v -> show n<>"="
- XmlText _t -> "text"
- XmlComment _c -> "comment"
- showXmlName n = "<"<>show n<>">"
+ 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 '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