packages feed

language-oberon 0.2 → 0.2.1

raw patch · 16 files changed

+2015/−631 lines, 16 filesdep +template-haskelldep +transformersdep ~grammatical-parsersdep ~prettyprinterdep ~rank2classes

Dependencies added: template-haskell, transformers

Dependency ranges changed: grammatical-parsers, prettyprinter, rank2classes

Files

ChangeLog.md view
@@ -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...
app/Parse.hs view
@@ -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"
examples/AGRS/OFS.Def view
@@ -1,3 +1,7 @@ DEFINITION OFS; + TYPE+  File *= RECORD END;+  Rider *= RECORD END;+ END OFS.
language-oberon.cabal view
@@ -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 <http://www.ethoberon.ethz.ch/compiler/index.html#report language reports>.@@ -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
src/Language/Oberon.hs view
@@ -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)
src/Language/Oberon/AST.hs view
@@ -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])
src/Language/Oberon/Grammar.hs view
@@ -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
src/Language/Oberon/Pretty.hs view
@@ -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]
src/Language/Oberon/Resolver.hs view
@@ -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)
+ src/Language/Oberon/TypeChecker.hs view
@@ -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])
+ src/Transformation.hs view
@@ -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
+ src/Transformation/AG.hs view
@@ -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 #-}
+ src/Transformation/Deep.hs view
@@ -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 = (<$>)
+ src/Transformation/Deep/TH.hs view
@@ -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 |]
+ src/Transformation/Rank2.hs view
@@ -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)
test/Test.hs view
@@ -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)