summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMarioBlazevic <>2019-01-27 19:55:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-01-27 19:55:00 (GMT)
commit8650136bbdb266618cbedbf5d3e0c9ed4c4bb05e (patch)
tree40f7c3a2a02b95d2f7c176577762570cbe8eddfb
parente998139c15521dca35efcb6f142cee6f13aa4bb9 (diff)
version 0.2.1HEAD0.2.1master
-rw-r--r--ChangeLog.md17
-rw-r--r--app/Parse.hs30
-rw-r--r--examples/AGRS/OFS.Def4
-rw-r--r--language-oberon.cabal23
-rw-r--r--src/Language/Oberon.hs29
-rw-r--r--src/Language/Oberon/AST.hs275
-rw-r--r--src/Language/Oberon/Grammar.hs234
-rw-r--r--src/Language/Oberon/Pretty.hs82
-rw-r--r--src/Language/Oberon/Resolver.hs632
-rw-r--r--src/Language/Oberon/TypeChecker.hs880
-rw-r--r--src/Transformation.hs23
-rw-r--r--src/Transformation/AG.hs37
-rw-r--r--src/Transformation/Deep.hs83
-rw-r--r--src/Transformation/Deep/TH.hs287
-rw-r--r--src/Transformation/Rank2.hs36
-rw-r--r--test/Test.hs34
16 files changed, 2045 insertions, 661 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 0ba165e..4ba4330 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,9 +1,22 @@
# Revision history for language-oberon
-## 0.1 -- 2018-04-08
+## 0.2.1 -- 2019-01-27
-* First version, but complete enough to be released on an unsuspecting world...
+* Pretty-printer fixes
+* Testing the idempotence of parse&pretty-print
+* Two type parameters for each AST node type, wrapping every field
+* Added the Transformation modules
+* Added the TypeChecker module
+
+## 0.2 -- 2018-07-09
+
+* Improved error reporting
+* Fixed compilation with GHC 8.0.2
## 0.1.1 -- 2018-04-08
* except for the missing Oberon module examples the test suite depends on.
+
+## 0.1 -- 2018-04-08
+
+* First version, but complete enough to be released on an unsuspecting world...
diff --git a/app/Parse.hs b/app/Parse.hs
index d02a83c..e158913 100644
--- a/app/Parse.hs
+++ b/app/Parse.hs
@@ -3,7 +3,7 @@
module Main where
import Language.Oberon (parseAndResolveModule)
-import Language.Oberon.AST (Module(..), Statement, Expression)
+import Language.Oberon.AST (Module(..), StatementSequence, Statement, Expression)
import qualified Language.Oberon.Grammar as Grammar
import qualified Language.Oberon.Resolver as Resolver
import qualified Language.Oberon.Pretty ()
@@ -30,7 +30,8 @@ import System.FilePath (FilePath, takeDirectory)
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 @@ main = execParser opts >>= main'
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 @@ main = execParser opts >>= main'
<> 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,8 +83,12 @@ main' Opts{..} =
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
@@ -127,11 +133,15 @@ succeed out contents x = either reportFailure showSuccess (validationToEither x)
Tree -> putStrLn . reprTreeString
Plain -> print
-instance Pretty (Module Ambiguous) where
+instance Pretty (Module Ambiguous Ambiguous) where
+ pretty _ = error "Disambiguate before pretty-printing"
+instance Pretty (StatementSequence Ambiguous Ambiguous) where
+ pretty _ = error "Disambiguate before pretty-printing"
+instance Pretty (Ambiguous (Statement Ambiguous Ambiguous)) where
pretty _ = error "Disambiguate before pretty-printing"
-instance Pretty (Ambiguous (Statement Ambiguous)) where
+instance Pretty (Statement Ambiguous Ambiguous) where
pretty _ = error "Disambiguate before pretty-printing"
-instance Pretty (Statement Ambiguous) where
+instance Pretty (Expression Ambiguous Ambiguous) where
pretty _ = error "Disambiguate before pretty-printing"
-instance Pretty (Expression Ambiguous) where
+instance Pretty (Ambiguous (Expression Ambiguous Ambiguous)) where
pretty _ = error "Disambiguate before pretty-printing"
diff --git a/examples/AGRS/OFS.Def b/examples/AGRS/OFS.Def
index acf9dbe..7bf2e96 100644
--- a/examples/AGRS/OFS.Def
+++ b/examples/AGRS/OFS.Def
@@ -1,3 +1,7 @@
DEFINITION OFS;
+ TYPE
+ File *= RECORD END;
+ Rider *= RECORD END;
+
END OFS. \ No newline at end of file
diff --git a/language-oberon.cabal b/language-oberon.cabal
index 9c998f5..623970e 100644
--- a/language-oberon.cabal
+++ b/language-oberon.cabal
@@ -2,8 +2,8 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: language-oberon
-version: 0.2
-synopsis: Parser and pretty-printer for the Oberon programming language
+version: 0.2.1
+synopsis: Parser, pretty-printer, and type checker for the Oberon programming language
description:
The library and the executable support both the original Oberon and the Oberon-2 programming language, as described
in the respective <http://www.ethoberon.ethz.ch/compiler/index.html#report language reports>.
@@ -23,7 +23,7 @@ license: GPL-3
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 @@ library
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 @@ executable parse
-- other-modules:
other-extensions: RankNTypes, RecordWildCards, ScopedTypeVariables, FlexibleInstances, DeriveDataTypeable
build-depends: base >= 4.7 && < 5, text < 1.3, either == 5.*, containers >= 0.5 && < 1.0,
- repr-tree-syb < 0.2, filepath < 1.5, prettyprinter >= 1 && < 1.3,
- rank2classes < 1.2, grammatical-parsers >= 0.3.1 && < 0.4, language-oberon,
+ repr-tree-syb < 0.2, filepath < 1.5, prettyprinter >= 1.2.1 && < 1.3,
+ rank2classes < 1.3, grammatical-parsers > 0.3.1 && < 0.4, language-oberon,
optparse-applicative
default-language: Haskell2010
test-suite examples
type: exitcode-stdio-1.0
- build-depends: base >= 4.7 && < 5,
- either == 5.*, directory < 2, filepath < 1.5,
+ build-depends: base >= 4.7 && < 5, text < 1.3, grammatical-parsers > 0.3.1 && < 0.4,
+ either == 5.*, directory < 2, filepath < 1.5, prettyprinter >= 1.2.1 && < 1.3,
tasty >= 0.7, tasty-hunit,
language-oberon
main-is: test/Test.hs
diff --git a/src/Language/Oberon.hs b/src/Language/Oberon.hs
index 1b24067..82f19ee 100644
--- a/src/Language/Oberon.hs
+++ b/src/Language/Oberon.hs
@@ -5,7 +5,9 @@ module Language.Oberon (parseModule, parseAndResolveModule, parseAndResolveModul
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 System.FilePath (FilePath, addExtension, combine, takeDirectory)
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 @@ parseNamedModule oberon2 path name =
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 @@ parseImportsOf oberon2 path modules =
-- | Given a directory path for module imports, parse the given module text and all the module files it imports, then
-- use all the information to resolve the syntactic ambiguities.
-parseAndResolveModule :: Bool -> FilePath -> Text -> IO (Validation (NonEmpty Resolver.Error) (Module Identity))
-parseAndResolveModule oberon2 path source =
+parseAndResolveModule :: Bool -> Bool -> FilePath -> Text
+ -> IO (Validation (NonEmpty Resolver.Error) (Module Identity Identity))
+parseAndResolveModule checkTypes oberon2 path source =
case parseModule oberon2 source
of Left err -> return (Failure $ Resolver.UnparseableModule err :| [])
Right [rootModule@(Module moduleName imports _ _ _)] ->
do importedModules <- parseImportsOf oberon2 path (Map.singleton moduleName rootModule)
let resolvedImportMap = Resolver.resolveModule predefinedScope resolvedImportMap <$> importedModules
predefinedScope = if oberon2 then Resolver.predefined2 else Resolver.predefined
- return $ Resolver.resolveModule predefinedScope resolvedImportMap rootModule
+ successful (Success a) = Just a
+ successful _ = Nothing
+ typeErrors = TypeChecker.checkModules
+ (if oberon2 then TypeChecker.predefined2 else TypeChecker.predefined)
+ (Map.mapMaybe successful resolvedImportMap)
+ when (checkTypes && not (null typeErrors)) (error $ show typeErrors)
+ return $ resolvedImportMap Map.! moduleName
Right _ -> return (Failure $ Resolver.AmbiguousParses :| [])
-- | Parse the module file at the given path, assuming all its imports are in the same directory.
-parseAndResolveModuleFile :: Bool -> FilePath -> IO (Validation (NonEmpty Resolver.Error) (Module Identity))
-parseAndResolveModuleFile oberon2 path = readFile path >>= parseAndResolveModule oberon2 (takeDirectory path)
+parseAndResolveModuleFile :: Bool -> Bool -> FilePath
+ -> IO (Validation (NonEmpty Resolver.Error) (Module Identity Identity))
+parseAndResolveModuleFile checkTypes oberon2 path =
+ readFile path >>= parseAndResolveModule checkTypes oberon2 (takeDirectory path)
diff --git a/src/Language/Oberon/AST.hs b/src/Language/Oberon/AST.hs
index fe7c7c9..0610748 100644
--- a/src/Language/Oberon/AST.hs
+++ b/src/Language/Oberon/AST.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances, StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances,
+ StandaloneDeriving, TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
-- | Oberon Abstract Syntax Tree definitions
@@ -7,28 +9,33 @@ module Language.Oberon.AST where
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 @@ data AccessMode = Exported | ReadOnly | PrivateOnly
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)
-
-deriving instance (Typeable f, Data (f (Designator f))) => Data (Expression f)
-deriving instance Show (f (Designator f)) => Show (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, 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 BaseType = QualIdent
-type FieldListSequence f = NonEmpty (FieldList f)
+data FieldList f' f = FieldList IdentList (f (Type f' f'))
+ | EmptyFieldList
-data FieldList f = FieldList IdentList (Type 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)
-
-deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f))) => Data (ProcedureHeading f)
-deriving instance (Show (f (Designator f)), Show (f (Expression f))) => Show (ProcedureHeading f)
-
-deriving instance (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, Data (f (Designator f)), Data (f (Expression f))) => Data (FPSection f)
-deriving instance (Show (f (Designator f)), Show (f (Expression f))) => Show (FPSection f)
-
-data ProcedureBody f = ProcedureBody [Declaration f] (Maybe (StatementSequence f))
-
-deriving instance (Typeable f, Data (f (Designator f)), Data (f (Expression f)), Data (f (Statement f))) =>
- Data (ProcedureBody f)
-deriving instance (Show (f (Designator f)), Show (f (Expression f)), Show (f (Statement f))) => Show (ProcedureBody f)
-
-type StatementSequence f = NonEmpty (f (Statement f))
-
-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))
-
-deriving instance (Typeable f, Data (f (Designator f)), Data (f (Statement f))) => Data (Statement f)
-deriving instance (Show (f (Designator f)), Show (f (Statement f))) => Show (Statement f)
-
-data WithAlternative f = WithAlternative QualIdent QualIdent (StatementSequence f)
-
-data Case f = Case (NonEmpty (CaseLabels f)) (StatementSequence f)
- | EmptyCase
-
-data CaseLabels f = SingleLabel (ConstExpression f)
- | LabelRange (ConstExpression f) (ConstExpression 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)
-
-deriving instance (Typeable f, Data (f (Designator f)), Data (f (Statement f))) => Data (Case f)
-deriving instance (Show (f (Designator f)), Show (f (Statement f))) => Show (Case f)
-
-deriving instance (Typeable f, Data (f (Designator f))) => Data (CaseLabels f)
-deriving instance Show (f (Designator f)) => Show (CaseLabels 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)
+
+data FPSection f' f = FPSection Bool (NonEmpty Ident) (f (Type f' 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, 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)
+
+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)
+
+data ProcedureBody f' f = ProcedureBody [f (Declaration f' f')] (Maybe (f (StatementSequence f' 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)
+
+newtype StatementSequence f' f = StatementSequence (NonEmpty (f (Statement f' 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 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')))
+
+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 WithAlternative f' f = WithAlternative QualIdent QualIdent (f (StatementSequence f' f'))
+
+data Case f' f = Case (NonEmpty (f (CaseLabels f' f'))) (f (StatementSequence f' f'))
+ | EmptyCase
+
+data CaseLabels f' f = SingleLabel (f (ConstExpression f' f'))
+ | LabelRange (f (ConstExpression f' f')) (f (ConstExpression f' f'))
+
+deriving instance (Typeable f, Typeable f', Data (f (Designator f' f')), Data (f (StatementSequence f' f'))) =>
+ Data (WithAlternative f' f)
+deriving instance (Show (f (StatementSequence f' f'))) => Show (WithAlternative f' f)
+
+deriving instance (Typeable f, Typeable f', Data (f (CaseLabels f' f')), Data (f (StatementSequence f' f'))) =>
+ Data (Case f' f)
+deriving instance (Show (f (CaseLabels f' f')), Show (f (StatementSequence f' f'))) => Show (Case f' f)
+
+deriving instance (Typeable f, Typeable f', Data (f (ConstExpression f' f'))) => Data (CaseLabels f' f)
+deriving instance Show (f (ConstExpression f' f')) => Show (CaseLabels f' f)
+
+$(mconcat <$> mapM Transformation.Deep.TH.deriveAll
+ [''Module, ''Declaration, ''Type, ''Expression,
+ ''Element, ''Designator, ''FieldList,
+ ''ProcedureHeading, ''FormalParameters, ''FPSection, ''ProcedureBody,
+ ''Statement, ''StatementSequence, ''WithAlternative, ''Case, ''CaseLabels])
diff --git a/src/Language/Oberon/Grammar.hs b/src/Language/Oberon/Grammar.hs
index 946e19f..8ad22c5 100644
--- a/src/Language/Oberon/Grammar.hs
+++ b/src/Language/Oberon/Grammar.hs
@@ -18,6 +18,7 @@ import Text.Grampa.ContextFree.LeftRecursive (Parser)
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 @@ import Prelude hiding (length, takeWhile)
-- | 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 @@ grammar2 g@OberonGrammar{..} = g1{
((,,) <$> (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 @@ grammar OberonGrammar{..} = OberonGrammar{
<|> 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,70 +223,74 @@ grammar OberonGrammar{..} = OberonGrammar{
<|> 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
delimiter, operator :: Text -> Parser (OberonGrammar f) Text Text
diff --git a/src/Language/Oberon/Pretty.hs b/src/Language/Oberon/Pretty.hs
index 02b2746..e8230e3 100644
--- a/src/Language/Oberon/Pretty.hs
+++ b/src/Language/Oberon/Pretty.hs
@@ -8,12 +8,14 @@ module Language.Oberon.Pretty () where
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 @@ instance Pretty (Module Identity) where
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 @@ instance Pretty IdentDef where
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 @@ instance Pretty RelOp where
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 @@ instance Pretty QualIdent where
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 @@ instance Pretty (ProcedureHeading Identity) where
<> 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 @@ instance Pretty (Statement Identity) where
: (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 @@ instance Pretty (Statement Identity) where
pretty Exit = "EXIT"
pretty (Return result) = "RETURN" <+> foldMap pretty result
-instance Pretty (Case Identity) where
- pretty (Case labels body) = vsep ["|" <+> pretty labels <+> colon,
+instance Pretty (Case Identity Identity) where
+ pretty (Case labels body) = vsep [hsep (punctuate comma (pretty <$> toList labels)) <+> colon,
prettyBlock body]
pretty EmptyCase = mempty
-instance Pretty (WithAlternative Identity) where
+instance Pretty (WithAlternative Identity Identity) where
pretty (WithAlternative name t body) = vsep [pretty name <+> colon <+> pretty t <+> "DO",
prettyBlock body]
-instance Pretty (CaseLabels Identity) where
+instance Pretty (CaseLabels Identity Identity) where
pretty (SingleLabel expression) = pretty expression
pretty (LabelRange from to) = pretty from <+> ".." <+> pretty to
-prettyBlock statements = indent 3 (pretty $ runIdentity <$> statements)
+prettyBlock :: Identity (StatementSequence Identity Identity) -> Doc ann
+prettyBlock (Identity (StatementSequence statements)) = indent 3 (pretty $ runIdentity <$> statements)
+
a <#> b = vsep [a, b]
diff --git a/src/Language/Oberon/Resolver.hs b/src/Language/Oberon/Resolver.hs
index a2b8977..c83f893 100644
--- a/src/Language/Oberon/Resolver.hs
+++ b/src/Language/Oberon/Resolver.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses,
+ OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
-- | This module exports functions for resolving the syntactic ambiguities in a parsed module. For example, an Oberon
-- expression @foo(bar)@ may be a call to function @foo@ with a parameter @bar@, or it may be type guard on variable
@@ -9,8 +11,10 @@ module Language.Oberon.Resolver (Error(..),
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 Data.Map.Lazy (Map, traverseWithKey)
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 = Scope
+
+data Resolution = Resolution{_modules :: Map Ident Scope}
+
+type Resolved = StateT (Scope, ResolutionState) (Validation (NonEmpty Error))
+
+data ResolutionState = ModuleState
+ | DeclarationState
+ | StatementState
+ | ExpressionState
+ | ExpressionOrTypeState
+ deriving (Eq, Show)
+
+instance Monad (Validation (NonEmpty Error)) where
+ Success s >>= f = f s
+ Failure errors >>= _ = Failure errors
+
+instance Shallow.Functor Resolution Ambiguous Resolved (Module Resolved Resolved) where
+ (<$>) = mapResolveDefault
+
+instance {-# overlappable #-} Show (g Identity Identity) =>
+ Shallow.Traversable Resolution Ambiguous Identity Resolved (g Identity Identity) where
+ traverse = traverseResolveDefault
+
+instance {-# overlappable #-} Show (g Ambiguous Ambiguous) =>
+ Shallow.Traversable Resolution Ambiguous Identity Resolved (g Ambiguous Ambiguous) where
+ traverse = traverseResolveDefault
+
+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 :| [])
+
+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)
+
+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)
+
+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)
+
+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)
+
+mapResolveDefault :: Resolution -> Ambiguous (g Resolved Resolved) -> Resolved (g Resolved Resolved)
+mapResolveDefault Resolution{} (Ambiguous (x :| [])) = pure x
+mapResolveDefault Resolution{} _ = StateT (const $ Failure $ pure AmbiguousParses)
+
+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 :: 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{} | state /= ExpressionOrTypeState -> Failure (NotAValue q :| [])
+ Success _ -> Success (Variable q)
+ 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 q =
+ case resolveName res scope q
+ of Failure err -> Failure err
+ Success DeclaredType{} -> Success q
+ Success _ -> Failure (NotAType q :| [])
--- | A set of 'Predefined' declarations.
-type Predefined = Map Ident (Validation (NonEmpty Error) (DeclarationRHS Identity))
+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 :| [])
--- | 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 :: 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
--- | 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
-
- module' = Module moduleName imports
- <$> traverse (resolveDeclaration moduleGlobalScope) declarations
- <*> traverse (resolveStatements moduleGlobalScope) body
- <*> pure name'
+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
- moduleGlobals = (resolveBinding moduleGlobalScope <$>)
- <$> Map.fromList (concatMap (declarationBinding moduleName) declarations)
- moduleGlobalScope = Map.union (snd <$> moduleGlobals) predefinedScope
-
- 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
-
- 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
-
- resolveFields scope (FieldList names fieldType) = FieldList names <$> resolveType scope fieldType
- resolveFields scope EmptyFieldList = pure EmptyFieldList
-
- resolveParameters scope (FormalParameters sections result) =
- FormalParameters <$> traverse resolveSection sections <*> pure result
- where resolveSection (FPSection var names t) = FPSection var names <$> resolveType scope t
-
- resolveStatements scope = traverse (fmap Identity . resolveOne)
- where resolveOne :: Ambiguous (Statement Ambiguous) -> Validation (NonEmpty Error) (Statement Identity)
- resolveOne (Ambiguous statements) = uniqueStatement (resolveStatement scope <$> statements)
-
- 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
-
- 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
-
- resolveExpressionOrType scope (Read (Ambiguous designators)) =
- Read . Identity <$> uniqueDesignator (resolveDesignatorOrType scope <$> designators)
- resolveExpressionOrType scope e = resolveExpression scope e
-
- resolveDesignatorOrType scope (Variable q)
- | Success DeclaredType{} <- resolveName scope q = Success (Variable q)
- resolveDesignatorOrType scope e = resolveDesignator scope e
-
- resolveElement scope (Element e) = Element <$> resolveExpression scope e
- resolveElement scope (Range left right) =
- Range <$> resolveExpression scope left <*> resolveExpression scope right
-
- resolveDesignator scope (Variable q) =
- case resolveName scope q
- of Failure err -> Failure err
- Success DeclaredType{} -> 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
-
- resolveTypeName scope q =
- case resolveName 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
-
- 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
-
- 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
-
- resolveArray = resolveDesignator
- resolvePointer = resolveDesignator
-
- 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))]
+ moduleGlobalScope = localScope res moduleName declarations predefined
+
+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)
+
+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 @@ declarationBinding _ (ForwardDeclaration (IdentDef name export) parameters) =
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
+ [("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)])
-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
-
-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
-
-uniqueDesignator = unique InvalidDesignator AmbiguousDesignator
-uniqueExpression = unique InvalidExpression AmbiguousExpression
-uniqueStatement = unique InvalidStatement AmbiguousStatement
-
-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 :| [])
+globalsOfModule :: Module Identity Identity -> Map Ident (AccessMode, DeclarationRHS Identity Identity)
+globalsOfModule (Module name imports declarations _ _) =
+ Map.fromList (concatMap (declarationBinding name . runIdentity) declarations)
+
+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 :| [])
+
+$(Rank2.TH.deriveFunctor ''DeclarationRHS)
+$(Rank2.TH.deriveFoldable ''DeclarationRHS)
+$(Rank2.TH.deriveTraversable ''DeclarationRHS)
+$(Transformation.Deep.TH.deriveDownTraversable ''DeclarationRHS)
diff --git a/src/Language/Oberon/TypeChecker.hs b/src/Language/Oberon/TypeChecker.hs
new file mode 100644
index 0000000..e8bdd1e
--- /dev/null
+++ b/src/Language/Oberon/TypeChecker.hs
@@ -0,0 +1,880 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings,
+ TemplateHaskell, TypeFamilies, UndecidableInstances #-}
+
+module Language.Oberon.TypeChecker (Error(..), checkModules, predefined, predefined2) where
+
+import Control.Applicative (liftA2)
+import Control.Arrow (first)
+import Data.Coerce (coerce)
+import Data.Either (partitionEithers)
+import Data.Either.Validation (Validation(..), validationToEither)
+import Data.Foldable (toList)
+import Data.Functor.Identity (Identity(..))
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.List as List
+import Data.Maybe (fromMaybe)
+import Data.Map.Lazy (Map)
+import qualified Data.Map.Lazy as Map
+import Data.Semigroup (Semigroup(..), sconcat)
+import qualified Data.Text as Text
+
+import qualified Rank2
+import qualified Rank2.TH
+import qualified Transformation as Shallow
+import qualified Transformation.Deep as Deep
+import qualified Transformation.AG as AG
+import Transformation.AG (Attribution(..), Atts, Inherited(..), Synthesized(..), Semantics)
+
+import qualified Language.Oberon.AST as AST
+
+import Debug.Trace
+
+data Type = NominalType AST.QualIdent (Maybe Type)
+ | RecordType{ancestry :: [AST.QualIdent],
+ recordFields :: Map AST.Ident Type}
+ | NilType
+ | IntegerType Int
+ | StringType Int
+ | ArrayType [Int] Type
+ | PointerType Type
+ | ProcedureType [(Bool, Type)] (Maybe Type)
+ | UnknownType
+
+data Error = TypeMismatch Type Type
+ | ArgumentCountMismatch Int Int
+ | DuplicateBinding AST.Ident
+ | ExtraDimensionalIndex Type
+ | TooSmallArrayType Type
+ | OpenArrayVariable
+ | NonArrayType Type
+ | NonBooleanType Type
+ | NonFunctionType Type
+ | NonIntegerType Type
+ | NonNumericType Type
+ | NonPointerType Type
+ | NonProcedureType Type
+ | NonRecordType Type
+ | UnequalTypes Type Type
+ | UnrealType Type
+ | UnknownName AST.QualIdent
+ | UnknownField AST.Ident Type
+ deriving Show
+
+instance Eq Type where
+ NominalType q1 _ == NominalType q2 _ = q1 == q2
+ ArrayType [] t1 == ArrayType [] t2 = t1 == t2
+ ProcedureType p1 r1 == ProcedureType p2 r2 = r1 == r2 && p1 == p2
+ StringType len1 == StringType len2 = len1 == len2
+ NilType == NilType = True
+ _ == _ = False
+
+instance Show Type where
+ show (NominalType q t) = "Nominal " ++ show q ++ " " ++ show t
+ show (RecordType ancestry fields) = "RecordType " ++ show ancestry ++ show (fst <$> Map.toList fields)
+ show (ArrayType dimensions itemType) = "ArrayType " ++ show dimensions ++ " " ++ show itemType
+ show (PointerType targetType) = "PointerType " ++ show targetType
+ show (ProcedureType parameters result) = "ProcedureType " ++ show parameters ++ " " ++ show result
+ show (IntegerType n) = "IntegerType " ++ show n
+ show (StringType len) = "StringType " ++ show len
+ show NilType = "NilType"
+ show UnknownType = "UnknownType"
+
+type Environment = Map AST.QualIdent Type
+
+newtype Modules f' f = Modules (Map AST.Ident (f (AST.Module f' f')))
+
+data TypeCheck = TypeCheck
+
+data InhTC = InhTC{env :: Environment} deriving Show
+
+data SynTC = SynTC{errors :: [Error]} deriving Show
+
+data SynTC' = SynTC'{errors' :: [Error],
+ env' :: Environment} deriving Show
+
+data SynTCMod = SynTCMod{moduleErrors :: [Error],
+ moduleEnv :: Environment,
+ pointerTargets :: Map AST.Ident AST.Ident} deriving Show
+
+data SynTCType = SynTCType{typeErrors :: [Error],
+ typeName :: Maybe AST.Ident,
+ definedType :: Type,
+ pointerTarget :: Maybe AST.Ident} deriving Show
+
+data SynTCFields = SynTCFields{fieldErrors :: [Error],
+ fieldEnv :: Map AST.Ident Type} deriving Show
+
+data SynTCSig = SynTCSig{signatureErrors :: [Error],
+ signatureEnv :: Environment,
+ signatureType :: Type} deriving Show
+
+data SynTCSec = SynTCSec{sectionErrors :: [Error],
+ sectionEnv :: Environment,
+ sectionParameters :: [(Bool, Type)]} deriving Show
+
+data SynTCDes = SynTCDes{designatorErrors :: [Error],
+ designatorSelf :: AST.Designator Identity Identity,
+ designatorType :: Type} deriving Show
+
+data SynTCExp = SynTCExp{expressionErrors :: [Error],
+ inferredType :: Type} deriving Show
+
+-- * Modules instances, TH candidates
+instance (Functor p, Deep.Functor t AST.Module p q, Shallow.Functor t p q (AST.Module q q)) =>
+ Deep.Functor t Modules p q where
+ t <$> ~(Modules ms) = Modules (mapModule <$> ms)
+ where mapModule m = t Shallow.<$> ((t Deep.<$>) <$> m)
+
+instance Rank2.Functor (Modules f') where
+ f <$> ~(Modules ms) = Modules (f <$> ms)
+
+instance Rank2.Apply (Modules f') where
+ ~(Modules fs) <*> ~(Modules ms) = Modules (Map.intersectionWith Rank2.apply fs ms)
+
+-- * Boring attribute types
+type instance Atts (Inherited TypeCheck) (Modules f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (Modules f' f) = SynTC
+type instance Atts (Inherited TypeCheck) (AST.Module f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.Module f' f) = SynTCMod
+type instance Atts (Inherited TypeCheck) (AST.Declaration f' f) = (InhTC, Map AST.Ident AST.Ident)
+type instance Atts (Synthesized TypeCheck) (AST.Declaration f' f) = SynTCMod
+type instance Atts (Inherited TypeCheck) (AST.FormalParameters f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.FormalParameters f' f) = SynTCSig
+type instance Atts (Inherited TypeCheck) (AST.FPSection f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.FPSection f' f) = SynTCSec
+type instance Atts (Inherited TypeCheck) (AST.Type f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.Type f' f) = SynTCType
+type instance Atts (Inherited TypeCheck) (AST.FieldList f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.FieldList f' f) = SynTCFields
+type instance Atts (Inherited TypeCheck) (AST.StatementSequence f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.StatementSequence f' f) = SynTC
+type instance Atts (Inherited TypeCheck) (AST.Expression f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.Expression f' f) = SynTCExp
+type instance Atts (Inherited TypeCheck) (AST.Element f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.Element f' f) = SynTCExp
+type instance Atts (Inherited TypeCheck) (AST.Designator f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.Designator f' f) = SynTCDes
+type instance Atts (Inherited TypeCheck) (Deep.Product AST.Expression AST.StatementSequence f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (Deep.Product AST.Expression AST.StatementSequence f' f) = SynTC
+type instance Atts (Inherited TypeCheck) (AST.Statement f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.Statement f' f) = SynTC
+type instance Atts (Inherited TypeCheck) (AST.Case f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.Case f' f) = SynTC
+type instance Atts (Inherited TypeCheck) (AST.CaseLabels f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.CaseLabels f' f) = SynTC
+type instance Atts (Inherited TypeCheck) (AST.WithAlternative f' f) = InhTC
+type instance Atts (Synthesized TypeCheck) (AST.WithAlternative f' f) = SynTC
+
+-- * Rules
+
+instance Attribution TypeCheck Modules where
+ attribution TypeCheck (Modules self) (inherited, Modules ms) =
+ (Synthesized SynTC{errors= foldMap (moduleErrors . syn) ms},
+ Modules (Inherited InhTC{env= env (inh inherited) <> foldMap (moduleEnv . syn) ms} <$ self))
+
+instance Attribution TypeCheck AST.Module where
+ attribution TypeCheck (AST.Module ident1 imports decls body ident2) (inherited, AST.Module _ _ decls' body' _) =
+ (Synthesized SynTCMod{moduleErrors= foldMap (moduleErrors . syn) decls' <> foldMap (errors . syn) body',
+ moduleEnv= exportedEnv,
+ pointerTargets= pointers},
+ AST.Module ident1 imports [Inherited (localEnv, pointers)] (Inherited localEnv <$ body) ident2)
+ where exportedEnv = exportNominal <$> Map.mapKeysMonotonic export newEnv
+ newEnv = Map.unionsWith mergeTypeBoundProcedures (moduleEnv . syn <$> decls')
+ localEnv = InhTC (newEnv `Map.union` env (inh inherited))
+ export (AST.NonQualIdent name) = AST.QualIdent ident1 name
+ export q = q
+ exportNominal (NominalType (AST.NonQualIdent name) t) =
+ NominalType (AST.QualIdent ident1 name) (exportNominal' <$> t)
+ exportNominal t = exportNominal' t
+ exportNominal' (RecordType ancestry fields) = RecordType (export <$> ancestry) (exportNominal' <$> fields)
+ exportNominal' (ProcedureType parameters result) =
+ ProcedureType ((exportNominal' <$>) <$> parameters) (exportNominal' <$> result)
+ exportNominal' (PointerType target) = PointerType (exportNominal' target)
+ exportNominal' (ArrayType dimensions itemType) = ArrayType dimensions (exportNominal' itemType)
+ exportNominal' (NominalType q@(AST.NonQualIdent name) (Just t)) =
+ fromMaybe (NominalType (AST.QualIdent ident1 name) $ Just $ exportNominal' t) (Map.lookup q exportedEnv)
+ exportNominal' t = t
+ pointers= foldMap (pointerTargets . syn) decls'
+ mergeTypeBoundProcedures' t1 t2 = mergeTypeBoundProcedures t1 t2
+ mergeTypeBoundProcedures (NominalType (AST.NonQualIdent "") (Just t1)) t2 = mergeTypeBoundProcedures t1 t2
+ mergeTypeBoundProcedures (NominalType q (Just t1)) t2 = NominalType q (Just $ mergeTypeBoundProcedures t1 t2)
+ mergeTypeBoundProcedures t1 (NominalType (AST.NonQualIdent "") (Just t2)) = mergeTypeBoundProcedures t1 t2
+ mergeTypeBoundProcedures t1 (NominalType q (Just t2)) = NominalType q (Just $ mergeTypeBoundProcedures t1 t2)
+ mergeTypeBoundProcedures (RecordType ancestry1 fields1) (RecordType ancestry2 fields2) =
+ RecordType (ancestry1 <> ancestry2) (fields1 <> fields2)
+ mergeTypeBoundProcedures (PointerType (RecordType ancestry1 fields1)) (RecordType ancestry2 fields2) =
+ PointerType (RecordType (ancestry1 <> ancestry2) (fields1 <> fields2))
+ mergeTypeBoundProcedures (RecordType ancestry1 fields1) (PointerType (RecordType ancestry2 fields2)) =
+ PointerType (RecordType (ancestry1 <> ancestry2) (fields1 <> fields2))
+ mergeTypeBoundProcedures t1 t2 = error (take 90 $ show t1)
+
+instance Attribution TypeCheck AST.Declaration where
+ attribution TypeCheck (AST.ConstantDeclaration namedef@(AST.IdentDef name _) _)
+ (inherited, AST.ConstantDeclaration _ expression) =
+ (Synthesized SynTCMod{moduleErrors= expressionErrors (syn expression),
+ moduleEnv= Map.singleton (AST.NonQualIdent name) (inferredType $ syn expression),
+ pointerTargets= mempty},
+ AST.ConstantDeclaration namedef (Inherited $ fst $ inh inherited))
+ attribution TypeCheck (AST.TypeDeclaration namedef@(AST.IdentDef name _) _) (inherited,
+ AST.TypeDeclaration _ definition) =
+ (Synthesized SynTCMod{moduleErrors= typeErrors (syn definition),
+ moduleEnv= Map.singleton qname (nominal $ definedType $ syn definition),
+ pointerTargets= foldMap (Map.singleton name) (pointerTarget $ syn definition)},
+ AST.TypeDeclaration namedef (Inherited $ fst $ inh inherited))
+ where nominal t@NominalType{} = t
+ nominal t = NominalType qname (Just t)
+ qname = AST.NonQualIdent name
+ attribution TypeCheck (AST.VariableDeclaration names _declaredType)
+ (inherited, AST.VariableDeclaration _names declaredType) =
+ (Synthesized SynTCMod{moduleErrors= typeErrors (syn declaredType)
+ <> case definedType (syn declaredType)
+ of ArrayType [] _ -> [OpenArrayVariable]
+ _ -> [],
+ moduleEnv= foldMap (\name-> Map.singleton (AST.NonQualIdent $ defName name)
+ (definedType $ syn declaredType))
+ names,
+ pointerTargets= mempty},
+ AST.VariableDeclaration names (Inherited $ fst $ inh inherited))
+ where defName (AST.IdentDef name _) = name
+ attribution TypeCheck (AST.ProcedureDeclaration (AST.ProcedureHeading receiver indirect
+ namedef@(AST.IdentDef name _) signature)
+ _body name')
+ (inherited,
+ AST.ProcedureDeclaration (AST.ProcedureHeading _receiver _indirect _ signature')
+ body@(AST.ProcedureBody declarations statements) _name') =
+ (Synthesized SynTCMod{moduleErrors= foldMap (signatureErrors . syn) signature',
+ moduleEnv= case receiver
+ of Just (_, _, typeName)
+ | Just targetName <- Map.lookup typeName (snd $ inh inherited) ->
+ Map.singleton (AST.NonQualIdent targetName) methodType
+ | otherwise -> Map.singleton (AST.NonQualIdent typeName) methodType
+
+ Nothing -> Map.singleton (AST.NonQualIdent name) procedureType,
+ pointerTargets= mempty},
+ AST.ProcedureDeclaration
+ (AST.ProcedureHeading receiver indirect namedef (Inherited (fst $ inh inherited) <$ signature))
+ (AST.ProcedureBody [Inherited (localInherited, mempty)] (Inherited localInherited <$ statements))
+ name')
+ where receiverEnv (_, formalName, typeName) =
+ foldMap (Map.singleton $ AST.NonQualIdent formalName) (Map.lookup (AST.NonQualIdent typeName)
+ $ env $ fst $ inh inherited)
+ methodType = NominalType (AST.NonQualIdent "") (Just $ RecordType [] $ Map.singleton name procedureType)
+ procedureType = maybe (ProcedureType [] Nothing) (signatureType . syn) signature'
+ receiverError (_, formalName, typeName) =
+ case Map.lookup (AST.NonQualIdent typeName) (env $ fst $ inh inherited)
+ of Nothing -> [UnknownName $ AST.NonQualIdent typeName]
+ Just RecordType{} -> []
+ Just (PointerType RecordType{}) -> []
+ Just (NominalType _ (Just RecordType{})) -> []
+ Just (NominalType _ (Just (PointerType RecordType{}))) -> []
+ Just t -> [NonRecordType t]
+ localInherited = InhTC (foldMap receiverEnv receiver
+ `Map.union` foldMap (signatureEnv . syn) signature'
+ `Map.union` env (fst $ inh inherited))
+ attribution TypeCheck (AST.ForwardDeclaration namedef@(AST.IdentDef name _) signature)
+ (inherited, AST.ForwardDeclaration _namedef signature') =
+ (Synthesized SynTCMod{moduleErrors= foldMap (signatureErrors . syn) signature',
+ moduleEnv= foldMap (Map.singleton (AST.NonQualIdent name) . signatureType . syn) signature',
+ pointerTargets= mempty},
+ AST.ForwardDeclaration namedef (Inherited (fst $ inh inherited) <$ signature))
+
+instance Attribution TypeCheck AST.FormalParameters where
+ attribution TypeCheck (AST.FormalParameters sections returnType)
+ (inherited, AST.FormalParameters sections' _returnType) =
+ (Synthesized SynTCSig{signatureErrors= foldMap (sectionErrors . syn) sections' <> foldMap typeRefErrors returnType,
+ signatureType= ProcedureType (foldMap (sectionParameters . syn) sections')
+ $ returnType >>= (`Map.lookup` env (inh inherited)),
+ signatureEnv= foldMap (sectionEnv . syn) sections'},
+ AST.FormalParameters (pure $ Inherited $ inh inherited) returnType)
+ where typeRefErrors q
+ | Map.member q (env $ inh inherited) = []
+ | otherwise = [UnknownName q]
+
+instance Attribution TypeCheck AST.FPSection where
+ attribution TypeCheck (AST.FPSection var names _typeDef) (inherited, AST.FPSection _var _names typeDef) =
+ (Synthesized SynTCSec{sectionErrors= typeErrors (syn typeDef),
+ sectionParameters= (var, definedType (syn typeDef)) <$ toList names,
+ sectionEnv= Map.fromList (toList
+ $ flip (,) (definedType $ syn typeDef) . AST.NonQualIdent
+ <$> names)},
+ AST.FPSection var names (Inherited $ inh inherited))
+
+instance Attribution TypeCheck AST.Type where
+ attribution TypeCheck (AST.TypeReference q) (inherited, _) =
+ (Synthesized SynTCType{typeErrors= if Map.member q (env $ inh inherited) then [] else [UnknownName q],
+ typeName= case q
+ of AST.NonQualIdent name -> Just name
+ _ -> Nothing,
+ pointerTarget= Nothing,
+ definedType= fromMaybe UnknownType (Map.lookup q $ env $ inh inherited)},
+ AST.TypeReference q)
+ attribution TypeCheck (AST.ArrayType dimensions _itemType) (inherited, AST.ArrayType dimensions' itemType) =
+ (Synthesized SynTCType{typeErrors= foldMap (expressionErrors . syn) dimensions' <> typeErrors (syn itemType)
+ <> foldMap (expectInteger . syn) dimensions',
+ typeName= Nothing,
+ pointerTarget= Nothing,
+ definedType= ArrayType (integerValue . syn <$> dimensions') (definedType $ syn itemType)},
+ AST.ArrayType [Inherited (inh inherited)] (Inherited $ inh inherited))
+ where expectInteger SynTCExp{inferredType= IntegerType{}} = []
+ expectInteger SynTCExp{inferredType= t} = [NonIntegerType t]
+ integerValue SynTCExp{inferredType= IntegerType n} = n
+ integerValue _ = 0
+ attribution TypeCheck (AST.RecordType base fields) (inherited, AST.RecordType _base fields') =
+ (Synthesized SynTCType{typeErrors= fst baseRecord <> foldMap (fieldErrors . syn) fields',
+ typeName= Nothing,
+ pointerTarget= Nothing,
+ definedType= RecordType (maybe [] (maybe id (:) base . ancestry) $ snd baseRecord)
+ (maybe Map.empty recordFields (snd baseRecord)
+ <> foldMap (fieldEnv . syn) fields')},
+ AST.RecordType base (pure $ Inherited $ inh inherited))
+ where baseRecord = case flip Map.lookup (env $ inh inherited) <$> base
+ of Just (Just t@RecordType{}) -> ([], Just t)
+ Just (Just (NominalType _ (Just t@RecordType{}))) -> ([], Just t)
+ Just (Just t) -> ([NonRecordType t], Nothing)
+ Just Nothing -> (foldMap ((:[]) . UnknownName) base, Nothing)
+ Nothing -> ([], Nothing)
+ attribution TypeCheck _self (inherited, AST.PointerType targetType') =
+ (Synthesized SynTCType{typeErrors= typeErrors (syn targetType'),
+ typeName= Nothing,
+ pointerTarget= typeName (syn targetType'),
+ definedType= PointerType (definedType $ syn targetType')},
+ AST.PointerType (Inherited $ inh inherited))
+ attribution TypeCheck (AST.ProcedureType signature) (inherited, AST.ProcedureType signature') =
+ (Synthesized SynTCType{typeErrors= foldMap (signatureErrors . syn) signature',
+ typeName= Nothing,
+ pointerTarget= Nothing,
+ definedType= maybe (ProcedureType [] Nothing) (signatureType . syn) signature'},
+ AST.ProcedureType (Inherited (inh inherited) <$ signature))
+
+instance Attribution TypeCheck AST.FieldList where
+ attribution TypeCheck (AST.FieldList names _declaredType) (inherited, AST.FieldList _names declaredType) =
+ (Synthesized SynTCFields{fieldErrors= typeErrors (syn declaredType),
+ fieldEnv= foldMap (\name-> Map.singleton (defName name) (definedType $ syn declaredType))
+ names},
+ AST.FieldList names (Inherited $ inh inherited))
+ where defName (AST.IdentDef name _) = name
+ attribution TypeCheck self (inherited, AST.EmptyFieldList) =
+ (Synthesized SynTCFields{fieldErrors= [], fieldEnv= mempty},
+ AST.EmptyFieldList)
+
+instance Attribution TypeCheck (Deep.Product AST.Expression AST.StatementSequence) where
+ attribution TypeCheck self (inherited, Deep.Pair condition statements) =
+ (Synthesized SynTC{errors= booleanExpressionErrors (syn condition) <> errors (syn statements)},
+ Deep.Pair (Inherited $ inh inherited) (Inherited $ inh inherited))
+
+instance Attribution TypeCheck AST.StatementSequence where
+ attribution TypeCheck (AST.StatementSequence statements) (inherited, AST.StatementSequence statements') =
+ (Synthesized SynTC{errors= foldMap (errors . syn) statements'},
+ AST.StatementSequence (pure $ Inherited $ inh inherited))
+
+instance Attribution TypeCheck AST.Statement where
+ attribution TypeCheck self (inherited, AST.EmptyStatement) = (Synthesized SynTC{errors= []}, AST.EmptyStatement)
+ attribution TypeCheck self (inherited, AST.Assignment var value) = {-# SCC "Assignment" #-}
+ (Synthesized SynTC{errors= assignmentCompatible (designatorType $ syn var) (inferredType $ syn value)},
+ AST.Assignment (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck (AST.ProcedureCall _proc parameters) (inherited, AST.ProcedureCall procedure' parameters') =
+ (Synthesized SynTC{errors= case syn procedure'
+ of SynTCDes{designatorErrors= [],
+ designatorType= t} -> {-# SCC "ProcedureCall" #-} procedureErrors t
+ SynTCDes{designatorErrors= errs} -> errs
+ <> foldMap (foldMap (expressionErrors . syn)) parameters'},
+ AST.ProcedureCall (Inherited $ inh inherited) (Just [Inherited $ inh inherited]))
+ where procedureErrors (ProcedureType formalTypes Nothing)
+ | length formalTypes /= maybe 0 length parameters =
+ [ArgumentCountMismatch (length formalTypes) $ maybe 0 length parameters]
+ | otherwise = concat (zipWith parameterCompatible formalTypes $ maybe [] (inferredType . syn <$>) parameters')
+ procedureErrors (NominalType _ (Just t)) = procedureErrors t
+ procedureErrors t = [NonProcedureType t]
+ attribution TypeCheck self (inherited, AST.If branches fallback) =
+ (Synthesized SynTC{errors= foldMap (errors . syn) branches <> foldMap (errors . syn) fallback},
+ AST.If (pure $ Inherited $ inh inherited) (Inherited (inh inherited) <$ fallback))
+ attribution TypeCheck self (inherited, AST.CaseStatement value branches fallback) =
+ (Synthesized SynTC{errors= expressionErrors (syn value) <> foldMap (errors . syn) branches
+ <> foldMap (errors . syn) fallback},
+ AST.CaseStatement (Inherited $ inh inherited) (pure $ Inherited $ inh inherited)
+ (Inherited (inh inherited) <$ fallback))
+ attribution TypeCheck self (inherited, AST.While condition body) =
+ (Synthesized SynTC{errors= booleanExpressionErrors (syn condition) <> errors (syn body)},
+ AST.While (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Repeat body condition) =
+ (Synthesized SynTC{errors= booleanExpressionErrors (syn condition) <> errors (syn body)},
+ AST.Repeat (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck (AST.For counter _start _end _step _body) (inherited, AST.For _counter start end step body) =
+ (Synthesized SynTC{errors= integerExpressionErrors (syn start) <> integerExpressionErrors (syn end)
+ <> foldMap (integerExpressionErrors . syn) step <> errors (syn body)},
+ AST.For counter (Inherited $ inh inherited) (Inherited $ inh inherited) (Inherited (inh inherited) <$ step)
+ (Inherited $ InhTC $
+ Map.insert (AST.NonQualIdent counter) (NominalType (AST.NonQualIdent "INTEGER") Nothing)
+ $ env $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Loop body) = (Synthesized SynTC{errors= errors (syn body)},
+ AST.Loop (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.With branches fallback) =
+ (Synthesized SynTC{errors= foldMap (errors . syn) branches <> foldMap (errors . syn) fallback},
+ AST.With (pure $ Inherited $ inh inherited) (Inherited (inh inherited) <$ fallback))
+ attribution TypeCheck self (inherited, AST.Exit) = (Synthesized SynTC{errors= []}, AST.Exit)
+ attribution TypeCheck self (inherited, AST.Return value) =
+ (Synthesized SynTC{errors= foldMap (expressionErrors . syn) value},
+ AST.Return (Inherited (inh inherited) <$ value))
+
+instance Attribution TypeCheck AST.WithAlternative where
+ attribution TypeCheck self (inherited, AST.WithAlternative var subtype body) = {-# SCC "WithAlternative" #-}
+ (Synthesized SynTC{errors= case (Map.lookup var (env $ inh inherited),
+ Map.lookup subtype (env $ inh inherited))
+ of (Just supertype, Just subtypeDef) -> assignmentCompatible supertype subtypeDef
+ (Nothing, _) -> [UnknownName var]
+ (_, Nothing) -> [UnknownName subtype]
+ <> errors (syn body)},
+ AST.WithAlternative var subtype (Inherited $ InhTC $
+ maybe id (Map.insert var) (Map.lookup subtype $ env $ inh inherited)
+ $ env $ inh inherited))
+
+instance Attribution TypeCheck AST.Case where
+ attribution TypeCheck self (inherited, AST.Case labels body) =
+ (Synthesized SynTC{errors= foldMap (errors . syn) labels <> errors (syn body)},
+ AST.Case (pure $ Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.EmptyCase) = (Synthesized SynTC{errors= []}, AST.EmptyCase)
+
+instance Attribution TypeCheck AST.CaseLabels where
+ attribution TypeCheck self (inherited, AST.SingleLabel value) =
+ (Synthesized SynTC{errors= integerExpressionErrors (syn value)},
+ AST.SingleLabel (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.LabelRange start end) =
+ (Synthesized SynTC{errors= integerExpressionErrors (syn start) <> integerExpressionErrors (syn end)},
+ AST.LabelRange (Inherited $ inh inherited) (Inherited $ inh inherited))
+
+instance Attribution TypeCheck AST.Expression where
+ attribution TypeCheck self (inherited, AST.Relation op left right) =
+ (Synthesized SynTCExp{expressionErrors= case expressionErrors (syn left) <> expressionErrors (syn right)
+ of [] | inferredType (syn left) == inferredType (syn right) -> []
+ | otherwise -> [TypeMismatch
+ (inferredType $ syn left)
+ (inferredType $ syn right)]
+ errs -> errs,
+ inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing},
+ AST.Relation op (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Positive expr) =
+ (Synthesized SynTCExp{expressionErrors= unaryNumericOperatorErrors (syn expr),
+ inferredType= inferredType (syn expr)},
+ AST.Positive (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Negative expr) =
+ (Synthesized SynTCExp{expressionErrors= unaryNumericOperatorErrors (syn expr),
+ inferredType= unaryNumericOperatorType negate (syn expr)},
+ AST.Negative (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Add left right) =
+ (Synthesized SynTCExp{expressionErrors= binaryNumericOperatorErrors (syn left) (syn right),
+ inferredType= binaryNumericOperatorType div (syn left) (syn right)},
+ AST.Add (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Subtract left right) =
+ (Synthesized SynTCExp{expressionErrors= binaryNumericOperatorErrors (syn left) (syn right),
+ inferredType= binaryNumericOperatorType div (syn left) (syn right)},
+ AST.Subtract (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Or left right) =
+ (Synthesized SynTCExp{expressionErrors= binaryBooleanOperatorErrors (syn left) (syn right),
+ inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing},
+ AST.Or (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Multiply left right) =
+ (Synthesized SynTCExp{expressionErrors= binaryNumericOperatorErrors (syn left) (syn right),
+ inferredType= binaryNumericOperatorType div (syn left) (syn right)},
+ AST.Multiply (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Divide left right) =
+ (Synthesized SynTCExp{expressionErrors=
+ case (syn left, syn right)
+ of (SynTCExp{expressionErrors= [],
+ inferredType= NominalType (AST.NonQualIdent "REAL") Nothing},
+ SynTCExp{expressionErrors= [],
+ inferredType= NominalType (AST.NonQualIdent "REAL") Nothing}) -> []
+ (SynTCExp{expressionErrors= [], inferredType= t1},
+ SynTCExp{expressionErrors= [], inferredType= t2})
+ | t1 == t2 -> [UnrealType t1]
+ | otherwise -> [TypeMismatch t1 t2],
+ inferredType= NominalType (AST.NonQualIdent "REAL") Nothing},
+ AST.Divide (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.IntegerDivide left right) =
+ (Synthesized SynTCExp{expressionErrors= binaryIntegerOperatorErrors (syn left) (syn right),
+ inferredType= binaryNumericOperatorType div (syn left) (syn right)},
+ AST.IntegerDivide (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Modulo left right) =
+ (Synthesized SynTCExp{expressionErrors= binaryIntegerOperatorErrors (syn left) (syn right),
+ inferredType= binaryNumericOperatorType mod (syn left) (syn right)},
+ AST.Modulo (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.And left right) =
+ (Synthesized SynTCExp{expressionErrors= binaryBooleanOperatorErrors (syn left) (syn right),
+ inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing},
+ AST.And (Inherited $ inh inherited) (Inherited $ inh inherited))
+ attribution TypeCheck (AST.Integer x) (inherited, _) =
+ (Synthesized SynTCExp{expressionErrors= mempty,
+ inferredType= IntegerType (read $ Text.unpack x)},
+ AST.Integer x)
+ attribution TypeCheck self (inherited, AST.Real x) =
+ (Synthesized SynTCExp{expressionErrors= mempty,
+ inferredType= NominalType (AST.NonQualIdent "REAL") Nothing},
+ AST.Real x)
+ attribution TypeCheck self (inherited, AST.CharConstant x) =
+ (Synthesized SynTCExp{expressionErrors= mempty,
+ inferredType= NominalType (AST.NonQualIdent "CHAR") Nothing},
+ AST.CharConstant x)
+ attribution TypeCheck self (inherited, AST.CharCode x) =
+ (Synthesized SynTCExp{expressionErrors= mempty,
+ inferredType= NominalType (AST.NonQualIdent "CHAR") Nothing},
+ AST.CharCode x)
+ attribution TypeCheck (AST.String x) (inherited, _) =
+ (Synthesized SynTCExp{expressionErrors= mempty,
+ inferredType= StringType (Text.length x)},
+ AST.String x)
+ attribution TypeCheck self (inherited, AST.Nil) =
+ (Synthesized SynTCExp{expressionErrors= mempty,
+ inferredType= NilType},
+ AST.Nil)
+ attribution TypeCheck self (inherited, AST.Set elements) =
+ (Synthesized SynTCExp{expressionErrors= mempty,
+ inferredType= NominalType (AST.NonQualIdent "SET") Nothing},
+ AST.Set [Inherited $ inh inherited])
+ attribution TypeCheck self (inherited, AST.Read designator) =
+ (Synthesized SynTCExp{expressionErrors= designatorErrors (syn designator),
+ inferredType= designatorType (syn designator)},
+ AST.Read (Inherited $ inh inherited))
+ attribution TypeCheck (AST.FunctionCall _designator parameters)
+ (inherited, AST.FunctionCall designator parameters') =
+ (Synthesized SynTCExp{expressionErrors= case {-# SCC "FunctionCall" #-} syn designator
+ of SynTCDes{designatorErrors= [],
+ designatorType= ProcedureType formalTypes Just{}}
+ | length formalTypes /= length parameters ->
+ [ArgumentCountMismatch (length formalTypes) (length parameters)]
+ | otherwise -> concat (zipWith parameterCompatible formalTypes $
+ inferredType . syn <$> parameters')
+ SynTCDes{designatorErrors= [],
+ designatorType= t} -> [NonFunctionType t]
+ SynTCDes{designatorErrors= errs} -> errs
+ <> foldMap (expressionErrors . syn) parameters',
+ inferredType= case syn designator
+ of SynTCDes{designatorSelf= d,
+ designatorType= ProcedureType _ (Just returnType)}
+ | IntegerType{} <- returnType ->
+ IntegerType (callValue d $ inferredType . syn <$> parameters')
+ | otherwise -> returnType
+ _ -> UnknownType},
+ AST.FunctionCall (Inherited $ inh inherited) [Inherited $ inh inherited])
+ where callValue (AST.Variable (AST.NonQualIdent "MAX"))
+ [NominalType (AST.NonQualIdent "SET") Nothing] = 63
+ callValue (AST.Variable (AST.NonQualIdent "MIN"))
+ [NominalType (AST.NonQualIdent "SET") Nothing] = 0
+ attribution TypeCheck self (inherited, AST.Not expr) =
+ (Synthesized SynTCExp{expressionErrors= booleanExpressionErrors (syn expr),
+ inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing},
+ AST.Not (Inherited $ inh inherited))
+
+instance Attribution TypeCheck AST.Element where
+ attribution TypeCheck self (inherited, AST.Element expr) =
+ (Synthesized SynTCExp{expressionErrors= integerExpressionErrors (syn expr),
+ inferredType= NominalType (AST.NonQualIdent "SET") Nothing},
+ AST.Element (Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.Range low high) =
+ (Synthesized SynTCExp{expressionErrors= integerExpressionErrors (syn low) <> integerExpressionErrors (syn high),
+ inferredType= NominalType (AST.NonQualIdent "SET") Nothing},
+ AST.Range (Inherited $ inh inherited) (Inherited $ inh inherited))
+
+instance Attribution TypeCheck AST.Designator where
+ attribution TypeCheck (AST.Variable q) (inherited, _) =
+ (Synthesized SynTCDes{designatorErrors= case designatorType
+ of Nothing -> [UnknownName q]
+ Just{} -> [],
+ designatorSelf= AST.Variable q,
+ designatorType= fromMaybe UnknownType designatorType},
+ AST.Variable q)
+ where designatorType = Map.lookup q (env $ inh inherited)
+ attribution TypeCheck (AST.Field _record fieldName) (inherited, AST.Field record _fieldName) =
+ (Synthesized SynTCDes{designatorErrors= case syn record
+ of SynTCDes{designatorErrors= [],
+ designatorType= t} ->
+ maybe [NonRecordType t]
+ (maybe [UnknownField fieldName t] $ const []) (access True t)
+ SynTCDes{designatorErrors= errors} -> errors,
+ designatorSelf= AST.Field (Identity $ designatorSelf $ syn record) fieldName,
+ designatorType= fromMaybe UnknownType (fromMaybe Nothing $ access True
+ $ designatorType $ syn record)},
+ AST.Field (Inherited $ inh inherited) fieldName)
+ where access _ (RecordType _ fields) = Just (Map.lookup fieldName fields)
+ access True (PointerType t) = access False t
+ access allowPtr (NominalType _ (Just t)) = access allowPtr t
+ access _ _ = Nothing
+ attribution TypeCheck (AST.Index _array indexes) (inherited, AST.Index array _indexes) =
+ (Synthesized SynTCDes{designatorErrors= case syn array
+ of SynTCDes{designatorErrors= [],
+ designatorType= t@(ArrayType dimensions _)}
+ | length dimensions == length indexes -> []
+ | length dimensions == 0 && length indexes == 1 -> []
+ | otherwise -> [ExtraDimensionalIndex t]
+ SynTCDes{designatorErrors= [],
+ designatorType= t} -> [NonArrayType t]
+ SynTCDes{designatorErrors= errors} -> errors,
+ designatorType= case designatorType (syn array)
+ of ArrayType _ itemType -> itemType
+ _ -> UnknownType},
+ AST.Index (Inherited $ inh inherited) (pure $ Inherited $ inh inherited))
+ attribution TypeCheck self (inherited, AST.TypeGuard designator q) = {-# SCC "TypeGuard" #-}
+ (Synthesized SynTCDes{designatorErrors= case (syn designator, targetType)
+ of (SynTCDes{designatorErrors= [],
+ designatorType= t},
+ Just t') -> assignmentCompatible t' t
+ (SynTCDes{designatorErrors= errors},
+ Nothing) -> UnknownName q : errors
+ (SynTCDes{designatorErrors= errors}, _) -> errors,
+ designatorType= fromMaybe UnknownType targetType},
+ AST.TypeGuard (Inherited $ inh inherited) q)
+ where targetType = Map.lookup q (env $ inh inherited)
+ attribution TypeCheck self (inherited, AST.Dereference pointer) =
+ (Synthesized SynTCDes{designatorErrors= case syn pointer
+ of SynTCDes{designatorErrors= [],
+ designatorType= PointerType{}} -> []
+ SynTCDes{designatorErrors= [],
+ designatorType= NominalType _ (Just PointerType{})} -> []
+ SynTCDes{designatorErrors= [],
+ designatorType= t} -> [NonPointerType t]
+ SynTCDes{designatorErrors= errors} -> errors,
+ designatorType= case designatorType (syn pointer)
+ of NominalType _ (Just (PointerType t)) -> t
+ PointerType t -> t
+ _ -> UnknownType},
+ AST.Dereference (Inherited $ inh inherited))
+
+unaryNumericOperatorErrors :: SynTCExp -> [Error]
+unaryNumericOperatorErrors SynTCExp{expressionErrors= [], inferredType= IntegerType{}} = []
+unaryNumericOperatorErrors SynTCExp{expressionErrors= [],
+ inferredType= NominalType (AST.NonQualIdent name) Nothing}
+ | name `elem` numericTypeNames = []
+unaryNumericOperatorErrors SynTCExp{expressionErrors= [], inferredType= t} = [NonNumericType t]
+unaryNumericOperatorErrors SynTCExp{expressionErrors= errs} = errs
+
+unaryNumericOperatorType :: (Int -> Int) -> SynTCExp -> Type
+unaryNumericOperatorType f SynTCExp{inferredType= IntegerType x} = IntegerType (f x)
+unaryNumericOperatorType _ SynTCExp{inferredType= t} = t
+
+binaryNumericOperatorErrors :: SynTCExp -> SynTCExp -> [Error]
+binaryNumericOperatorErrors
+ SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent name1) Nothing}
+ SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent name2) Nothing}
+ | name1 `elem` numericTypeNames, name2 `elem` numericTypeNames = []
+binaryNumericOperatorErrors
+ SynTCExp{expressionErrors= [], inferredType= IntegerType{}}
+ SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent name) Nothing}
+ | name `elem` numericTypeNames = []
+binaryNumericOperatorErrors
+ SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent name) Nothing}
+ SynTCExp{expressionErrors= [], inferredType= IntegerType{}}
+ | name `elem` numericTypeNames = []
+binaryNumericOperatorErrors SynTCExp{expressionErrors= [], inferredType= IntegerType{}}
+ SynTCExp{expressionErrors= [], inferredType= IntegerType{}} = []
+binaryNumericOperatorErrors SynTCExp{expressionErrors= [], inferredType= t1}
+ SynTCExp{expressionErrors= [], inferredType= t2}
+ | t1 == t2 = [NonNumericType t1]
+ | otherwise = [TypeMismatch t1 t2]
+binaryNumericOperatorErrors SynTCExp{expressionErrors= errs1} SynTCExp{expressionErrors= errs2} = errs1 <> errs2
+
+binaryNumericOperatorType :: (Int -> Int -> Int) -> SynTCExp -> SynTCExp -> Type
+binaryNumericOperatorType f SynTCExp{inferredType= IntegerType x} SynTCExp{inferredType= IntegerType y} =
+ IntegerType (f x y)
+binaryNumericOperatorType _ SynTCExp{inferredType= t1} SynTCExp{inferredType= t2}
+ | t1 == t2 = t1
+ | IntegerType{} <- t1 = t2
+ | IntegerType{} <- t2 = t1
+ | NominalType (AST.NonQualIdent name1) Nothing <- t1,
+ NominalType (AST.NonQualIdent name2) Nothing <- t2,
+ Just index1 <- List.elemIndex name1 numericTypeNames,
+ Just index2 <- List.elemIndex name2 numericTypeNames =
+ NominalType (AST.NonQualIdent $ numericTypeNames !! max index1 index2) Nothing
+ | otherwise = t1
+
+binaryIntegerOperatorErrors :: SynTCExp -> SynTCExp -> [Error]
+binaryIntegerOperatorErrors syn1 syn2 = integerExpressionErrors syn1 <> integerExpressionErrors syn2
+
+integerExpressionErrors SynTCExp{expressionErrors= [], inferredType= t} = expectInteger t
+ where expectInteger IntegerType{} = []
+ expectInteger (NominalType (AST.NonQualIdent "SHORTINT") Nothing) = []
+ expectInteger (NominalType (AST.NonQualIdent "INTEGER") Nothing) = []
+ expectInteger (NominalType (AST.NonQualIdent "LONGINT") Nothing) = []
+ expectInteger t = [NonIntegerType t]
+integerExpressionErrors SynTCExp{expressionErrors= errs} = errs
+
+booleanExpressionErrors SynTCExp{expressionErrors= [],
+ inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing} = []
+booleanExpressionErrors SynTCExp{expressionErrors= [], inferredType= t} = [NonBooleanType t]
+booleanExpressionErrors SynTCExp{expressionErrors= errs} = errs
+
+binaryBooleanOperatorErrors :: SynTCExp -> SynTCExp -> [Error]
+binaryBooleanOperatorErrors
+ SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing}
+ SynTCExp{expressionErrors= [], inferredType= NominalType (AST.NonQualIdent "BOOLEAN") Nothing} = []
+binaryBooleanOperatorErrors SynTCExp{expressionErrors= [], inferredType= t1}
+ SynTCExp{expressionErrors= [], inferredType= t2}
+ | t1 == t2 = [NonBooleanType t1]
+ | otherwise = [TypeMismatch t1 t2]
+
+parameterCompatible :: (Bool, Type) -> Type -> [Error]
+parameterCompatible (True, expected) actual
+ | expected == actual = []
+ | otherwise = [UnequalTypes expected actual]
+parameterCompatible (False, expected) actual = assignmentCompatible expected actual
+
+assignmentCompatible :: Type -> Type -> [Error]
+assignmentCompatible expected actual
+ | expected == actual = []
+ | NominalType (AST.NonQualIdent name1) Nothing <- expected,
+ NominalType (AST.NonQualIdent name2) Nothing <- actual,
+ Just index1 <- List.elemIndex name1 numericTypeNames,
+ Just index2 <- List.elemIndex name2 numericTypeNames,
+ index1 >= index2 = []
+ | NominalType (AST.NonQualIdent name) Nothing <- expected,
+ IntegerType{} <- actual, name `elem` numericTypeNames = []
+ | expected == NominalType (AST.NonQualIdent "BASIC TYPE") Nothing,
+ NominalType (AST.NonQualIdent q) Nothing <- actual,
+ q `elem` ["BOOLEAN", "CHAR", "SHORTINT", "INTEGER", "LONGINT", "REAL", "LONGREAL", "SET"] = []
+ | expected == NominalType (AST.NonQualIdent "POINTER") Nothing, PointerType{} <- actual = []
+ | expected == NominalType (AST.NonQualIdent "POINTER") Nothing, NominalType _ (Just t) <- actual =
+ assignmentCompatible expected t
+ | expected == NominalType (AST.NonQualIdent "CHAR") Nothing, actual == StringType 1 = []
+ | NilType <- actual, PointerType{} <- expected = []
+ | NilType <- actual, ProcedureType{} <- expected = []
+ | NilType <- actual, NominalType _ (Just t) <- expected = assignmentCompatible t actual
+ | ArrayType [] (NominalType (AST.NonQualIdent "CHAR") Nothing) <- expected, StringType{} <- actual = []
+ | ArrayType [m] (NominalType (AST.NonQualIdent "CHAR") Nothing) <- expected, StringType n <- actual =
+ if m < n then [TooSmallArrayType expected] else []
+ | targetExtends actual expected = []
+ | NominalType _ (Just t) <- expected, ProcedureType{} <- actual = assignmentCompatible t actual
+ | otherwise = error (show (expected, actual))
+
+extends, targetExtends :: Type -> Type -> Bool
+t1 `extends` t2 | t1 == t2 = True
+RecordType ancestry _ `extends` NominalType q _ = q `elem` ancestry
+NominalType _ (Just t1) `extends` t2 = t1 `extends` t2
+t1 `extends` t2 = False -- error (show (t1, t2))
+
+numericTypeNames = ["SHORTINT", "INTEGER", "LONGINT", "REAL", "LONGREAL"]
+
+PointerType t1 `targetExtends` PointerType t2 = t1 `extends` t2
+NominalType _ (Just t1) `targetExtends` t2 = t1 `targetExtends` t2
+t1 `targetExtends` NominalType _ (Just t2) = t1 `targetExtends` t2
+t1 `targetExtends` t2 | t1 == t2 = True
+t1 `targetExtends` t2 = False
+
+-- * More boring Shallow.Functor instances, TH candidates
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (Modules (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.Module (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.Declaration (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.FormalParameters (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.FPSection (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (Deep.Product AST.Expression AST.StatementSequence (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.StatementSequence (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.Statement (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.Case (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.CaseLabels (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.WithAlternative (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.Expression (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.Element (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.Designator (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.Type (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+instance Shallow.Functor TypeCheck Identity (Semantics TypeCheck)
+ (AST.FieldList (Semantics TypeCheck) (Semantics TypeCheck)) where
+ (<$>) = AG.mapDefault runIdentity
+
+-- * Unsafe Rank2 AST instances
+
+instance Rank2.Apply (AST.Module f') where
+ AST.Module ident1a imports1 decls1 body1 ident1b <*> ~(AST.Module ident2a imports2 decls2 body2 ident2b) =
+ AST.Module ident1a imports1 (liftA2 Rank2.apply decls1 decls2) (liftA2 Rank2.apply body1 body2) ident1b
+
+checkModules :: Environment -> Map AST.Ident (AST.Module Identity Identity) -> [Error]
+checkModules predef modules =
+ errors (syn (TypeCheck Shallow.<$> Identity (TypeCheck Deep.<$> Modules (Identity <$> modules))
+ `Rank2.apply`
+ Inherited (InhTC predef)))
+
+predefined, predefined2 :: Environment
+-- | The set of 'Predefined' types and procedures defined in the Oberon Language Report.
+predefined = Map.fromList $ map (first AST.NonQualIdent) $
+ [("BOOLEAN", NominalType (AST.NonQualIdent "BOOLEAN") Nothing),
+ ("CHAR", NominalType (AST.NonQualIdent "CHAR") Nothing),
+ ("SHORTINT", NominalType (AST.NonQualIdent "SHORTINT") Nothing),
+ ("INTEGER", NominalType (AST.NonQualIdent "INTEGER") Nothing),
+ ("LONGINT", NominalType (AST.NonQualIdent "LONGINT") Nothing),
+ ("REAL", NominalType (AST.NonQualIdent "REAL") Nothing),
+ ("LONGREAL", NominalType (AST.NonQualIdent "LONGREAL") Nothing),
+ ("SET", NominalType (AST.NonQualIdent "SET") Nothing),
+ ("TRUE", NominalType (AST.NonQualIdent "BOOLEAN") Nothing),
+ ("FALSE", NominalType (AST.NonQualIdent "BOOLEAN") Nothing),
+ ("ABS", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing),
+ ("ASH", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing),
+ ("CAP", ProcedureType [(False, NominalType (AST.NonQualIdent "CHAR") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "CHAR") Nothing),
+ ("LEN", ProcedureType [(False, NominalType (AST.NonQualIdent "ARRAY") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "LONGINT") Nothing),
+ ("MAX", ProcedureType [(False, NominalType (AST.NonQualIdent "BASIC TYPE") Nothing)] $ Just $ IntegerType 0),
+ ("MIN", ProcedureType [(False, NominalType (AST.NonQualIdent "BASIC TYPE") Nothing)] $ Just $ IntegerType 0),
+ ("ODD", ProcedureType [(False, NominalType (AST.NonQualIdent "CHAR") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "BOOLEAN") Nothing),
+ ("SIZE", ProcedureType [(False, NominalType (AST.NonQualIdent "CHAR") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing),
+ ("ORD", ProcedureType [(False, NominalType (AST.NonQualIdent "CHAR") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing),
+ ("CHR", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "CHAR") Nothing),
+ ("SHORT", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)]
+ $ Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing),
+ ("LONG", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing),
+ ("ENTIER", ProcedureType [(False, NominalType (AST.NonQualIdent "REAL") Nothing)] $
+ Just $ NominalType (AST.NonQualIdent "INTEGER") Nothing),
+ ("INC", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing),
+ ("DEC", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing),
+ ("INCL", ProcedureType [(False, NominalType (AST.NonQualIdent "SET") Nothing),
+ (False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing),
+ ("EXCL", ProcedureType [(False, NominalType (AST.NonQualIdent "SET") Nothing),
+ (False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing),
+ ("COPY", ProcedureType [(False, NominalType (AST.NonQualIdent "ARRAY") Nothing),
+ (False, NominalType (AST.NonQualIdent "ARRAY") Nothing)] Nothing),
+ ("NEW", ProcedureType [(False, NominalType (AST.NonQualIdent "POINTER") Nothing)] Nothing),
+ ("HALT", ProcedureType [(False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing)]
+
+-- | The set of 'Predefined' types and procedures defined in the Oberon-2 Language Report.
+predefined2 = predefined <>
+ Map.fromList (first AST.NonQualIdent <$>
+ [("ASSERT", ProcedureType [(False, NominalType (AST.NonQualIdent "BOOL") Nothing),
+ (False, NominalType (AST.NonQualIdent "INTEGER") Nothing)] Nothing)])
+
+$(mconcat <$> mapM Rank2.TH.unsafeDeriveApply
+ [''AST.Declaration, ''AST.Type, ''AST.Expression,
+ ''AST.Element, ''AST.Designator, ''AST.FieldList,
+ ''AST.ProcedureHeading, ''AST.FormalParameters, ''AST.FPSection, ''AST.ProcedureBody,
+ ''AST.Statement, ''AST.StatementSequence, ''AST.WithAlternative, ''AST.Case, ''AST.CaseLabels])
diff --git a/src/Transformation.hs b/src/Transformation.hs
new file mode 100644
index 0000000..2f41b4b
--- /dev/null
+++ b/src/Transformation.hs
@@ -0,0 +1,23 @@
+{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses,
+ PolyKinds, RankNTypes, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+
+module Transformation where
+
+import qualified Rank2
+
+import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd)
+
+class Functor t p q x | t -> p q where
+ (<$>) :: t -> p x -> q x
+
+class Foldable t p m x | t -> p m where
+ foldMap :: t -> p x -> m
+
+class Traversable t p q m x | t -> p q m where
+ traverse :: t -> p x -> m (q x)
+
+fmap :: Functor t p q x => t -> p x -> q x
+fmap = (<$>)
+
+instance Functor (Rank2.Arrow p q x) p q x where
+ (<$>) = Rank2.apply
diff --git a/src/Transformation/AG.hs b/src/Transformation/AG.hs
new file mode 100644
index 0000000..9ad561e
--- /dev/null
+++ b/src/Transformation/AG.hs
@@ -0,0 +1,37 @@
+{-# Language DefaultSignatures, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving,
+ TypeFamilies, TypeOperators, UndecidableInstances #-}
+
+module Transformation.AG where
+
+import Data.Functor.Identity
+import qualified Rank2
+import qualified Transformation as Shallow
+import qualified Transformation.Deep as Deep
+
+data Inherited a g = Inherited{inh :: Atts (Inherited a) g}
+data Synthesized a g = Synthesized{syn :: Atts (Synthesized a) g}
+
+type family Atts (f :: * -> *) x
+deriving instance (Show (Atts (Inherited a) g)) => Show (Inherited a g)
+deriving instance (Show (Atts (Synthesized a) g)) => Show (Synthesized a g)
+-- type instance Atts Identity f = f Identity
+-- type instance Atts (Inherited a Rank2.~> Synthesized a) g = Atts (Inherited a) g -> Atts (Synthesized a) g
+
+type Semantics a = Inherited a Rank2.~> Synthesized a
+
+type Rule a g (f :: * -> *) = g f (Semantics a)
+ -> (Inherited a (g f (Semantics a)), g f (Synthesized a))
+ -> (Synthesized a (g f (Semantics a)), g f (Inherited a))
+
+knit :: Rank2.Apply (g f) => Rule a g f -> g f (Semantics a) -> Semantics a (g f (Semantics a))
+knit r chSem = Rank2.Arrow knit'
+ where knit' inh = syn
+ where (syn, chInh) = r chSem (inh, chSyn)
+ chSyn = chSem Rank2.<*> chInh
+
+class Shallow.Functor t Identity (Semantics t) (g (Semantics t) (Semantics t)) => Attribution t g where
+ attribution :: t -> Rule t g (Semantics t)
+
+mapDefault :: (q ~ Semantics t, x ~ g q q, Rank2.Apply (g q), Attribution t g) => (p x -> x) -> t -> p x -> q x
+mapDefault extract t sem = knit (attribution t) (extract sem)
+{-# INLINE mapDefault #-}
diff --git a/src/Transformation/Deep.hs b/src/Transformation/Deep.hs
new file mode 100644
index 0000000..fda172c
--- /dev/null
+++ b/src/Transformation/Deep.hs
@@ -0,0 +1,83 @@
+{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses,
+ PolyKinds, RankNTypes, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+
+module Transformation.Deep where
+
+import Control.Applicative ((<*>), liftA2)
+import Data.Data (Data, Typeable)
+import Data.Monoid (Monoid, (<>))
+import qualified Rank2
+import qualified Data.Foldable
+import qualified Data.Functor
+import qualified Data.Traversable
+import qualified Transformation as Shallow
+
+import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd)
+
+class Rank2.Functor (g p) => Functor t g (p :: * -> *) (q :: * -> *) where
+ (<$>) :: t -> g p p -> g q q
+
+class Rank2.Foldable (g p) => Foldable t g p m where
+ foldMap :: t -> g p p -> m
+
+class Rank2.Traversable (g p) => UpTraversable t g (p :: * -> *) (q :: * -> *) m where
+ traverseUp :: t -> g p p -> m (g q q)
+
+class Rank2.Traversable (g p) => DownTraversable t g (p :: * -> *) (q :: * -> *) m where
+ traverseDown :: t -> g p p -> m (g q q)
+
+data Product g1 g2 (p :: * -> *) (q :: * -> *) = Pair{fst :: q (g1 p p),
+ snd :: q (g2 p p)}
+
+instance Rank2.Functor (Product g1 g2 p) where
+ f <$> ~(Pair left right) = Pair (f left) (f right)
+
+instance Rank2.Apply (Product g h p) where
+ ~(Pair g1 h1) <*> ~(Pair g2 h2) = Pair (Rank2.apply g1 g2) (Rank2.apply h1 h2)
+ liftA2 f ~(Pair g1 h1) ~(Pair g2 h2) = Pair (f g1 g2) (f h1 h2)
+
+instance Rank2.Applicative (Product g h p) where
+ pure f = Pair f f
+
+instance Rank2.Foldable (Product g h p) where
+ foldMap f ~(Pair g h) = f g `mappend` f h
+
+instance Rank2.Traversable (Product g h p) where
+ traverse f ~(Pair g h) = liftA2 Pair (f g) (f h)
+
+instance Rank2.DistributiveTraversable (Product g h p)
+
+instance Rank2.Distributive (Product g h p) where
+ cotraverse w f = Pair{fst= w (fst Data.Functor.<$> f),
+ snd= w (snd Data.Functor.<$> f)}
+
+instance (Data.Functor.Functor p, Shallow.Functor t p q (g1 q q), Shallow.Functor t p q (g2 q q),
+ Functor t g1 p q, Functor t g2 p q) => Functor t (Product g1 g2) p q where
+ t <$> Pair left right = Pair (t Shallow.<$> ((t <$>) Data.Functor.<$> left))
+ (t Shallow.<$> ((t <$>) Data.Functor.<$> right))
+
+instance (Monoid m, Data.Foldable.Foldable p,
+ Foldable t g1 p m, Foldable t g2 p m) => Foldable t (Product g1 g2) p m where
+ foldMap t (Pair left right) = Data.Foldable.foldMap (foldMap t) left
+ <> Data.Foldable.foldMap (foldMap t) right
+
+instance (Monad m, Data.Traversable.Traversable p,
+ Shallow.Traversable t p q m (g1 q q), Shallow.Traversable t p q m (g2 q q),
+ UpTraversable t g1 p q m, UpTraversable t g2 p q m) => UpTraversable t (Product g1 g2) p q m where
+ traverseUp t (Pair left right) =
+ Pair Data.Functor.<$> (Data.Traversable.traverse (traverseUp t) left >>= Shallow.traverse t)
+ Control.Applicative.<*> (Data.Traversable.traverse (traverseUp t) right >>= Shallow.traverse t)
+
+instance (Monad m, Data.Traversable.Traversable q,
+ Shallow.Traversable t p q m (g1 p p), Shallow.Traversable t p q m (g2 p p),
+ DownTraversable t g1 p q m, DownTraversable t g2 p q m) => DownTraversable t (Product g1 g2) p q m where
+ traverseDown t (Pair left right) =
+ Pair Data.Functor.<$> (Shallow.traverse t left >>= Data.Traversable.traverse (traverseDown t))
+ Control.Applicative.<*> (Shallow.traverse t right >>= Data.Traversable.traverse (traverseDown t))
+
+deriving instance (Typeable p, Typeable q, Typeable g1, Typeable g2,
+ Data (q (g1 p p)), Data (q (g2 p p))) => Data (Product g1 g2 p q)
+deriving instance (Show (q (g1 p p)), Show (q (g2 p p))) => Show (Product g1 g2 p q)
+
+fmap :: Functor t g p q => t -> g p p -> g q q
+fmap = (<$>)
diff --git a/src/Transformation/Deep/TH.hs b/src/Transformation/Deep/TH.hs
new file mode 100644
index 0000000..4a0a8d2
--- /dev/null
+++ b/src/Transformation/Deep/TH.hs
@@ -0,0 +1,287 @@
+-- | This module exports the templates for automatic instance deriving of "Transformation.Deep" type classes. The most
+-- common way to use it would be
+--
+-- > import qualified Transformation.Deep.TH
+-- > data MyDataType f' f = ...
+-- > $(Transformation.Deep.TH.deriveFunctor ''MyDataType)
+--
+
+{-# Language TemplateHaskell #-}
+-- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial
+
+module Transformation.Deep.TH (deriveAll, deriveFunctor, deriveFoldable, deriveDownTraversable, deriveUpTraversable)
+where
+
+import Control.Monad (replicateM)
+import Data.Monoid ((<>))
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ)
+
+import qualified Transformation
+import qualified Transformation.Deep
+import qualified Rank2.TH
+
+
+data Deriving = Deriving { _constructor :: Name, _variableN :: Name, _variable1 :: Name }
+
+deriveAll :: Name -> Q [Dec]
+deriveAll ty = foldr f (pure []) [Rank2.TH.deriveFunctor, Rank2.TH.deriveFoldable, Rank2.TH.deriveTraversable,
+ Transformation.Deep.TH.deriveFunctor, Transformation.Deep.TH.deriveFoldable,
+ Transformation.Deep.TH.deriveDownTraversable,
+ Transformation.Deep.TH.deriveUpTraversable]
+ where f derive rest = (<>) <$> derive ty <*> rest
+
+deriveFunctor :: Name -> Q [Dec]
+deriveFunctor ty = do
+ t <- varT <$> newName "t"
+ p <- varT <$> newName "p"
+ q <- varT <$> newName "q"
+ let deepConstraint ty = conT ''Transformation.Deep.Functor `appT` t `appT` ty `appT` p `appT` q
+ shallowConstraint ty =
+ conT ''Transformation.Functor `appT` t `appT` p `appT` q `appT` (ty `appT` q `appT` q)
+ (instanceType, cs) <- reifyConstructors ty
+ (constraints, dec) <- genDeepmap deepConstraint shallowConstraint cs
+ sequence [instanceD (cxt (appT (conT ''Functor) p : map pure constraints))
+ (deepConstraint instanceType)
+ [pure dec]]
+
+deriveFoldable :: Name -> Q [Dec]
+deriveFoldable ty = do
+ t <- varT <$> newName "t"
+ f <- varT <$> newName "f"
+ m <- varT <$> newName "m"
+ let deepConstraint ty = conT ''Transformation.Deep.Foldable `appT` t `appT` ty `appT` f `appT` m
+ shallowConstraint ty =
+ conT ''Transformation.Foldable `appT` t `appT` f `appT` m `appT` (ty `appT` f `appT` f)
+ (instanceType, cs) <- reifyConstructors ty
+ (constraints, dec) <- genFoldMap deepConstraint shallowConstraint cs
+ sequence [instanceD (cxt (appT (conT ''Monoid) m : appT (conT ''Foldable) f : map pure constraints))
+ (deepConstraint instanceType)
+ [pure dec]]
+
+deriveDownTraversable :: Name -> Q [Dec]
+deriveDownTraversable ty = do
+ t <- varT <$> newName "t"
+ p <- varT <$> newName "p"
+ q <- varT <$> newName "q"
+ m <- varT <$> newName "m"
+ let deepConstraint ty = conT ''Transformation.Deep.DownTraversable `appT` t `appT` ty `appT` p `appT` q `appT` m
+ shallowConstraint ty =
+ conT ''Transformation.Traversable `appT` t `appT` p `appT` q `appT` m `appT` (ty `appT` p `appT` p)
+ (instanceType, cs) <- reifyConstructors ty
+ (constraints, dec) <- genTraverseDown deepConstraint shallowConstraint cs
+ sequence [instanceD (cxt (appT (conT ''Monad) m : appT (conT ''Traversable) q : map pure constraints))
+ (deepConstraint instanceType)
+ [pure dec]]
+
+deriveUpTraversable :: Name -> Q [Dec]
+deriveUpTraversable ty = do
+ t <- varT <$> newName "t"
+ p <- varT <$> newName "p"
+ q <- varT <$> newName "q"
+ m <- varT <$> newName "m"
+ let deepConstraint ty = conT ''Transformation.Deep.UpTraversable `appT` t `appT` ty `appT` p `appT` q `appT` m
+ shallowConstraint ty =
+ conT ''Transformation.Traversable `appT` t `appT` p `appT` q `appT` m `appT` (ty `appT` q `appT` q)
+ (instanceType, cs) <- reifyConstructors ty
+ (constraints, dec) <- genTraverseUp deepConstraint shallowConstraint cs
+ sequence [instanceD (cxt (appT (conT ''Monad) m : appT (conT ''Traversable) p : map pure constraints))
+ (deepConstraint instanceType)
+ [pure dec]]
+
+reifyConstructors :: Name -> Q (TypeQ, [Con])
+reifyConstructors ty = do
+ (TyConI tyCon) <- reify ty
+ (tyConName, tyVars, _kind, cs) <- case tyCon of
+ DataD _ nm tyVars kind cs _ -> return (nm, tyVars, kind, cs)
+ NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c])
+ _ -> fail "deriveApply: tyCon may not be a type synonym."
+
+ let (KindedTV tyVar (AppT (AppT ArrowT StarT) StarT) :
+ KindedTV tyVar' (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars
+ instanceType = foldl apply (conT tyConName) (reverse $ drop 2 $ reverse tyVars)
+ apply t (PlainTV name) = appT t (varT name)
+ apply t (KindedTV name _) = appT t (varT name)
+
+ putQ (Deriving tyConName tyVar' tyVar)
+ return (instanceType, cs)
+
+genDeepmap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> [Con] -> Q ([Type], Dec)
+genDeepmap deepConstraint shallowConstraint cs = do
+ (constraints, clauses) <- unzip <$> mapM (genDeepmapClause deepConstraint shallowConstraint) cs
+ return (concat constraints, FunD '(Transformation.Deep.<$>) clauses)
+
+genFoldMap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> [Con] -> Q ([Type], Dec)
+genFoldMap deepConstraint shallowConstraint cs = do
+ (constraints, clauses) <- unzip <$> mapM (genFoldMapClause deepConstraint shallowConstraint) cs
+ return (concat constraints, FunD 'Transformation.Deep.foldMap clauses)
+
+genTraverseDown :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> [Con] -> Q ([Type], Dec)
+genTraverseDown deepConstraint shallowConstraint cs = do
+ (constraints, clauses) <- unzip <$> mapM (genTraverseClause genTraverseDownField deepConstraint shallowConstraint) cs
+ return (concat constraints, FunD 'Transformation.Deep.traverseDown clauses)
+
+genTraverseUp :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> [Con] -> Q ([Type], Dec)
+genTraverseUp deepConstraint shallowConstraint cs = do
+ (constraints, clauses) <- unzip <$> mapM (genTraverseClause genTraverseUpField deepConstraint shallowConstraint) cs
+ return (concat constraints, FunD 'Transformation.Deep.traverseUp clauses)
+
+genDeepmapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Con -> Q ([Type], Clause)
+genDeepmapClause deepConstraint shallowConstraint (NormalC name fieldTypes) = do
+ t <- newName "t"
+ fieldNames <- replicateM (length fieldTypes) (newName "x")
+ let pats = [varP t, parensP (conP name $ map varP fieldNames)]
+ constraintsAndFields = zipWith newField fieldNames fieldTypes
+ newFields = map (snd <$>) constraintsAndFields
+ body = normalB $ appsE $ conE name : newFields
+ newField :: Name -> BangType -> Q ([Type], Exp)
+ newField x (_, fieldType) = genDeepmapField (varE t) fieldType deepConstraint shallowConstraint (varE x) id
+ constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
+ (,) constraints <$> clause pats body []
+genDeepmapClause deepConstraint shallowConstraint (RecC name fields) = do
+ f <- newName "f"
+ x <- newName "x"
+ let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields
+ constraintsAndFields = map newNamedField fields
+ newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
+ newNamedField (fieldName, _, fieldType) =
+ ((,) fieldName <$>)
+ <$> genDeepmapField (varE f) fieldType deepConstraint shallowConstraint (appE (varE fieldName) (varE x)) id
+ constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
+ (,) constraints <$> clause [varP f, varP x] body []
+
+genFoldMapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Con -> Q ([Type], Clause)
+genFoldMapClause deepConstraint shallowConstraint (NormalC name fieldTypes) = do
+ t <- newName "t"
+ fieldNames <- replicateM (length fieldTypes) (newName "x")
+ let pats = [varP t, parensP (conP name $ map varP fieldNames)]
+ constraintsAndFields = zipWith newField fieldNames fieldTypes
+ newFields = map (snd <$>) constraintsAndFields
+ body | null newFields = [| mempty |]
+ | otherwise = foldr1 append newFields
+ append a b = [| $(a) <> $(b) |]
+ newField :: Name -> BangType -> Q ([Type], Exp)
+ newField x (_, fieldType) = genFoldMapField (varE t) fieldType deepConstraint shallowConstraint (varE x) id
+ constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
+ (,) constraints <$> clause pats (normalB body) []
+genFoldMapClause deepConstraint shallowConstraint (RecC _name fields) = do
+ t <- newName "t"
+ x <- newName "x"
+ let body | null fields = [| mempty |]
+ | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields
+ append a b = [| $(a) <> $(b) |]
+ constraintsAndFields = map newNamedField fields
+ newNamedField :: VarBangType -> Q ([Type], Exp)
+ newNamedField (fieldName, _, fieldType) =
+ genFoldMapField (varE t) fieldType deepConstraint shallowConstraint (appE (varE fieldName) (varE x)) id
+ constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
+ (,) constraints <$> clause [varP t, varP x] (normalB body) []
+
+type GenTraverseFieldType = Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)
+ -> Q ([Type], Exp)
+
+genTraverseClause :: GenTraverseFieldType -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Con -> Q ([Type], Clause)
+genTraverseClause genTraverseField deepConstraint shallowConstraint (NormalC name fieldTypes) = do
+ t <- newName "t"
+ fieldNames <- replicateM (length fieldTypes) (newName "x")
+ let pats = [varP t, parensP (conP name $ map varP fieldNames)]
+ constraintsAndFields = zipWith newField fieldNames fieldTypes
+ newFields = map (snd <$>) constraintsAndFields
+ body | null fieldTypes = [| pure $(conE name) |]
+ | otherwise = fst $ foldl apply (conE name, False) newFields
+ apply (a, False) b = ([| $(a) <$> $(b) |], True)
+ apply (a, True) b = ([| $(a) <*> $(b) |], True)
+ newField :: Name -> BangType -> Q ([Type], Exp)
+ newField x (_, fieldType) = genTraverseField (varE t) fieldType deepConstraint shallowConstraint (varE x) id
+ constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
+ (,) constraints <$> clause pats (normalB body) []
+genTraverseClause genTraverseField deepConstraint shallowConstraint (RecC name fields) = do
+ f <- newName "f"
+ x <- newName "x"
+ let constraintsAndFields = map newNamedField fields
+ body | null fields = [| pure $(conE name) |]
+ | otherwise = fst (foldl apply (conE name, False) $ map (snd . snd <$>) constraintsAndFields)
+ apply (a, False) b = ([| $(a) <$> $(b) |], True)
+ apply (a, True) b = ([| $(a) <*> $(b) |], True)
+ newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
+ newNamedField (fieldName, _, fieldType) =
+ ((,) fieldName <$>)
+ <$> genTraverseField (varE f) fieldType deepConstraint shallowConstraint (appE (varE fieldName) (varE x)) id
+ constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
+ (,) constraints <$> clause [varP f, varP x] (normalB body) []
+
+genDeepmapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)
+ -> Q ([Type], Exp)
+genDeepmapField trans fieldType deepConstraint shallowConstraint fieldAccess wrap = do
+ Just (Deriving _ typeVarN typeVar1) <- getQ
+ case fieldType of
+ AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN ->
+ (,) <$> ((:) <$> deepConstraint (pure con) <*> ((:[]) <$> shallowConstraint (pure con)))
+ <*> appE (wrap [| (Transformation.fmap $trans . (Transformation.Deep.fmap $trans <$>)) |]) fieldAccess
+ AppT ty _ | ty == VarT typeVar1 ->
+ (,) [] <$> (wrap (varE 'Transformation.fmap `appE` trans) `appE` fieldAccess)
+ AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 ->
+ (,) <$> ((:[]) <$> deepConstraint (pure con))
+ <*> appE (wrap [| Transformation.Deep.fmap $trans |]) fieldAccess
+ AppT t1 t2 | t1 /= VarT typeVar1 ->
+ genDeepmapField trans t2 deepConstraint shallowConstraint fieldAccess (wrap . appE (varE '(<$>)))
+ SigT ty _kind -> genDeepmapField trans ty deepConstraint shallowConstraint fieldAccess wrap
+ ParensT ty -> genDeepmapField trans ty deepConstraint shallowConstraint fieldAccess wrap
+ _ -> (,) [] <$> fieldAccess
+
+genFoldMapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)
+ -> Q ([Type], Exp)
+genFoldMapField trans fieldType deepConstraint shallowConstraint fieldAccess wrap = do
+ Just (Deriving _ typeVarN typeVar1) <- getQ
+ case fieldType of
+ AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN ->
+ (,) <$> ((:) <$> deepConstraint (pure con) <*> ((:[]) <$> shallowConstraint (pure con)))
+ <*> appE (wrap [| foldMap (Transformation.Deep.foldMap $trans) |]) fieldAccess
+ AppT ty _ | ty == VarT typeVar1 ->
+ (,) [] <$> (wrap (varE 'Transformation.foldMap `appE` trans) `appE` fieldAccess)
+ AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 ->
+ (,) <$> ((:[]) <$> deepConstraint (pure con))
+ <*> appE (wrap [| Transformation.Deep.foldMap $trans |]) fieldAccess
+ AppT t1 t2 | t1 /= VarT typeVar1 ->
+ genFoldMapField trans t2 deepConstraint shallowConstraint fieldAccess (wrap . appE (varE 'foldMap))
+ SigT ty _kind -> genFoldMapField trans ty deepConstraint shallowConstraint fieldAccess wrap
+ ParensT ty -> genFoldMapField trans ty deepConstraint shallowConstraint fieldAccess wrap
+ _ -> (,) [] <$> [| mempty |]
+
+genTraverseDownField :: GenTraverseFieldType
+genTraverseDownField trans fieldType deepConstraint shallowConstraint fieldAccess wrap = do
+ Just (Deriving _ typeVarN typeVar1) <- getQ
+ case fieldType of
+ AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN ->
+ (,) <$> ((:) <$> deepConstraint (pure con) <*> ((:[]) <$> shallowConstraint (pure con)))
+ <*> appE (wrap [| (>>= traverse (Transformation.Deep.traverseDown $trans)) . Transformation.traverse $trans |])
+ fieldAccess
+ AppT ty _ | ty == VarT typeVar1 ->
+ (,) [] <$> (wrap (varE 'Transformation.traverse `appE` trans) `appE` fieldAccess)
+ AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 ->
+ (,) <$> ((:[]) <$> deepConstraint (pure con))
+ <*> appE (wrap [| Transformation.Deep.traverseDown $trans |]) fieldAccess
+ AppT t1 t2 | t1 /= VarT typeVar1 ->
+ genTraverseDownField trans t2 deepConstraint shallowConstraint fieldAccess (wrap . appE (varE 'traverse))
+ SigT ty _kind -> genTraverseDownField trans ty deepConstraint shallowConstraint fieldAccess wrap
+ ParensT ty -> genTraverseDownField trans ty deepConstraint shallowConstraint fieldAccess wrap
+ _ -> (,) [] <$> [| pure $fieldAccess |]
+
+genTraverseUpField :: GenTraverseFieldType
+genTraverseUpField trans fieldType deepConstraint shallowConstraint fieldAccess wrap = do
+ Just (Deriving _ typeVarN typeVar1) <- getQ
+ case fieldType of
+ AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN ->
+ (,) <$> ((:) <$> deepConstraint (pure con) <*> ((:[]) <$> shallowConstraint (pure con)))
+ <*> appE (wrap [| (>>= Transformation.traverse $trans) . traverse (Transformation.Deep.traverseUp $trans) |])
+ fieldAccess
+ AppT ty _ | ty == VarT typeVar1 ->
+ (,) [] <$> (wrap (varE 'Transformation.traverse `appE` trans) `appE` fieldAccess)
+ AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 ->
+ (,) <$> ((:[]) <$> deepConstraint (pure con))
+ <*> appE (wrap [| Transformation.Deep.traverseUp $trans |]) fieldAccess
+ AppT t1 t2 | t1 /= VarT typeVar1 ->
+ genTraverseUpField trans t2 deepConstraint shallowConstraint fieldAccess (wrap . appE (varE 'traverse))
+ SigT ty _kind -> genTraverseUpField trans ty deepConstraint shallowConstraint fieldAccess wrap
+ ParensT ty -> genTraverseUpField trans ty deepConstraint shallowConstraint fieldAccess wrap
+ _ -> (,) [] <$> [| pure $fieldAccess |]
diff --git a/src/Transformation/Rank2.hs b/src/Transformation/Rank2.hs
new file mode 100644
index 0000000..d34f387
--- /dev/null
+++ b/src/Transformation/Rank2.hs
@@ -0,0 +1,36 @@
+{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses,
+ PolyKinds, RankNTypes, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+
+module Transformation.Rank2 where
+
+import qualified Transformation as Shallow
+import qualified Transformation.Deep as Deep
+
+import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd)
+
+newtype Map p q = Map (forall x. p x -> q x)
+
+newtype Fold p m = Fold (forall x. p x -> m)
+
+newtype Traversal p q m = Traversal (forall x. p x -> m (q x))
+
+instance Shallow.Functor (Map p q) p q x where
+ (<$>) (Map f) = f
+
+instance Shallow.Foldable (Fold p m) p m x where
+ foldMap (Fold f) = f
+
+instance Shallow.Traversable (Traversal p q m) p q m x where
+ traverse (Traversal t) = t
+
+(<$>) :: Deep.Functor (Map p q) g p q => (forall a. p a -> q a) -> g p p -> g q q
+(<$>) f = (Deep.<$>) (Map f)
+
+foldMap :: (Deep.Foldable (Fold p m) g p m, Monoid m) => (forall a. p a -> m) -> g p p -> m
+foldMap f = Deep.foldMap (Fold f)
+
+traverseDown :: Deep.DownTraversable (Traversal p q m) g p q m => (forall a. p a -> m (q a)) -> g p p -> m (g q q)
+traverseDown f = Deep.traverseDown (Traversal f)
+
+traverseUp :: Deep.UpTraversable (Traversal p q m) g p q m => (forall a. p a -> m (q a)) -> g p p -> m (g q q)
+traverseUp f = Deep.traverseUp (Traversal f)
diff --git a/test/Test.hs b/test/Test.hs
index af0b2f6..d21eb9c 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -2,15 +2,29 @@ module Main where
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 @@ exampleTree ancestry path =
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)