Commit a3bff752 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Make parsing errors a bit more descriptive

parent 26dd5fe4
......@@ -60,6 +60,7 @@ functorsParser functors = try spaceConsumer *> parseLevel (zip (reverse functors
variable :: ParserT m (FunctorExpression f Precedence)
variable = symbol "X" >> return Variable
<?> "variable (X)"
checkForFunctor ::
FunctorExpression f Precedence -> ParserT m (FunctorExpression f Precedence)
......
......@@ -30,6 +30,7 @@ import Data.Tuple (swap)
import qualified Data.Vector.Algorithms.Intro as V (sort)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import Text.Megaparsec
......@@ -189,6 +190,7 @@ parseSum1 sum@(Sum (product :| [])) = do
(try parseSumPrefix >>= parseSum sum) <|>
(first (SumValue 0) <$> parseProduct1 product)
parseSum1 other = parseSumPrefix >>= parseSum other -- otherwise, require 'inj'
<?> "coproduct injection"
-- | parses @inj i@ where @i@ is a decimal integer
parseSumPrefix :: MonadParser m => m Int
......@@ -218,19 +220,20 @@ parseProduct1 other = parseProduct other
parseProduct ::
MonadParser m => Product (m a) -> m (ProductValue (), [(a, (Int, Int))])
parseProduct (Product (f :| fs)) = L.parens $ do
factors <- (:)
<$> parseFactor f
<*> traverse (\x -> L.comma *> parseFactor x) fs
parseProduct (Product l@(f :| fs)) =
label ("a product of " ++ show (length l) ++ " element(s)") $ L.parens $ do
factors <- (:)
<$> parseFactor f
<*> traverse (\x -> L.comma *> parseFactor x) fs
let (h1, successors) = unzip factors
labeledSuccessors =
zipWith
(\x i -> x & _Just . traversed . _2 %~ (i,) & fromMaybe [])
successors
[0..]
let (h1, successors) = unzip factors
labeledSuccessors =
zipWith
(\x i -> x & _Just . traversed . _2 %~ (i,) & fromMaybe [])
successors
[0..]
return ( ProductValue (V.fromList h1) , concat labeledSuccessors)
return ( ProductValue (V.fromList h1) , concat labeledSuccessors)
----------- Factor parser
......@@ -239,13 +242,13 @@ parseFactor (Const (ExplicitSet names)) = do
h1 <- ConstValue <$> someName names
return (h1, Nothing) -- const has no successors
parseFactor (Const IntSet) = do
x <- L.signed L.decimal
x <- L.signed L.decimal <?> "integer"
return (ConstValue x, Nothing)
parseFactor (Const NatSet) = do
x <- L.decimal
x <- L.decimal <?> "natural number"
return (ConstValue x, Nothing)
parseFactor (Const (FiniteNatSet n)) = do
x <- L.decimal
x <- L.decimal <?> ("natural number small than " ++ show n)
unless (x < n) $
fail ("out of range constant: " ++ show x ++
"(must be between 0 and " ++ show n ++ ")")
......@@ -287,7 +290,7 @@ showExp (FiniteNatExp n) = "{0.." ++ show n ++ "}"
someName :: MonadParser m => Vector Text -> m Int
someName v =
(V.ifoldr (\i new old -> (L.symbol new *> pure i) <|> old) empty v)
<?> ("one of " ++ show v)
<?> ("a name from {" ++ T.unpack (T.intercalate "," (V.toList v)) ++ "}")
instance RefinementInterface Polynomial where
......
......@@ -28,8 +28,9 @@ coalgebraParser ::
(Traversable f, ParseMorphism f)
=> [[FunctorParser f]]
-> Parser (SymbolTable, Encoding (Label (Desorted f)) (H1 (Desorted f)))
coalgebraParser functors =
functorsParser (concat functors) >>= return . annotateSorts >>= morphismsParser
coalgebraParser functors = do
f <- (annotateSorts <$> functorsParser (concat functors))
morphismsParser f <?> "morphism definition"
-- TODO: Needs better name
type TheFunctor = Desorted SomeFunctor
......
......@@ -59,7 +59,7 @@ dot :: MonadParser m => m Text
dot = symbol "."
name :: MonadParser m => m Text
name = lexeme $ T.pack <$> ((:) <$> nameChar1 <*> many nameChar)
name = lexeme (T.pack <$> ((:) <$> nameChar1 <*> many nameChar) <?> "name")
nameChar1 :: MonadParser m => m Char
nameChar1 = letterChar <|> char '_'
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment