diff --git a/app/Parse.hs b/app/Parse.hs --- a/app/Parse.hs +++ b/app/Parse.hs @@ -15,7 +15,7 @@ import Data.Either.Validation (Validation(..), validationToEither) import Data.Functor.Identity (Identity) import Data.Functor.Compose (getCompose) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.Map.Lazy as Map import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) @@ -23,7 +23,7 @@ import Data.Text.IO (getLine, readFile, getContents) import Data.Typeable (Typeable) import Options.Applicative -import Text.Grampa (Ambiguous, Grammar, ParseResults, parseComplete) +import Text.Grampa (Ambiguous, Grammar, ParseResults, parseComplete, showFailure) import qualified Text.Grampa.ContextFree.LeftRecursive as LeftRecursive import ReprTree import System.FilePath (FilePath, takeDirectory) @@ -84,7 +84,7 @@ of ModuleWithImportsMode -> \source-> parseAndResolveModule optsOberon2 (fromMaybe (takeDirectory file) optsInclude) source - >>= succeed optsOutput + >>= succeed optsOutput source ModuleMode -> go (Resolver.resolveModule predefined mempty) Grammar.module_prod chosenGrammar file DefinitionMode -> go (Resolver.resolveModule predefined mempty) Grammar.module_prod @@ -114,15 +114,18 @@ -> String -> Text -> IO () go resolve production grammar filename contents = case getCompose (production $ parseComplete grammar contents) - of Right [x] -> succeed optsOutput (resolve x) + of Right [x] -> succeed optsOutput contents (resolve x) Right l -> putStrLn ("Ambiguous: " ++ show optsIndex ++ "/" ++ show (length l) ++ " parses") - >> succeed optsOutput (resolve $ l !! optsIndex) - Left err -> error (show err) + >> succeed optsOutput contents (resolve $ l !! optsIndex) + Left err -> putStrLn (showFailure contents err 3) -succeed out x = case out - of Pretty width -> either print (putDocW width . pretty) (validationToEither x) - Tree -> either print (putStrLn . reprTreeString) (validationToEither x) - Plain -> print x +succeed out contents x = either reportFailure showSuccess (validationToEither x) + where reportFailure (Resolver.UnparseableModule err :| []) = putStrLn (showFailure contents err 3) + reportFailure errs = print errs + showSuccess = case out + of Pretty width -> putDocW width . pretty + Tree -> putStrLn . reprTreeString + Plain -> print instance Pretty (Module Ambiguous) where pretty _ = error "Disambiguate before pretty-printing" diff --git a/language-oberon.cabal b/language-oberon.cabal --- a/language-oberon.cabal +++ b/language-oberon.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-oberon -version: 0.1.1 +version: 0.2 synopsis: Parser and pretty-printer for the Oberon programming language description: The library and the executable support both the original Oberon and the Oberon-2 programming language, as described @@ -36,7 +36,7 @@ Language.Oberon.Pretty, Language.Oberon.Resolver build-depends: base >= 4.7 && < 5, text < 1.3, containers >= 0.5 && < 1.0, filepath < 1.5, directory < 1.4, parsers >= 0.12.7 && < 0.13, prettyprinter >= 1 && < 1.3, either == 5.*, - rank2classes < 1.1, grammatical-parsers == 0.3.* + rank2classes < 1.2, grammatical-parsers >= 0.3.1 && < 0.4 default-language: Haskell2010 executable parse @@ -45,7 +45,7 @@ other-extensions: RankNTypes, RecordWildCards, ScopedTypeVariables, FlexibleInstances, DeriveDataTypeable build-depends: base >= 4.7 && < 5, text < 1.3, either == 5.*, containers >= 0.5 && < 1.0, repr-tree-syb < 0.2, filepath < 1.5, prettyprinter >= 1 && < 1.3, - rank2classes < 1.1, grammatical-parsers == 0.3.*, language-oberon, + rank2classes < 1.2, grammatical-parsers >= 0.3.1 && < 0.4, language-oberon, optparse-applicative default-language: Haskell2010 diff --git a/src/Language/Oberon.hs b/src/Language/Oberon.hs --- a/src/Language/Oberon.hs +++ b/src/Language/Oberon.hs @@ -9,7 +9,7 @@ import Data.Either.Validation (Validation(..)) import Data.Functor.Identity (Identity) import Data.Functor.Compose (getCompose) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.Map.Lazy as Map import Data.Map.Lazy (Map) import Data.Monoid ((<>)) @@ -61,13 +61,13 @@ parseAndResolveModule :: Bool -> FilePath -> Text -> IO (Validation (NonEmpty Resolver.Error) (Module Identity)) parseAndResolveModule oberon2 path source = case parseModule oberon2 source - of Left err -> error (show err) + of Left err -> return (Failure $ Resolver.UnparseableModule err :| []) Right [rootModule@(Module moduleName imports _ _ _)] -> do importedModules <- parseImportsOf oberon2 path (Map.singleton moduleName rootModule) let resolvedImportMap = Resolver.resolveModule predefinedScope resolvedImportMap <$> importedModules predefinedScope = if oberon2 then Resolver.predefined2 else Resolver.predefined return $ Resolver.resolveModule predefinedScope resolvedImportMap rootModule - Right _ -> error "Ambiguous parsings" + Right _ -> return (Failure $ Resolver.AmbiguousParses :| []) -- | Parse the module file at the given path, assuming all its imports are in the same directory. parseAndResolveModuleFile :: Bool -> FilePath -> IO (Validation (NonEmpty Resolver.Error) (Module Identity)) diff --git a/src/Language/Oberon/AST.hs b/src/Language/Oberon/AST.hs --- a/src/Language/Oberon/AST.hs +++ b/src/Language/Oberon/AST.hs @@ -4,7 +4,7 @@ module Language.Oberon.AST where -import Data.Data (Data) +import Data.Data (Data, Typeable) import Data.Functor.Identity (Identity) import Data.List.NonEmpty import Data.Text @@ -12,8 +12,8 @@ data Module f = Module Ident [Import] [Declaration f] (Maybe (StatementSequence f)) Ident -deriving instance Data (Module Identity) -deriving instance Data (Module Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f)), Data (f (Statement f))) => + Data (Module f) deriving instance (Show (f (Designator f)), Show (f (Expression f)), Show (f (Statement f))) => Show (Module f) type Ident = Text @@ -26,8 +26,8 @@ | ProcedureDeclaration (ProcedureHeading f) (ProcedureBody f) Ident | ForwardDeclaration IdentDef (Maybe (FormalParameters f)) -deriving instance Data (Declaration Identity) -deriving instance Data (Declaration Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f)), Data (f (Statement f))) => + Data (Declaration f) deriving instance (Show (f (Designator f)), Show (f (Expression f)), Show (f (Statement f))) => Show (Declaration f) data IdentDef = IdentDef Ident AccessMode @@ -60,8 +60,7 @@ | FunctionCall (AmbDesignator f) (ActualParameters f) | Not (Expression f) -deriving instance Data (Expression Identity) -deriving instance Data (Expression Ambiguous) +deriving instance (Typeable f, Data (f (Designator f))) => Data (Expression f) deriving instance Show (f (Designator f)) => Show (Expression f) data RelOp = Equal | Unequal | Less | LessOrEqual | Greater | GreaterOrEqual | In | Is @@ -70,8 +69,7 @@ data Element f = Element (Expression f) | Range (Expression f) (Expression f) -deriving instance Data (Element Identity) -deriving instance Data (Element Ambiguous) +deriving instance (Typeable f, Data (f (Designator f))) => Data (Element f) deriving instance Show (f (Designator f)) => Show (Element f) type AmbDesignator f = f (Designator f) @@ -82,8 +80,7 @@ | TypeGuard (Designator f) QualIdent | Dereference (Designator f) -deriving instance Data (Designator Identity) -deriving instance Data (Designator Ambiguous) +deriving instance (Typeable f, Data (f (Designator f))) => Data (Designator f) deriving instance Show (f (Designator f)) => Show (Designator f) type ActualParameters f = [Expression f] @@ -94,8 +91,7 @@ | PointerType (Type f) | ProcedureType (Maybe (FormalParameters f)) -deriving instance Data (Type Identity) -deriving instance Data (Type Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f))) => Data (Type f) deriving instance (Show (f (Designator f)), Show (f (Expression f))) => Show (Type f) data QualIdent = QualIdent Ident Ident @@ -109,8 +105,7 @@ data FieldList f = FieldList IdentList (Type f) | EmptyFieldList -deriving instance Data (FieldList Identity) -deriving instance Data (FieldList Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f))) => Data (FieldList f) deriving instance (Show (f (Designator f)), Show (f (Expression f))) => Show (FieldList f) type IdentList = NonEmpty IdentDef @@ -119,22 +114,19 @@ data FormalParameters f = FormalParameters [FPSection f] (Maybe QualIdent) data FPSection f = FPSection Bool (NonEmpty Ident) (Type f) -deriving instance Data (ProcedureHeading Identity) -deriving instance Data (ProcedureHeading Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f))) => Data (ProcedureHeading f) deriving instance (Show (f (Designator f)), Show (f (Expression f))) => Show (ProcedureHeading f) -deriving instance Data (FormalParameters Identity) -deriving instance Data (FormalParameters Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f))) => Data (FormalParameters f) deriving instance (Show (f (Designator f)), Show (f (Expression f))) => Show (FormalParameters f) -deriving instance Data (FPSection Identity) -deriving instance Data (FPSection Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f))) => Data (FPSection f) deriving instance (Show (f (Designator f)), Show (f (Expression f))) => Show (FPSection f) data ProcedureBody f = ProcedureBody [Declaration f] (Maybe (StatementSequence f)) -deriving instance Data (ProcedureBody Identity) -deriving instance Data (ProcedureBody Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f)), Data (f (Statement f))) => + Data (ProcedureBody f) deriving instance (Show (f (Designator f)), Show (f (Expression f)), Show (f (Statement f))) => Show (ProcedureBody f) type StatementSequence f = NonEmpty (f (Statement f)) @@ -152,8 +144,7 @@ | Exit | Return (Maybe (Expression f)) -deriving instance Data (Statement Identity) -deriving instance Data (Statement Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Statement f))) => Data (Statement f) deriving instance (Show (f (Designator f)), Show (f (Statement f))) => Show (Statement f) data WithAlternative f = WithAlternative QualIdent QualIdent (StatementSequence f) @@ -164,14 +155,11 @@ data CaseLabels f = SingleLabel (ConstExpression f) | LabelRange (ConstExpression f) (ConstExpression f) -deriving instance Data (WithAlternative Identity) -deriving instance Data (WithAlternative Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Statement f))) => Data (WithAlternative f) deriving instance (Show (f (Designator f)), Show (f (Statement f))) => Show (WithAlternative f) -deriving instance Data (Case Identity) -deriving instance Data (Case Ambiguous) +deriving instance (Typeable f, Data (f (Designator f)), Data (f (Statement f))) => Data (Case f) deriving instance (Show (f (Designator f)), Show (f (Statement f))) => Show (Case f) -deriving instance Data (CaseLabels Identity) -deriving instance Data (CaseLabels Ambiguous) +deriving instance (Typeable f, Data (f (Designator f))) => Data (CaseLabels f) deriving instance Show (f (Designator f)) => Show (CaseLabels f) diff --git a/src/Language/Oberon/Grammar.hs b/src/Language/Oberon/Grammar.hs --- a/src/Language/Oberon/Grammar.hs +++ b/src/Language/Oberon/Grammar.hs @@ -15,7 +15,7 @@ import Data.Text (Text, unpack) import Text.Grampa import Text.Grampa.ContextFree.LeftRecursive (Parser) -import Text.Parser.Combinators (sepBy, sepBy1, sepByNonEmpty) +import Text.Parser.Combinators (sepBy, sepBy1, sepByNonEmpty, try) import Text.Parser.Token (braces, brackets, parens) import qualified Rank2 @@ -100,10 +100,10 @@ instance Lexical (OberonGrammar f) where type LexicalConstraint p (OberonGrammar f) s = (s ~ Text, p ~ Parser) - lexicalComment = string "(*" - *> skipMany (lexicalComment - <|> notFollowedBy (string "*)") <* anyToken <* takeCharsWhile isCommentChar) - <* string "*)" + lexicalComment = try (string "(*" + *> skipMany (lexicalComment + <|> notFollowedBy (string "*)") <* anyToken <* takeCharsWhile isCommentChar) + <* string "*)") where isCommentChar c = c /= '*' && c /= '(' lexicalWhiteSpace = takeCharsWhile isSpace *> skipMany (lexicalComment *> takeCharsWhile isSpace) isIdentifierStartChar = isLetter @@ -139,6 +139,8 @@ grammar2 g@OberonGrammar{..} = g1{ identdef = IdentDef <$> ident <*> (Exported <$ delimiter "*" <|> ReadOnly <$ delimiter "-" <|> pure PrivateOnly), + + string_prod = string_prod1 <|> lexicalToken (char '\'' *> takeWhile (/= "'") <* char '\''), procedureHeading = ProcedureHeading <$ keyword "PROCEDURE" <*> optional (parens ((,,) <$> (True <$ keyword "VAR" <|> pure False) @@ -152,7 +154,7 @@ <*> statementSequence <* keyword "END", withStatement = With <$ keyword "WITH" <*> sepByNonEmpty withAlternative (delimiter "|") <*> optional (keyword "ELSE" *> statementSequence) <* keyword "END"} - where g1@OberonGrammar{statement= statement1} = grammar g + where g1@OberonGrammar{statement= statement1, string_prod= string_prod1} = grammar g withAlternative = WithAlternative <$> qualident <* delimiter ":" <*> qualident <* keyword "DO" <*> statementSequence @@ -169,11 +171,13 @@ <|> keyword "TYPE" *> many (typeDeclaration <* delimiter ";") <|> keyword "VAR" *> many (variableDeclaration <* delimiter ";")) <> many (procedureDeclaration <* delimiter ";" - <|> forwardDeclaration <* delimiter ";"), + <|> forwardDeclaration <* delimiter ";") + "declarations", constantDeclaration = ConstantDeclaration <$> identdef <* delimiter "=" <*> ambiguous constExpression, identdef = IdentDef <$> ident <*> (Exported <$ delimiter "*" <|> pure PrivateOnly), constExpression = expression, - expression = simpleExpression <**> (pure id <|> (flip . Relation) <$> relation <*> simpleExpression), + expression = simpleExpression <**> (pure id <|> (flip . Relation) <$> relation <*> simpleExpression) + "expression", simpleExpression = (Positive <$ operator "+" <|> Negative <$ operator "-" <|> pure id) <*> (term <**> (appEndo <$> concatMany (Endo <$> (flip . applyBinOp <$> addOperator <*> term)))), term = factor <**> (appEndo <$> concatMany (Endo <$> (flip . applyBinOp <$> mulOperator <*> factor))), @@ -195,8 +199,7 @@ charConstant = lexicalToken (empty -- CharConstant <$ char '"' <*> anyChar <* char '"' <|> CharCode . fst . head . readHex . unpack <$> (digit <> takeCharsWhile isHexDigit <* string "X")), - string_prod = lexicalToken (char '"' *> takeWhile (/= "\"") <* char '"' - <|> char '\'' *> takeWhile (/= "'") <* char '\''), -- Oberon2 + string_prod = lexicalToken (char '"' *> takeWhile (/= "\"") <* char '"'), set = Set <$> braces (sepBy element (delimiter ",")), element = Element <$> expression <|> Range <$> expression <* delimiter ".." <*> expression, @@ -228,7 +231,7 @@ <*> fieldListSequence <* keyword "END", baseType = qualident, fieldListSequence = sepByNonEmpty fieldList (delimiter ";"), - fieldList = FieldList <$> identList <* delimiter ":" <*> type_prod + fieldList = (FieldList <$> identList <* delimiter ":" <*> type_prod "record field declarations") <|> pure EmptyFieldList, identList = sepByNonEmpty identdef (delimiter ","), pointerType = PointerType <$ keyword "POINTER" <* keyword "TO" <*> type_prod, @@ -253,7 +256,8 @@ <|> whileStatement <|> repeatStatement <|> loopStatement <|> withStatement <|> Exit <$ keyword "EXIT" <|> Return <$ keyword "RETURN" <*> optional expression - <|> pure EmptyStatement, + <|> pure EmptyStatement + "statement", assignment = Assignment <$> ambiguous designator <* delimiter ":=" <*> expression, procedureCall = ProcedureCall <$> ambiguous designator <*> optional actualParameters, ifStatement = If <$ keyword "IF" @@ -281,8 +285,8 @@ delimiter, operator :: Text -> Parser (OberonGrammar f) Text Text -delimiter s = lexicalToken (string s) -operator = delimiter +delimiter s = lexicalToken (string s) ("delimiter " <> show s) +operator s = lexicalToken (string s) ("operator " <> show s) reservedWords :: [Text] reservedWords = ["ARRAY", "IMPORT", "RETURN", diff --git a/src/Language/Oberon/Resolver.hs b/src/Language/Oberon/Resolver.hs --- a/src/Language/Oberon/Resolver.hs +++ b/src/Language/Oberon/Resolver.hs @@ -4,7 +4,8 @@ -- expression @foo(bar)@ may be a call to function @foo@ with a parameter @bar@, or it may be type guard on variable -- @foo@ casting it to type @bar@. -module Language.Oberon.Resolver (Error, Predefined, predefined, predefined2, resolveModule, resolveModules) where +module Language.Oberon.Resolver (Error(..), + Predefined, predefined, predefined2, resolveModule, resolveModules) where import Control.Applicative (Alternative) import Control.Monad ((>=>)) @@ -19,7 +20,7 @@ import qualified Data.Map.Lazy as Map import Data.Semigroup (Semigroup(..), sconcat) -import Text.Grampa (Ambiguous(..)) +import Text.Grampa (Ambiguous(..), ParseFailure) import Language.Oberon.AST @@ -32,6 +33,7 @@ data Error = UnknownModule Ident | UnknownLocal Ident | UnknownImport QualIdent + | AmbiguousParses | AmbiguousDesignator [Designator Identity] | AmbiguousExpression [Expression Identity] | AmbiguousStatement [Statement Identity] @@ -45,6 +47,7 @@ | NotAValue QualIdent | NotWriteable QualIdent | ClashingImports + | UnparseableModule ParseFailure deriving (Show) type Scope = Predefined