diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,9 +1,22 @@ # Revision history for language-oberon -## 0.1 -- 2018-04-08 +## 0.2.1 -- 2019-01-27 -* First version, but complete enough to be released on an unsuspecting world... +* Pretty-printer fixes +* Testing the idempotence of parse&pretty-print +* Two type parameters for each AST node type, wrapping every field +* Added the Transformation modules +* Added the TypeChecker module +## 0.2 -- 2018-07-09 + +* Improved error reporting +* Fixed compilation with GHC 8.0.2 + ## 0.1.1 -- 2018-04-08 * except for the missing Oberon module examples the test suite depends on. + +## 0.1 -- 2018-04-08 + +* First version, but complete enough to be released on an unsuspecting world... diff --git a/app/Parse.hs b/app/Parse.hs --- a/app/Parse.hs +++ b/app/Parse.hs @@ -3,7 +3,7 @@ module Main where import Language.Oberon (parseAndResolveModule) -import Language.Oberon.AST (Module(..), Statement, Expression) +import Language.Oberon.AST (Module(..), StatementSequence, Statement, Expression) import qualified Language.Oberon.Grammar as Grammar import qualified Language.Oberon.Resolver as Resolver import qualified Language.Oberon.Pretty () @@ -30,7 +30,8 @@ import Prelude hiding (getLine, getContents, readFile) -data GrammarMode = ModuleWithImportsMode | ModuleMode | AmbiguousModuleMode | DefinitionMode | StatementsMode | StatementMode | ExpressionMode +data GrammarMode = TypeCheckedModuleMode | ModuleWithImportsMode | ModuleMode | AmbiguousModuleMode | DefinitionMode + | StatementsMode | StatementMode | ExpressionMode deriving Show data Output = Plain | Pretty Int | Tree @@ -55,7 +56,7 @@ p :: Parser Opts p = Opts - <$> (mode <|> pure ModuleWithImportsMode) + <$> mode <*> (switch (long "oberon2")) <*> (option auto (long "index" <> help "Index of ambiguous parse" <> showDefault <> value 0 <> metavar "INT")) <*> (Pretty <$> option auto (long "pretty" <> help "Pretty-print output" <> metavar "WIDTH") @@ -68,7 +69,8 @@ <> help "Oberon file to parse")) mode :: Parser GrammarMode - mode = ModuleWithImportsMode <$ switch (long "module-with-imports") + mode = TypeCheckedModuleMode <$ switch (long "type-checked-module") + <|> ModuleWithImportsMode <$ switch (long "module-with-imports") <|> ModuleMode <$ switch (long "module") <|> AmbiguousModuleMode <$ switch (long "module-ambiguous") <|> DefinitionMode <$ switch (long "definition") @@ -81,10 +83,14 @@ case optsFile of Just file -> (if file == "-" then getContents else readFile file) >>= case optsMode - of ModuleWithImportsMode -> - \source-> parseAndResolveModule optsOberon2 + of TypeCheckedModuleMode -> + \source-> parseAndResolveModule True optsOberon2 (fromMaybe (takeDirectory file) optsInclude) source >>= succeed optsOutput source + ModuleWithImportsMode -> + \source-> parseAndResolveModule False optsOberon2 + (fromMaybe (takeDirectory file) optsInclude) source + >>= succeed optsOutput source ModuleMode -> go (Resolver.resolveModule predefined mempty) Grammar.module_prod chosenGrammar file DefinitionMode -> go (Resolver.resolveModule predefined mempty) Grammar.module_prod @@ -127,11 +133,15 @@ Tree -> putStrLn . reprTreeString Plain -> print -instance Pretty (Module Ambiguous) where +instance Pretty (Module Ambiguous Ambiguous) where pretty _ = error "Disambiguate before pretty-printing" -instance Pretty (Ambiguous (Statement Ambiguous)) where +instance Pretty (StatementSequence Ambiguous Ambiguous) where pretty _ = error "Disambiguate before pretty-printing" -instance Pretty (Statement Ambiguous) where +instance Pretty (Ambiguous (Statement Ambiguous Ambiguous)) where pretty _ = error "Disambiguate before pretty-printing" -instance Pretty (Expression Ambiguous) where +instance Pretty (Statement Ambiguous Ambiguous) where + pretty _ = error "Disambiguate before pretty-printing" +instance Pretty (Expression Ambiguous Ambiguous) where + pretty _ = error "Disambiguate before pretty-printing" +instance Pretty (Ambiguous (Expression Ambiguous Ambiguous)) where pretty _ = error "Disambiguate before pretty-printing" diff --git a/examples/AGRS/OFS.Def b/examples/AGRS/OFS.Def --- a/examples/AGRS/OFS.Def +++ b/examples/AGRS/OFS.Def @@ -1,3 +1,7 @@ DEFINITION OFS; + TYPE + File *= RECORD END; + Rider *= RECORD END; + END OFS. diff --git a/language-oberon.cabal b/language-oberon.cabal --- a/language-oberon.cabal +++ b/language-oberon.cabal @@ -2,8 +2,8 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-oberon -version: 0.2 -synopsis: Parser and pretty-printer for the Oberon programming language +version: 0.2.1 +synopsis: Parser, pretty-printer, and type checker for the Oberon programming language description: The library and the executable support both the original Oberon and the Oberon-2 programming language, as described in the respective . @@ -23,7 +23,7 @@ license-file: LICENSE author: Mario Blažević maintainer: blamario@protonmail.com --- copyright: +-- copyright: category: Language build-type: Simple extra-source-files: ChangeLog.md, examples/AGRS/*.Def, examples/AGRS/*.Mod @@ -33,10 +33,13 @@ hs-source-dirs: src exposed-modules: Language.Oberon, Language.Oberon.AST, Language.Oberon.Grammar, - Language.Oberon.Pretty, Language.Oberon.Resolver + Language.Oberon.Pretty, Language.Oberon.Resolver, Language.Oberon.TypeChecker, + Transformation, Transformation.Deep, Transformation.Deep.TH, + Transformation.Rank2, Transformation.AG 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.2, grammatical-parsers >= 0.3.1 && < 0.4 + parsers >= 0.12.7 && < 0.13, prettyprinter >= 1.2.1 && < 1.3, either == 5.*, + rank2classes < 1.3, grammatical-parsers > 0.3.1 && < 0.4, transformers == 0.5.*, + template-haskell >= 2.11 && < 2.15 default-language: Haskell2010 executable parse @@ -44,15 +47,15 @@ -- other-modules: 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.2, grammatical-parsers >= 0.3.1 && < 0.4, language-oberon, + repr-tree-syb < 0.2, filepath < 1.5, prettyprinter >= 1.2.1 && < 1.3, + rank2classes < 1.3, grammatical-parsers > 0.3.1 && < 0.4, language-oberon, optparse-applicative default-language: Haskell2010 test-suite examples type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5, - either == 5.*, directory < 2, filepath < 1.5, + build-depends: base >= 4.7 && < 5, text < 1.3, grammatical-parsers > 0.3.1 && < 0.4, + either == 5.*, directory < 2, filepath < 1.5, prettyprinter >= 1.2.1 && < 1.3, tasty >= 0.7, tasty-hunit, language-oberon main-is: test/Test.hs diff --git a/src/Language/Oberon.hs b/src/Language/Oberon.hs --- a/src/Language/Oberon.hs +++ b/src/Language/Oberon.hs @@ -5,7 +5,9 @@ import Language.Oberon.AST (Module(..)) import qualified Language.Oberon.Grammar as Grammar import qualified Language.Oberon.Resolver as Resolver +import qualified Language.Oberon.TypeChecker as TypeChecker +import Control.Monad (when) import Data.Either.Validation (Validation(..)) import Data.Functor.Identity (Identity) import Data.Functor.Compose (getCompose) @@ -23,17 +25,17 @@ import Prelude hiding (readFile) -- | Parse the given text of a single module, without resolving the syntactic ambiguities. -parseModule :: Bool -> Text -> ParseResults [Module Ambiguous] +parseModule :: Bool -> Text -> ParseResults [Module Ambiguous Ambiguous] parseModule oberon2 = getCompose . Grammar.module_prod . parseComplete (if oberon2 then Grammar.oberon2Grammar else Grammar.oberonGrammar) -- | Parse the given text of a single /definition/ module, without resolving the syntactic ambiguities. -parseDefinitionModule :: Bool -> Text -> ParseResults [Module Ambiguous] +parseDefinitionModule :: Bool -> Text -> ParseResults [Module Ambiguous Ambiguous] parseDefinitionModule oberon2 = getCompose . Grammar.module_prod . parseComplete (if oberon2 then Grammar.oberon2DefinitionGrammar else Grammar.oberonDefinitionGrammar) -parseNamedModule :: Bool -> FilePath -> Text -> IO (ParseResults [Module Ambiguous]) +parseNamedModule :: Bool -> FilePath -> Text -> IO (ParseResults [Module Ambiguous Ambiguous]) parseNamedModule oberon2 path name = do let basePath = combine path (unpack name) isDefn <- doesFileExist (addExtension basePath "Def") @@ -43,7 +45,7 @@ getCompose . Grammar.module_prod . parseComplete grammar <$> readFile (addExtension basePath $ if isDefn then "Def" else "Mod") -parseImportsOf :: Bool -> FilePath -> Map Text (Module Ambiguous) -> IO (Map Text (Module Ambiguous)) +parseImportsOf :: Bool -> FilePath -> Map Text (Module Ambiguous Ambiguous) -> IO (Map Text (Module Ambiguous Ambiguous)) parseImportsOf oberon2 path modules = case filter (`Map.notMember` modules) moduleImports of [] -> return modules @@ -58,17 +60,26 @@ -- | Given a directory path for module imports, parse the given module text and all the module files it imports, then -- use all the information to resolve the syntactic ambiguities. -parseAndResolveModule :: Bool -> FilePath -> Text -> IO (Validation (NonEmpty Resolver.Error) (Module Identity)) -parseAndResolveModule oberon2 path source = +parseAndResolveModule :: Bool -> Bool -> FilePath -> Text + -> IO (Validation (NonEmpty Resolver.Error) (Module Identity Identity)) +parseAndResolveModule checkTypes oberon2 path source = case parseModule oberon2 source 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 + successful (Success a) = Just a + successful _ = Nothing + typeErrors = TypeChecker.checkModules + (if oberon2 then TypeChecker.predefined2 else TypeChecker.predefined) + (Map.mapMaybe successful resolvedImportMap) + when (checkTypes && not (null typeErrors)) (error $ show typeErrors) + return $ resolvedImportMap Map.! moduleName 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)) -parseAndResolveModuleFile oberon2 path = readFile path >>= parseAndResolveModule oberon2 (takeDirectory path) +parseAndResolveModuleFile :: Bool -> Bool -> FilePath + -> IO (Validation (NonEmpty Resolver.Error) (Module Identity Identity)) +parseAndResolveModuleFile checkTypes oberon2 path = + readFile path >>= parseAndResolveModule checkTypes oberon2 (takeDirectory path) 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 @@ -1,4 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, + StandaloneDeriving, TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -- | Oberon Abstract Syntax Tree definitions @@ -7,28 +9,33 @@ import Data.Data (Data, Typeable) import Data.Functor.Identity (Identity) import Data.List.NonEmpty -import Data.Text -import Text.Grampa (Ambiguous) +import Data.Text (Text) -data Module f = Module Ident [Import] [Declaration f] (Maybe (StatementSequence f)) Ident +import Transformation.Deep (Product) +import qualified Transformation.Deep.TH +import qualified Rank2.TH -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) +data Module f' f = Module Ident [Import] ([f (Declaration f' f')]) (Maybe (f (StatementSequence f' f'))) Ident +deriving instance (Typeable f, Typeable f', + Data (f (Declaration f' f')), Data (f (StatementSequence f' f'))) => Data (Module f' f) +deriving instance (Show (f (Declaration f' f')), Show (f (StatementSequence f' f'))) => Show (Module f' f) + type Ident = Text type Import = (Maybe Ident, Ident) -data Declaration f = ConstantDeclaration IdentDef (f (ConstExpression f)) - | TypeDeclaration IdentDef (Type f) - | VariableDeclaration IdentList (Type f) - | ProcedureDeclaration (ProcedureHeading f) (ProcedureBody f) Ident - | ForwardDeclaration IdentDef (Maybe (FormalParameters f)) +data Declaration f' f = ConstantDeclaration IdentDef (f (ConstExpression f' f')) + | TypeDeclaration IdentDef (f (Type f' f')) + | VariableDeclaration IdentList (f (Type f' f')) + | ProcedureDeclaration (ProcedureHeading f' f) (ProcedureBody f' f) Ident + | ForwardDeclaration IdentDef (Maybe (f (FormalParameters f' f'))) -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) +deriving instance (Typeable f, Typeable f', + Data (f (Type f' f')), Data (f (ConstExpression f' f')), Data (f (FormalParameters f' f')), + Data (ProcedureHeading f' f), Data (ProcedureBody f' f)) => Data (Declaration f' f) +deriving instance (Show (f (Type f' f')), Show (f (ConstExpression f' f')), Show (f (FormalParameters f' f')), + Show (ProcedureHeading f' f), Show (ProcedureBody f' f)) => Show (Declaration f' f) data IdentDef = IdentDef Ident AccessMode deriving (Data, Eq, Ord, Show) @@ -38,128 +45,154 @@ type ConstExpression = Expression -data Expression f = Relation RelOp (Expression f) (Expression f) - | Positive (Expression f) - | Negative (Expression f) - | Add (Expression f) (Expression f) - | Subtract (Expression f) (Expression f) - | Or (Expression f) (Expression f) - | Multiply (Expression f) (Expression f) - | Divide (Expression f) (Expression f) - | IntegerDivide (Expression f) (Expression f) - | Modulo (Expression f) (Expression f) - | And (Expression f) (Expression f) - | Integer Text - | Real Text - | CharConstant Char - | CharCode Int - | String Text - | Nil - | Set [Element f] - | Read (AmbDesignator f) - | FunctionCall (AmbDesignator f) (ActualParameters f) - | Not (Expression f) +data Expression f' f = Relation RelOp (f (Expression f' f')) (f (Expression f' f')) + | Positive (f (Expression f' f')) + | Negative (f (Expression f' f')) + | Add (f (Expression f' f')) (f (Expression f' f')) + | Subtract (f (Expression f' f')) (f (Expression f' f')) + | Or (f (Expression f' f')) (f (Expression f' f')) + | Multiply (f (Expression f' f')) (f (Expression f' f')) + | Divide (f (Expression f' f')) (f (Expression f' f')) + | IntegerDivide (f (Expression f' f')) (f (Expression f' f')) + | Modulo (f (Expression f' f')) (f (Expression f' f')) + | And (f (Expression f' f')) (f (Expression f' f')) + | Integer Text + | Real Text + | CharConstant Char + | CharCode Int + | String Text + | Nil + | Set [f (Element f' f')] + | Read (f (Designator f' f')) + | FunctionCall (f (Designator f' f')) [f (Expression f' f')] + | Not (f (Expression f' f')) -deriving instance (Typeable f, Data (f (Designator f))) => Data (Expression f) -deriving instance Show (f (Designator f)) => Show (Expression f) +deriving instance (Typeable f, Typeable f', Data (f (Designator f' f')), + Data (f (Element f' f')), Data (f (Expression f' f'))) => Data (Expression f' f) +deriving instance (Show (f (Designator f' f')), + Show (f (Element f' f')), Show (f (Expression f' f'))) => Show (Expression f' f) data RelOp = Equal | Unequal | Less | LessOrEqual | Greater | GreaterOrEqual | In | Is deriving (Data, Show) -data Element f = Element (Expression f) - | Range (Expression f) (Expression f) - -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) +data Element f' f = Element (f (Expression f' f')) + | Range (f (Expression f' f')) (f (Expression f' f')) -data Designator f = Variable QualIdent - | Field (Designator f) Ident - | Index (Designator f) (NonEmpty (Expression f)) - | TypeGuard (Designator f) QualIdent - | Dereference (Designator f) +deriving instance (Typeable f, Typeable f', Data (f (Expression f' f'))) => Data (Element f' f) +deriving instance Show (f (Expression f' f')) => Show (Element f' f) -deriving instance (Typeable f, Data (f (Designator f))) => Data (Designator f) -deriving instance Show (f (Designator f)) => Show (Designator f) +data Designator f' f = Variable QualIdent + | Field (f (Designator f' f')) Ident + | Index (f (Designator f' f')) (NonEmpty (f (Expression f' f'))) + | TypeGuard (f (Designator f' f')) QualIdent + | Dereference (f (Designator f' f')) -type ActualParameters f = [Expression f] +deriving instance (Typeable f, Typeable f', Data (f (Designator f' f')), Data (f (Expression f' f'))) => + Data (Designator f' f) +deriving instance (Show (f (Designator f' f')), Show (f (Expression f' f'))) => Show (Designator f' f) -data Type f = TypeReference QualIdent - | ArrayType [f (ConstExpression f)] (Type f) - | RecordType (Maybe BaseType) (FieldListSequence f) - | PointerType (Type f) - | ProcedureType (Maybe (FormalParameters f)) +data Type f' f = TypeReference QualIdent + | ArrayType [f (ConstExpression f' f')] (f (Type f' f')) + | RecordType (Maybe BaseType) (NonEmpty (f (FieldList f' f'))) + | PointerType (f (Type f' f')) + | ProcedureType (Maybe (f (FormalParameters f' f'))) -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) +deriving instance (Typeable f, Typeable f', Data (f (Type f' f')), Data (f (ConstExpression f' f')), + Data (f (FormalParameters f' f')), Data (f (FieldList f' f'))) => Data (Type f' f) +deriving instance (Show (f (Type f' f')), Show (f (ConstExpression f' f')), + Show (f (FormalParameters f' f')), Show (f (FieldList f' f'))) => Show (Type f' f) data QualIdent = QualIdent Ident Ident | NonQualIdent Ident deriving (Data, Eq, Ord, Show) -type BaseType = QualIdent - -type FieldListSequence f = NonEmpty (FieldList f) +type BaseType = QualIdent -data FieldList f = FieldList IdentList (Type f) - | EmptyFieldList +data FieldList f' f = FieldList IdentList (f (Type f' f')) + | EmptyFieldList -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) +deriving instance (Typeable f, Typeable f', Data (f (Type f' f')), Data (f (Expression f' f'))) => Data (FieldList f' f) +deriving instance (Show (f (Type f' f')), Show (f (Expression f' f'))) => Show (FieldList f' f) type IdentList = NonEmpty IdentDef -data ProcedureHeading f = ProcedureHeading (Maybe (Bool, Ident, Ident)) Bool IdentDef (Maybe (FormalParameters f)) -data FormalParameters f = FormalParameters [FPSection f] (Maybe QualIdent) -data FPSection f = FPSection Bool (NonEmpty Ident) (Type f) +data ProcedureHeading f' f = + ProcedureHeading (Maybe (Bool, Ident, Ident)) Bool IdentDef (Maybe (f (FormalParameters f' f'))) +data FormalParameters f' f = FormalParameters [f (FPSection f' f')] (Maybe QualIdent) -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) +data FPSection f' f = FPSection Bool (NonEmpty Ident) (f (Type f' f')) -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 (Typeable f, Typeable f', Data (f (FormalParameters f' f'))) => Data (ProcedureHeading f' f) +deriving instance (Show (f (FormalParameters f' f'))) => Show (ProcedureHeading f' f) -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) +deriving instance (Typeable f, Typeable f', Data (f (FPSection f' f')), Data (f (Expression f' f'))) => + Data (FormalParameters f' f) +deriving instance (Show (f (FPSection f' f')), Show (f (Expression f' f'))) => Show (FormalParameters f' f) -data ProcedureBody f = ProcedureBody [Declaration f] (Maybe (StatementSequence f)) +deriving instance (Typeable f, Typeable f', Data (f (Type f' f')), Data (f (Expression f' f'))) => + Data (FPSection f' f) +deriving instance (Show (f (Type f' f')), Show (f (Expression f' f'))) => Show (FPSection f' f) -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) +data ProcedureBody f' f = ProcedureBody [f (Declaration f' f')] (Maybe (f (StatementSequence f' f'))) -type StatementSequence f = NonEmpty (f (Statement f)) +deriving instance (Typeable f, Typeable f', Data (f (Declaration f' f')), Data (f (Designator f' f')), + Data (f (Expression f' f')), Data (f (StatementSequence f' f'))) => + Data (ProcedureBody f' f) +deriving instance (Show (f (Declaration f' f')), Show (f (Designator f' f')), + Show (f (Expression f' f')), Show (f (StatementSequence f' f'))) => Show (ProcedureBody f' f) -data Statement f = EmptyStatement - | Assignment (AmbDesignator f) (Expression f) - | ProcedureCall (AmbDesignator f) (Maybe (ActualParameters f)) - | If (NonEmpty (Expression f, StatementSequence f)) (Maybe (StatementSequence f)) - | CaseStatement (Expression f) (NonEmpty (Case f)) (Maybe (StatementSequence f)) - | While (Expression f) (StatementSequence f) - | Repeat (StatementSequence f) (Expression f) - | For Ident (Expression f) (Expression f) (Maybe (Expression f)) (StatementSequence f) -- Oberon2 - | Loop (StatementSequence f) - | With (NonEmpty (WithAlternative f)) (Maybe (StatementSequence f)) - | Exit - | Return (Maybe (Expression f)) +newtype StatementSequence f' f = StatementSequence (NonEmpty (f (Statement f' f'))) -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) +deriving instance (Typeable f, Typeable f', Data (f (Statement f' f'))) => Data (StatementSequence f' f) +deriving instance Show (f (Statement f' f')) => Show (StatementSequence f' f) -data WithAlternative f = WithAlternative QualIdent QualIdent (StatementSequence f) +data Statement f' f = EmptyStatement + | Assignment (f (Designator f' f')) (f (Expression f' f')) + | ProcedureCall (f (Designator f' f')) (Maybe [f (Expression f' f')]) + | If (NonEmpty (f (Product Expression StatementSequence f' f'))) + (Maybe (f (StatementSequence f' f'))) + | CaseStatement (f (Expression f' f')) + (NonEmpty (f (Case f' f'))) + (Maybe (f (StatementSequence f' f'))) + | While (f (Expression f' f')) (f (StatementSequence f' f')) + | Repeat (f (StatementSequence f' f')) (f (Expression f' f')) + | For Ident (f (Expression f' f')) (f (Expression f' f')) + (Maybe (f (Expression f' f'))) (f (StatementSequence f' f')) -- Oberon2 + | Loop (f (StatementSequence f' f')) + | With (NonEmpty (f (WithAlternative f' f'))) (Maybe (f (StatementSequence f' f'))) + | Exit + | Return (Maybe (f (Expression f' f'))) -data Case f = Case (NonEmpty (CaseLabels f)) (StatementSequence f) - | EmptyCase +deriving instance (Typeable f, Typeable f', Data (f (Designator f' f')), Data (f (Expression f' f')), + Data (f (Product Expression StatementSequence f' f')), + Data (f (Case f' f')), Data (f (WithAlternative f' f')), + Data (f (Statement f' f')), Data (f (StatementSequence f' f'))) => Data (Statement f' f) +deriving instance (Show (f (Designator f' f')), Show (f (Expression f' f')), + Show (f (Product Expression StatementSequence f' f')), + Show (f (Case f' f')), Show (f (WithAlternative f' f')), + Show (f (Statement f' f')), Show (f (StatementSequence f' f'))) => Show (Statement f' f) -data CaseLabels f = SingleLabel (ConstExpression f) - | LabelRange (ConstExpression f) (ConstExpression f) +data WithAlternative f' f = WithAlternative QualIdent QualIdent (f (StatementSequence f' f')) -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) +data Case f' f = Case (NonEmpty (f (CaseLabels f' f'))) (f (StatementSequence f' f')) + | EmptyCase -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) +data CaseLabels f' f = SingleLabel (f (ConstExpression f' f')) + | LabelRange (f (ConstExpression f' f')) (f (ConstExpression f' f')) -deriving instance (Typeable f, Data (f (Designator f))) => Data (CaseLabels f) -deriving instance Show (f (Designator f)) => Show (CaseLabels f) +deriving instance (Typeable f, Typeable f', Data (f (Designator f' f')), Data (f (StatementSequence f' f'))) => + Data (WithAlternative f' f) +deriving instance (Show (f (StatementSequence f' f'))) => Show (WithAlternative f' f) + +deriving instance (Typeable f, Typeable f', Data (f (CaseLabels f' f')), Data (f (StatementSequence f' f'))) => + Data (Case f' f) +deriving instance (Show (f (CaseLabels f' f')), Show (f (StatementSequence f' f'))) => Show (Case f' f) + +deriving instance (Typeable f, Typeable f', Data (f (ConstExpression f' f'))) => Data (CaseLabels f' f) +deriving instance Show (f (ConstExpression f' f')) => Show (CaseLabels f' f) + +$(mconcat <$> mapM Transformation.Deep.TH.deriveAll + [''Module, ''Declaration, ''Type, ''Expression, + ''Element, ''Designator, ''FieldList, + ''ProcedureHeading, ''FormalParameters, ''FPSection, ''ProcedureBody, + ''Statement, ''StatementSequence, ''WithAlternative, ''Case, ''CaseLabels]) 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 @@ -18,6 +18,7 @@ import Text.Parser.Combinators (sepBy, sepBy1, sepByNonEmpty, try) import Text.Parser.Token (braces, brackets, parens) +import Transformation.Deep as Deep (Product(Pair)) import qualified Rank2 import qualified Rank2.TH @@ -27,71 +28,71 @@ -- | All the productions of the Oberon grammar data OberonGrammar f p = OberonGrammar { - module_prod :: p (Module f), + module_prod :: p (Module f f), ident :: p Ident, letter :: p Text, digit :: p Text, importList :: p [Import], import_prod :: p Import, - declarationSequence :: p [Declaration f], - constantDeclaration :: p (Declaration f), + declarationSequence :: p [f (Declaration f f)], + constantDeclaration :: p (Declaration f f), identdef :: p IdentDef, - constExpression :: p (Expression f), - expression :: p (Expression f), - simpleExpression :: p (Expression f), - term :: p (Expression f), - factor :: p (Expression f), - number :: p (Expression f), - integer :: p (Expression f), + constExpression :: p (f (Expression f f)), + expression :: p (f (Expression f f)), + simpleExpression :: p (f (Expression f f)), + term :: p (f (Expression f f)), + factor :: p (f (Expression f f)), + number :: p (Expression f f), + integer :: p (Expression f f), hexDigit :: p Text, - real :: p (Expression f), + real :: p (Expression f f), scaleFactor :: p Text, - charConstant :: p (Expression f), + charConstant :: p (Expression f f), string_prod :: p Text, - set :: p (Expression f), - element :: p (Element f), - designator :: p (Designator f), - expList :: p (NonEmpty (Expression f)), - actualParameters :: p [(Expression f)], + set :: p (Expression f f), + element :: p (Element f f), + designator :: p (f (Designator f f)), + expList :: p (NonEmpty (f (Expression f f))), + actualParameters :: p [f (Expression f f)], mulOperator :: p (BinOp f), addOperator :: p (BinOp f), relation :: p RelOp, - typeDeclaration :: p (Declaration f), - type_prod :: p (Type f), + typeDeclaration :: p (Declaration f f), + type_prod :: p (Type f f), qualident :: p QualIdent, - arrayType :: p (Type f), - length :: p (Expression f), - recordType :: p (Type f), + arrayType :: p (Type f f), + length :: p (f (Expression f f)), + recordType :: p (Type f f), baseType :: p QualIdent, - fieldListSequence :: p (FieldListSequence f), - fieldList :: p (FieldList f), + fieldListSequence :: p (NonEmpty (f (FieldList f f))), + fieldList :: p (FieldList f f), identList :: p IdentList, - pointerType :: p (Type f), - procedureType :: p (Type f), - variableDeclaration :: p (Declaration f), - procedureDeclaration :: p (Declaration f), - procedureHeading :: p (ProcedureHeading f), - formalParameters :: p (FormalParameters f), - fPSection :: p (FPSection f), - formalType :: p (Type f), - procedureBody :: p (ProcedureBody f), - forwardDeclaration :: p (Declaration f), - statementSequence :: p (NonEmpty (Ambiguous (Statement f))), - statement :: p (Statement f), - assignment :: p (Statement f), - procedureCall :: p (Statement f), - ifStatement :: p (Statement f), - caseStatement :: p (Statement f), - case_prod :: p (Case f), - caseLabelList :: p (NonEmpty (CaseLabels f)), - caseLabels :: p (CaseLabels f), - whileStatement :: p (Statement f), - repeatStatement :: p (Statement f), - forStatement :: p (Statement f), - loopStatement :: p (Statement f), - withStatement :: p (Statement f)} + pointerType :: p (Type f f), + procedureType :: p (Type f f), + variableDeclaration :: p (Declaration f f), + procedureDeclaration :: p (Declaration f f), + procedureHeading :: p (ProcedureHeading f f), + formalParameters :: p (FormalParameters f f), + fPSection :: p (FPSection f f), + formalType :: p (Type f f), + procedureBody :: p (ProcedureBody f f), + forwardDeclaration :: p (Declaration f f), + statementSequence :: p (StatementSequence f f), + statement :: p (Statement f f), + assignment :: p (Statement f f), + procedureCall :: p (Statement f f), + ifStatement :: p (Statement f f), + caseStatement :: p (Statement f f), + case_prod :: p (Case f f), + caseLabelList :: p (NonEmpty (f (CaseLabels f f))), + caseLabels :: p (CaseLabels f f), + whileStatement :: p (Statement f f), + repeatStatement :: p (Statement f f), + forStatement :: p (Statement f f), + loopStatement :: p (Statement f f), + withStatement :: p (Statement f f)} -newtype BinOp f = BinOp {applyBinOp :: (Expression f -> Expression f -> Expression f)} +newtype BinOp f = BinOp {applyBinOp :: (f (Expression f f) -> f (Expression f f) -> Expression f f)} instance Show (BinOp f) where show = const "BinOp{}" @@ -146,50 +147,54 @@ ((,,) <$> (True <$ keyword "VAR" <|> pure False) <*> ident <* delimiter ":" <*> ident)) <*> (True <$ delimiter "*" <|> pure False) - <*> identdef <*> optional formalParameters, - arrayType = ArrayType <$ keyword "ARRAY" <*> sepBy (ambiguous length) (delimiter ",") <* keyword "OF" <*> type_prod, + <*> identdef <*> optional (wrap formalParameters), + arrayType = + ArrayType <$ keyword "ARRAY" <*> sepBy length (delimiter ",") <* keyword "OF" <*> wrap type_prod, statement = statement1 <|> forStatement, - forStatement = For <$ keyword "FOR" <*> ident <* delimiter ":=" <*> expression <* keyword "TO" <*> expression - <*> optional (keyword "BY" *> constExpression) <* keyword "DO" - <*> statementSequence <* keyword "END", - withStatement = With <$ keyword "WITH" <*> sepByNonEmpty withAlternative (delimiter "|") - <*> optional (keyword "ELSE" *> statementSequence) <* keyword "END"} + forStatement = + For <$ keyword "FOR" <*> ident <* delimiter ":=" <*> expression <* keyword "TO" <*> expression + <*> optional (keyword "BY" *> constExpression) <* keyword "DO" + <*> wrap statementSequence <* keyword "END", + withStatement = With <$ keyword "WITH" <*> sepByNonEmpty (wrap withAlternative) (delimiter "|") + <*> optional (keyword "ELSE" *> wrap statementSequence) <* keyword "END"} where g1@OberonGrammar{statement= statement1, string_prod= string_prod1} = grammar g withAlternative = WithAlternative <$> qualident <* delimiter ":" <*> qualident - <* keyword "DO" <*> statementSequence + <* keyword "DO" <*> wrap statementSequence grammar OberonGrammar{..} = OberonGrammar{ module_prod = Module <$ (lexicalWhiteSpace *> keyword "MODULE") <*> ident <* delimiter ";" <*> moptional importList <*> declarationSequence - <*> optional (keyword "BEGIN" *> statementSequence) <* keyword "END" <*> ident <* delimiter ".", + <*> optional (keyword "BEGIN" *> wrap statementSequence) <* keyword "END" <*> ident <* delimiter ".", ident = identifier, letter = satisfyCharInput isLetter, digit = satisfyCharInput isDigit, importList = keyword "IMPORT" *> sepBy1 import_prod (delimiter ",") <* delimiter ";", import_prod = (,) <$> optional (ident <* delimiter ":=") <*> ident, - declarationSequence = concatMany (keyword "CONST" *> many (constantDeclaration <* delimiter ";") - <|> keyword "TYPE" *> many (typeDeclaration <* delimiter ";") - <|> keyword "VAR" *> many (variableDeclaration <* delimiter ";")) - <> many (procedureDeclaration <* delimiter ";" - <|> forwardDeclaration <* delimiter ";") + declarationSequence = concatMany (keyword "CONST" *> many (wrap constantDeclaration <* delimiter ";") + <|> keyword "TYPE" *> many (wrap typeDeclaration <* delimiter ";") + <|> keyword "VAR" *> many (wrap variableDeclaration <* delimiter ";")) + <> many (wrap procedureDeclaration <* delimiter ";" + <|> wrap forwardDeclaration <* delimiter ";") "declarations", - constantDeclaration = ConstantDeclaration <$> identdef <* delimiter "=" <*> ambiguous constExpression, + constantDeclaration = ConstantDeclaration <$> identdef <* delimiter "=" <*> constExpression, identdef = IdentDef <$> ident <*> (Exported <$ delimiter "*" <|> pure PrivateOnly), constExpression = expression, - expression = simpleExpression <**> (pure id <|> (flip . Relation) <$> relation <*> simpleExpression) + expression = simpleExpression <**> (pure id <|> (pure .) <$> ((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))), - factor = number - <|> charConstant - <|> String <$> string_prod - <|> Nil <$ keyword "NIL" - <|> set - <|> Read <$> ambiguous designator - <|> FunctionCall <$> ambiguous designator <*> actualParameters - <|> parens expression - <|> Not <$ operator "~" <*> factor, + simpleExpression = + (((pure .) <$> (Positive <$ operator "+" <|> Negative <$ operator "-") <|> pure id) + <*> term) + <**> (appEndo <$> concatMany (Endo . (pure .) <$> (flip . applyBinOp <$> addOperator <*> term))), + term = factor <**> (appEndo <$> concatMany (Endo . (pure .) <$> (flip . applyBinOp <$> mulOperator <*> factor))), + factor = ambiguous (number + <|> charConstant + <|> String <$> string_prod + <|> Nil <$ keyword "NIL" + <|> set + <|> Read <$> designator + <|> FunctionCall <$> designator <*> actualParameters + <|> Not <$ operator "~" <*> factor) + <|> parens expression, number = integer <|> real, integer = Integer <$> lexicalToken (digit <> (takeCharsWhile isDigit <|> takeCharsWhile isHexDigit <> string "H")), hexDigit = satisfyCharInput isHexDigit, @@ -200,10 +205,11 @@ <|> CharCode . fst . head . readHex . unpack <$> (digit <> takeCharsWhile isHexDigit <* string "X")), string_prod = lexicalToken (char '"' *> takeWhile (/= "\"") <* char '"'), - set = Set <$> braces (sepBy element (delimiter ",")), - element = Element <$> expression + set = Set <$> braces (sepBy (wrap element) (delimiter ",")), + element = Element <$> expression <|> Range <$> expression <* delimiter ".." <*> expression, - designator = Variable <$> qualident + designator = ambiguous $ + Variable <$> qualident <|> Field <$> designator <* delimiter "." <*> ident <|> Index <$> designator <*> brackets expList <|> TypeGuard <$> designator <*> parens qualident @@ -217,69 +223,73 @@ <|> Less <$ operator "<" <|> LessOrEqual <$ operator "<=" <|> Greater <$ operator ">" <|> GreaterOrEqual <$ operator ">=" <|> In <$ keyword "IN" <|> Is <$ keyword "IS", - typeDeclaration = TypeDeclaration <$> identdef <* delimiter "=" <*> type_prod, + typeDeclaration = TypeDeclaration <$> identdef <* delimiter "=" <*> wrap type_prod, type_prod = TypeReference <$> qualident <|> arrayType <|> recordType <|> pointerType <|> procedureType, - qualident = QualIdent <$> ident <* delimiter "." <*> ident + qualident = QualIdent <$> ident <* delimiter "." <*> ident <|> NonQualIdent <$> ident, - arrayType = ArrayType <$ keyword "ARRAY" <*> sepBy1 (ambiguous length) (delimiter ",") <* keyword "OF" <*> type_prod, + arrayType = ArrayType <$ keyword "ARRAY" <*> sepBy1 length (delimiter ",") <* keyword "OF" <*> wrap type_prod, length = constExpression, recordType = RecordType <$ keyword "RECORD" <*> optional (parens baseType) <*> fieldListSequence <* keyword "END", baseType = qualident, - fieldListSequence = sepByNonEmpty fieldList (delimiter ";"), - fieldList = (FieldList <$> identList <* delimiter ":" <*> type_prod "record field declarations") + fieldListSequence = sepByNonEmpty (wrap fieldList) (delimiter ";"), + fieldList = (FieldList <$> identList <* delimiter ":" <*> wrap type_prod "record field declarations") <|> pure EmptyFieldList, identList = sepByNonEmpty identdef (delimiter ","), - pointerType = PointerType <$ keyword "POINTER" <* keyword "TO" <*> type_prod, - procedureType = ProcedureType <$ keyword "PROCEDURE" <*> optional formalParameters, - variableDeclaration = VariableDeclaration <$> identList <* delimiter ":" <*> type_prod, + pointerType = PointerType <$ keyword "POINTER" <* keyword "TO" <*> wrap type_prod, + procedureType = ProcedureType <$ keyword "PROCEDURE" <*> optional (wrap formalParameters), + variableDeclaration = VariableDeclaration <$> identList <* delimiter ":" <*> wrap type_prod, procedureDeclaration = ProcedureDeclaration <$> procedureHeading <* delimiter ";" <*> procedureBody <*> ident, procedureHeading = ProcedureHeading Nothing <$ keyword "PROCEDURE" <*> (True <$ delimiter "*" <|> pure False) - <*> identdef <*> optional formalParameters, - formalParameters = FormalParameters <$> parens (sepBy fPSection (delimiter ";")) + <*> identdef <*> optional (wrap formalParameters), + formalParameters = FormalParameters <$> parens (sepBy (wrap fPSection) (delimiter ";")) <*> optional (delimiter ":" *> qualident), fPSection = FPSection <$> (True <$ keyword "VAR" <|> pure False) - <*> sepByNonEmpty ident (delimiter ",") <* delimiter ":" <*> formalType, - formalType = ArrayType [] <$ keyword "ARRAY" <* keyword "OF" <*> formalType - <|> TypeReference <$> qualident - <|> ProcedureType <$ keyword "PROCEDURE" <*> optional formalParameters, - procedureBody = ProcedureBody <$> declarationSequence - <*> optional (keyword "BEGIN" *> statementSequence) <* keyword "END", + <*> sepByNonEmpty ident (delimiter ",") <* delimiter ":" <*> wrap formalType, + formalType = ArrayType [] <$ keyword "ARRAY" <* keyword "OF" <*> wrap formalType + <|> TypeReference <$> qualident + <|> ProcedureType <$ keyword "PROCEDURE" <*> optional (wrap formalParameters), + procedureBody = ProcedureBody <$> declarationSequence + <*> optional (keyword "BEGIN" *> wrap statementSequence) <* keyword "END", forwardDeclaration = ForwardDeclaration <$ keyword "PROCEDURE" <* delimiter "^" - <*> identdef <*> optional formalParameters, - statementSequence = sepByNonEmpty (ambiguous statement) (delimiter ";"), + <*> identdef <*> optional (wrap formalParameters), + statementSequence = StatementSequence <$> sepByNonEmpty (ambiguous statement) (delimiter ";"), statement = assignment <|> procedureCall <|> ifStatement <|> caseStatement <|> whileStatement <|> repeatStatement <|> loopStatement <|> withStatement <|> Exit <$ keyword "EXIT" <|> Return <$ keyword "RETURN" <*> optional expression <|> pure EmptyStatement "statement", - assignment = Assignment <$> ambiguous designator <* delimiter ":=" <*> expression, - procedureCall = ProcedureCall <$> ambiguous designator <*> optional actualParameters, + assignment = Assignment <$> designator <* delimiter ":=" <*> expression, + procedureCall = ProcedureCall <$> designator <*> optional actualParameters, ifStatement = If <$ keyword "IF" - <*> sepByNonEmpty ((,) <$> expression <* keyword "THEN" <*> statementSequence) (keyword "ELSIF") - <*> optional (keyword "ELSE" *> statementSequence) <* keyword "END", + <*> sepByNonEmpty (wrap $ Deep.Pair <$> expression <* keyword "THEN" <*> wrap statementSequence) + (keyword "ELSIF") + <*> optional (keyword "ELSE" *> wrap statementSequence) <* keyword "END", caseStatement = CaseStatement <$ keyword "CASE" <*> expression - <* keyword "OF" <*> sepByNonEmpty case_prod (delimiter "|") - <*> optional (keyword "ELSE" *> statementSequence) <* keyword "END", - case_prod = Case <$> caseLabelList <* delimiter ":" <*> statementSequence + <* keyword "OF" <*> sepByNonEmpty (wrap case_prod) (delimiter "|") + <*> optional (keyword "ELSE" *> wrap statementSequence) <* keyword "END", + case_prod = Case <$> caseLabelList <* delimiter ":" <*> wrap statementSequence <|> pure EmptyCase, - caseLabelList = sepByNonEmpty caseLabels (delimiter ","), - caseLabels = SingleLabel <$> constExpression + caseLabelList = sepByNonEmpty (wrap caseLabels) (delimiter ","), + caseLabels = SingleLabel <$> constExpression <|> LabelRange <$> constExpression <* delimiter ".." <*> constExpression, - whileStatement = While <$ keyword "WHILE" <*> expression <* keyword "DO" <*> statementSequence <* keyword "END", - repeatStatement = Repeat <$ keyword "REPEAT" <*> statementSequence <* keyword "UNTIL" <*> expression, - loopStatement = Loop <$ keyword "LOOP" <*> statementSequence <* keyword "END", + whileStatement = While <$ keyword "WHILE" <*> expression <* keyword "DO" + <*> wrap statementSequence <* keyword "END", + repeatStatement = Repeat <$ keyword "REPEAT" <*> wrap statementSequence <* keyword "UNTIL" <*> expression, + loopStatement = Loop <$ keyword "LOOP" <*> wrap statementSequence <* keyword "END", forStatement = empty, withStatement = With <$ keyword "WITH" <*> ((:| []) - <$> (WithAlternative <$> qualident <* delimiter ":" <*> qualident - <* keyword "DO" <*> statementSequence)) + <$> wrap (WithAlternative <$> qualident <* delimiter ":" <*> qualident + <* keyword "DO" <*> wrap statementSequence)) <*> pure Nothing <* keyword "END"} + +wrap = ambiguous moptional p = p <|> mempty diff --git a/src/Language/Oberon/Pretty.hs b/src/Language/Oberon/Pretty.hs --- a/src/Language/Oberon/Pretty.hs +++ b/src/Language/Oberon/Pretty.hs @@ -8,12 +8,14 @@ import Data.Functor.Identity (Identity(..)) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty((:|)), fromList, toList) +import qualified Data.Text as Text import Data.Text.Prettyprint.Doc import Numeric (showHex) +import Transformation.Deep as Deep (Product(Pair)) import Language.Oberon.AST -instance Pretty (Module Identity) where +instance Pretty (Module Identity Identity) where pretty (Module name imports declarations body name') = vsep $ intersperse mempty $ ["MODULE" <+> pretty name <> semi, @@ -25,7 +27,7 @@ where prettyImport (Nothing, mod) = pretty mod prettyImport (Just inner, mod) = pretty inner <> ":=" <+> pretty mod -instance Pretty (Declaration Identity) where +instance Pretty (Declaration Identity Identity) where pretty (ConstantDeclaration ident (Identity expr)) = "CONST" <+> pretty ident <+> "=" <+> pretty expr <> semi pretty (TypeDeclaration ident typeDef) = "TYPE" <+> pretty ident <+> "=" <+> pretty typeDef <> semi pretty (VariableDeclaration idents varType) = @@ -40,31 +42,35 @@ pretty (IdentDef name ReadOnly) = pretty name <> "-" pretty (IdentDef name PrivateOnly) = pretty name -instance Pretty (Expression Identity) where +instance Pretty (Expression Identity Identity) where pretty = prettyPrec 0 - where prettyPrec 0 (Relation op left right) = prettyPrec 1 left <+> pretty op <+> prettyPrec 1 right - prettyPrec p (Positive e) | p < 2 = "+" <> prettyPrec 2 e - prettyPrec p (Negative e) | p < 2 = "-" <> prettyPrec 2 e - prettyPrec p (Add left right) | p < 3 = prettyPrec 3 left <> "+" <> prettyPrec 3 right - prettyPrec p (Subtract left right) | p < 3 = prettyPrec 3 left <> "-" <> prettyPrec 3 right - prettyPrec p (Or left right) | p < 3 = prettyPrec 3 left <+> "OR" <+> prettyPrec 3 right - prettyPrec p (Multiply left right) | p < 4 = prettyPrec 4 left <> "*" <> prettyPrec 4 right - prettyPrec p (Divide left right) | p < 4 = prettyPrec 4 left <> "/" <> prettyPrec 4 right - prettyPrec p (IntegerDivide left right) | p < 4 = prettyPrec 4 left <+> "DIV" <+> prettyPrec 4 right - prettyPrec p (Modulo left right) | p < 4 = prettyPrec 4 left <+> "MOD" <+> prettyPrec 4 right - prettyPrec p (And left right) | p < 4 = prettyPrec 4 left <+> "&" <+> prettyPrec 4 right + where prettyPrec 0 (Relation op left right) = prettyPrec' 1 left <+> pretty op <+> prettyPrec' 1 right + prettyPrec p (Positive e) | p < 2 = "+" <> prettyPrec' 2 e + prettyPrec p (Negative e) | p < 2 = "-" <> prettyPrec' 2 e + prettyPrec p (Add left right) | p < 3 = prettyPrec' 3 left <> "+" <> prettyPrec' 3 right + prettyPrec p (Subtract left right) | p < 3 = prettyPrec' 3 left <> "-" <> prettyPrec' 3 right + prettyPrec p (Or left right) | p < 3 = prettyPrec' 3 left <+> "OR" <+> prettyPrec' 3 right + prettyPrec p (Multiply left right) | p < 4 = prettyPrec' 4 left <> "*" <> prettyPrec' 4 right + prettyPrec p (Divide left right) | p < 4 = prettyPrec' 4 left <> "/" <> prettyPrec' 4 right + prettyPrec p (IntegerDivide left right) | p < 4 = prettyPrec' 4 left <+> "DIV" <+> prettyPrec' 4 right + prettyPrec p (Modulo left right) | p < 4 = prettyPrec' 4 left <+> "MOD" <+> prettyPrec' 4 right + prettyPrec p (And left right) | p < 4 = prettyPrec' 4 left <+> "&" <+> prettyPrec' 4 right prettyPrec _ (Integer n) = pretty n prettyPrec _ (Real r) = pretty r + prettyPrec _ (CharConstant c@'"') = squotes (pretty c) prettyPrec _ (CharConstant c) = dquotes (pretty c) prettyPrec _ (CharCode c) = "0" <> pretty (showHex c "") <> "X" - prettyPrec _ (String s) = dquotes (pretty s) + prettyPrec _ (String s) + | Text.any (== '"') s = squotes (pretty s) + | otherwise = dquotes (pretty s) prettyPrec _ Nil = "NIL" prettyPrec _ (Set elements) = braces (hsep $ punctuate comma $ pretty <$> elements) prettyPrec _ (Read (Identity var)) = pretty var prettyPrec _ (FunctionCall (Identity fun) parameters) = pretty fun <> parens (hsep $ punctuate comma $ pretty <$> parameters) - prettyPrec p (Not e) | p < 5 = "~" <> prettyPrec 5 e + prettyPrec p (Not e) | p < 5 = "~" <> prettyPrec' 5 e prettyPrec p e = parens (prettyPrec 0 e) + prettyPrec' p (Identity e) = prettyPrec p e instance Pretty RelOp where pretty Equal = "=" @@ -76,18 +82,18 @@ pretty In = "IN" pretty Is = "IS" -instance Pretty (Element Identity) where +instance Pretty (Element Identity Identity) where pretty (Element e) = pretty e pretty (Range from to) = pretty from <+> ".." <+> pretty to -instance Pretty (Designator Identity) where +instance Pretty (Designator Identity Identity) where pretty (Variable q) = pretty q pretty (Field record name) = pretty record <> dot <> pretty name pretty (Index array indexes) = pretty array <> brackets (hsep $ punctuate comma $ pretty <$> toList indexes) pretty (TypeGuard scrutinee typeName) = pretty scrutinee <> parens (pretty typeName) pretty (Dereference pointer) = pretty pointer <> "^" -instance Pretty (Type Identity) where +instance Pretty (Type Identity Identity) where pretty (TypeReference q) = pretty q pretty (ArrayType dimensions itemType) = "ARRAY" <+> hsep (punctuate comma $ pretty . runIdentity <$> dimensions) <+> "OF" <+> pretty itemType @@ -101,11 +107,11 @@ pretty (QualIdent moduleName memberName) = pretty moduleName <> "." <> pretty memberName pretty (NonQualIdent localName) = pretty localName -instance Pretty (FieldList Identity) where +instance Pretty (FieldList Identity Identity) where pretty (FieldList names t) = hsep (punctuate comma $ pretty <$> toList names) <+> ":" <+> pretty t pretty EmptyFieldList = mempty -instance Pretty (ProcedureHeading Identity) where +instance Pretty (ProcedureHeading Identity Identity) where pretty (ProcedureHeading receiver indirect ident parameters) = "PROCEDURE" <> (if indirect then "* " else space) <> foldMap prettyReceiver receiver <> pretty ident <> pretty parameters @@ -113,21 +119,23 @@ <> pretty name <> colon <+> pretty t) <> space -instance Pretty (FormalParameters Identity) where +instance Pretty (FormalParameters Identity Identity) where pretty (FormalParameters sections result) = - prettyList sections <> foldMap (colon <+>) (pretty <$> result) + lparen <> hsep (punctuate semi $ pretty <$> sections) <> rparen <> foldMap (colon <+>) (pretty <$> result) -instance Pretty (FPSection Identity) where - prettyList sections = lparen <> hsep (punctuate semi $ pretty <$> sections) <> rparen +instance Pretty (FPSection Identity Identity) where pretty (FPSection var names t) = (if var then ("VAR" <+>) else id) $ hsep (punctuate comma $ pretty <$> toList names) <+> colon <+> pretty t -instance Pretty (ProcedureBody Identity) where +instance Pretty (ProcedureBody Identity Identity) where pretty (ProcedureBody declarations body) = vsep ((indent 3 . pretty <$> declarations) ++ foldMap (\statements-> ["BEGIN", prettyBlock statements]) body) -instance Pretty (Statement Identity) where +instance Pretty (StatementSequence Identity Identity) where + pretty (StatementSequence statements) = pretty (runIdentity <$> statements) + +instance Pretty (Statement Identity Identity) where prettyList l = vsep (dropEmptyTail $ punctuate semi $ pretty <$> l) where dropEmptyTail | not (null l), EmptyStatement <- last l = init @@ -140,10 +148,12 @@ : (branch "ELSIF" <$> elsifs) ++ foldMap (\x-> ["ELSE", prettyBlock x]) fallback ++ ["END"]) - where branch kwd (condition, body) = vsep [kwd <+> pretty condition <+> "THEN", - prettyBlock body] + where branch kwd (Identity (Deep.Pair (Identity condition) (Identity body))) = + vsep [kwd <+> pretty condition <+> "THEN", + prettyBlock (Identity body)] pretty (CaseStatement scrutinee cases fallback) = vsep ["CASE" <+> pretty scrutinee <+> "OF", - pretty cases, + align (encloseSep mempty mempty "| " + $ pretty <$> toList cases), foldMap ("ELSE" <#>) (prettyBlock <$> fallback), "END"] @@ -168,18 +178,20 @@ pretty Exit = "EXIT" pretty (Return result) = "RETURN" <+> foldMap pretty result -instance Pretty (Case Identity) where - pretty (Case labels body) = vsep ["|" <+> pretty labels <+> colon, +instance Pretty (Case Identity Identity) where + pretty (Case labels body) = vsep [hsep (punctuate comma (pretty <$> toList labels)) <+> colon, prettyBlock body] pretty EmptyCase = mempty -instance Pretty (WithAlternative Identity) where +instance Pretty (WithAlternative Identity Identity) where pretty (WithAlternative name t body) = vsep [pretty name <+> colon <+> pretty t <+> "DO", prettyBlock body] -instance Pretty (CaseLabels Identity) where +instance Pretty (CaseLabels Identity Identity) where pretty (SingleLabel expression) = pretty expression pretty (LabelRange from to) = pretty from <+> ".." <+> pretty to -prettyBlock statements = indent 3 (pretty $ runIdentity <$> statements) +prettyBlock :: Identity (StatementSequence Identity Identity) -> Doc ann +prettyBlock (Identity (StatementSequence statements)) = indent 3 (pretty $ runIdentity <$> statements) + a <#> b = vsep [a, b] 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 @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, + OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -- | This module exports functions for resolving the syntactic ambiguities in a parsed module. For example, an Oberon -- expression @foo(bar)@ may be a call to function @foo@ with a parameter @bar@, or it may be type guard on variable @@ -9,8 +11,10 @@ import Control.Applicative (Alternative) import Control.Monad ((>=>)) +import Control.Monad.Trans.State (StateT(..), evalStateT) import Data.Either (partitionEithers) import Data.Either.Validation (Validation(..), validationToEither) +import Data.Foldable (toList) import Data.Functor.Identity (Identity(..)) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -20,304 +24,234 @@ import qualified Data.Map.Lazy as Map import Data.Semigroup (Semigroup(..), sconcat) +import qualified Rank2.TH +import qualified Transformation as Shallow +import qualified Transformation.Deep as Deep +import qualified Transformation.Deep.TH +import qualified Transformation.Rank2 as Rank2 import Text.Grampa (Ambiguous(..), ParseFailure) import Language.Oberon.AST -data DeclarationRHS f = DeclaredConstant (f (ConstExpression f)) - | DeclaredType (Type f) - | DeclaredVariable (Type f) - | DeclaredProcedure Bool (Maybe (FormalParameters f)) +data DeclarationRHS f' f = DeclaredConstant (f (ConstExpression f' f')) + | DeclaredType (f (Type f' f')) + | DeclaredVariable (f (Type f' f')) + | DeclaredProcedure Bool (Maybe (f (FormalParameters f' f'))) +deriving instance Show (DeclarationRHS Identity Identity) +deriving instance Show (DeclarationRHS Ambiguous Ambiguous) --- | All possible resultion errors -data Error = UnknownModule Ident +-- | All possible resolution errors +data Error = UnknownModule QualIdent | UnknownLocal Ident | UnknownImport QualIdent | AmbiguousParses - | AmbiguousDesignator [Designator Identity] - | AmbiguousExpression [Expression Identity] - | AmbiguousStatement [Statement Identity] - | InvalidDesignator (NonEmpty Error) + | AmbiguousDeclaration [Declaration Ambiguous Ambiguous] + | AmbiguousDesignator [Designator Ambiguous Ambiguous] + | AmbiguousExpression [Expression Ambiguous Ambiguous] + | AmbiguousRecord [Designator Ambiguous Ambiguous] + | AmbiguousStatement [Statement Ambiguous Ambiguous] | InvalidExpression (NonEmpty Error) + | InvalidFunctionParameters [Ambiguous (Expression Ambiguous Ambiguous)] + | InvalidRecord (NonEmpty Error) | InvalidStatement (NonEmpty Error) - | NotAProcedure QualIdent | NotARecord QualIdent | NotAType QualIdent - | NotATypeDesignator (Designator Ambiguous) | NotAValue QualIdent - | NotWriteable QualIdent | ClashingImports | UnparseableModule ParseFailure deriving (Show) -type Scope = Predefined +type Scope = Map Ident (Validation (NonEmpty Error) (DeclarationRHS Identity Identity)) --- | A set of 'Predefined' declarations. -type Predefined = Map Ident (Validation (NonEmpty Error) (DeclarationRHS Identity)) +-- | A set of predefined declarations. +type Predefined = Scope --- | Eliminate the ambiguites in the given map of module names to their parsed syntax trees. The first argument is a set --- of 'Predefined' declarations, such as 'predefined' or 'predefined2'. -resolveModules :: Predefined -> Map Ident (Module Ambiguous) - -> Validation (NonEmpty (Ident, NonEmpty Error)) (Map Ident (Module Identity)) -resolveModules predefinedScope modules = traverseWithKey extractErrors modules' - where modules' = resolveModule predefinedScope modules' <$> modules - extractErrors moduleKey (Failure e) = Failure ((moduleKey, e) :| []) - extractErrors _ (Success mod) = Success mod +data Resolution = Resolution{_modules :: Map Ident Scope} --- | Eliminate the ambiguites in the parsed syntax tree of a single module. The first argument is a set of 'Predefined' --- declarations, such as 'predefined' or 'predefined2'. The second is a mapping of imported module names to their --- already resolved syntax trees. -resolveModule :: Predefined -> Map Ident (Validation (NonEmpty Error) (Module Identity)) -> Module Ambiguous - -> Validation (NonEmpty Error) (Module Identity) -resolveModule predefinedScope modules (Module moduleName imports declarations body name') = module' - where moduleExports :: Map Ident Scope - moduleGlobals :: Map Ident (AccessMode, Validation (NonEmpty Error) (DeclarationRHS Identity)) - importedModules :: Map Ident (Validation (NonEmpty Error) (Module Identity)) - resolveBinding :: Scope -> DeclarationRHS Ambiguous - -> Validation (NonEmpty Error) (DeclarationRHS Identity) - resolveDeclaration :: Scope -> Declaration Ambiguous -> Validation (NonEmpty Error) (Declaration Identity) - resolveType :: Scope -> Type Ambiguous -> Validation (NonEmpty Error) (Type Identity) - resolveFields :: Scope -> FieldList Ambiguous -> Validation (NonEmpty Error) (FieldList Identity) - resolveStatements :: Scope -> StatementSequence Ambiguous - -> Validation (NonEmpty Error) (StatementSequence Identity) - resolveStatement :: Scope -> Statement Ambiguous -> Validation (NonEmpty Error) (Statement Identity) - resolveExpression :: Scope -> Expression Ambiguous -> Validation (NonEmpty Error) (Expression Identity) - resolveElement :: Scope -> Element Ambiguous -> Validation (NonEmpty Error) (Element Identity) - resolveDesignator, resolveWriteable, resolveProcedure, resolveRecord, resolvePointer - :: Scope -> Designator Ambiguous -> Validation (NonEmpty Error) (Designator Identity) - resolveName :: Scope -> QualIdent -> Validation (NonEmpty Error) (DeclarationRHS Identity) - resolveTypeName :: Scope -> QualIdent -> Validation (NonEmpty Error) QualIdent +type Resolved = StateT (Scope, ResolutionState) (Validation (NonEmpty Error)) - module' = Module moduleName imports - <$> traverse (resolveDeclaration moduleGlobalScope) declarations - <*> traverse (resolveStatements moduleGlobalScope) body - <*> pure name' - importedModules = Map.delete mempty (Map.mapKeysWith clashingRenames importedAs modules) - where importedAs moduleName = case List.find ((== moduleName) . snd) imports - of Just (Nothing, moduleKey) -> moduleKey - Just (Just innerKey, _) -> innerKey - Nothing -> mempty - clashingRenames _ _ = Failure (ClashingImports :| []) +data ResolutionState = ModuleState + | DeclarationState + | StatementState + | ExpressionState + | ExpressionOrTypeState + deriving (Eq, Show) - moduleExports = foldMap exportsOfModule <$> importedModules - moduleGlobals = (resolveBinding moduleGlobalScope <$>) - <$> Map.fromList (concatMap (declarationBinding moduleName) declarations) - moduleGlobalScope = Map.union (snd <$> moduleGlobals) predefinedScope +instance Monad (Validation (NonEmpty Error)) where + Success s >>= f = f s + Failure errors >>= _ = Failure errors - resolveDeclaration scope (ConstantDeclaration name (Ambiguous expr)) = - ConstantDeclaration name . Identity <$> uniqueExpression (resolveExpression scope <$> expr) - resolveDeclaration scope (TypeDeclaration name typeDef) = - TypeDeclaration name <$> resolveType scope typeDef - resolveDeclaration scope (VariableDeclaration name typeDef) = - VariableDeclaration name <$> resolveType scope typeDef - resolveDeclaration scope (ProcedureDeclaration head (ProcedureBody declarations statements) name) = - ProcedureDeclaration <$> resolveHeading head - <*> (ProcedureBody <$> sequenceA declarations' - <*> (traverse (resolveStatements scope'') statements)) - <*> pure name - where scope'' = Map.union (resolveBinding scope . snd <$> Map.fromList declarationBindings) scope' - scope' = Map.union (headBindings head) scope - headBindings (ProcedureHeading receiver indirect name parameters) = - Map.union (foldMap receiverBinding receiver) (foldMap parametersBinding parameters) - receiverBinding (_, name, t) = - Map.singleton name (DeclaredVariable <$> resolveType scope (TypeReference $ NonQualIdent t)) - parametersBinding (FormalParameters sections _return) = foldMap sectionBinding sections - sectionBinding (FPSection var names t) = foldMap parameterBinding names - where parameterBinding name = Map.singleton name (DeclaredVariable <$> resolveType scope t) - - declarationBindings = concatMap (declarationBinding moduleName) declarations - declarations' = resolveDeclaration scope'' <$> declarations - resolveHeading (ProcedureHeading receiver indirect name parameters) = - ProcedureHeading receiver indirect name <$> traverse (resolveParameters scope) parameters - resolveDeclaration scope (ForwardDeclaration name parameters) = - ForwardDeclaration name <$> traverse (resolveParameters scope) parameters +instance Shallow.Functor Resolution Ambiguous Resolved (Module Resolved Resolved) where + (<$>) = mapResolveDefault - resolveType scope (TypeReference name) = pure (TypeReference name) - resolveType scope (ArrayType dimensions itemType) = - ArrayType <$> (traverse (fmap Identity . uniqueExpression . (resolveExpression scope <$>) . unA) dimensions) - <*> resolveType scope itemType - where unA (Ambiguous a) = a - resolveType scope (RecordType baseType fields) = RecordType baseType <$> traverse (resolveFields scope) fields - resolveType scope (PointerType baseType) = PointerType <$> resolveType scope baseType - resolveType scope (ProcedureType parameters) = ProcedureType <$> traverse (resolveParameters scope) parameters +instance {-# overlappable #-} Show (g Identity Identity) => + Shallow.Traversable Resolution Ambiguous Identity Resolved (g Identity Identity) where + traverse = traverseResolveDefault - resolveFields scope (FieldList names fieldType) = FieldList names <$> resolveType scope fieldType - resolveFields scope EmptyFieldList = pure EmptyFieldList +instance {-# overlappable #-} Show (g Ambiguous Ambiguous) => + Shallow.Traversable Resolution Ambiguous Identity Resolved (g Ambiguous Ambiguous) where + traverse = traverseResolveDefault - resolveParameters scope (FormalParameters sections result) = - FormalParameters <$> traverse resolveSection sections <*> pure result - where resolveSection (FPSection var names t) = FPSection var names <$> resolveType scope t +instance {-# overlaps #-} Shallow.Traversable + Resolution Ambiguous Identity Resolved (Designator Ambiguous Ambiguous) where + traverse res (Ambiguous designators) = StateT $ \s@(scope, state)-> + case partitionEithers (NonEmpty.toList (validationToEither . resolveDesignator res scope state <$> designators)) + of (_, [x]) -> Success (Identity x, s) + (errors, []) -> Failure (sconcat $ NonEmpty.fromList errors) + (_, multi) -> Failure (AmbiguousDesignator multi :| []) - resolveStatements scope = traverse (fmap Identity . resolveOne) - where resolveOne :: Ambiguous (Statement Ambiguous) -> Validation (NonEmpty Error) (Statement Identity) - resolveOne (Ambiguous statements) = uniqueStatement (resolveStatement scope <$> statements) +instance {-# overlaps #-} Shallow.Traversable + Resolution Ambiguous Identity Resolved (Expression Ambiguous Ambiguous) where + traverse res expressions = StateT $ \s@(scope, state)-> + let resolveExpression :: Expression Ambiguous Ambiguous + -> Validation (NonEmpty Error) (Expression Ambiguous Ambiguous, ResolutionState) + resolveExpression e@(Read designators) = + case evalStateT (Shallow.traverse res designators) s + of Failure errors -> Failure errors + Success{} -> pure (e, state) + resolveExpression e@(FunctionCall functions parameters) = + case evalStateT (Shallow.traverse res functions) s + of Failure errors -> Failure errors + Success (Identity d) + | Variable q <- d, Success (DeclaredProcedure True _) <- resolveName res scope q + -> pure (e, ExpressionOrTypeState) + | Success{} <- evalStateT (traverse (Shallow.traverse res) parameters) (scope, ExpressionState) + -> pure (e, ExpressionState) + | otherwise -> Failure (pure $ InvalidFunctionParameters parameters) + resolveExpression e@(Relation Is lefts rights) = pure (e, ExpressionOrTypeState) + resolveExpression e = pure (e, state) + in (\(r, s)-> (Identity r, (scope, s))) + <$> unique InvalidExpression (AmbiguousExpression . (fst <$>)) (resolveExpression <$> expressions) - resolveStatement _ EmptyStatement = pure EmptyStatement - resolveStatement scope (Assignment (Ambiguous designators) exp) = - Assignment <$> (Identity <$> uniqueDesignator (resolveWriteable scope <$> designators)) - <*> resolveExpression scope exp - resolveStatement scope (ProcedureCall (Ambiguous designators) parameters) = - ProcedureCall <$> (Identity <$> uniqueDesignator (resolveProcedure scope <$> designators)) - <*> (traverse . traverse) (resolveExpression scope) parameters - resolveStatement scope (If branches fallback) = - If <$> traverse resolveBranch branches <*> traverse (resolveStatements scope) fallback - where resolveBranch (condition, action) = (,) <$> resolveExpression scope condition - <*> resolveStatements scope action - resolveStatement scope (CaseStatement expression cases fallback) = - CaseStatement <$> resolveExpression scope expression - <*> traverse resolveCase cases - <*> traverse (resolveStatements scope) fallback - where resolveCase (Case caseLabels action) = - Case <$> traverse resolveLabels caseLabels <*> resolveStatements scope action - resolveCase EmptyCase = pure EmptyCase - resolveLabels (SingleLabel expression) = SingleLabel <$> resolveExpression scope expression - resolveLabels (LabelRange low high) = - LabelRange <$> resolveExpression scope low <*> resolveExpression scope high - resolveStatement scope (While condition body) = - While <$> resolveExpression scope condition <*> resolveStatements scope body - resolveStatement scope (Repeat body condition) = - Repeat <$> resolveStatements scope body <*> resolveExpression scope condition - resolveStatement scope (For index from to by body) = - For index <$> resolveExpression scope from <*> resolveExpression scope to - <*> traverse (resolveExpression scope) by <*> resolveStatements scope body - resolveStatement scope (Loop body) = Loop <$> resolveStatements scope body - resolveStatement scope (With alternatives fallback) = With <$> traverse resolveAlt alternatives - <*> traverse (resolveStatements scope) fallback - where resolveAlt (WithAlternative name t action) = - WithAlternative name t <$> resolveStatements scope action - resolveStatement scope Exit = pure Exit - resolveStatement scope (Return expression) = Return <$> traverse (resolveExpression scope) expression +instance {-# overlaps #-} Shallow.Traversable + Resolution Ambiguous Identity Resolved (Declaration Ambiguous Ambiguous) where + traverse res (Ambiguous (proc@(ProcedureDeclaration heading body _) :| [])) = + StateT $ \s@(scope, state)-> + let ProcedureHeading receiver _indirect _name parameters = heading + ProcedureBody declarations statements = body + innerScope = localScope res "" declarations (parameterScope `Map.union` receiverScope `Map.union` scope) + receiverScope = maybe mempty receiverBinding receiver + receiverBinding (_, name, ty) = Map.singleton name (Success $ DeclaredVariable $ pure $ TypeReference + $ NonQualIdent ty) + parameterScope = case parameters + of Nothing -> mempty + Just (Ambiguous (FormalParameters sections _ :| [])) + -> Map.fromList (concatMap binding sections) + binding (Ambiguous (FPSection _ names types :| [])) = + [(v, evalStateT (Deep.traverseDown res $ DeclaredVariable types) s) | v <- NonEmpty.toList names] + in Success (Identity proc, (innerScope, state)) + traverse res (Ambiguous (dec :| [])) = pure (Identity dec) + traverse _ declarations = StateT (const $ Failure $ pure $ AmbiguousDeclaration $ toList declarations) - resolveExpression scope (Relation Is left (Read (Ambiguous rights))) = - Relation Is <$> resolveExpression scope left - <*> (typeToValue <$> sconcat (designatorToType <$> rights)) - where typeToValue (TypeReference n) = Read (Identity (Variable n)) - designatorToType (Variable q) = resolveType scope (TypeReference q) - designatorToType d = Failure (NotATypeDesignator d :| []) - resolveExpression scope (Relation op left right) = - Relation op <$> resolveExpression scope left <*> resolveExpression scope right - resolveExpression scope (Positive e) = Positive <$> resolveExpression scope e - resolveExpression scope (Negative e) = Negative <$> resolveExpression scope e - resolveExpression scope (Add left right) = - Add <$> resolveExpression scope left <*> resolveExpression scope right - resolveExpression scope (Subtract left right) = - Subtract <$> resolveExpression scope left <*> resolveExpression scope right - resolveExpression scope (Or left right) = - Or <$> resolveExpression scope left <*> resolveExpression scope right - resolveExpression scope (Multiply left right) = - Multiply <$> resolveExpression scope left <*> resolveExpression scope right - resolveExpression scope (Divide left right) = - Divide <$> resolveExpression scope left <*> resolveExpression scope right - resolveExpression scope (IntegerDivide left right) = - IntegerDivide <$> resolveExpression scope left <*> resolveExpression scope right - resolveExpression scope (Modulo left right) = - Modulo <$> resolveExpression scope left <*> resolveExpression scope right - resolveExpression scope (And left right) = - And <$> resolveExpression scope left <*> resolveExpression scope right - resolveExpression scope (Integer x) = pure (Integer x) - resolveExpression scope (Real x) = pure (Real x) - resolveExpression scope (CharConstant x) = pure (CharConstant x) - resolveExpression scope (CharCode x) = pure (CharCode x) - resolveExpression scope (String x) = pure (String x) - resolveExpression scope Nil = pure Nil - resolveExpression scope (Set elements) = Set <$> traverse (resolveElement scope) elements - resolveExpression scope (Read (Ambiguous designators)) = - Read . Identity <$> uniqueDesignator (resolveDesignator scope <$> designators) - resolveExpression scope (FunctionCall (Ambiguous functions) parameters) - | Success (Variable q) <- uniqueDesignator (resolveProcedure scope <$> functions), - Success (DeclaredProcedure True _) <- resolveName scope q = - FunctionCall (Identity $ Variable q) - <$> traverse (resolveExpressionOrType scope) parameters - | otherwise = - FunctionCall . Identity - <$> uniqueDesignator (resolveProcedure scope <$> functions) - <*> traverse (resolveExpression scope) parameters - resolveExpression scope (Not e) = Negative <$> resolveExpression scope e +instance {-# overlaps #-} Shallow.Traversable + Resolution Ambiguous Identity Resolved (ProcedureBody Ambiguous Ambiguous) where + traverse res (Ambiguous (body@(ProcedureBody declarations statements) :| [])) = StateT $ \(scope, state)-> + Success (Identity body, (localScope res "" declarations scope, state)) + traverse _ b = StateT (const $ Failure $ pure AmbiguousParses) - resolveExpressionOrType scope (Read (Ambiguous designators)) = - Read . Identity <$> uniqueDesignator (resolveDesignatorOrType scope <$> designators) - resolveExpressionOrType scope e = resolveExpression scope e +instance {-# overlaps #-} Shallow.Traversable + Resolution Ambiguous Identity Resolved (Statement Ambiguous Ambiguous) where + traverse res statements = StateT $ \s@(scope, state)-> + let resolveStatement :: Statement Ambiguous Ambiguous + -> Validation (NonEmpty Error) (Statement Ambiguous Ambiguous, ResolutionState) + resolveStatement p@(ProcedureCall procedures parameters) = + case evalStateT (Shallow.traverse res procedures) s + of Failure errors -> Failure errors + Success{} -> pure (p, StatementState) + resolveStatement stat = pure (stat, StatementState) + in (\(r, s)-> (Identity r, (scope, s))) + <$> unique InvalidStatement (AmbiguousStatement . (fst <$>)) (resolveStatement <$> statements) - resolveDesignatorOrType scope (Variable q) - | Success DeclaredType{} <- resolveName scope q = Success (Variable q) - resolveDesignatorOrType scope e = resolveDesignator scope e +mapResolveDefault :: Resolution -> Ambiguous (g Resolved Resolved) -> Resolved (g Resolved Resolved) +mapResolveDefault Resolution{} (Ambiguous (x :| [])) = pure x +mapResolveDefault Resolution{} _ = StateT (const $ Failure $ pure AmbiguousParses) - resolveElement scope (Element e) = Element <$> resolveExpression scope e - resolveElement scope (Range left right) = - Range <$> resolveExpression scope left <*> resolveExpression scope right +traverseResolveDefault :: Show (g f f) => Resolution -> Ambiguous (g (f :: * -> *) f) -> Resolved (Identity (g f f)) +traverseResolveDefault Resolution{} (Ambiguous (x :| [])) = StateT (\s-> Success (Identity x, s)) +traverseResolveDefault Resolution{} x@(Ambiguous _) = StateT (const $ Failure $ pure AmbiguousParses) - resolveDesignator scope (Variable q) = - case resolveName scope q +resolveDesignator :: Resolution -> Scope -> ResolutionState -> Designator Ambiguous Ambiguous + -> Validation (NonEmpty Error) (Designator Ambiguous Ambiguous) +resolveDesignator res scope state = resolveDesignator' + where resolveTypeName :: QualIdent -> Validation (NonEmpty Error) QualIdent + resolveDesignator' (Variable q) = + case resolveName res scope q of Failure err -> Failure err - Success DeclaredType{} -> Failure (NotAValue q :| []) + Success DeclaredType{} | state /= ExpressionOrTypeState -> Failure (NotAValue q :| []) Success _ -> Success (Variable q) - resolveDesignator scope (Field record field) = Field <$> resolveRecord scope record <*> pure field - resolveDesignator scope (Index array indexes) = Index <$> resolveArray scope array - <*> traverse (resolveExpression scope) indexes - resolveDesignator scope (TypeGuard designator subtype) = TypeGuard <$> resolveRecord scope designator - <*> resolveTypeName scope subtype - resolveDesignator scope (Dereference pointer) = Dereference <$> resolvePointer scope pointer + resolveDesignator' d@(Field records field) = + case evalStateT (Shallow.traverse res records) (scope, state) + of Failure errors -> Failure errors + Success{} -> pure d + resolveDesignator' (TypeGuard records subtypes) = + case unique InvalidRecord AmbiguousRecord (resolveRecord <$> records) + of Failure errors -> Failure errors + Success{} -> TypeGuard records <$> resolveTypeName subtypes + resolveDesignator' d@(Dereference pointers) = + case evalStateT (Shallow.traverse res pointers) (scope, state) + of Failure errors -> Failure errors + Success{} -> pure d + resolveDesignator' d = pure d + resolveRecord d@(Variable q) = + case resolveName res scope q + of Failure err -> Failure err + Success DeclaredType{} -> Failure (NotAValue q :| []) + Success DeclaredProcedure{} -> Failure (NotARecord q :| []) + Success (DeclaredVariable t) -> resolveDesignator' d + resolveRecord d = resolveDesignator' d - resolveTypeName scope q = - case resolveName scope q + resolveTypeName q = + case resolveName res scope q of Failure err -> Failure err Success DeclaredType{} -> Success q Success _ -> Failure (NotAType q :| []) - resolveBaseType scope t = case resolveType scope t - of Failure err -> Failure err - Success t' -> resolveTypeReference scope t' - - resolveProcedure scope d@(Variable q) = - case resolveName scope q - of Failure err -> Failure err - Success DeclaredType{} -> Failure (NotAValue q :| []) - Success DeclaredProcedure{} -> resolveDesignator scope d - Success (DeclaredVariable t) - | Success ProcedureType{} <- resolveTypeReference scope t -> resolveDesignator scope d - | otherwise -> Failure (NotAProcedure q :| []) - resolveProcedure scope d = resolveDesignator scope d +resolveName :: Resolution -> Scope -> QualIdent -> Validation (NonEmpty Error) (DeclarationRHS Identity Identity) +resolveName res scope q@(QualIdent moduleName name) = + case Map.lookup moduleName (_modules res) + of Nothing -> Failure (UnknownModule q :| []) + Just exports -> case Map.lookup name exports + of Just rhs -> rhs + Nothing -> Failure (UnknownImport q :| []) +resolveName res scope (NonQualIdent name) = + case Map.lookup name scope + of Just (Success rhs) -> Success rhs + _ -> Failure (UnknownLocal name :| []) - resolveWriteable scope d@(Variable q) = - case resolveName scope q - of Failure err -> Failure err - Success DeclaredType{} -> Failure (NotAValue q :| []) - Success DeclaredProcedure{} -> Failure (NotWriteable q :| []) - Success DeclaredConstant{} -> Failure (NotWriteable q :| []) - Success DeclaredVariable{} -> resolveDesignator scope d - resolveWriteable scope d = resolveDesignator scope d +resolveModules :: Predefined -> Map Ident (Module Ambiguous Ambiguous) + -> Validation (NonEmpty (Ident, NonEmpty Error)) (Map Ident (Module Identity Identity)) +resolveModules predefinedScope modules = traverseWithKey extractErrors modules' + where modules' = resolveModule predefinedScope modules' <$> modules + extractErrors moduleKey (Failure e) = Failure ((moduleKey, e) :| []) + extractErrors _ (Success mod) = Success mod - resolveRecord scope d@(Variable q) = - case resolveName scope q - of Failure err -> Failure err - Success DeclaredType{} -> Failure (NotAValue q :| []) - Success DeclaredProcedure{} -> Failure (NotAValue q :| []) - Success (DeclaredVariable t) -> resolveDesignator scope d - resolveRecord scope d = resolveDesignator scope d +resolveModule :: Scope -> Map Ident (Validation (NonEmpty Error) (Module Identity Identity)) + -> Module Ambiguous Ambiguous -> Validation (NonEmpty Error) (Module Identity Identity) +resolveModule predefined modules m@(Module moduleName imports declarations body _) = + evalStateT (Deep.traverseDown res m) (moduleGlobalScope, ModuleState) + where res = Resolution moduleExports + importedModules = Map.delete mempty (Map.mapKeysWith clashingRenames importedAs modules) + where importedAs moduleName = case List.find ((== moduleName) . snd) imports + of Just (Nothing, moduleKey) -> moduleKey + Just (Just innerKey, _) -> innerKey + Nothing -> mempty + clashingRenames _ _ = Failure (ClashingImports :| []) + resolveDeclaration :: Ambiguous (Declaration Ambiguous Ambiguous) -> Resolved (Declaration Identity Identity) + resolveDeclaration d = runIdentity <$> (traverse (Deep.traverseDown res) d >>= Shallow.traverse res) + moduleExports = foldMap exportsOfModule <$> importedModules + moduleGlobalScope = localScope res moduleName declarations predefined - resolveArray = resolveDesignator - resolvePointer = resolveDesignator +localScope :: Resolution -> Ident -> [Ambiguous (Declaration Ambiguous Ambiguous)] -> Scope -> Scope +localScope res qual declarations outerScope = innerScope + where innerScope = Map.union (snd <$> scopeAdditions) outerScope + scopeAdditions = (resolveBinding res innerScope <$>) + <$> Map.fromList (concatMap (declarationBinding qual . unamb) declarations) + unamb (Ambiguous (x :| [])) = x + resolveBinding :: Resolution -> Scope -> DeclarationRHS Ambiguous Ambiguous + -> Validation (NonEmpty Error) (DeclarationRHS Identity Identity) + resolveBinding res scope dr = evalStateT (Deep.traverseDown res dr) (scope, DeclarationState) - resolveName scope q@(QualIdent moduleName name) = - case Map.lookup moduleName moduleExports - of Nothing -> Failure (UnknownModule moduleName :| []) - Just exports -> case Map.lookup name exports - of Just (Success rhs) -> Success rhs - Just (Failure err) -> Failure err - Nothing -> Failure (UnknownImport q :| []) - resolveName scope (NonQualIdent name) = - case Map.lookup name scope - of Just (Success rhs) -> Success rhs - _ -> Failure (UnknownLocal name :| []) - - resolveBinding scope (DeclaredConstant (Ambiguous expression)) = - DeclaredConstant . Identity <$> uniqueExpression (resolveExpression scope <$> expression) - resolveBinding scope (DeclaredType typeDef) = DeclaredType <$> resolveBaseType scope typeDef - resolveBinding scope (DeclaredVariable typeDef) = DeclaredVariable <$> resolveBaseType scope typeDef - resolveBinding scope (DeclaredProcedure special parameters) = - DeclaredProcedure special <$> traverse (resolveParameters scope) parameters - -declarationBinding :: Ident -> Declaration f -> [(Ident, (AccessMode, DeclarationRHS f))] +declarationBinding :: Ident -> Declaration f f -> [(Ident, (AccessMode, DeclarationRHS f f))] declarationBinding _ (ConstantDeclaration (IdentDef name export) expr) = [(name, (export, DeclaredConstant expr))] declarationBinding _ (TypeDeclaration (IdentDef name export) typeDef) = @@ -332,113 +266,99 @@ predefined, predefined2 :: Predefined -- | The set of 'Predefined' types and procedures defined in the Oberon Language Report. predefined = Success <$> Map.fromList - [("BOOLEAN", DeclaredType (TypeReference $ NonQualIdent "BOOLEAN")), - ("CHAR", DeclaredType (TypeReference $ NonQualIdent "CHAR")), - ("SHORTINT", DeclaredType (TypeReference $ NonQualIdent "SHORTINT")), - ("INTEGER", DeclaredType (TypeReference $ NonQualIdent "INTEGER")), - ("LONGINT", DeclaredType (TypeReference $ NonQualIdent "LONGINT")), - ("REAL", DeclaredType (TypeReference $ NonQualIdent "REAL")), - ("LONGREAL", DeclaredType (TypeReference $ NonQualIdent "LONGREAL")), - ("SET", DeclaredType (TypeReference $ NonQualIdent "SET")), + [("BOOLEAN", DeclaredType (Identity $ TypeReference $ NonQualIdent "BOOLEAN")), + ("CHAR", DeclaredType (Identity $ TypeReference $ NonQualIdent "CHAR")), + ("SHORTINT", DeclaredType (Identity $ TypeReference $ NonQualIdent "SHORTINT")), + ("INTEGER", DeclaredType (Identity $ TypeReference $ NonQualIdent "INTEGER")), + ("LONGINT", DeclaredType (Identity $ TypeReference $ NonQualIdent "LONGINT")), + ("REAL", DeclaredType (Identity $ TypeReference $ NonQualIdent "REAL")), + ("LONGREAL", DeclaredType (Identity $ TypeReference $ NonQualIdent "LONGREAL")), + ("SET", DeclaredType (Identity $ TypeReference $ NonQualIdent "SET")), ("TRUE", DeclaredConstant (Identity $ Read $ Identity $ Variable $ NonQualIdent "TRUE")), ("FALSE", DeclaredConstant (Identity $ Read $ Identity $ Variable $ NonQualIdent "FALSE")), - ("ABS", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] $ + ("ABS", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ Just $ NonQualIdent "INTEGER"), - ("ASH", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] $ + ("ASH", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ Just $ NonQualIdent "INTEGER"), - ("CAP", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "c") $ TypeReference $ NonQualIdent "INTEGER"] $ - Just $ NonQualIdent "CAP"), - ("LEN", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "c") $ TypeReference $ NonQualIdent "ARRAY"] $ + ("CAP", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "c") $ Identity $ TypeReference $ NonQualIdent "CHAR"] $ + Just $ NonQualIdent "CHAR"), + ("LEN", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "c") $ Identity $ TypeReference $ NonQualIdent "ARRAY"] $ Just $ NonQualIdent "LONGINT"), - ("MAX", DeclaredProcedure True $ Just $ - FormalParameters [FPSection False (pure "c") $ TypeReference $ NonQualIdent "SET"] $ + ("MAX", DeclaredProcedure True $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "c") $ Identity $ TypeReference $ NonQualIdent "SET"] $ Just $ NonQualIdent "INTEGER"), - ("MIN", DeclaredProcedure True $ Just $ - FormalParameters [FPSection False (pure "c") $ TypeReference $ NonQualIdent "SET"] $ + ("MIN", DeclaredProcedure True $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "c") $ Identity $ TypeReference $ NonQualIdent "SET"] $ Just $ NonQualIdent "INTEGER"), - ("ODD", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "CHAR"] $ + ("ODD", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "CHAR"] $ Just $ NonQualIdent "BOOLEAN"), - ("SIZE", DeclaredProcedure True $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "CHAR"] $ + ("SIZE", DeclaredProcedure True $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "CHAR"] $ Just $ NonQualIdent "INTEGER"), - ("ORD", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "CHAR"] $ + ("ORD", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "CHAR"] $ Just $ NonQualIdent "INTEGER"), - ("CHR", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] $ + ("CHR", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ Just $ NonQualIdent "CHAR"), - ("SHORT", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] $ + ("SHORT", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ Just $ NonQualIdent "INTEGER"), - ("LONG", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] $ + ("LONG", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ Just $ NonQualIdent "INTEGER"), - ("ENTIER", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "REAL"] $ + ("ENTIER", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "REAL"] $ Just $ NonQualIdent "INTEGER"), - ("INC", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] Nothing), - ("DEC", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] Nothing), - ("INCL", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "s") $ TypeReference $ NonQualIdent "SET", - FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] Nothing), - ("EXCL", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "s") $ TypeReference $ NonQualIdent "SET", - FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] Nothing), - ("COPY", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "s") $ TypeReference $ NonQualIdent "ARRAY", - FPSection False (pure "n") $ TypeReference $ NonQualIdent "ARRAY"] Nothing), - ("NEW", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "POINTER"] Nothing), - ("HALT", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "n") $ TypeReference $ NonQualIdent "INTEGER"] Nothing)] + ("INC", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] Nothing), + ("DEC", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] Nothing), + ("INCL", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "s") $ Identity $ TypeReference $ NonQualIdent "SET", + Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] Nothing), + ("EXCL", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "s") $ Identity $ TypeReference $ NonQualIdent "SET", + Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] Nothing), + ("COPY", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "s") $ Identity $ TypeReference $ NonQualIdent "ARRAY", + Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "ARRAY"] Nothing), + ("NEW", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "POINTER"] Nothing), + ("HALT", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] Nothing)] -- | The set of 'Predefined' types and procedures defined in the Oberon-2 Language Report. predefined2 = predefined <> (Success <$> Map.fromList - [("ASSERT", DeclaredProcedure False $ Just $ - FormalParameters [FPSection False (pure "s") $ TypeReference $ NonQualIdent "ARRAY", - FPSection False (pure "n") $ TypeReference $ NonQualIdent "ARRAY"] Nothing)]) - -resolveTypeReferenceIn scope (DeclaredType t) = DeclaredType <$> resolveTypeReference scope t -resolveTypeReferenceIn scope (DeclaredVariable t) = DeclaredVariable <$> resolveTypeReference scope t -resolveTypeReferenceIn scope d = pure d - -resolveTypeReference scope t@(TypeReference q@(NonQualIdent name)) = - case Map.lookup name scope - of Nothing -> pure t - Just (Failure err) -> Failure err - Just (Success (DeclaredType t'@(TypeReference q'))) - | q == q' -> pure t' -- built-in type - Just (Success (DeclaredType t')) -> resolveTypeReference scope t' - Just {} -> Failure (NotAType q :| []) -resolveTypeReference scope t = pure t + [("ASSERT", DeclaredProcedure False $ Just $ Identity $ + FormalParameters [Identity $ FPSection False (pure "s") $ Identity $ TypeReference $ NonQualIdent "ARRAY", + Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "ARRAY"] Nothing)]) -exportsOfModule :: Module Identity -> Scope -exportsOfModule = Map.mapMaybe isExported . globalsOfModule +exportsOfModule :: Module Identity Identity -> Scope +exportsOfModule = fmap Success . Map.mapMaybe isExported . globalsOfModule where isExported (PrivateOnly, _) = Nothing isExported (_, binding) = Just binding -globalsOfModule :: Module Identity -> Map Ident (AccessMode, Validation (NonEmpty Error) (DeclarationRHS Identity)) -globalsOfModule (Module name imports declarations _ _) = scope - where scope = (resolveTypeReferenceIn scope' <$>) <$> Map.fromList declarationBindings - scope' = snd <$> scope - declarationBindings = concatMap (declarationBinding name) declarations +globalsOfModule :: Module Identity Identity -> Map Ident (AccessMode, DeclarationRHS Identity Identity) +globalsOfModule (Module name imports declarations _ _) = + Map.fromList (concatMap (declarationBinding name . runIdentity) declarations) -uniqueDesignator = unique InvalidDesignator AmbiguousDesignator -uniqueExpression = unique InvalidExpression AmbiguousExpression -uniqueStatement = unique InvalidStatement AmbiguousStatement +unique :: (NonEmpty Error -> Error) -> ([a] -> Error) -> Ambiguous (Validation (NonEmpty Error) a) + -> Validation (NonEmpty Error) a +unique _ _ (Ambiguous (x :| [])) = x +unique inv amb (Ambiguous xs) = + case partitionEithers (validationToEither <$> NonEmpty.toList xs) + of (_, [x]) -> Success x + (errors, []) -> Failure (inv (sconcat $ NonEmpty.fromList errors) :| []) + (_, multi) -> Failure (amb multi :| []) -unique :: (NonEmpty Error -> Error) -> ([a] -> Error) - -> NonEmpty (Validation (NonEmpty Error) a) -> Validation (NonEmpty Error) a -unique _ _ (x :| []) = x -unique inv amb xs = case partitionEithers (validationToEither <$> NonEmpty.toList xs) - of (_, [x]) -> Success x - (errors, []) -> Failure (inv (sconcat $ NonEmpty.fromList errors) :| []) - (_, stats) -> Failure (amb stats :| []) +$(Rank2.TH.deriveFunctor ''DeclarationRHS) +$(Rank2.TH.deriveFoldable ''DeclarationRHS) +$(Rank2.TH.deriveTraversable ''DeclarationRHS) +$(Transformation.Deep.TH.deriveDownTraversable ''DeclarationRHS) diff --git a/src/Language/Oberon/TypeChecker.hs b/src/Language/Oberon/TypeChecker.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon/TypeChecker.hs @@ -0,0 +1,880 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, + TemplateHaskell, TypeFamilies, UndecidableInstances #-} + +module Language.Oberon.TypeChecker (Error(..), checkModules, predefined, predefined2) where + +import Control.Applicative (liftA2) +import Control.Arrow (first) +import Data.Coerce (coerce) +import Data.Either (partitionEithers) +import Data.Either.Validation (Validation(..), validationToEither) +import Data.Foldable (toList) +import Data.Functor.Identity (Identity(..)) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.List as List +import Data.Maybe (fromMaybe) +import Data.Map.Lazy (Map) +import qualified Data.Map.Lazy as Map +import Data.Semigroup (Semigroup(..), sconcat) +import qualified Data.Text as Text + +import qualified Rank2 +import qualified Rank2.TH +import qualified Transformation as Shallow +import qualified Transformation.Deep as Deep +import qualified Transformation.AG as AG +import Transformation.AG (Attribution(..), Atts, Inherited(..), Synthesized(..), Semantics) + +import qualified Language.Oberon.AST as AST + +import Debug.Trace + +data Type = NominalType AST.QualIdent (Maybe Type) + | RecordType{ancestry :: [AST.QualIdent], + recordFields :: Map AST.Ident Type} + | NilType + | IntegerType Int + | StringType Int + | ArrayType [Int] Type + | PointerType Type + | ProcedureType [(Bool, Type)] (Maybe Type) + | UnknownType + +data Error = TypeMismatch Type Type + | ArgumentCountMismatch Int Int + | DuplicateBinding AST.Ident + | ExtraDimensionalIndex Type + | TooSmallArrayType Type + | OpenArrayVariable + | NonArrayType Type + | NonBooleanType Type + | NonFunctionType Type + | NonIntegerType Type + | NonNumericType Type + | NonPointerType Type + | NonProcedureType Type + | NonRecordType Type + | UnequalTypes Type Type + | UnrealType Type + | UnknownName AST.QualIdent + | UnknownField AST.Ident Type + deriving Show + +instance Eq Type where + NominalType q1 _ == NominalType q2 _ = q1 == q2 + ArrayType [] t1 == ArrayType [] t2 = t1 == t2 + ProcedureType p1 r1 == ProcedureType p2 r2 = r1 == r2 && p1 == p2 + StringType len1 == StringType len2 = len1 == len2 + NilType == NilType = True + _ == _ = False + +instance Show Type where + show (NominalType q t) = "Nominal " ++ show q ++ " " ++ show t + show (RecordType ancestry fields) = "RecordType " ++ show ancestry ++ show (fst <$> Map.toList fields) + show (ArrayType dimensions itemType) = "ArrayType " ++ show dimensions ++ " " ++ show itemType + show (PointerType targetType) = "PointerType " ++ show targetType + show (ProcedureType parameters result) = "ProcedureType " ++ show parameters ++ " " ++ show result + show (IntegerType n) = "IntegerType " ++ show n + show (StringType len) = "StringType " ++ show len + show NilType = "NilType" + show UnknownType = "UnknownType" + +type Environment = Map AST.QualIdent Type + +newtype Modules f' f = Modules (Map AST.Ident (f (AST.Module f' f'))) + +data TypeCheck = TypeCheck + +data InhTC = InhTC{env :: Environment} deriving Show + +data SynTC = SynTC{errors :: [Error]} deriving Show + +data SynTC' = SynTC'{errors' :: [Error], + env' :: Environment} deriving Show + +data SynTCMod = SynTCMod{moduleErrors :: [Error], + moduleEnv :: Environment, + pointerTargets :: Map AST.Ident AST.Ident} deriving Show + +data SynTCType = SynTCType{typeErrors :: [Error], + typeName :: Maybe AST.Ident, + definedType :: Type, + pointerTarget :: Maybe AST.Ident} deriving Show + +data SynTCFields = SynTCFields{fieldErrors :: [Error], + fieldEnv :: Map AST.Ident Type} deriving Show + +data SynTCSig = SynTCSig{signatureErrors :: [Error], + signatureEnv :: Environment, + signatureType :: Type} deriving Show + +data SynTCSec = SynTCSec{sectionErrors :: [Error], + sectionEnv :: Environment, + sectionParameters :: [(Bool, Type)]} deriving Show + +data SynTCDes = SynTCDes{designatorErrors :: [Error], + designatorSelf :: AST.Designator Identity Identity, + designatorType :: Type} deriving Show + +data SynTCExp = SynTCExp{expressionErrors :: [Error], + inferredType :: Type} deriving Show + +-- * Modules instances, TH candidates +instance (Functor p, Deep.Functor t AST.Module p q, Shallow.Functor t p q (AST.Module q q)) => + Deep.Functor t Modules p q where + t <$> ~(Modules ms) = Modules (mapModule <$> ms) + where mapModule m = t Shallow.<$> ((t Deep.<$>) <$> m) + +instance Rank2.Functor (Modules f') where + f <$> ~(Modules ms) = Modules (f <$> ms) + +instance Rank2.Apply (Modules f') where + ~(Modules fs) <*> ~(Modules ms) = Modules (Map.intersectionWith Rank2.apply fs ms) + +-- * Boring attribute types +type instance Atts (Inherited TypeCheck) (Modules f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (Modules f' f) = SynTC +type instance Atts (Inherited TypeCheck) (AST.Module f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.Module f' f) = SynTCMod +type instance Atts (Inherited TypeCheck) (AST.Declaration f' f) = (InhTC, Map AST.Ident AST.Ident) +type instance Atts (Synthesized TypeCheck) (AST.Declaration f' f) = SynTCMod +type instance Atts (Inherited TypeCheck) (AST.FormalParameters f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.FormalParameters f' f) = SynTCSig +type instance Atts (Inherited TypeCheck) (AST.FPSection f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.FPSection f' f) = SynTCSec +type instance Atts (Inherited TypeCheck) (AST.Type f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.Type f' f) = SynTCType +type instance Atts (Inherited TypeCheck) (AST.FieldList f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.FieldList f' f) = SynTCFields +type instance Atts (Inherited TypeCheck) (AST.StatementSequence f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.StatementSequence f' f) = SynTC +type instance Atts (Inherited TypeCheck) (AST.Expression f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.Expression f' f) = SynTCExp +type instance Atts (Inherited TypeCheck) (AST.Element f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.Element f' f) = SynTCExp +type instance Atts (Inherited TypeCheck) (AST.Designator f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.Designator f' f) = SynTCDes +type instance Atts (Inherited TypeCheck) (Deep.Product AST.Expression AST.StatementSequence f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (Deep.Product AST.Expression AST.StatementSequence f' f) = SynTC +type instance Atts (Inherited TypeCheck) (AST.Statement f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.Statement f' f) = SynTC +type instance Atts (Inherited TypeCheck) (AST.Case f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.Case f' f) = SynTC +type instance Atts (Inherited TypeCheck) (AST.CaseLabels f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.CaseLabels f' f) = SynTC +type instance Atts (Inherited TypeCheck) (AST.WithAlternative f' f) = InhTC +type instance Atts (Synthesized TypeCheck) (AST.WithAlternative f' f) = SynTC + +-- * Rules + +instance Attribution TypeCheck Modules where + attribution TypeCheck (Modules self) (inherited, Modules ms) = + (Synthesized SynTC{errors= foldMap (moduleErrors . syn) ms}, + Modules (Inherited InhTC{env= env (inh inherited) <> foldMap (moduleEnv . syn) ms} <$ self)) + +instance Attribution TypeCheck AST.Module where + attribution TypeCheck (AST.Module ident1 imports decls body ident2) (inherited, AST.Module _ _ decls' body' _) = + (Synthesized SynTCMod{moduleErrors= foldMap (moduleErrors . syn) decls' <> foldMap (errors . syn) body', + moduleEnv= exportedEnv, + pointerTargets= pointers}, + AST.Module ident1 imports [Inherited (localEnv, pointers)] (Inherited localEnv <$ body) ident2) + where exportedEnv = exportNominal <$> Map.mapKeysMonotonic export newEnv + newEnv = Map.unionsWith mergeTypeBoundProcedures (moduleEnv . syn <$> decls') + localEnv = InhTC (newEnv `Map.union` env (inh inherited)) + export (AST.NonQualIdent name) = AST.QualIdent ident1 name + export q = q + exportNominal (NominalType (AST.NonQualIdent name) t) = + NominalType (AST.QualIdent ident1 name) (exportNominal' <$> t) + exportNominal t = exportNominal' t + exportNominal' (RecordType ancestry fields) = RecordType (export <$> ancestry) (exportNominal' <$> fields) + exportNominal' (ProcedureType parameters result) = + ProcedureType ((exportNominal' <$>) <$> parameters) (exportNominal' <$> result) + exportNominal' (PointerType target) = PointerType (exportNominal' target) + exportNominal' (ArrayType dimensions itemType) = ArrayType dimensions (exportNominal' itemType) + exportNominal' (NominalType q@(AST.NonQualIdent name) (Just t)) = + fromMaybe (NominalType (AST.QualIdent ident1 name) $ Just $ exportNominal' t) (Map.lookup q exportedEnv) + exportNominal' t = t + pointers= foldMap (pointerTargets . syn) decls' + mergeTypeBoundProcedures' t1 t2 = mergeTypeBoundProcedures t1 t2 + mergeTypeBoundProcedures (NominalType (AST.NonQualIdent "") (Just t1)) t2 = mergeTypeBoundProcedures t1 t2 + mergeTypeBoundProcedures (NominalType q (Just t1)) t2 = NominalType q (Just $ mergeTypeBoundProcedures t1 t2) + mergeTypeBoundProcedures t1 (NominalType (AST.NonQualIdent "") (Just t2)) = mergeTypeBoundProcedures t1 t2 + mergeTypeBoundProcedures t1 (NominalType q (Just t2)) = NominalType q (Just $ mergeTypeBoundProcedures t1 t2) + mergeTypeBoundProcedures (RecordType ancestry1 fields1) (RecordType ancestry2 fields2) = + RecordType (ancestry1 <> ancestry2) (fields1 <> fields2) + mergeTypeBoundProcedures (PointerType (RecordType ancestry1 fields1)) (RecordType ancestry2 fields2) = + PointerType (RecordType (ancestry1 <> ancestry2) (fields1 <> fields2)) + mergeTypeBoundProcedures (RecordType ancestry1 fields1) (PointerType (RecordType ancestry2 fields2)) = + PointerType (RecordType (ancestry1 <> ancestry2) (fields1 <> fields2)) + mergeTypeBoundProcedures t1 t2 = error (take 90 $ show t1) + +instance Attribution TypeCheck AST.Declaration where + attribution TypeCheck (AST.ConstantDeclaration namedef@(AST.IdentDef name _) _) + (inherited, AST.ConstantDeclaration _ expression) = + (Synthesized SynTCMod{moduleErrors= expressionErrors (syn expression), + moduleEnv= Map.singleton (AST.NonQualIdent name) (inferredType $ syn expression), + pointerTargets= mempty}, + AST.ConstantDeclaration namedef (Inherited $ fst $ inh inherited)) + attribution TypeCheck (AST.TypeDeclaration namedef@(AST.IdentDef name _) _) (inherited, + AST.TypeDeclaration _ definition) = + (Synthesized SynTCMod{moduleErrors= typeErrors (syn definition), + moduleEnv= Map.singleton qname (nominal $ definedType $ syn definition), + pointerTargets= foldMap (Map.singleton name) (pointerTarget $ syn definition)}, + AST.TypeDeclaration namedef (Inherited $ fst $ inh inherited)) + where nominal t@NominalType{} = t + nominal t = NominalType qname (Just t) + qname = AST.NonQualIdent name + attribution TypeCheck (AST.VariableDeclaration names _declaredType) + (inherited, AST.VariableDeclaration _names declaredType) = + (Synthesized SynTCMod{moduleErrors= typeErrors (syn declaredType) + <> case definedType (syn declaredType) + of ArrayType [] _ -> [OpenArrayVariable] + _ -> [], + moduleEnv= foldMap (\name-> Map.singleton (AST.NonQualIdent $ defName name) + (definedType $ syn declaredType)) + names, + pointerTargets= mempty}, + AST.VariableDeclaration names (Inherited $ fst $ inh inherited)) + where defName (AST.IdentDef name _) = name + attribution TypeCheck (AST.ProcedureDeclaration (AST.ProcedureHeading receiver indirect + namedef@(AST.IdentDef name _) signature) + _body name') + (inherited, + AST.ProcedureDeclaration (AST.ProcedureHeading _receiver _indirect _ signature') + body@(AST.ProcedureBody declarations statements) _name') = + (Synthesized SynTCMod{moduleErrors= foldMap (signatureErrors . syn) signature', + moduleEnv= case receiver + of Just (_, _, typeName) + | Just targetName <- Map.lookup typeName (snd $ inh inherited) -> + Map.singleton (AST.NonQualIdent targetName) methodType + | otherwise -> Map.singleton (AST.NonQualIdent typeName) methodType + + Nothing -> Map.singleton (AST.NonQualIdent name) procedureType, + pointerTargets= mempty}, + AST.ProcedureDeclaration + (AST.ProcedureHeading receiver indirect namedef (Inherited (fst $ inh inherited) <$ signature)) + (AST.ProcedureBody [Inherited (localInherited, mempty)] (Inherited localInherited <$ statements)) + name') + where receiverEnv (_, formalName, typeName) = + foldMap (Map.singleton $ AST.NonQualIdent formalName) (Map.lookup (AST.NonQualIdent typeName) + $ env $ fst $ inh inherited) + methodType = NominalType (AST.NonQualIdent "") (Just $ RecordType [] $ Map.singleton name procedureType) + procedureType = maybe (ProcedureType [] Nothing) (signatureType . syn) signature' + receiverError (_, formalName, typeName) = + case Map.lookup (AST.NonQualIdent typeName) (env $ fst $ inh inherited) + of Nothing -> [UnknownName $ AST.NonQualIdent typeName] + Just RecordType{} -> [] + Just (PointerType RecordType{}) -> [] + Just (NominalType _ (Just RecordType{})) -> [] + Just (NominalType _ (Just (PointerType RecordType{}))) -> [] + Just t -> [NonRecordType t] + localInherited = InhTC (foldMap receiverEnv receiver + `Map.union` foldMap (signatureEnv . syn) signature' + `Map.union` env (fst $ inh inherited)) + attribution TypeCheck (AST.ForwardDeclaration namedef@(AST.IdentDef name _) signature) + (inherited, AST.ForwardDeclaration _namedef signature') = + (Synthesized SynTCMod{moduleErrors= foldMap (signatureErrors . syn) signature', + moduleEnv= foldMap (Map.singleton (AST.NonQualIdent name) . signatureType . syn) signature', + pointerTargets= mempty}, + AST.ForwardDeclaration namedef (Inherited (fst $ inh inherited) <$ signature)) + +instance Attribution TypeCheck AST.FormalParameters where + attribution TypeCheck (AST.FormalParameters sections returnType) + (inherited, AST.FormalParameters sections' _returnType) = + (Synthesized SynTCSig{signatureErrors= foldMap (sectionErrors . syn) sections' <> foldMap typeRefErrors returnType, + signatureType= ProcedureType (foldMap (sectionParameters . syn) sections') + $ returnType >>= (`Map.lookup` env (inh inherited)), + signatureEnv= foldMap (sectionEnv . syn) sections'}, + AST.FormalParameters (pure $ Inherited $ inh inherited) returnType) + where typeRefErrors q + | Map.member q (env $ inh inherited) = [] + | otherwise = [UnknownName q] + +instance Attribution TypeCheck AST.FPSection where + attribution TypeCheck (AST.FPSection var names _typeDef) (inherited, AST.FPSection _var _names typeDef) = + (Synthesized SynTCSec{sectionErrors= typeErrors (syn typeDef), + sectionParameters= (var, definedType (syn typeDef)) <$ toList names, + sectionEnv= Map.fromList (toList + $ flip (,) (definedType $ syn typeDef) . AST.NonQualIdent + <$> names)}, + AST.FPSection var names (Inherited $ inh inherited)) + +instance Attribution TypeCheck AST.Type where + attribution TypeCheck (AST.TypeReference q) (inherited, _) = + (Synthesized SynTCType{typeErrors= if Map.member q (env $ inh inherited) then [] else [UnknownName q], + typeName= case q + of AST.NonQualIdent name -> Just name + _ -> Nothing, + pointerTarget= Nothing, + definedType= fromMaybe UnknownType (Map.lookup q $ env $ inh inherited)}, + AST.TypeReference q) + attribution TypeCheck (AST.ArrayType dimensions _itemType) (inherited, AST.ArrayType dimensions' itemType) = + (Synthesized SynTCType{typeErrors= foldMap (expressionErrors . syn) dimensions' <> typeErrors (syn itemType) + <> foldMap (expectInteger . syn) dimensions', + typeName= Nothing, + pointerTarget= Nothing, + definedType= ArrayType (integerValue . syn <$> dimensions') (definedType $ syn itemType)}, + AST.ArrayType [Inherited (inh inherited)] (Inherited $ inh inherited)) + where expectInteger SynTCExp{inferredType= IntegerType{}} = [] + expectInteger SynTCExp{inferredType= t} = [NonIntegerType t] + integerValue SynTCExp{inferredType= IntegerType n} = n + integerValue _ = 0 + attribution TypeCheck (AST.RecordType base fields) (inherited, AST.RecordType _base fields') = + (Synthesized SynTCType{typeErrors= fst baseRecord <> foldMap (fieldErrors . syn) fields', + typeName= Nothing, + pointerTarget= Nothing, + definedType= RecordType (maybe [] (maybe id (:) base . ancestry) $ snd baseRecord) + (maybe Map.empty recordFields (snd baseRecord) + <> foldMap (fieldEnv . syn) fields')}, + AST.RecordType base (pure $ Inherited $ inh inherited)) + where baseRecord = case flip Map.lookup (env $ inh inherited) <$> base + of Just (Just t@RecordType{}) -> ([], Just t) + Just (Just (NominalType _ (Just t@RecordType{}))) -> ([], Just t) + Just (Just t) -> ([NonRecordType t], Nothing) + Just Nothing -> (foldMap ((:[]) . UnknownName) base, Nothing) + Nothing -> ([], Nothing) + attribution TypeCheck _self (inherited, AST.PointerType targetType') = + (Synthesized SynTCType{typeErrors= typeErrors (syn targetType'), + typeName= Nothing, + pointerTarget= typeName (syn targetType'), + definedType= PointerType (definedType $ syn targetType')}, + AST.PointerType (Inherited $ inh inherited)) + attribution TypeCheck (AST.ProcedureType signature) (inherited, AST.ProcedureType signature') = + (Synthesized SynTCType{typeErrors= foldMap (signatureErrors . syn) signature', + typeName= Nothing, + pointerTarget= Nothing, + definedType= maybe (ProcedureType [] Nothing) (signatureType . syn) signature'}, + AST.ProcedureType (Inherited (inh inherited) <$ signature)) + +instance Attribution TypeCheck AST.FieldList where + attribution TypeCheck (AST.FieldList names _declaredType) (inherited, AST.FieldList _names declaredType) = + (Synthesized SynTCFields{fieldErrors= typeErrors (syn declaredType), + fieldEnv= foldMap (\name-> Map.singleton (defName name) (definedType $ syn declaredType)) + names}, + AST.FieldList names (Inherited $ inh inherited)) + where defName (AST.IdentDef name _) = name + attribution TypeCheck self (inherited, AST.EmptyFieldList) = + (Synthesized SynTCFields{fieldErrors= [], fieldEnv= mempty}, + AST.EmptyFieldList) + +instance Attribution TypeCheck (Deep.Product AST.Expression AST.StatementSequence) where + attribution TypeCheck self (inherited, Deep.Pair condition statements) = + (Synthesized SynTC{errors= booleanExpressionErrors (syn condition) <> errors (syn statements)}, + Deep.Pair (Inherited $ inh inherited) (Inherited $ inh inherited)) + +instance Attribution TypeCheck AST.StatementSequence where + attribution TypeCheck (AST.StatementSequence statements) (inherited, AST.StatementSequence statements') = + (Synthesized SynTC{errors= foldMap (errors . syn) statements'}, + AST.StatementSequence (pure $ Inherited $ inh inherited)) + +instance Attribution TypeCheck AST.Statement where + attribution TypeCheck self (inherited, AST.EmptyStatement) = (Synthesized SynTC{errors= []}, AST.EmptyStatement) + attribution TypeCheck self (inherited, AST.Assignment var value) = {-# SCC "Assignment" #-} + (Synthesized SynTC{errors= assignmentCompatible (designatorType $ syn var) (inferredType $ syn value)}, + AST.Assignment (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck (AST.ProcedureCall _proc parameters) (inherited, AST.ProcedureCall procedure' parameters') = + (Synthesized SynTC{errors= case syn procedure' + of SynTCDes{designatorErrors= [], + designatorType= t} -> {-# SCC "ProcedureCall" #-} procedureErrors t + SynTCDes{designatorErrors= errs} -> errs + <> foldMap (foldMap (expressionErrors . syn)) parameters'}, + AST.ProcedureCall (Inherited $ inh inherited) (Just [Inherited $ inh inherited])) + where procedureErrors (ProcedureType formalTypes Nothing) + | length formalTypes /= maybe 0 length parameters = + [ArgumentCountMismatch (length formalTypes) $ maybe 0 length parameters] + | otherwise = concat (zipWith parameterCompatible formalTypes $ maybe [] (inferredType . syn <$>) parameters') + procedureErrors (NominalType _ (Just t)) = procedureErrors t + procedureErrors t = [NonProcedureType t] + attribution TypeCheck self (inherited, AST.If branches fallback) = + (Synthesized SynTC{errors= foldMap (errors . syn) branches <> foldMap (errors . syn) fallback}, + AST.If (pure $ Inherited $ inh inherited) (Inherited (inh inherited) <$ fallback)) + attribution TypeCheck self (inherited, AST.CaseStatement value branches fallback) = + (Synthesized SynTC{errors= expressionErrors (syn value) <> foldMap (errors . syn) branches + <> foldMap (errors . syn) fallback}, + AST.CaseStatement (Inherited $ inh inherited) (pure $ Inherited $ inh inherited) + (Inherited (inh inherited) <$ fallback)) + attribution TypeCheck self (inherited, AST.While condition body) = + (Synthesized SynTC{errors= booleanExpressionErrors (syn condition) <> errors (syn body)}, + AST.While (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Repeat body condition) = + (Synthesized SynTC{errors= booleanExpressionErrors (syn condition) <> errors (syn body)}, + AST.Repeat (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck (AST.For counter _start _end _step _body) (inherited, AST.For _counter start end step body) = + (Synthesized SynTC{errors= integerExpressionErrors (syn start) <> integerExpressionErrors (syn end) + <> foldMap (integerExpressionErrors . syn) step <> errors (syn body)}, + AST.For counter (Inherited $ inh inherited) (Inherited $ inh inherited) (Inherited (inh inherited) <$ step) + (Inherited $ InhTC $ + Map.insert (AST.NonQualIdent counter) (NominalType (AST.NonQualIdent "INTEGER") Nothing) + $ env $ inh inherited)) + attribution TypeCheck self (inherited, AST.Loop body) = (Synthesized SynTC{errors= errors (syn body)}, + AST.Loop (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.With branches fallback) = + (Synthesized SynTC{errors= foldMap (errors . syn) branches <> foldMap (errors . syn) fallback}, + AST.With (pure $ Inherited $ inh inherited) (Inherited (inh inherited) <$ fallback)) + attribution TypeCheck self (inherited, AST.Exit) = (Synthesized SynTC{errors= []}, AST.Exit) + attribution TypeCheck self (inherited, AST.Return value) = + (Synthesized SynTC{errors= foldMap (expressionErrors . syn) value}, + AST.Return (Inherited (inh inherited) <$ value)) + +instance Attribution TypeCheck AST.WithAlternative where + attribution TypeCheck self (inherited, AST.WithAlternative var subtype body) = {-# SCC "WithAlternative" #-} + (Synthesized SynTC{errors= case (Map.lookup var (env $ inh inherited), + Map.lookup subtype (env $ inh inherited)) + of (Just supertype, Just subtypeDef) -> assignmentCompatible supertype subtypeDef + (Nothing, _) -> [UnknownName var] + (_, Nothing) -> [UnknownName subtype] + <> errors (syn body)}, + AST.WithAlternative var subtype (Inherited $ InhTC $ + maybe id (Map.insert var) (Map.lookup subtype $ env $ inh inherited) + $ env $ inh inherited)) + +instance Attribution TypeCheck AST.Case where + attribution TypeCheck self (inherited, AST.Case labels body) = + (Synthesized SynTC{errors= foldMap (errors . syn) labels <> errors (syn body)}, + AST.Case (pure $ Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.EmptyCase) = (Synthesized SynTC{errors= []}, AST.EmptyCase) + +instance Attribution TypeCheck AST.CaseLabels where + attribution TypeCheck self (inherited, AST.SingleLabel value) = + (Synthesized SynTC{errors= integerExpressionErrors (syn value)}, + AST.SingleLabel (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.LabelRange start end) = + (Synthesized SynTC{errors= integerExpressionErrors (syn start) <> integerExpressionErrors (syn end)}, + AST.LabelRange (Inherited $ inh inherited) (Inherited $ inh inherited)) + +instance Attribution TypeCheck AST.Expression where + attribution TypeCheck self (inherited, AST.Relation op left right) = + (Synthesized SynTCExp{expressionErrors= case expressionErrors (syn left) <> expressionErrors (syn right) + of [] | inferredType (syn left) == inferredType (syn right) -> [] + | otherwise -> [TypeMismatch + (inferredType $ syn left) + (inferredType $ syn right)] + errs -> errs, + inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing}, + AST.Relation op (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Positive expr) = + (Synthesized SynTCExp{expressionErrors= unaryNumericOperatorErrors (syn expr), + inferredType= inferredType (syn expr)}, + AST.Positive (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Negative expr) = + (Synthesized SynTCExp{expressionErrors= unaryNumericOperatorErrors (syn expr), + inferredType= unaryNumericOperatorType negate (syn expr)}, + AST.Negative (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Add left right) = + (Synthesized SynTCExp{expressionErrors= binaryNumericOperatorErrors (syn left) (syn right), + inferredType= binaryNumericOperatorType div (syn left) (syn right)}, + AST.Add (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Subtract left right) = + (Synthesized SynTCExp{expressionErrors= binaryNumericOperatorErrors (syn left) (syn right), + inferredType= binaryNumericOperatorType div (syn left) (syn right)}, + AST.Subtract (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Or left right) = + (Synthesized SynTCExp{expressionErrors= binaryBooleanOperatorErrors (syn left) (syn right), + inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing}, + AST.Or (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Multiply left right) = + (Synthesized SynTCExp{expressionErrors= binaryNumericOperatorErrors (syn left) (syn right), + inferredType= binaryNumericOperatorType div (syn left) (syn right)}, + AST.Multiply (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Divide left right) = + (Synthesized SynTCExp{expressionErrors= + case (syn left, syn right) + of (SynTCExp{expressionErrors= [], + inferredType= NominalType (AST.NonQualIdent "REAL") Nothing}, + SynTCExp{expressionErrors= [], + inferredType= NominalType (AST.NonQualIdent "REAL") Nothing}) -> [] + (SynTCExp{expressionErrors= [], inferredType= t1}, + SynTCExp{expressionErrors= [], inferredType= t2}) + | t1 == t2 -> [UnrealType t1] + | otherwise -> [TypeMismatch t1 t2], + inferredType= NominalType (AST.NonQualIdent "REAL") Nothing}, + AST.Divide (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.IntegerDivide left right) = + (Synthesized SynTCExp{expressionErrors= binaryIntegerOperatorErrors (syn left) (syn right), + inferredType= binaryNumericOperatorType div (syn left) (syn right)}, + AST.IntegerDivide (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Modulo left right) = + (Synthesized SynTCExp{expressionErrors= binaryIntegerOperatorErrors (syn left) (syn right), + inferredType= binaryNumericOperatorType mod (syn left) (syn right)}, + AST.Modulo (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.And left right) = + (Synthesized SynTCExp{expressionErrors= binaryBooleanOperatorErrors (syn left) (syn right), + inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing}, + AST.And (Inherited $ inh inherited) (Inherited $ inh inherited)) + attribution TypeCheck (AST.Integer x) (inherited, _) = + (Synthesized SynTCExp{expressionErrors= mempty, + inferredType= IntegerType (read $ Text.unpack x)}, + AST.Integer x) + attribution TypeCheck self (inherited, AST.Real x) = + (Synthesized SynTCExp{expressionErrors= mempty, + inferredType= NominalType (AST.NonQualIdent "REAL") Nothing}, + AST.Real x) + attribution TypeCheck self (inherited, AST.CharConstant x) = + (Synthesized SynTCExp{expressionErrors= mempty, + inferredType= NominalType (AST.NonQualIdent "CHAR") Nothing}, + AST.CharConstant x) + attribution TypeCheck self (inherited, AST.CharCode x) = + (Synthesized SynTCExp{expressionErrors= mempty, + inferredType= NominalType (AST.NonQualIdent "CHAR") Nothing}, + AST.CharCode x) + attribution TypeCheck (AST.String x) (inherited, _) = + (Synthesized SynTCExp{expressionErrors= mempty, + inferredType= StringType (Text.length x)}, + AST.String x) + attribution TypeCheck self (inherited, AST.Nil) = + (Synthesized SynTCExp{expressionErrors= mempty, + inferredType= NilType}, + AST.Nil) + attribution TypeCheck self (inherited, AST.Set elements) = + (Synthesized SynTCExp{expressionErrors= mempty, + inferredType= NominalType (AST.NonQualIdent "SET") Nothing}, + AST.Set [Inherited $ inh inherited]) + attribution TypeCheck self (inherited, AST.Read designator) = + (Synthesized SynTCExp{expressionErrors= designatorErrors (syn designator), + inferredType= designatorType (syn designator)}, + AST.Read (Inherited $ inh inherited)) + attribution TypeCheck (AST.FunctionCall _designator parameters) + (inherited, AST.FunctionCall designator parameters') = + (Synthesized SynTCExp{expressionErrors= case {-# SCC "FunctionCall" #-} syn designator + of SynTCDes{designatorErrors= [], + designatorType= ProcedureType formalTypes Just{}} + | length formalTypes /= length parameters -> + [ArgumentCountMismatch (length formalTypes) (length parameters)] + | otherwise -> concat (zipWith parameterCompatible formalTypes $ + inferredType . syn <$> parameters') + SynTCDes{designatorErrors= [], + designatorType= t} -> [NonFunctionType t] + SynTCDes{designatorErrors= errs} -> errs + <> foldMap (expressionErrors . syn) parameters', + inferredType= case syn designator + of SynTCDes{designatorSelf= d, + designatorType= ProcedureType _ (Just returnType)} + | IntegerType{} <- returnType -> + IntegerType (callValue d $ inferredType . syn <$> parameters') + | otherwise -> returnType + _ -> UnknownType}, + AST.FunctionCall (Inherited $ inh inherited) [Inherited $ inh inherited]) + where callValue (AST.Variable (AST.NonQualIdent "MAX")) + [NominalType (AST.NonQualIdent "SET") Nothing] = 63 + callValue (AST.Variable (AST.NonQualIdent "MIN")) + [NominalType (AST.NonQualIdent "SET") Nothing] = 0 + attribution TypeCheck self (inherited, AST.Not expr) = + (Synthesized SynTCExp{expressionErrors= booleanExpressionErrors (syn expr), + inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing}, + AST.Not (Inherited $ inh inherited)) + +instance Attribution TypeCheck AST.Element where + attribution TypeCheck self (inherited, AST.Element expr) = + (Synthesized SynTCExp{expressionErrors= integerExpressionErrors (syn expr), + inferredType= NominalType (AST.NonQualIdent "SET") Nothing}, + AST.Element (Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.Range low high) = + (Synthesized SynTCExp{expressionErrors= integerExpressionErrors (syn low) <> integerExpressionErrors (syn high), + inferredType= NominalType (AST.NonQualIdent "SET") Nothing}, + AST.Range (Inherited $ inh inherited) (Inherited $ inh inherited)) + +instance Attribution TypeCheck AST.Designator where + attribution TypeCheck (AST.Variable q) (inherited, _) = + (Synthesized SynTCDes{designatorErrors= case designatorType + of Nothing -> [UnknownName q] + Just{} -> [], + designatorSelf= AST.Variable q, + designatorType= fromMaybe UnknownType designatorType}, + AST.Variable q) + where designatorType = Map.lookup q (env $ inh inherited) + attribution TypeCheck (AST.Field _record fieldName) (inherited, AST.Field record _fieldName) = + (Synthesized SynTCDes{designatorErrors= case syn record + of SynTCDes{designatorErrors= [], + designatorType= t} -> + maybe [NonRecordType t] + (maybe [UnknownField fieldName t] $ const []) (access True t) + SynTCDes{designatorErrors= errors} -> errors, + designatorSelf= AST.Field (Identity $ designatorSelf $ syn record) fieldName, + designatorType= fromMaybe UnknownType (fromMaybe Nothing $ access True + $ designatorType $ syn record)}, + AST.Field (Inherited $ inh inherited) fieldName) + where access _ (RecordType _ fields) = Just (Map.lookup fieldName fields) + access True (PointerType t) = access False t + access allowPtr (NominalType _ (Just t)) = access allowPtr t + access _ _ = Nothing + attribution TypeCheck (AST.Index _array indexes) (inherited, AST.Index array _indexes) = + (Synthesized SynTCDes{designatorErrors= case syn array + of SynTCDes{designatorErrors= [], + designatorType= t@(ArrayType dimensions _)} + | length dimensions == length indexes -> [] + | length dimensions == 0 && length indexes == 1 -> [] + | otherwise -> [ExtraDimensionalIndex t] + SynTCDes{designatorErrors= [], + designatorType= t} -> [NonArrayType t] + SynTCDes{designatorErrors= errors} -> errors, + designatorType= case designatorType (syn array) + of ArrayType _ itemType -> itemType + _ -> UnknownType}, + AST.Index (Inherited $ inh inherited) (pure $ Inherited $ inh inherited)) + attribution TypeCheck self (inherited, AST.TypeGuard designator q) = {-# SCC "TypeGuard" #-} + (Synthesized SynTCDes{designatorErrors= case (syn designator, targetType) + of (SynTCDes{designatorErrors= [], + designatorType= t}, + Just t') -> assignmentCompatible t' t + (SynTCDes{designatorErrors= errors}, + Nothing) -> UnknownName q : errors + (SynTCDes{designatorErrors= errors}, _) -> errors, + designatorType= fromMaybe UnknownType targetType}, + AST.TypeGuard (Inherited $ inh inherited) q) + where targetType = Map.lookup q (env $ inh inherited) + attribution TypeCheck self (inherited, AST.Dereference pointer) = + (Synthesized SynTCDes{designatorErrors= case syn pointer + of SynTCDes{designatorErrors= [], + designatorType= PointerType{}} -> [] + SynTCDes{designatorErrors= [], + designatorType= NominalType _ (Just PointerType{})} -> [] + SynTCDes{designatorErrors= [], + designatorType= t} -> [NonPointerType t] + SynTCDes{designatorErrors= errors} -> errors, + designatorType= case designatorType (syn pointer) + of NominalType _ (Just (PointerType t)) -> t + PointerType t -> t + _ -> UnknownType}, + AST.Dereference (Inherited $ inh inherited)) + +unaryNumericOperatorErrors :: SynTCExp -> [Error] +unaryNumericOperatorErrors SynTCExp{expressionErrors= [], inferredType= IntegerType{}} = [] +unaryNumericOperatorErrors SynTCExp{expressionErrors= [], + inferredType= NominalType (AST.NonQualIdent name) Nothing} + | name `elem` numericTypeNames = [] +unaryNumericOperatorErrors SynTCExp{expressionErrors= [], inferredType= t} = [NonNumericType t] +unaryNumericOperatorErrors SynTCExp{expressionErrors= errs} = errs + +unaryNumericOperatorType :: (Int -> Int) -> SynTCExp -> Type +unaryNumericOperatorType f SynTCExp{inferredType= IntegerType x} = IntegerType (f x) +unaryNumericOperatorType _ SynTCExp{inferredType= t} = t + +binaryNumericOperatorErrors :: SynTCExp -> SynTCExp -> [Error] +binaryNumericOperatorErrors + SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent name1) Nothing} + SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent name2) Nothing} + | name1 `elem` numericTypeNames, name2 `elem` numericTypeNames = [] +binaryNumericOperatorErrors + SynTCExp{expressionErrors= [], inferredType= IntegerType{}} + SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent name) Nothing} + | name `elem` numericTypeNames = [] +binaryNumericOperatorErrors + SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent name) Nothing} + SynTCExp{expressionErrors= [], inferredType= IntegerType{}} + | name `elem` numericTypeNames = [] +binaryNumericOperatorErrors SynTCExp{expressionErrors= [], inferredType= IntegerType{}} + SynTCExp{expressionErrors= [], inferredType= IntegerType{}} = [] +binaryNumericOperatorErrors SynTCExp{expressionErrors= [], inferredType= t1} + SynTCExp{expressionErrors= [], inferredType= t2} + | t1 == t2 = [NonNumericType t1] + | otherwise = [TypeMismatch t1 t2] +binaryNumericOperatorErrors SynTCExp{expressionErrors= errs1} SynTCExp{expressionErrors= errs2} = errs1 <> errs2 + +binaryNumericOperatorType :: (Int -> Int -> Int) -> SynTCExp -> SynTCExp -> Type +binaryNumericOperatorType f SynTCExp{inferredType= IntegerType x} SynTCExp{inferredType= IntegerType y} = + IntegerType (f x y) +binaryNumericOperatorType _ SynTCExp{inferredType= t1} SynTCExp{inferredType= t2} + | t1 == t2 = t1 + | IntegerType{} <- t1 = t2 + | IntegerType{} <- t2 = t1 + | NominalType (AST.NonQualIdent name1) Nothing <- t1, + NominalType (AST.NonQualIdent name2) Nothing <- t2, + Just index1 <- List.elemIndex name1 numericTypeNames, + Just index2 <- List.elemIndex name2 numericTypeNames = + NominalType (AST.NonQualIdent $ numericTypeNames !! max index1 index2) Nothing + | otherwise = t1 + +binaryIntegerOperatorErrors :: SynTCExp -> SynTCExp -> [Error] +binaryIntegerOperatorErrors syn1 syn2 = integerExpressionErrors syn1 <> integerExpressionErrors syn2 + +integerExpressionErrors SynTCExp{expressionErrors= [], inferredType= t} = expectInteger t + where expectInteger IntegerType{} = [] + expectInteger (NominalType (AST.NonQualIdent "SHORTINT") Nothing) = [] + expectInteger (NominalType (AST.NonQualIdent "INTEGER") Nothing) = [] + expectInteger (NominalType (AST.NonQualIdent "LONGINT") Nothing) = [] + expectInteger t = [NonIntegerType t] +integerExpressionErrors SynTCExp{expressionErrors= errs} = errs + +booleanExpressionErrors SynTCExp{expressionErrors= [], + inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing} = [] +booleanExpressionErrors SynTCExp{expressionErrors= [], inferredType= t} = [NonBooleanType t] +booleanExpressionErrors SynTCExp{expressionErrors= errs} = errs + +binaryBooleanOperatorErrors :: SynTCExp -> SynTCExp -> [Error] +binaryBooleanOperatorErrors + SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing} + SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing} = [] +binaryBooleanOperatorErrors SynTCExp{expressionErrors= [], inferredType= t1} + SynTCExp{expressionErrors= [], inferredType= t2} + | t1 == t2 = [NonBooleanType t1] + | otherwise = [TypeMismatch t1 t2] + +parameterCompatible :: (Bool, Type) -> Type -> [Error] +parameterCompatible (True, expected) actual + | expected == actual = [] + | otherwise = [UnequalTypes expected actual] +parameterCompatible (False, expected) actual = assignmentCompatible expected actual + +assignmentCompatible :: Type -> Type -> [Error] +assignmentCompatible expected actual + | expected == actual = [] + | NominalType (AST.NonQualIdent name1) Nothing <- expected, + NominalType (AST.NonQualIdent name2) Nothing <- actual, + Just index1 <- List.elemIndex name1 numericTypeNames, + Just index2 <- List.elemIndex name2 numericTypeNames, + index1 >= index2 = [] + | NominalType (AST.NonQualIdent name) Nothing <- expected, + IntegerType{} <- actual, name `elem` numericTypeNames = [] + | expected == NominalType (AST.NonQualIdent "BASIC TYPE") Nothing, + NominalType (AST.NonQualIdent q) Nothing <- actual, + q `elem` ["BOOLEAN", "CHAR", "SHORTINT", "INTEGER", "LONGINT", "REAL", "LONGREAL", "SET"] = [] + | expected == NominalType (AST.NonQualIdent "POINTER") Nothing, PointerType{} <- actual = [] + | expected == NominalType (AST.NonQualIdent "POINTER") Nothing, NominalType _ (Just t) <- actual = + assignmentCompatible expected t + | expected == NominalType (AST.NonQualIdent "CHAR") Nothing, actual == StringType 1 = [] + | NilType <- actual, PointerType{} <- expected = [] + | NilType <- actual, ProcedureType{} <- expected = [] + | NilType <- actual, NominalType _ (Just t) <- expected = assignmentCompatible t actual + | ArrayType [] (NominalType (AST.NonQualIdent "CHAR") Nothing) <- expected, StringType{} <- actual = [] + | ArrayType [m] (NominalType (AST.NonQualIdent "CHAR") Nothing) <- expected, StringType n <- actual = + if m < n then [TooSmallArrayType expected] else [] + | targetExtends actual expected = [] + | NominalType _ (Just t) <- expected, ProcedureType{} <- actual = assignmentCompatible t actual + | otherwise = error (show (expected, actual)) + +extends, targetExtends :: Type -> Type -> Bool +t1 `extends` t2 | t1 == t2 = True +RecordType ancestry _ `extends` NominalType q _ = q `elem` ancestry +NominalType _ (Just t1) `extends` t2 = t1 `extends` t2 +t1 `extends` t2 = False -- error (show (t1, t2)) + +numericTypeNames = ["SHORTINT", "INTEGER", "LONGINT", "REAL", "LONGREAL"] + +PointerType t1 `targetExtends` PointerType t2 = t1 `extends` t2 +NominalType _ (Just t1) `targetExtends` t2 = t1 `targetExtends` t2 +t1 `targetExtends` NominalType _ (Just t2) = t1 `targetExtends` t2 +t1 `targetExtends` t2 | t1 == t2 = True +t1 `targetExtends` t2 = False + +-- * More boring Shallow.Functor instances, TH candidates +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (Modules (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.Module (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.Declaration (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.FormalParameters (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.FPSection (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (Deep.Product AST.Expression AST.StatementSequence (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.StatementSequence (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.Statement (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.Case (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.CaseLabels (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.WithAlternative (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.Expression (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.Element (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.Designator (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.Type (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity +instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck) + (AST.FieldList (Semantics TypeCheck) (Semantics TypeCheck)) where + (<$>) = AG.mapDefault runIdentity + +-- * Unsafe Rank2 AST instances + +instance Rank2.Apply (AST.Module f') where + AST.Module ident1a imports1 decls1 body1 ident1b <*> ~(AST.Module ident2a imports2 decls2 body2 ident2b) = + AST.Module ident1a imports1 (liftA2 Rank2.apply decls1 decls2) (liftA2 Rank2.apply body1 body2) ident1b + +checkModules :: Environment -> Map AST.Ident (AST.Module Identity Identity) -> [Error] +checkModules predef modules = + errors (syn (TypeCheck Shallow.<$> Identity (TypeCheck Deep.<$> Modules (Identity <$> modules)) + `Rank2.apply` + Inherited (InhTC predef))) + +predefined, predefined2 :: Environment +-- | The set of 'Predefined' types and procedures defined in the Oberon Language Report. +predefined = Map.fromList $ map (first AST.NonQualIdent) $ + [("BOOLEAN", NominalType (AST.NonQualIdent "BOOLEAN") Nothing), + ("CHAR", NominalType (AST.NonQualIdent "CHAR") Nothing), + ("SHORTINT", NominalType (AST.NonQualIdent "SHORTINT") Nothing), + ("INTEGER", NominalType (AST.NonQualIdent "INTEGER") Nothing), + ("LONGINT", NominalType (AST.NonQualIdent "LONGINT") Nothing), + ("REAL", NominalType (AST.NonQualIdent "REAL") Nothing), + ("LONGREAL", NominalType (AST.NonQualIdent "LONGREAL") Nothing), + ("SET", NominalType (AST.NonQualIdent "SET") Nothing), + ("TRUE", NominalType (AST.NonQualIdent "BOOLEAN") Nothing), + ("FALSE", NominalType (AST.NonQualIdent "BOOLEAN") Nothing), + ("ABS", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing), + ("ASH", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing), + ("CAP", ProcedureType [(False, NominalType (AST.NonQualIdent "CHAR") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "CHAR") Nothing), + ("LEN", ProcedureType [(False, NominalType (AST.NonQualIdent "ARRAY") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "LONGINT") Nothing), + ("MAX", ProcedureType [(False, NominalType (AST.NonQualIdent "BASIC TYPE") Nothing)] $ Just $ IntegerType 0), + ("MIN", ProcedureType [(False, NominalType (AST.NonQualIdent "BASIC TYPE") Nothing)] $ Just $ IntegerType 0), + ("ODD", ProcedureType [(False, NominalType (AST.NonQualIdent "CHAR") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "BOOLEAN") Nothing), + ("SIZE", ProcedureType [(False, NominalType (AST.NonQualIdent "CHAR") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing), + ("ORD", ProcedureType [(False, NominalType (AST.NonQualIdent "CHAR") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing), + ("CHR", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "CHAR") Nothing), + ("SHORT", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] + $ Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing), + ("LONG", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing), + ("ENTIER", ProcedureType [(False, NominalType (AST.NonQualIdent "REAL") Nothing)] $ + Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing), + ("INC", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing), + ("DEC", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing), + ("INCL", ProcedureType [(False, NominalType (AST.NonQualIdent "SET") Nothing), + (False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing), + ("EXCL", ProcedureType [(False, NominalType (AST.NonQualIdent "SET") Nothing), + (False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing), + ("COPY", ProcedureType [(False, NominalType (AST.NonQualIdent "ARRAY") Nothing), + (False, NominalType (AST.NonQualIdent "ARRAY") Nothing)] Nothing), + ("NEW", ProcedureType [(False, NominalType (AST.NonQualIdent "POINTER") Nothing)] Nothing), + ("HALT", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing)] + +-- | The set of 'Predefined' types and procedures defined in the Oberon-2 Language Report. +predefined2 = predefined <> + Map.fromList (first AST.NonQualIdent <$> + [("ASSERT", ProcedureType [(False, NominalType (AST.NonQualIdent "BOOL") Nothing), + (False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing)]) + +$(mconcat <$> mapM Rank2.TH.unsafeDeriveApply + [''AST.Declaration, ''AST.Type, ''AST.Expression, + ''AST.Element, ''AST.Designator, ''AST.FieldList, + ''AST.ProcedureHeading, ''AST.FormalParameters, ''AST.FPSection, ''AST.ProcedureBody, + ''AST.Statement, ''AST.StatementSequence, ''AST.WithAlternative, ''AST.Case, ''AST.CaseLabels]) diff --git a/src/Transformation.hs b/src/Transformation.hs new file mode 100644 --- /dev/null +++ b/src/Transformation.hs @@ -0,0 +1,23 @@ +{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, + PolyKinds, RankNTypes, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} + +module Transformation where + +import qualified Rank2 + +import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd) + +class Functor t p q x | t -> p q where + (<$>) :: t -> p x -> q x + +class Foldable t p m x | t -> p m where + foldMap :: t -> p x -> m + +class Traversable t p q m x | t -> p q m where + traverse :: t -> p x -> m (q x) + +fmap :: Functor t p q x => t -> p x -> q x +fmap = (<$>) + +instance Functor (Rank2.Arrow p q x) p q x where + (<$>) = Rank2.apply diff --git a/src/Transformation/AG.hs b/src/Transformation/AG.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/AG.hs @@ -0,0 +1,37 @@ +{-# Language DefaultSignatures, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, + TypeFamilies, TypeOperators, UndecidableInstances #-} + +module Transformation.AG where + +import Data.Functor.Identity +import qualified Rank2 +import qualified Transformation as Shallow +import qualified Transformation.Deep as Deep + +data Inherited a g = Inherited{inh :: Atts (Inherited a) g} +data Synthesized a g = Synthesized{syn :: Atts (Synthesized a) g} + +type family Atts (f :: * -> *) x +deriving instance (Show (Atts (Inherited a) g)) => Show (Inherited a g) +deriving instance (Show (Atts (Synthesized a) g)) => Show (Synthesized a g) +-- type instance Atts Identity f = f Identity +-- type instance Atts (Inherited a Rank2.~> Synthesized a) g = Atts (Inherited a) g -> Atts (Synthesized a) g + +type Semantics a = Inherited a Rank2.~> Synthesized a + +type Rule a g (f :: * -> *) = g f (Semantics a) + -> (Inherited a (g f (Semantics a)), g f (Synthesized a)) + -> (Synthesized a (g f (Semantics a)), g f (Inherited a)) + +knit :: Rank2.Apply (g f) => Rule a g f -> g f (Semantics a) -> Semantics a (g f (Semantics a)) +knit r chSem = Rank2.Arrow knit' + where knit' inh = syn + where (syn, chInh) = r chSem (inh, chSyn) + chSyn = chSem Rank2.<*> chInh + +class Shallow.Functor t Identity (Semantics t) (g (Semantics t) (Semantics t)) => Attribution t g where + attribution :: t -> Rule t g (Semantics t) + +mapDefault :: (q ~ Semantics t, x ~ g q q, Rank2.Apply (g q), Attribution t g) => (p x -> x) -> t -> p x -> q x +mapDefault extract t sem = knit (attribution t) (extract sem) +{-# INLINE mapDefault #-} diff --git a/src/Transformation/Deep.hs b/src/Transformation/Deep.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Deep.hs @@ -0,0 +1,83 @@ +{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, + PolyKinds, RankNTypes, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} + +module Transformation.Deep where + +import Control.Applicative ((<*>), liftA2) +import Data.Data (Data, Typeable) +import Data.Monoid (Monoid, (<>)) +import qualified Rank2 +import qualified Data.Foldable +import qualified Data.Functor +import qualified Data.Traversable +import qualified Transformation as Shallow + +import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd) + +class Rank2.Functor (g p) => Functor t g (p :: * -> *) (q :: * -> *) where + (<$>) :: t -> g p p -> g q q + +class Rank2.Foldable (g p) => Foldable t g p m where + foldMap :: t -> g p p -> m + +class Rank2.Traversable (g p) => UpTraversable t g (p :: * -> *) (q :: * -> *) m where + traverseUp :: t -> g p p -> m (g q q) + +class Rank2.Traversable (g p) => DownTraversable t g (p :: * -> *) (q :: * -> *) m where + traverseDown :: t -> g p p -> m (g q q) + +data Product g1 g2 (p :: * -> *) (q :: * -> *) = Pair{fst :: q (g1 p p), + snd :: q (g2 p p)} + +instance Rank2.Functor (Product g1 g2 p) where + f <$> ~(Pair left right) = Pair (f left) (f right) + +instance Rank2.Apply (Product g h p) where + ~(Pair g1 h1) <*> ~(Pair g2 h2) = Pair (Rank2.apply g1 g2) (Rank2.apply h1 h2) + liftA2 f ~(Pair g1 h1) ~(Pair g2 h2) = Pair (f g1 g2) (f h1 h2) + +instance Rank2.Applicative (Product g h p) where + pure f = Pair f f + +instance Rank2.Foldable (Product g h p) where + foldMap f ~(Pair g h) = f g `mappend` f h + +instance Rank2.Traversable (Product g h p) where + traverse f ~(Pair g h) = liftA2 Pair (f g) (f h) + +instance Rank2.DistributiveTraversable (Product g h p) + +instance Rank2.Distributive (Product g h p) where + cotraverse w f = Pair{fst= w (fst Data.Functor.<$> f), + snd= w (snd Data.Functor.<$> f)} + +instance (Data.Functor.Functor p, Shallow.Functor t p q (g1 q q), Shallow.Functor t p q (g2 q q), + Functor t g1 p q, Functor t g2 p q) => Functor t (Product g1 g2) p q where + t <$> Pair left right = Pair (t Shallow.<$> ((t <$>) Data.Functor.<$> left)) + (t Shallow.<$> ((t <$>) Data.Functor.<$> right)) + +instance (Monoid m, Data.Foldable.Foldable p, + Foldable t g1 p m, Foldable t g2 p m) => Foldable t (Product g1 g2) p m where + foldMap t (Pair left right) = Data.Foldable.foldMap (foldMap t) left + <> Data.Foldable.foldMap (foldMap t) right + +instance (Monad m, Data.Traversable.Traversable p, + Shallow.Traversable t p q m (g1 q q), Shallow.Traversable t p q m (g2 q q), + UpTraversable t g1 p q m, UpTraversable t g2 p q m) => UpTraversable t (Product g1 g2) p q m where + traverseUp t (Pair left right) = + Pair Data.Functor.<$> (Data.Traversable.traverse (traverseUp t) left >>= Shallow.traverse t) + Control.Applicative.<*> (Data.Traversable.traverse (traverseUp t) right >>= Shallow.traverse t) + +instance (Monad m, Data.Traversable.Traversable q, + Shallow.Traversable t p q m (g1 p p), Shallow.Traversable t p q m (g2 p p), + DownTraversable t g1 p q m, DownTraversable t g2 p q m) => DownTraversable t (Product g1 g2) p q m where + traverseDown t (Pair left right) = + Pair Data.Functor.<$> (Shallow.traverse t left >>= Data.Traversable.traverse (traverseDown t)) + Control.Applicative.<*> (Shallow.traverse t right >>= Data.Traversable.traverse (traverseDown t)) + +deriving instance (Typeable p, Typeable q, Typeable g1, Typeable g2, + Data (q (g1 p p)), Data (q (g2 p p))) => Data (Product g1 g2 p q) +deriving instance (Show (q (g1 p p)), Show (q (g2 p p))) => Show (Product g1 g2 p q) + +fmap :: Functor t g p q => t -> g p p -> g q q +fmap = (<$>) diff --git a/src/Transformation/Deep/TH.hs b/src/Transformation/Deep/TH.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Deep/TH.hs @@ -0,0 +1,287 @@ +-- | This module exports the templates for automatic instance deriving of "Transformation.Deep" type classes. The most +-- common way to use it would be +-- +-- > import qualified Transformation.Deep.TH +-- > data MyDataType f' f = ... +-- > $(Transformation.Deep.TH.deriveFunctor ''MyDataType) +-- + +{-# Language TemplateHaskell #-} +-- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial + +module Transformation.Deep.TH (deriveAll, deriveFunctor, deriveFoldable, deriveDownTraversable, deriveUpTraversable) +where + +import Control.Monad (replicateM) +import Data.Monoid ((<>)) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ) + +import qualified Transformation +import qualified Transformation.Deep +import qualified Rank2.TH + + +data Deriving = Deriving { _constructor :: Name, _variableN :: Name, _variable1 :: Name } + +deriveAll :: Name -> Q [Dec] +deriveAll ty = foldr f (pure []) [Rank2.TH.deriveFunctor, Rank2.TH.deriveFoldable, Rank2.TH.deriveTraversable, + Transformation.Deep.TH.deriveFunctor, Transformation.Deep.TH.deriveFoldable, + Transformation.Deep.TH.deriveDownTraversable, + Transformation.Deep.TH.deriveUpTraversable] + where f derive rest = (<>) <$> derive ty <*> rest + +deriveFunctor :: Name -> Q [Dec] +deriveFunctor ty = do + t <- varT <$> newName "t" + p <- varT <$> newName "p" + q <- varT <$> newName "q" + let deepConstraint ty = conT ''Transformation.Deep.Functor `appT` t `appT` ty `appT` p `appT` q + shallowConstraint ty = + conT ''Transformation.Functor `appT` t `appT` p `appT` q `appT` (ty `appT` q `appT` q) + (instanceType, cs) <- reifyConstructors ty + (constraints, dec) <- genDeepmap deepConstraint shallowConstraint cs + sequence [instanceD (cxt (appT (conT ''Functor) p : map pure constraints)) + (deepConstraint instanceType) + [pure dec]] + +deriveFoldable :: Name -> Q [Dec] +deriveFoldable ty = do + t <- varT <$> newName "t" + f <- varT <$> newName "f" + m <- varT <$> newName "m" + let deepConstraint ty = conT ''Transformation.Deep.Foldable `appT` t `appT` ty `appT` f `appT` m + shallowConstraint ty = + conT ''Transformation.Foldable `appT` t `appT` f `appT` m `appT` (ty `appT` f `appT` f) + (instanceType, cs) <- reifyConstructors ty + (constraints, dec) <- genFoldMap deepConstraint shallowConstraint cs + sequence [instanceD (cxt (appT (conT ''Monoid) m : appT (conT ''Foldable) f : map pure constraints)) + (deepConstraint instanceType) + [pure dec]] + +deriveDownTraversable :: Name -> Q [Dec] +deriveDownTraversable ty = do + t <- varT <$> newName "t" + p <- varT <$> newName "p" + q <- varT <$> newName "q" + m <- varT <$> newName "m" + let deepConstraint ty = conT ''Transformation.Deep.DownTraversable `appT` t `appT` ty `appT` p `appT` q `appT` m + shallowConstraint ty = + conT ''Transformation.Traversable `appT` t `appT` p `appT` q `appT` m `appT` (ty `appT` p `appT` p) + (instanceType, cs) <- reifyConstructors ty + (constraints, dec) <- genTraverseDown deepConstraint shallowConstraint cs + sequence [instanceD (cxt (appT (conT ''Monad) m : appT (conT ''Traversable) q : map pure constraints)) + (deepConstraint instanceType) + [pure dec]] + +deriveUpTraversable :: Name -> Q [Dec] +deriveUpTraversable ty = do + t <- varT <$> newName "t" + p <- varT <$> newName "p" + q <- varT <$> newName "q" + m <- varT <$> newName "m" + let deepConstraint ty = conT ''Transformation.Deep.UpTraversable `appT` t `appT` ty `appT` p `appT` q `appT` m + shallowConstraint ty = + conT ''Transformation.Traversable `appT` t `appT` p `appT` q `appT` m `appT` (ty `appT` q `appT` q) + (instanceType, cs) <- reifyConstructors ty + (constraints, dec) <- genTraverseUp deepConstraint shallowConstraint cs + sequence [instanceD (cxt (appT (conT ''Monad) m : appT (conT ''Traversable) p : map pure constraints)) + (deepConstraint instanceType) + [pure dec]] + +reifyConstructors :: Name -> Q (TypeQ, [Con]) +reifyConstructors ty = do + (TyConI tyCon) <- reify ty + (tyConName, tyVars, _kind, cs) <- case tyCon of + DataD _ nm tyVars kind cs _ -> return (nm, tyVars, kind, cs) + NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c]) + _ -> fail "deriveApply: tyCon may not be a type synonym." + + let (KindedTV tyVar (AppT (AppT ArrowT StarT) StarT) : + KindedTV tyVar' (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars + instanceType = foldl apply (conT tyConName) (reverse $ drop 2 $ reverse tyVars) + apply t (PlainTV name) = appT t (varT name) + apply t (KindedTV name _) = appT t (varT name) + + putQ (Deriving tyConName tyVar' tyVar) + return (instanceType, cs) + +genDeepmap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> [Con] -> Q ([Type], Dec) +genDeepmap deepConstraint shallowConstraint cs = do + (constraints, clauses) <- unzip <$> mapM (genDeepmapClause deepConstraint shallowConstraint) cs + return (concat constraints, FunD '(Transformation.Deep.<$>) clauses) + +genFoldMap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> [Con] -> Q ([Type], Dec) +genFoldMap deepConstraint shallowConstraint cs = do + (constraints, clauses) <- unzip <$> mapM (genFoldMapClause deepConstraint shallowConstraint) cs + return (concat constraints, FunD 'Transformation.Deep.foldMap clauses) + +genTraverseDown :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> [Con] -> Q ([Type], Dec) +genTraverseDown deepConstraint shallowConstraint cs = do + (constraints, clauses) <- unzip <$> mapM (genTraverseClause genTraverseDownField deepConstraint shallowConstraint) cs + return (concat constraints, FunD 'Transformation.Deep.traverseDown clauses) + +genTraverseUp :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> [Con] -> Q ([Type], Dec) +genTraverseUp deepConstraint shallowConstraint cs = do + (constraints, clauses) <- unzip <$> mapM (genTraverseClause genTraverseUpField deepConstraint shallowConstraint) cs + return (concat constraints, FunD 'Transformation.Deep.traverseUp clauses) + +genDeepmapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Con -> Q ([Type], Clause) +genDeepmapClause deepConstraint shallowConstraint (NormalC name fieldTypes) = do + t <- newName "t" + fieldNames <- replicateM (length fieldTypes) (newName "x") + let pats = [varP t, parensP (conP name $ map varP fieldNames)] + constraintsAndFields = zipWith newField fieldNames fieldTypes + newFields = map (snd <$>) constraintsAndFields + body = normalB $ appsE $ conE name : newFields + newField :: Name -> BangType -> Q ([Type], Exp) + newField x (_, fieldType) = genDeepmapField (varE t) fieldType deepConstraint shallowConstraint (varE x) id + constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields + (,) constraints <$> clause pats body [] +genDeepmapClause deepConstraint shallowConstraint (RecC name fields) = do + f <- newName "f" + x <- newName "x" + let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields + constraintsAndFields = map newNamedField fields + newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) + newNamedField (fieldName, _, fieldType) = + ((,) fieldName <$>) + <$> genDeepmapField (varE f) fieldType deepConstraint shallowConstraint (appE (varE fieldName) (varE x)) id + constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields + (,) constraints <$> clause [varP f, varP x] body [] + +genFoldMapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Con -> Q ([Type], Clause) +genFoldMapClause deepConstraint shallowConstraint (NormalC name fieldTypes) = do + t <- newName "t" + fieldNames <- replicateM (length fieldTypes) (newName "x") + let pats = [varP t, parensP (conP name $ map varP fieldNames)] + constraintsAndFields = zipWith newField fieldNames fieldTypes + newFields = map (snd <$>) constraintsAndFields + body | null newFields = [| mempty |] + | otherwise = foldr1 append newFields + append a b = [| $(a) <> $(b) |] + newField :: Name -> BangType -> Q ([Type], Exp) + newField x (_, fieldType) = genFoldMapField (varE t) fieldType deepConstraint shallowConstraint (varE x) id + constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields + (,) constraints <$> clause pats (normalB body) [] +genFoldMapClause deepConstraint shallowConstraint (RecC _name fields) = do + t <- newName "t" + x <- newName "x" + let body | null fields = [| mempty |] + | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields + append a b = [| $(a) <> $(b) |] + constraintsAndFields = map newNamedField fields + newNamedField :: VarBangType -> Q ([Type], Exp) + newNamedField (fieldName, _, fieldType) = + genFoldMapField (varE t) fieldType deepConstraint shallowConstraint (appE (varE fieldName) (varE x)) id + constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields + (,) constraints <$> clause [varP t, varP x] (normalB body) [] + +type GenTraverseFieldType = Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp) + -> Q ([Type], Exp) + +genTraverseClause :: GenTraverseFieldType -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Con -> Q ([Type], Clause) +genTraverseClause genTraverseField deepConstraint shallowConstraint (NormalC name fieldTypes) = do + t <- newName "t" + fieldNames <- replicateM (length fieldTypes) (newName "x") + let pats = [varP t, parensP (conP name $ map varP fieldNames)] + constraintsAndFields = zipWith newField fieldNames fieldTypes + newFields = map (snd <$>) constraintsAndFields + body | null fieldTypes = [| pure $(conE name) |] + | otherwise = fst $ foldl apply (conE name, False) newFields + apply (a, False) b = ([| $(a) <$> $(b) |], True) + apply (a, True) b = ([| $(a) <*> $(b) |], True) + newField :: Name -> BangType -> Q ([Type], Exp) + newField x (_, fieldType) = genTraverseField (varE t) fieldType deepConstraint shallowConstraint (varE x) id + constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields + (,) constraints <$> clause pats (normalB body) [] +genTraverseClause genTraverseField deepConstraint shallowConstraint (RecC name fields) = do + f <- newName "f" + x <- newName "x" + let constraintsAndFields = map newNamedField fields + body | null fields = [| pure $(conE name) |] + | otherwise = fst (foldl apply (conE name, False) $ map (snd . snd <$>) constraintsAndFields) + apply (a, False) b = ([| $(a) <$> $(b) |], True) + apply (a, True) b = ([| $(a) <*> $(b) |], True) + newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) + newNamedField (fieldName, _, fieldType) = + ((,) fieldName <$>) + <$> genTraverseField (varE f) fieldType deepConstraint shallowConstraint (appE (varE fieldName) (varE x)) id + constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields + (,) constraints <$> clause [varP f, varP x] (normalB body) [] + +genDeepmapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp) + -> Q ([Type], Exp) +genDeepmapField trans fieldType deepConstraint shallowConstraint fieldAccess wrap = do + Just (Deriving _ typeVarN typeVar1) <- getQ + case fieldType of + AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN -> + (,) <$> ((:) <$> deepConstraint (pure con) <*> ((:[]) <$> shallowConstraint (pure con))) + <*> appE (wrap [| (Transformation.fmap $trans . (Transformation.Deep.fmap $trans <$>)) |]) fieldAccess + AppT ty _ | ty == VarT typeVar1 -> + (,) [] <$> (wrap (varE 'Transformation.fmap `appE` trans) `appE` fieldAccess) + AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 -> + (,) <$> ((:[]) <$> deepConstraint (pure con)) + <*> appE (wrap [| Transformation.Deep.fmap $trans |]) fieldAccess + AppT t1 t2 | t1 /= VarT typeVar1 -> + genDeepmapField trans t2 deepConstraint shallowConstraint fieldAccess (wrap . appE (varE '(<$>))) + SigT ty _kind -> genDeepmapField trans ty deepConstraint shallowConstraint fieldAccess wrap + ParensT ty -> genDeepmapField trans ty deepConstraint shallowConstraint fieldAccess wrap + _ -> (,) [] <$> fieldAccess + +genFoldMapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp) + -> Q ([Type], Exp) +genFoldMapField trans fieldType deepConstraint shallowConstraint fieldAccess wrap = do + Just (Deriving _ typeVarN typeVar1) <- getQ + case fieldType of + AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN -> + (,) <$> ((:) <$> deepConstraint (pure con) <*> ((:[]) <$> shallowConstraint (pure con))) + <*> appE (wrap [| foldMap (Transformation.Deep.foldMap $trans) |]) fieldAccess + AppT ty _ | ty == VarT typeVar1 -> + (,) [] <$> (wrap (varE 'Transformation.foldMap `appE` trans) `appE` fieldAccess) + AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 -> + (,) <$> ((:[]) <$> deepConstraint (pure con)) + <*> appE (wrap [| Transformation.Deep.foldMap $trans |]) fieldAccess + AppT t1 t2 | t1 /= VarT typeVar1 -> + genFoldMapField trans t2 deepConstraint shallowConstraint fieldAccess (wrap . appE (varE 'foldMap)) + SigT ty _kind -> genFoldMapField trans ty deepConstraint shallowConstraint fieldAccess wrap + ParensT ty -> genFoldMapField trans ty deepConstraint shallowConstraint fieldAccess wrap + _ -> (,) [] <$> [| mempty |] + +genTraverseDownField :: GenTraverseFieldType +genTraverseDownField trans fieldType deepConstraint shallowConstraint fieldAccess wrap = do + Just (Deriving _ typeVarN typeVar1) <- getQ + case fieldType of + AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN -> + (,) <$> ((:) <$> deepConstraint (pure con) <*> ((:[]) <$> shallowConstraint (pure con))) + <*> appE (wrap [| (>>= traverse (Transformation.Deep.traverseDown $trans)) . Transformation.traverse $trans |]) + fieldAccess + AppT ty _ | ty == VarT typeVar1 -> + (,) [] <$> (wrap (varE 'Transformation.traverse `appE` trans) `appE` fieldAccess) + AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 -> + (,) <$> ((:[]) <$> deepConstraint (pure con)) + <*> appE (wrap [| Transformation.Deep.traverseDown $trans |]) fieldAccess + AppT t1 t2 | t1 /= VarT typeVar1 -> + genTraverseDownField trans t2 deepConstraint shallowConstraint fieldAccess (wrap . appE (varE 'traverse)) + SigT ty _kind -> genTraverseDownField trans ty deepConstraint shallowConstraint fieldAccess wrap + ParensT ty -> genTraverseDownField trans ty deepConstraint shallowConstraint fieldAccess wrap + _ -> (,) [] <$> [| pure $fieldAccess |] + +genTraverseUpField :: GenTraverseFieldType +genTraverseUpField trans fieldType deepConstraint shallowConstraint fieldAccess wrap = do + Just (Deriving _ typeVarN typeVar1) <- getQ + case fieldType of + AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN -> + (,) <$> ((:) <$> deepConstraint (pure con) <*> ((:[]) <$> shallowConstraint (pure con))) + <*> appE (wrap [| (>>= Transformation.traverse $trans) . traverse (Transformation.Deep.traverseUp $trans) |]) + fieldAccess + AppT ty _ | ty == VarT typeVar1 -> + (,) [] <$> (wrap (varE 'Transformation.traverse `appE` trans) `appE` fieldAccess) + AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 -> + (,) <$> ((:[]) <$> deepConstraint (pure con)) + <*> appE (wrap [| Transformation.Deep.traverseUp $trans |]) fieldAccess + AppT t1 t2 | t1 /= VarT typeVar1 -> + genTraverseUpField trans t2 deepConstraint shallowConstraint fieldAccess (wrap . appE (varE 'traverse)) + SigT ty _kind -> genTraverseUpField trans ty deepConstraint shallowConstraint fieldAccess wrap + ParensT ty -> genTraverseUpField trans ty deepConstraint shallowConstraint fieldAccess wrap + _ -> (,) [] <$> [| pure $fieldAccess |] diff --git a/src/Transformation/Rank2.hs b/src/Transformation/Rank2.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Rank2.hs @@ -0,0 +1,36 @@ +{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, + PolyKinds, RankNTypes, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} + +module Transformation.Rank2 where + +import qualified Transformation as Shallow +import qualified Transformation.Deep as Deep + +import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd) + +newtype Map p q = Map (forall x. p x -> q x) + +newtype Fold p m = Fold (forall x. p x -> m) + +newtype Traversal p q m = Traversal (forall x. p x -> m (q x)) + +instance Shallow.Functor (Map p q) p q x where + (<$>) (Map f) = f + +instance Shallow.Foldable (Fold p m) p m x where + foldMap (Fold f) = f + +instance Shallow.Traversable (Traversal p q m) p q m x where + traverse (Traversal t) = t + +(<$>) :: Deep.Functor (Map p q) g p q => (forall a. p a -> q a) -> g p p -> g q q +(<$>) f = (Deep.<$>) (Map f) + +foldMap :: (Deep.Foldable (Fold p m) g p m, Monoid m) => (forall a. p a -> m) -> g p p -> m +foldMap f = Deep.foldMap (Fold f) + +traverseDown :: Deep.DownTraversable (Traversal p q m) g p q m => (forall a. p a -> m (q a)) -> g p p -> m (g q q) +traverseDown f = Deep.traverseDown (Traversal f) + +traverseUp :: Deep.UpTraversable (Traversal p q m) g p q m => (forall a. p a -> m (q a)) -> g p p -> m (g q q) +traverseUp f = Deep.traverseUp (Traversal f) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -2,15 +2,29 @@ import Data.Either.Validation (Validation(..)) import Data.List (isSuffixOf) +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Text (Text) +import Data.Text.IO (readFile) +import Data.Text.Prettyprint.Doc (Pretty(pretty), layoutPretty, defaultLayoutOptions) +import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath.Posix (combine) +import Text.Grampa (showFailure) import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase) +import Test.Tasty.HUnit (assertFailure, assertEqual, testCase) -import Language.Oberon (parseAndResolveModuleFile) +import Language.Oberon (parseAndResolveModule) +import Language.Oberon.Pretty () +import qualified Language.Oberon.Resolver as Resolver +import Prelude hiding (readFile) + main = exampleTree "" "examples" >>= defaultMain . testGroup "Oberon" +width = 80 +contextLines = 3 + +exampleTree :: FilePath -> FilePath -> IO [TestTree] exampleTree ancestry path = do let fullPath = combine ancestry path isDir <- doesDirectoryExist fullPath @@ -18,8 +32,16 @@ then (:[]) . testGroup path . concat <$> (listDirectory fullPath >>= mapM (exampleTree fullPath)) else if ".Mod" `isSuffixOf` path then return . (:[]) . testCase path $ - do resolvedModule <- parseAndResolveModuleFile True fullPath - case resolvedModule - of Failure err -> assertFailure (show err) - Success{} -> pure () + do moduleSource <- readFile fullPath + prettyModule <- prettyFile ancestry moduleSource + prettyModule' <- prettyFile ancestry prettyModule + assertEqual "pretty" prettyModule prettyModule' else return [] + +prettyFile :: FilePath -> Text -> IO Text +prettyFile dirPath source = do + resolvedModule <- parseAndResolveModule True True dirPath source + case resolvedModule + of Failure (Resolver.UnparseableModule err :| []) -> assertFailure (showFailure source err contextLines) + Failure errs -> assertFailure (show errs) + Success mod -> return (renderStrict $ layoutPretty defaultLayoutOptions $ pretty mod)