diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for language-oberon +## 0.3 -- 2020-11-01 + +* Preserving the parsed start and end positions and lexemes of every node +* Added the `Reserializer` module and the `--original` command-line option +* Added the `ConstantFolder` module +* Moved the `Transformation` modules into the new `deep-transformations` package +* Eliminated many of the attribute grammar rules using `Tranformation.AG.Generics` +* Added the `README` + ## 0.2.1 -- 2019-01-27 * Pretty-printer fixes diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,18 @@ +language-oberon - Oberon parser, pretty-printer, and more +--------------------------------------------------------- + +This package provides a library and executable for parsing and processing the source code in programming language +Oberon. The following functionality is presently available: + +* Parsing with the grammars specified in the + [Grammar](http://hackage.haskell.org/package/language-oberon/docs/Language-Oberon-Grammar.html) module. +* Resolution of identifiers and disambiguation of a parsed AST with the + [Resolver](http://hackage.haskell.org/package/language-oberon/docs/Language-Oberon-Resolver.html) module. +* Checking and reporting of type errors with the + [TypeChecker](http://hackage.haskell.org/package/language-oberon/docs/Language-Oberon-TypeChecker.html) module. +* Constant folding with the + [ConstantFolder](http://hackage.haskell.org/package/language-oberon/docs/Language-Oberon-ConstantFolder.html) module. +* Re-printing of a parsed AST in its original form, preserving the whitespace and comments, with the + [Reserializer](http://hackage.haskell.org/package/language-oberon/docs/Language-Oberon-Reserializer.html) module. +* Pretty-printing of a parsed AST with the + [Pretty](http://hackage.haskell.org/package/language-oberon/docs/Language-Oberon-Pretty.html) module. diff --git a/app/Parse.hs b/app/Parse.hs --- a/app/Parse.hs +++ b/app/Parse.hs @@ -1,49 +1,59 @@ -{-# LANGUAGE FlexibleInstances, RankNTypes, RecordWildCards, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, RecordWildCards, ScopedTypeVariables, TypeFamilies #-} module Main where -import Language.Oberon (parseAndResolveModule) -import Language.Oberon.AST (Module(..), StatementSequence, Statement, Expression) +import Language.Oberon (Placed, LanguageVersion(Oberon1, Oberon2), Options(..), parseAndResolveModule) +import Language.Oberon.AST (Language, Module(..), StatementSequence, Statement, Expression) +import qualified Language.Oberon.AST as AST import qualified Language.Oberon.Grammar as Grammar -import qualified Language.Oberon.Resolver as Resolver import qualified Language.Oberon.Pretty () +import qualified Language.Oberon.Reserializer as Reserializer +import qualified Language.Oberon.Resolver as Resolver +import qualified Language.Oberon.TypeChecker as TypeChecker + +import qualified Transformation.Rank2 as Rank2 +import qualified Transformation.Deep as Deep + import Data.Text.Prettyprint.Doc (Pretty(pretty)) import Data.Text.Prettyprint.Doc.Util (putDocW) +import Control.Arrow (second) import Control.Monad import Data.Data (Data) import Data.Either.Validation (Validation(..), validationToEither) -import Data.Functor.Identity (Identity) -import Data.Functor.Compose (getCompose) +import Data.Functor.Identity (Identity(Identity)) +import Data.Functor.Compose (Compose(..)) import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.Map.Lazy as Map import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Text.IO (getLine, readFile, getContents) -import Data.Typeable (Typeable) +import qualified Data.Text.IO as Text import Options.Applicative -import Text.Grampa (Ambiguous, Grammar, ParseResults, parseComplete, showFailure) +import qualified Text.Parser.Input.Position as Position +import Text.Grampa (Ambiguous, Grammar, parseComplete, failureDescription) import qualified Text.Grampa.ContextFree.LeftRecursive as LeftRecursive import ReprTree -import System.FilePath (FilePath, takeDirectory) +import System.FilePath (FilePath, addExtension, combine, takeDirectory) import Prelude hiding (getLine, getContents, readFile) -data GrammarMode = TypeCheckedModuleMode | ModuleWithImportsMode | ModuleMode | AmbiguousModuleMode | DefinitionMode - | StatementsMode | StatementMode | ExpressionMode +data GrammarMode = ModuleWithImportsMode | ModuleMode | AmbiguousModuleMode | DefinitionMode + | StatementMode | ExpressionMode deriving Show -data Output = Plain | Pretty Int | Tree +data Output = Original | Plain | Pretty Int | Tree deriving Show data Opts = Opts - { optsMode :: GrammarMode - , optsOberon2 :: Bool - , optsIndex :: Int - , optsOutput :: Output - , optsInclude :: Maybe FilePath - , optsFile :: Maybe FilePath + { optsMode :: GrammarMode + , optsVersion :: LanguageVersion + , optsCheckTypes :: Bool + , optsFoldConstants :: Bool + , optsIndex :: Int + , optsOutput :: Output + , optsInclude :: Maybe FilePath + , optsFile :: Maybe FilePath } deriving Show main :: IO () @@ -57,10 +67,15 @@ p :: Parser Opts p = Opts <$> mode - <*> (switch (long "oberon2")) + <*> (flag' Oberon2 (long "oberon2") + <|> flag' Oberon1 (long "oberon1") + <|> pure Oberon2) + <*> (switch (long "check-types")) + <*> (switch (long "fold-constants")) <*> (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") - <|> Tree <$ switch (long "tree" <> help "Print the output as an abstract syntax tree") + <|> flag' Tree (long "tree" <> help "Print the output as an abstract syntax tree") + <|> flag' Original (long "original" <> help "Print the output with the original tokens and whitespace") <|> pure Plain) <*> optional (strOption (short 'i' <> long "include" <> metavar "DIRECTORY" <> help "Where to look for imports")) @@ -69,79 +84,120 @@ <> help "Oberon file to parse")) mode :: Parser GrammarMode - 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") - <|> StatementMode <$ switch (long "statement") - <|> StatementsMode <$ switch (long "statements") - <|> ExpressionMode <$ switch (long "expression") + mode = flag' ModuleWithImportsMode (long "module-with-imports") + <|> flag' ModuleMode (long "module") + <|> flag' AmbiguousModuleMode (long "module-ambiguous") + <|> flag' DefinitionMode (long "definition") + <|> flag' StatementMode (long "statement") + <|> flag' ExpressionMode (long "expression") main' :: Opts -> IO () main' Opts{..} = case optsFile of Just file -> (if file == "-" then getContents else readFile file) >>= case optsMode - of TypeCheckedModuleMode -> - \source-> parseAndResolveModule True optsOberon2 - (fromMaybe (takeDirectory file) optsInclude) source - >>= succeed optsOutput source - ModuleWithImportsMode -> - \source-> parseAndResolveModule False optsOberon2 - (fromMaybe (takeDirectory file) optsInclude) source - >>= succeed optsOutput source - ModuleMode -> go (Resolver.resolveModule predefined mempty) Grammar.module_prod - chosenGrammar file - DefinitionMode -> go (Resolver.resolveModule predefined mempty) Grammar.module_prod - Grammar.oberonDefinitionGrammar file - AmbiguousModuleMode -> go pure Grammar.module_prod chosenGrammar file - _ -> error "A file usually contains a whole module." + of ModuleWithImportsMode -> + let dir = fromMaybe (takeDirectory file) optsInclude + in \source-> parseAndResolveModule Options{checkTypes= optsCheckTypes, + foldConstants= optsFoldConstants, + version= optsVersion} dir source + >>= succeed optsOutput (reportTypeErrorIn dir) id + ModuleMode -> + go (Resolver.resolveModule predefined mempty) Grammar.module_prod chosenGrammar file + DefinitionMode -> + go (Resolver.resolveModule predefined mempty) Grammar.module_prod + Grammar.oberonDefinitionGrammar file + AmbiguousModuleMode -> + go pure Grammar.module_prod chosenGrammar file + _ -> error "A file usually contains a whole module." Nothing -> forever $ getLine >>= case optsMode of + ModuleWithImportsMode -> + let dir = fromMaybe "." optsInclude + in \source-> parseAndResolveModule Options{checkTypes= optsCheckTypes, + foldConstants= optsFoldConstants, + version= optsVersion} dir source + >>= succeed optsOutput (reportTypeErrorIn dir) id ModuleMode -> go (Resolver.resolveModule predefined mempty) Grammar.module_prod chosenGrammar "" AmbiguousModuleMode -> go pure Grammar.module_prod chosenGrammar "" DefinitionMode -> go (Resolver.resolveModule predefined mempty) Grammar.module_prod Grammar.oberonDefinitionGrammar "" StatementMode -> go pure Grammar.statement chosenGrammar "" - StatementsMode -> go pure Grammar.statementSequence chosenGrammar "" ExpressionMode -> go pure Grammar.expression chosenGrammar "" + where - chosenGrammar = if optsOberon2 then Grammar.oberon2Grammar else Grammar.oberonGrammar - predefined = if optsOberon2 then Resolver.predefined2 else Resolver.predefined - go :: (Show f, Data f, Pretty f) => - (f' -> Validation (NonEmpty Resolver.Error) f) - -> (forall p. Grammar.OberonGrammar Ambiguous p -> p f') - -> (Grammar (Grammar.OberonGrammar Ambiguous) LeftRecursive.Parser Text) + chosenGrammar = case optsVersion + of Oberon1 -> Grammar.oberonGrammar + Oberon2 -> Grammar.oberon2Grammar + predefined = case optsVersion + of Oberon1 -> Resolver.predefined + Oberon2 -> Resolver.predefined2 + go :: (Data a, Flattenable a, Pretty a, Show a, a ~ f (g f f), + Deep.Functor (Rank2.Map Grammar.NodeWrap NodeWrap) g) => + (NodeWrap (g NodeWrap NodeWrap) -> Validation (NonEmpty (Resolver.Error Language)) a) + -> (forall p. Grammar.OberonGrammar AST.Language Grammar.NodeWrap p + -> p (Grammar.NodeWrap (g Grammar.NodeWrap Grammar.NodeWrap))) + -> (Grammar (Grammar.OberonGrammar AST.Language Grammar.NodeWrap) Grammar.Parser Text) -> String -> Text -> IO () go resolve production grammar filename contents = - case getCompose (production $ parseComplete grammar contents) - of Right [x] -> succeed optsOutput contents (resolve x) + case getCompose (second (Resolver.resolvePositions contents) + <$> getCompose (production $ parseComplete grammar contents)) + of Right [(s, x)] -> succeed optsOutput (reportTypeErrorIn $ takeDirectory filename) Left (resolve x) Right l -> putStrLn ("Ambiguous: " ++ show optsIndex ++ "/" ++ show (length l) ++ " parses") - >> succeed optsOutput contents (resolve $ l !! optsIndex) - Left err -> putStrLn (showFailure contents err 3) + >> succeed optsOutput (reportTypeErrorIn $ takeDirectory filename) Left (resolve . snd $ l !! optsIndex) + Left err -> Text.putStrLn (failureDescription contents err 4) -succeed out contents x = either reportFailure showSuccess (validationToEither x) - where reportFailure (Resolver.UnparseableModule err :| []) = putStrLn (showFailure contents err 3) - reportFailure errs = print errs +type NodeWrap = Compose ((,) (Int, Int)) (Compose Ambiguous ((,) Grammar.ParsedLexemes)) + +succeed :: (Data a, Flattenable a, Pretty a, Show a) + => Output -> (TypeChecker.Error Language -> IO ()) + -> (err -> Either (NonEmpty (Resolver.Error Language)) (NonEmpty (TypeChecker.Error Language))) + -> Validation err a -> IO () +succeed out reportTypeError prepare x = either (reportFailure . prepare) showSuccess (validationToEither x) + where reportFailure (Left (Resolver.UnparseableModule err :| [])) = Text.putStrLn err + reportFailure (Left errs) = print errs + reportFailure (Right errs) = mapM_ reportTypeError errs showSuccess = case out - of Pretty width -> putDocW width . pretty + of Original -> Text.putStr . flatten + Pretty width -> putDocW width . pretty Tree -> putStrLn . reprTreeString Plain -> print -instance Pretty (Module Ambiguous Ambiguous) where - pretty _ = error "Disambiguate before pretty-printing" -instance Pretty (StatementSequence Ambiguous Ambiguous) where +reportTypeErrorIn directory (moduleName, (pos, _, _), err) = + do contents <- readFile (combine directory $ addExtension (unpack moduleName) "Mod") + putStrLn ("Type error: " ++ TypeChecker.errorMessage err) + Text.putStrLn (Position.context contents (Position.fromStart pos) 4) + +class Flattenable a where + flatten :: a -> Text + +instance Flattenable (Placed (Module Language Language Placed Placed)) where + flatten = Reserializer.reserialize +instance Flattenable (Placed (StatementSequence Language Language Placed Placed)) where + flatten = Reserializer.reserialize +instance Flattenable (Placed (Statement Language Language Placed Placed)) where + flatten = Reserializer.reserialize +instance Flattenable (Placed (Expression Language Language Placed Placed)) where + flatten = Reserializer.reserialize + +instance Flattenable (NodeWrap a) where + flatten = error "Disambiguate before serializing" + +instance {-# overlaps #-} Pretty a => Pretty (Placed a) where + pretty = pretty . snd +instance Pretty (Module Language Language Placed Placed) where + pretty m = pretty ((Identity . snd) Rank2.<$> m) +instance Pretty (Module Language Language NodeWrap NodeWrap) where pretty _ = error "Disambiguate before pretty-printing" -instance Pretty (Ambiguous (Statement Ambiguous Ambiguous)) where +instance Pretty (StatementSequence Language Language NodeWrap NodeWrap) where pretty _ = error "Disambiguate before pretty-printing" -instance Pretty (Statement Ambiguous Ambiguous) where +instance Pretty (Statement Language Language NodeWrap NodeWrap) where pretty _ = error "Disambiguate before pretty-printing" -instance Pretty (Expression Ambiguous Ambiguous) where +instance Pretty (Expression Language Language NodeWrap NodeWrap) where pretty _ = error "Disambiguate before pretty-printing" -instance Pretty (Ambiguous (Expression Ambiguous Ambiguous)) where +instance Pretty (NodeWrap a) where pretty _ = error "Disambiguate before pretty-printing" diff --git a/examples/AGRS/Texts.Def b/examples/AGRS/Texts.Def --- a/examples/AGRS/Texts.Def +++ b/examples/AGRS/Texts.Def @@ -38,7 +38,27 @@ pos: LONGINT; (* Offset of Finder in text. *) END; + Handler* = PROCEDURE (e: Elem; VAR msg: ElemMsg); + ElemMsg* = RECORD END ; + + Run = POINTER TO RunDesc; + RunDesc = RECORD + prev, next: Run; + len: LONGINT; + fnt: Fonts.Font; + col, voff: SHORTINT; + ascii: BOOLEAN + END ; + + Elem* = POINTER TO ElemDesc; + ElemDesc* = RECORD (RunDesc) + W*, H*: LONGINT; + handle*: Handler; + base: Text + END ; + Reader = RECORD (* Character-wise reader of a text stream. *) + elem*: Elem; lib: Objects.Library; (* Library of last character/object read. *) col: SHORTINT; (* Color index of last character read. *) voff: SHORTINT; (* vertical offset of last character read. *) diff --git a/language-oberon.cabal b/language-oberon.cabal --- a/language-oberon.cabal +++ b/language-oberon.cabal @@ -2,20 +2,15 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-oberon -version: 0.2.1 -synopsis: Parser, pretty-printer, and type checker for the Oberon programming language +version: 0.3 +synopsis: Parser, pretty-printer, and more 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 . . - The grammars in "Language.Oberon.Grammar" attempt to follow the language grammars from the reports, while - generating a semantically meaningful abstract syntax tree; the latter is defined in "Language.Oberon.AST". As the - grammars are ambiguous, it is necessary to resolve the ambiguities after parsing all Oberon modules in use. - "Language.Oberon.Resolver" provides this functionality. Only after the ambiguity resolution can the abstract syntax - tree be pretty-printed using the instances from "Language.Oberon.Pretty". - . The original purpose for the library was to be a test of the underlying - library. The experiment succeeded, so the package can be used in practice. + library. The experiment succeeded, so + the package can be used in practice. homepage: https://github.com/blamario/language-oberon bug-reports: https://github.com/blamario/language-oberon/issues @@ -23,39 +18,43 @@ license-file: LICENSE author: Mario Blažević maintainer: blamario@protonmail.com --- copyright: +copyright: (c) 2018 Mario Blažević category: Language build-type: Simple -extra-source-files: ChangeLog.md, examples/AGRS/*.Def, examples/AGRS/*.Mod +extra-source-files: README.md, ChangeLog.md, examples/AGRS/*.Def, examples/AGRS/*.Mod cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Language.Oberon, - Language.Oberon.AST, Language.Oberon.Grammar, - 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.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 + Language.Oberon.Abstract, Language.Oberon.AST, Language.Oberon.ConstantFolder, + Language.Oberon.Grammar, Language.Oberon.Pretty, Language.Oberon.Reserializer, + Language.Oberon.Resolver, Language.Oberon.TypeChecker + build-depends: base >= 4.12 && < 5, base-orphans >= 0.8.2 && < 1.0, + text < 1.3, containers >= 0.5 && < 1.0, filepath < 1.5, directory < 1.4, + parsers >= 0.12.7 && < 0.13, input-parsers < 0.2, + prettyprinter >= 1.2.1 && < 1.8, either == 5.*, + rank2classes >= 1.3 && < 1.5, grammatical-parsers >= 0.5 && < 0.6, deep-transformations < 0.2, + transformers == 0.5.*, + template-haskell >= 2.11 && < 2.17 default-language: Haskell2010 executable parse main-is: app/Parse.hs -- 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.2.1 && < 1.3, - rank2classes < 1.3, grammatical-parsers > 0.3.1 && < 0.4, language-oberon, + build-depends: base >= 4.12 && < 5, text < 1.3, either == 5.*, containers >= 0.5 && < 1.0, + repr-tree-syb < 0.2, filepath < 1.5, prettyprinter, + rank2classes, input-parsers, grammatical-parsers, deep-transformations < 0.2, + language-oberon, optparse-applicative default-language: Haskell2010 test-suite examples type: exitcode-stdio-1.0 - 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, + build-depends: base >= 4.12 && < 5, text < 1.3, grammatical-parsers, + either == 5.*, directory < 2, filepath < 1.5, prettyprinter, + deep-transformations < 0.2, tasty >= 0.7, tasty-hunit, language-oberon main-is: test/Test.hs diff --git a/src/Language/Oberon.hs b/src/Language/Oberon.hs --- a/src/Language/Oberon.hs +++ b/src/Language/Oberon.hs @@ -1,85 +1,131 @@ --- | Every function in this module takes a flag that determines whether the input is an Oberon or Oberon-2 module. +{-# Language FlexibleContexts, RecordWildCards, TypeFamilies #-} -module Language.Oberon (parseModule, parseAndResolveModule, parseAndResolveModuleFile) where +-- | The programming languages Oberon and Oberon-2 -import Language.Oberon.AST (Module(..)) +module Language.Oberon (parseModule, parseAndResolveModule, parseAndResolveModuleFile, + LanguageVersion(..), Options(..), NodeWrap, Placed) where + +import Language.Oberon.AST (Language, Module(..)) import qualified Language.Oberon.Grammar as Grammar import qualified Language.Oberon.Resolver as Resolver +import qualified Language.Oberon.Reserializer as Reserializer +import qualified Language.Oberon.ConstantFolder as ConstantFolder import qualified Language.Oberon.TypeChecker as TypeChecker +import Language.Oberon.Resolver (NodeWrap, Placed) -import Control.Monad (when) +import qualified Transformation.Deep as Deep +import qualified Transformation.Full as Full + +import Control.Monad (guard) import Data.Either.Validation (Validation(..)) -import Data.Functor.Identity (Identity) -import Data.Functor.Compose (getCompose) +import Data.Functor.Compose (Compose(Compose, getCompose)) import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Lazy as Map import Data.Map.Lazy (Map) import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Text.IO (readFile) -import Text.Grampa (Ambiguous, Grammar, ParseResults, parseComplete) +import Text.Grampa (Ambiguous(Ambiguous), Grammar, ParseResults, parseComplete, failureDescription) import qualified Text.Grampa.ContextFree.LeftRecursive as LeftRecursive import System.Directory (doesFileExist) import System.FilePath (FilePath, addExtension, combine, takeDirectory) import Prelude hiding (readFile) +data LanguageVersion = Oberon1 | Oberon2 deriving (Eq, Ord, Show) + +-- | choice of modes of operation +data Options = Options{ + -- | whether to fold the constants + foldConstants :: Bool, + -- | whether to verify the types + checkTypes :: Bool, + -- | which language version? + version :: LanguageVersion} + +moduleGrammar Oberon1 = Grammar.oberonGrammar +moduleGrammar Oberon2 = Grammar.oberon2Grammar + +definitionGrammar Oberon1 = Grammar.oberonDefinitionGrammar +definitionGrammar Oberon2 = Grammar.oberon2DefinitionGrammar + -- | Parse the given text of a single module, without resolving the syntactic ambiguities. -parseModule :: Bool -> Text -> ParseResults [Module Ambiguous Ambiguous] -parseModule oberon2 = getCompose . Grammar.module_prod - . parseComplete (if oberon2 then Grammar.oberon2Grammar else Grammar.oberonGrammar) +parseModule :: LanguageVersion -> Text -> ParseResults Text [NodeWrap (Module Language Language NodeWrap NodeWrap)] +parseModule version src = + getCompose (Resolver.resolvePositions src . snd + <$> (getCompose $ Grammar.module_prod $ parseComplete (moduleGrammar version) src)) -- | Parse the given text of a single /definition/ module, without resolving the syntactic ambiguities. -parseDefinitionModule :: Bool -> Text -> ParseResults [Module Ambiguous Ambiguous] -parseDefinitionModule oberon2 = getCompose . Grammar.module_prod - . parseComplete (if oberon2 then Grammar.oberon2DefinitionGrammar - else Grammar.oberonDefinitionGrammar) +parseDefinitionModule :: LanguageVersion -> Text + -> ParseResults Text [NodeWrap (Module Language Language NodeWrap NodeWrap)] +parseDefinitionModule version src = + getCompose (Resolver.resolvePositions src . snd + <$> (getCompose $ Grammar.module_prod $ parseComplete (definitionGrammar version) src)) -parseNamedModule :: Bool -> FilePath -> Text -> IO (ParseResults [Module Ambiguous Ambiguous]) -parseNamedModule oberon2 path name = +parseNamedModule :: LanguageVersion -> FilePath -> Text + -> IO (ParseResults Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]) +parseNamedModule version path name = do let basePath = combine path (unpack name) isDefn <- doesFileExist (addExtension basePath "Def") - let grammar = if oberon2 - then if isDefn then Grammar.oberon2DefinitionGrammar else Grammar.oberon2Grammar - else if isDefn then Grammar.oberonDefinitionGrammar else Grammar.oberonGrammar - getCompose . Grammar.module_prod . parseComplete grammar - <$> readFile (addExtension basePath $ if isDefn then "Def" else "Mod") + let grammar = (if isDefn then definitionGrammar else moduleGrammar) version + src <- readFile (addExtension basePath $ if isDefn then "Def" else "Mod") + return (getCompose $ Resolver.resolvePositions src . snd + <$> (getCompose $ Grammar.module_prod $ parseComplete grammar src)) -parseImportsOf :: Bool -> FilePath -> Map Text (Module Ambiguous Ambiguous) -> IO (Map Text (Module Ambiguous Ambiguous)) -parseImportsOf oberon2 path modules = +parseImportsOf :: LanguageVersion -> FilePath -> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap)) + -> IO (Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))) +parseImportsOf version path modules = case filter (`Map.notMember` modules) moduleImports of [] -> return modules newImports -> (((modules <>) . Map.fromList . map assertSuccess) <$> - (traverse . traverse) (parseNamedModule oberon2 path) [(p, p) | p <- newImports]) - >>= parseImportsOf oberon2 path - where moduleImports = foldMap importsOf modules - importsOf (Module _ imports _ _ _) = snd <$> imports - assertSuccess (m, Left err) = error ("Parse error in module " <> unpack m <> ":" <> show err) + (traverse . traverse) (parseNamedModule version path) [(p, p) | p <- newImports]) + >>= parseImportsOf version path + where moduleImports = foldMap importsOf (Compose modules) + importsOf (Module _ imports _) = snd <$> imports + assertSuccess (m, Left err) = error ("Parse error in module " <> unpack m) assertSuccess (m, Right [p]) = (m, p) assertSuccess (m, Right _) = error ("Ambiguous parses of module " <> unpack m) -- | 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 -> 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) +parseAndResolveModule :: Options -> FilePath -> Text + -> IO (Validation (Either (NonEmpty (Resolver.Error Language)) + (NonEmpty (TypeChecker.Error Language))) + (Placed (Module Language Language Placed Placed))) +parseAndResolveModule Options{..} path source = + case parseModule version source + of Left err -> return (Failure $ Left $ Resolver.UnparseableModule (failureDescription source err 4) :| []) + Right [rootModule@(Compose (pos, Compose (Ambiguous ((_, Module moduleName imports _) :| []))))] -> + do importedModules <- parseImportsOf version path (Map.singleton moduleName rootModule) let resolvedImportMap = Resolver.resolveModule predefinedScope resolvedImportMap <$> importedModules - predefinedScope = if oberon2 then Resolver.predefined2 else Resolver.predefined + predefinedScope = case version + of Oberon1 -> Resolver.predefined + Oberon2 -> Resolver.predefined2 successful (Success a) = Just a successful _ = Nothing + addLeft (Failure resolutionErrors) = Failure (Left resolutionErrors) + addLeft (Success result) = Success result + constantFolded = Reserializer.adjustPositions <$> + ConstantFolder.foldConstants + (case version + of Oberon1 -> ConstantFolder.predefined + Oberon2 -> ConstantFolder.predefined2) + (Map.mapMaybe successful resolvedImportMap) 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 :| []) + (case version + of Oberon1 -> TypeChecker.predefined + Oberon2 -> TypeChecker.predefined2) + constantFolded + return (if checkTypes && not (null typeErrors) + then Failure (Right (NonEmpty.fromList typeErrors)) + else maybe (addLeft $ resolvedImportMap Map.! moduleName) Success + (guard foldConstants *> Map.lookup moduleName constantFolded)) + Right _ -> return (Failure $ Left $ Resolver.AmbiguousParses :| []) -- | Parse the module file at the given path, assuming all its imports are in the same directory. -parseAndResolveModuleFile :: Bool -> Bool -> FilePath - -> IO (Validation (NonEmpty Resolver.Error) (Module Identity Identity)) -parseAndResolveModuleFile checkTypes oberon2 path = - readFile path >>= parseAndResolveModule checkTypes oberon2 (takeDirectory path) +parseAndResolveModuleFile :: Options -> FilePath + -> IO (Validation (Either (NonEmpty (Resolver.Error Language)) (NonEmpty (TypeChecker.Error Language))) + (Placed (Module Language Language Placed Placed))) +parseAndResolveModuleFile options path = + readFile path >>= parseAndResolveModule options (takeDirectory path) diff --git a/src/Language/Oberon/AST.hs b/src/Language/Oberon/AST.hs --- a/src/Language/Oberon/AST.hs +++ b/src/Language/Oberon/AST.hs @@ -1,198 +1,466 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, - StandaloneDeriving, TemplateHaskell #-} + OverloadedStrings, StandaloneDeriving, TemplateHaskell, TypeFamilies #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} --- | Oberon Abstract Syntax Tree definitions +-- | Concrete data types for Oberon constructs that make up its Abstract Syntax Tree. Every data type from this module +-- is an instance of a type family declared in "Language.Oberon.Abstract". This way it can be replaced by another data +-- type for another language while leaving other types to be reused. -module Language.Oberon.AST where +module Language.Oberon.AST (module Language.Oberon.AST, RelOp(..)) where +import Control.Applicative (ZipList(ZipList, getZipList)) +import Control.Monad (forM, mapM) import Data.Data (Data, Typeable) -import Data.Functor.Identity (Identity) -import Data.List.NonEmpty +import Data.List.NonEmpty (NonEmpty((:|))) import Data.Text (Text) -import Transformation.Deep (Product) +import qualified Transformation +import qualified Transformation.Shallow as Shallow +import qualified Transformation.Shallow.TH import qualified Transformation.Deep.TH +import qualified Transformation.AG as AG import qualified Rank2.TH -data Module f' f = Module Ident [Import] ([f (Declaration f' f')]) (Maybe (f (StatementSequence f' f'))) Ident +import qualified Language.Oberon.Abstract as Abstract +import Language.Oberon.Abstract (RelOp(..)) -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) +-- | Data type representing the Oberon language, both versions of it. +data Language = Language deriving (Data, Typeable) +instance Abstract.Wirthy Language where + type Module Language = Module Language + type Declaration Language = Declaration Language + type Type Language = Type Language + type Statement Language = Statement Language + type Expression Language = Expression Language + type Designator Language = Designator Language + type Value Language = Value Language + + type Import Language = Import Language + type FieldList Language = FieldList Language + type ProcedureHeading Language = ProcedureHeading Language + type FormalParameters Language = FormalParameters Language + type FPSection Language = FPSection Language + type Block Language = Block Language + type StatementSequence Language = StatementSequence Language + type Case Language = Case Language + type CaseLabels Language = CaseLabels Language + type ConditionalBranch Language = ConditionalBranch Language + type Element Language = Element Language + + type IdentDef Language = IdentDef Language + type QualIdent Language = QualIdent Language + + -- Declaration + constantDeclaration = ConstantDeclaration + typeDeclaration = TypeDeclaration + variableDeclaration = VariableDeclaration + procedureDeclaration = ProcedureDeclaration + + formalParameters = FormalParameters . ZipList + fpSection = FPSection + block = Block . ZipList + + fieldList = FieldList + + -- Type + pointerType = PointerType + procedureType = ProcedureType + typeReference = TypeReference + + -- Statement + assignment = Assignment + caseStatement scrutinee cases = CaseStatement scrutinee (ZipList cases) + emptyStatement = EmptyStatement + exitStatement = Exit + ifStatement (branch :| branches) = If branch (ZipList branches) + loopStatement = Loop + procedureCall proc args = ProcedureCall proc (ZipList <$> args) + repeatStatement = Repeat + returnStatement = Return + whileStatement = While + + conditionalBranch = ConditionalBranch + caseAlternative (c :| cs) = Case c (ZipList cs) + labelRange = LabelRange + singleLabel = SingleLabel + + statementSequence = StatementSequence . ZipList + + -- Expression + add = Add + and = And + divide = Divide + functionCall fun args = FunctionCall fun (ZipList args) + integerDivide = IntegerDivide + literal = Literal + modulo = Modulo + multiply = Multiply + negative = Negative + not = Not + or = Or + positive = Positive + read = Read + relation = Relation + subtract = Subtract + + element = Element + range = Range + + -- Value + builtin = Builtin + charCode = CharCode + false = Boolean False + integer = Integer + nil = Nil + real = Real + string = String + true = Boolean True + + -- Designator + variable = Variable + field = Field + index array (i :| is) = Index array i (ZipList is) + dereference = Dereference + + -- Identifier + identDef = flip IdentDef PrivateOnly + nonQualIdent = NonQualIdent + +instance Abstract.CoWirthy Language where + type TargetClass Language = Abstract.Oberon2 + coDeclaration (ConstantDeclaration name value) = Abstract.constantDeclaration name value + coDeclaration (TypeDeclaration name ty) = Abstract.typeDeclaration name ty + coDeclaration (VariableDeclaration name ty) = Abstract.variableDeclaration name ty + coDeclaration (ProcedureDeclaration heading body) = Abstract.procedureDeclaration heading body + coDeclaration (ForwardDeclaration name params) = Abstract.forwardDeclaration name params + + coType (TypeReference q) = Abstract.typeReference q + coType (ProcedureType params) = Abstract.procedureType params + coType (PointerType destination) = Abstract.pointerType destination + coType (ArrayType dimensions itemType) = Abstract.arrayType (getZipList dimensions) itemType + coType (RecordType baseType fields) = Abstract.recordType baseType (getZipList fields) + + coStatement EmptyStatement = Abstract.emptyStatement + coStatement (Assignment destination expression) = Abstract.assignment destination expression + coStatement (ProcedureCall procedure parameters) = Abstract.procedureCall procedure $ getZipList <$> parameters + coStatement (If branch elsifs fallback) = Abstract.ifStatement (branch :| getZipList elsifs) fallback + coStatement (CaseStatement scrutinee cases fallback) = Abstract.caseStatement scrutinee (getZipList cases) fallback + coStatement (While condition body) = Abstract.whileStatement condition body + coStatement (Repeat body condition) = Abstract.repeatStatement body condition + coStatement (For index from to by body) = Abstract.forStatement index from to by body + coStatement (Loop body) = Abstract.loopStatement body + coStatement (With alternative alternatives fallback) = + Abstract.variantWithStatement (alternative :| getZipList alternatives) fallback + coStatement Exit = Abstract.exitStatement + coStatement (Return result) = Abstract.returnStatement result + + coExpression (Relation op left right) = Abstract.relation op left right + coExpression (IsA scrutinee typeName) = Abstract.is scrutinee typeName + coExpression (Positive e) = Abstract.positive e + coExpression (Negative e) = Abstract.negative e + coExpression (Add left right) = Abstract.add left right + coExpression (Subtract left right) = Abstract.subtract left right + coExpression (Or left right) = Abstract.or left right + coExpression (Multiply left right) = Abstract.multiply left right + coExpression (Divide left right) = Abstract.divide left right + coExpression (IntegerDivide left right) = Abstract.integerDivide left right + coExpression (Modulo left right) = Abstract.modulo left right + coExpression (And left right) = Abstract.and left right + coExpression (Set elements) = Abstract.set (getZipList elements) + coExpression (Read var) = Abstract.read var + coExpression (FunctionCall function parameters) = Abstract.functionCall function $ getZipList parameters + coExpression (Not e) = Abstract.not e + + coValue Nil = Abstract.nil + coValue (Boolean False) = Abstract.false + coValue (Boolean True) = Abstract.true + coValue (Builtin name) = Abstract.builtin name + coValue (Integer n) = Abstract.integer n + coValue (Real r) = Abstract.real r + coValue (String s) = Abstract.string s + coValue (CharCode c) = Abstract.charCode c + + coDesignator (Variable q) = Abstract.variable q + coDesignator (Field record name) = Abstract.field record name + coDesignator (Index array index indexes) = Abstract.index array (index :| getZipList indexes) + coDesignator (TypeGuard scrutinee typeName) = Abstract.typeGuard scrutinee typeName + coDesignator (Dereference pointer) = Abstract.dereference pointer + +instance Abstract.Nameable Language where + getProcedureName (ProcedureHeading _ iddef _) = Abstract.getIdentDefName iddef + getProcedureName (TypeBoundHeading _ _ _ _ iddef _) = Abstract.getIdentDefName iddef + getIdentDefName (IdentDef name _) = name + getNonQualIdentName (NonQualIdent name) = Just name + getNonQualIdentName _ = Nothing + +isNamedVar :: Abstract.Nameable l => Ident -> Maybe (Designator Language l f f) -> Bool +isNamedVar name (Just (Variable q)) | Abstract.getNonQualIdentName q == Just name = True +isNamedVar _ _ = False + +instance Abstract.Oberon Language where + type WithAlternative Language = WithAlternative Language + moduleUnit = Module + moduleImport = (,) + exported = flip IdentDef Exported + qualIdent = QualIdent + getQualIdentNames (QualIdent moduleName name) = Just (moduleName, name) + getQualIdentNames _ = Nothing + + arrayType = ArrayType . ZipList + recordType base fields = RecordType base (ZipList fields) + procedureHeading = ProcedureHeading + forwardDeclaration = ForwardDeclaration + withStatement alt = With alt (ZipList []) Nothing + withAlternative = WithAlternative + is = IsA + set = Set . ZipList + typeGuard = TypeGuard + +instance Abstract.Oberon2 Language where + readOnly = flip IdentDef ReadOnly + typeBoundHeading = TypeBoundHeading + forStatement = For + variantWithStatement (variant :| variants) = With variant (ZipList variants) + +data Module λ l f' f = Module Ident [Import l] (f (Abstract.Block l l f' f')) + +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (Abstract.Import l), + Data (f (Abstract.Block l l f' f'))) => + Data (Module λ l f' f) +deriving instance (Show (Abstract.Import l), Show (f (Abstract.Block l l f' f'))) => Show (Module λ l f' f) + type Ident = Text -type Import = (Maybe Ident, Ident) +type Import l = (Maybe Ident, Ident) -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'))) +data Declaration λ l f' f = ConstantDeclaration (Abstract.IdentDef l) (f (Abstract.ConstExpression l l f' f')) + | TypeDeclaration (Abstract.IdentDef l) (f (Abstract.Type l l f' f')) + | VariableDeclaration (Abstract.IdentList l) (f (Abstract.Type l l f' f')) + | ProcedureDeclaration (f (Abstract.ProcedureHeading l l f' f')) + (f (Abstract.Block l l f' f')) + | ForwardDeclaration (Abstract.IdentDef l) (Maybe (f (Abstract.FormalParameters l l f' 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) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', + Data (f (Abstract.Type l l f' f')), Data (f (Abstract.ConstExpression l l f' f')), + Data (f (Abstract.FormalParameters l l f' f')), Data (f (Abstract.ProcedureHeading l l f' f')), + Data (f (Abstract.Block l l f' f')), Data (Abstract.IdentDef l)) => Data (Declaration λ l f' f) +deriving instance (Show (f (Abstract.Type l l f' f')), Show (f (Abstract.ConstExpression l l f' f')), + Show (f (Abstract.FormalParameters l l f' f')), Show (f (Abstract.ProcedureHeading l l f' f')), + Show (f (Abstract.Block l l f' f')), Show (Abstract.IdentDef l)) => Show (Declaration λ l f' f) -data IdentDef = IdentDef Ident AccessMode +data QualIdent l = QualIdent Ident Ident + | NonQualIdent Ident deriving (Data, Eq, Ord, Show) +data IdentDef l = IdentDef Ident AccessMode + deriving (Data, Eq, Ord, Show) + data AccessMode = Exported | ReadOnly | PrivateOnly deriving (Data, Eq, Ord, Show) -type ConstExpression = Expression +data Expression λ l f' f = Relation RelOp (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + | IsA (f (Abstract.Expression l l f' f')) (Abstract.QualIdent l) + | Positive (f (Abstract.Expression l l f' f')) + | Negative (f (Abstract.Expression l l f' f')) + | Add (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + | Subtract (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + | Or (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + | Multiply (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + | Divide (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + | IntegerDivide (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + | Modulo (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + | And (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + | Set (ZipList (f (Abstract.Element l l f' f'))) + | Read (f (Abstract.Designator l l f' f')) + | FunctionCall (f (Abstract.Designator l l f' f')) (ZipList (f (Abstract.Expression l l f' f'))) + | Not (f (Abstract.Expression l l f' f')) + | Literal (f (Abstract.Value l l f' 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 λ, Typeable l, Typeable f, Typeable f', + Data (Abstract.QualIdent l), Data (f (Abstract.Value l l f' f')), + Data (f (Abstract.Designator l l f' f')), Data (f (Abstract.Element l l f' f')), + Data (f (Abstract.Expression l l f' f'))) => + Data (Expression λ l f' f) +deriving instance (Show (Abstract.QualIdent l), Show (f (Abstract.Value l l f' f')), Show (f (Abstract.Designator l l f' f')), + Show (f (Abstract.Element l l f' f')), Show (f (Abstract.Expression l l f' f'))) => + Show (Expression λ l f' f) +deriving instance (Eq (Abstract.QualIdent l), Eq (f (Abstract.Value l l f' f')), + Eq (f (Abstract.Designator l l f' f')), Eq (f (Abstract.Element l l f' f')), + Eq (f (Abstract.Expression l l f' f'))) => Eq (Expression λ l 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 Element λ l f' f = Element (f (Abstract.Expression l l f' f')) + | Range (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) -data RelOp = Equal | Unequal | Less | LessOrEqual | Greater | GreaterOrEqual | In | Is - deriving (Data, Show) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (f (Abstract.Expression l l f' f'))) => + Data (Element λ l f' f) +deriving instance Show (f (Abstract.Expression l l f' f')) => Show (Element λ l f' f) +deriving instance Eq (f (Abstract.Expression l l f' f')) => Eq (Element λ l f' f) -data Element f' f = Element (f (Expression f' f')) - | Range (f (Expression f' f')) (f (Expression f' f')) +data Value λ l (f' :: * -> *) (f :: * -> *) = Boolean Bool + | Builtin Text + | CharCode Int + | Integer Integer + | Nil + | Real Double + | String Text + deriving (Eq, Show) -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 λ, Typeable l, Typeable f, Typeable f') => Data (Value λ l f' 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')) +data Designator λ l f' f = Variable (Abstract.QualIdent l) + | Field (f (Abstract.Designator l l f' f')) Ident + | Index (f (Abstract.Designator l l f' f')) + (f (Abstract.Expression l l f' f')) (ZipList (f (Abstract.Expression l l f' f'))) + | TypeGuard (f (Abstract.Designator l l f' f')) (Abstract.QualIdent l) + | Dereference (f (Abstract.Designator l l f' 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) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (Abstract.QualIdent l), + Data (f (Abstract.Designator l l f' f')), Data (f (Abstract.Expression l l f' f'))) => + Data (Designator λ l f' f) +deriving instance (Show (Abstract.QualIdent l), Show (f (Abstract.Designator l l f' f')), + Show (f (Abstract.Expression l l f' f'))) => Show (Designator λ l f' f) +deriving instance (Eq (Abstract.QualIdent l), Eq (f (Abstract.Designator l l f' f')), + Eq (f (Abstract.Expression l l f' f'))) => Eq (Designator λ l f' 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'))) +data Type λ l f' f = TypeReference (Abstract.QualIdent l) + | ArrayType (ZipList (f (Abstract.ConstExpression l l f' f'))) (f (Abstract.Type l l f' f')) + | RecordType (Maybe (Abstract.BaseType l)) (ZipList (f (Abstract.FieldList l l f' f'))) + | PointerType (f (Abstract.Type l l f' f')) + | ProcedureType (Maybe (f (Abstract.FormalParameters l l f' 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) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (Abstract.QualIdent l), Data (f (Abstract.Type l l f' f')), + Data (f (Abstract.ConstExpression l l f' f')), Data (f (Abstract.FormalParameters l l f' f')), + Data (f (Abstract.FieldList l l f' f'))) => + Data (Type λ l f' f) +deriving instance (Show (Abstract.QualIdent l), Show (f (Abstract.Type l l f' f')), + Show (f (Abstract.ConstExpression l l f' f')), Show (f (Abstract.FormalParameters l l f' f')), + Show (f (Abstract.FieldList l l f' f'))) => + Show (Type λ l f' f) -data QualIdent = QualIdent Ident Ident - | NonQualIdent Ident - deriving (Data, Eq, Ord, Show) +data FieldList λ l f' f = FieldList (Abstract.IdentList l) (f (Abstract.Type l l f' f')) -type BaseType = QualIdent +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (Abstract.IdentDef l), Data (f (Abstract.Type l l f' f')), + Data (f (Abstract.Expression l l f' f'))) => Data (FieldList λ l f' f) +deriving instance (Show (Abstract.IdentDef l), Show (f (Abstract.Type l l f' f')), Show (f (Abstract.Expression l l f' f'))) => + Show (FieldList λ l f' f) -data FieldList f' f = FieldList IdentList (f (Type f' f')) - | EmptyFieldList +data ProcedureHeading λ l f' f = + ProcedureHeading Bool (Abstract.IdentDef l) (Maybe (f (Abstract.FormalParameters l l f' f'))) + | TypeBoundHeading Bool Ident Ident Bool (Abstract.IdentDef l) (Maybe (f (Abstract.FormalParameters l l f' 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) +data FormalParameters λ l f' f = FormalParameters (ZipList (f (Abstract.FPSection l l f' f'))) (Maybe (Abstract.ReturnType l)) -type IdentList = NonEmpty IdentDef +data FPSection λ l f' f = FPSection Bool [Ident] (f (Abstract.Type l l f' f')) -data ProcedureHeading f' f = - ProcedureHeading (Maybe (Bool, Ident, Ident)) Bool IdentDef (Maybe (f (FormalParameters f' f'))) -data FormalParameters f' f = FormalParameters [f (FPSection f' f')] (Maybe QualIdent) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (Abstract.IdentDef l), + Data (f (Abstract.FormalParameters l l f' f'))) => Data (ProcedureHeading λ l f' f) +deriving instance (Show (Abstract.IdentDef l), Show (f (Abstract.FormalParameters l l f' f'))) => + Show (ProcedureHeading λ l f' f) -data FPSection f' f = FPSection Bool (NonEmpty Ident) (f (Type f' f')) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (Abstract.ReturnType l), + Data (f (Abstract.FPSection l l f' f')), Data (f (Abstract.Expression l l f' f'))) => + Data (FormalParameters λ l f' f) +deriving instance (Show (f (Abstract.FPSection l l f' f')), Show (Abstract.ReturnType l), + Show (f (Abstract.Expression l l f' f'))) => Show (FormalParameters λ l 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 λ, Typeable l, Typeable f, Typeable f', Data (f (Abstract.Type l l f' f')), + Data (f (Abstract.Expression l l f' f'))) => Data (FPSection λ l f' f) +deriving instance (Show (f (Abstract.Type l l f' f')), Show (f (Abstract.Expression l l f' f'))) => Show (FPSection λ l 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) +data Block λ l f' f = Block (ZipList (f (Abstract.Declaration l l f' f'))) (Maybe (f (Abstract.StatementSequence l l 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) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (f (Abstract.Declaration l l f' f')), + Data (f (Abstract.Designator l l f' f')), Data (f (Abstract.Expression l l f' f')), + Data (f (Abstract.StatementSequence l l f' f'))) => + Data (Block λ l f' f) +deriving instance (Show (f (Abstract.Declaration l l f' f')), Show (f (Abstract.Designator l l f' f')), + Show (f (Abstract.Expression l l f' f')), Show (f (Abstract.StatementSequence l l f' f'))) => + Show (Block λ l f' f) -data ProcedureBody f' f = ProcedureBody [f (Declaration f' f')] (Maybe (f (StatementSequence f' f'))) +newtype StatementSequence λ l f' f = StatementSequence (ZipList (f (Abstract.Statement l l 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) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (f (Abstract.Statement l l f' f'))) => + Data (StatementSequence λ l f' f) +deriving instance Show (f (Abstract.Statement l l f' f')) => Show (StatementSequence λ l f' f) -newtype StatementSequence f' f = StatementSequence (NonEmpty (f (Statement f' f'))) +data Statement λ l f' f = EmptyStatement + | Assignment (f (Abstract.Designator l l f' f')) (f (Abstract.Expression l l f' f')) + | ProcedureCall (f (Abstract.Designator l l f' f')) (Maybe (ZipList (f (Abstract.Expression l l f' f')))) + | If (f (Abstract.ConditionalBranch l l f' f')) + (ZipList (f (Abstract.ConditionalBranch l l f' f'))) + (Maybe (f (Abstract.StatementSequence l l f' f'))) + | CaseStatement (f (Abstract.Expression l l f' f')) + (ZipList (f (Abstract.Case l l f' f'))) + (Maybe (f (Abstract.StatementSequence l l f' f'))) + | While (f (Abstract.Expression l l f' f')) (f (Abstract.StatementSequence l l f' f')) + | Repeat (f (Abstract.StatementSequence l l f' f')) (f (Abstract.Expression l l f' f')) + | For Ident (f (Abstract.Expression l l f' f')) (f (Abstract.Expression l l f' f')) + (Maybe (f (Abstract.Expression l l f' f'))) (f (Abstract.StatementSequence l l f' f')) -- Oberon2 + | Loop (f (Abstract.StatementSequence l l f' f')) + | With (f (Abstract.WithAlternative l l f' f')) + (ZipList (f (Abstract.WithAlternative l l f' f'))) + (Maybe (f (Abstract.StatementSequence l l f' f'))) + | Exit + | Return (Maybe (f (Abstract.Expression l l 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) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', + Data (f (Abstract.Designator l l f' f')), Data (f (Abstract.Expression l l f' f')), + Data (f (Abstract.Case l l f' f')), Data (f (Abstract.WithAlternative l l f' f')), + Data (f (Abstract.ConditionalBranch l l f' f')), + Data (f (Abstract.StatementSequence l l f' f'))) => Data (Statement λ l f' f) +deriving instance (Show (f (Abstract.Designator l l f' f')), Show (f (Abstract.Expression l l f' f')), + Show (f (Abstract.Case l l f' f')), Show (f (Abstract.WithAlternative l l f' f')), + Show (f (Abstract.ConditionalBranch l l f' f')), + Show (f (Abstract.StatementSequence l l f' f'))) => Show (Statement λ l 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'))) +data WithAlternative λ l f' f = WithAlternative (Abstract.QualIdent l) (Abstract.QualIdent l) + (f (Abstract.StatementSequence l l 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 Case λ l f' f = Case (f (Abstract.CaseLabels l l f' f')) (ZipList (f (Abstract.CaseLabels l l f' f'))) + (f (Abstract.StatementSequence l l f' f')) -data WithAlternative f' f = WithAlternative QualIdent QualIdent (f (StatementSequence f' f')) +data CaseLabels λ l f' f = SingleLabel (f (Abstract.ConstExpression l l f' f')) + | LabelRange (f (Abstract.ConstExpression l l f' f')) (f (Abstract.ConstExpression l l f' f')) -data Case f' f = Case (NonEmpty (f (CaseLabels f' f'))) (f (StatementSequence f' f')) - | EmptyCase +data ConditionalBranch λ l f' f = + ConditionalBranch (f (Abstract.Expression l l f' f')) (f (Abstract.StatementSequence l l f' f')) -data CaseLabels f' f = SingleLabel (f (ConstExpression f' f')) - | LabelRange (f (ConstExpression f' f')) (f (ConstExpression f' f')) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (Abstract.QualIdent l), + Data (f (Abstract.Designator l l f' f')), Data (f (Abstract.StatementSequence l l f' f'))) => + Data (WithAlternative λ l f' f) +deriving instance (Show (Abstract.QualIdent l), Show (f (Abstract.StatementSequence l l f' f'))) => + Show (WithAlternative λ l 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 λ, Typeable l, Typeable f, Typeable f', + Data (f (Abstract.CaseLabels l l f' f')), Data (f (Abstract.StatementSequence l l f' f'))) => + Data (Case λ l f' f) +deriving instance (Show (f (Abstract.CaseLabels l l f' f')), Show (f (Abstract.StatementSequence l l f' f'))) => + Show (Case λ l 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 λ, Typeable l, Typeable f, Typeable f', + Data (f (Abstract.Expression l l f' f')), Data (f (Abstract.StatementSequence l l f' f'))) => + Data (ConditionalBranch λ l f' f) +deriving instance (Show (f (Abstract.Expression l l f' f')), Show (f (Abstract.StatementSequence l l f' f'))) => + Show (ConditionalBranch λ l 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) +deriving instance (Typeable λ, Typeable l, Typeable f, Typeable f', Data (f (Abstract.ConstExpression l l f' f'))) => + Data (CaseLabels λ l f' f) +deriving instance Show (f (Abstract.ConstExpression l l f' f')) => Show (CaseLabels λ l f' f) -$(mconcat <$> mapM Transformation.Deep.TH.deriveAll - [''Module, ''Declaration, ''Type, ''Expression, +$(concat <$> + (forM [Rank2.TH.deriveFunctor, Rank2.TH.deriveFoldable, Rank2.TH.deriveTraversable, + Transformation.Shallow.TH.deriveAll, Transformation.Deep.TH.deriveAll] $ + \derive-> mconcat <$> mapM derive + [''Module, ''Declaration, ''Type, ''Expression, ''Value, + ''Element, ''Designator, ''FieldList, + ''ProcedureHeading, ''FormalParameters, ''FPSection, ''Block, + ''Statement, ''StatementSequence, + ''Case, ''CaseLabels, ''ConditionalBranch, ''WithAlternative])) + +$(mconcat <$> mapM Rank2.TH.unsafeDeriveApply + [''Declaration, ''Type, ''Expression, ''Value, ''Element, ''Designator, ''FieldList, - ''ProcedureHeading, ''FormalParameters, ''FPSection, ''ProcedureBody, - ''Statement, ''StatementSequence, ''WithAlternative, ''Case, ''CaseLabels]) + ''ProcedureHeading, ''FormalParameters, ''FPSection, ''Block, + ''Statement, ''StatementSequence, + ''Case, ''CaseLabels, ''ConditionalBranch, ''WithAlternative]) diff --git a/src/Language/Oberon/Abstract.hs b/src/Language/Oberon/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon/Abstract.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE DeriveDataTypeable, KindSignatures, PolyKinds, RankNTypes, ScopedTypeVariables, + TypeApplications, TypeFamilies, TypeFamilyDependencies, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +-- | Finally Tagless Abstract Syntax Tree definitions for the programming language Oberon + +module Language.Oberon.Abstract (-- * Language classes + Wirthy(..), CoWirthy(..), Oberon(..), Oberon2(..), Nameable(..), + -- * Type synonyms + Ident, IdentList, BaseType, ReturnType, ConstExpression, + -- * Auxiliary data types + RelOp(..), WirthySubsetOf(..), Maybe3(..), + -- * Utilities + just3, nothing3, maybe3, + ) where + +import Data.Data (Data) +import Data.Kind (Constraint) +import Data.List.NonEmpty +import Data.Text (Text) + +import Prelude hiding (and, not, or, read, subtract) + +type Ident = Text + +-- | Relational operators +data RelOp = Equal | Unequal | Less | LessOrEqual | Greater | GreaterOrEqual | In + deriving (Data, Eq, Show) + +-- | The finally-tagless associated types and methods relevant to all programming languages designed by Niklaus +-- Wirth. Every non-leaf node type has four type variables: +-- +-- * type variable @l@ represents the language of the constructs built by the methods, +-- * @l'@ is the language of the child node constructs, +-- * @f'@ wraps all descendant nodes, except +-- * @f@ wraps all direct children of the node. +class Wirthy l where + type Module l = (m :: * -> (* -> *) -> (* -> *) -> *) | m -> l + type Declaration l = (d :: * -> (* -> *) -> (* -> *) -> *) | d -> l + type Type l = (t :: * -> (* -> *) -> (* -> *) -> *) | t -> l + type Statement l = (s :: * -> (* -> *) -> (* -> *) -> *) | s -> l + type Expression l = (e :: * -> (* -> *) -> (* -> *) -> *) | e -> l + type Designator l = (d :: * -> (* -> *) -> (* -> *) -> *) | d -> l + type Value l = (v :: * -> (* -> *) -> (* -> *) -> *) | v -> l + + type FieldList l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + type ProcedureHeading l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + type FormalParameters l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + type FPSection l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + type Block l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + type StatementSequence l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + type Case l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + type CaseLabels l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + type ConditionalBranch l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + type Element l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + + type Import l = x | x -> l + type IdentDef l = x | x -> l + type QualIdent l = x | x -> l + + -- Declaration + constantDeclaration :: IdentDef l' -> f (ConstExpression l' l' f' f') -> Declaration l l' f' f + typeDeclaration :: IdentDef l' -> f (Type l' l' f' f') -> Declaration l l' f' f + variableDeclaration :: IdentList l' -> f (Type l' l' f' f') -> Declaration l l' f' f + procedureDeclaration :: f (ProcedureHeading l' l' f' f') -> f (Block l' l' f' f') -> Declaration l l' f' f + + formalParameters :: [f (FPSection l' l' f' f')] -> Maybe (ReturnType l') -> FormalParameters l l' f' f + fpSection :: Bool -> [Ident] -> f (Type l' l' f' f') -> FPSection l l' f' f + block :: [f (Declaration l' l' f' f')] -> Maybe (f (StatementSequence l' l' f' f')) -> Block l l' f' f + + fieldList :: NonEmpty (IdentDef l') -> f (Type l' l' f' f') -> FieldList l l' f' f + + -- Type + pointerType :: f (Type l' l' f' f') -> Type l l' f' f + procedureType :: Maybe (f (FormalParameters l' l' f' f')) -> Type l l' f' f + typeReference :: QualIdent l' -> Type l l' f' f + + -- Statement + assignment :: f (Designator l' l' f' f') -> f (Expression l' l' f' f') -> Statement l l' f' f + caseStatement :: f (Expression l' l' f' f') -> [f (Case l' l' f' f')] -> Maybe (f (StatementSequence l' l' f' f')) + -> Statement l l' f' f + emptyStatement :: Statement l l' f' f + exitStatement :: Statement l l' f' f + ifStatement :: NonEmpty (f (ConditionalBranch l' l' f' f')) + -> Maybe (f (StatementSequence l' l' f' f')) + -> Statement l l' f' f + loopStatement :: f (StatementSequence l' l' f' f') -> Statement l l' f' f + procedureCall :: f (Designator l' l' f' f') -> Maybe [f (Expression l' l' f' f')] -> Statement l l' f' f + repeatStatement :: f (StatementSequence l' l' f' f') -> f (Expression l' l' f' f') -> Statement l l' f' f + returnStatement :: Maybe (f (Expression l' l' f' f')) -> Statement l l' f' f + whileStatement :: f (Expression l' l' f' f') -> f (StatementSequence l' l' f' f') -> Statement l l' f' f + + conditionalBranch :: f (Expression l' l' f' f') -> f (StatementSequence l' l' f' f') -> ConditionalBranch l l' f' f + caseAlternative :: NonEmpty (f (CaseLabels l' l' f' f')) -> f (StatementSequence l' l' f' f') -> Case l l' f' f + + singleLabel :: f (ConstExpression l' l' f' f') -> CaseLabels l l' f' f + labelRange :: f (ConstExpression l' l' f' f') -> f (ConstExpression l' l' f' f') -> CaseLabels l l' f' f + + statementSequence :: [f (Statement l' l' f' f')] -> StatementSequence l l' f' f + + -- Expression + add, subtract :: f (Expression l' l' f' f') -> f (Expression l' l' f' f') -> Expression l l' f' f + and, or :: f (Expression l' l' f' f') -> f (Expression l' l' f' f') -> Expression l l' f' f + divide, integerDivide, modulo, multiply :: f (Expression l' l' f' f') -> f (Expression l' l' f' f') -> Expression l l' f' f + functionCall :: f (Designator l' l' f' f') -> [f (Expression l' l' f' f')] -> Expression l l' f' f + literal :: f (Value l' l' f' f') -> Expression l l' f' f + negative, positive :: f (Expression l' l' f' f') -> Expression l l' f' f + not :: f (Expression l' l' f' f') -> Expression l l' f' f + read :: f (Designator l' l' f' f') -> Expression l l' f' f + relation :: RelOp -> f (Expression l' l' f' f') -> f (Expression l' l' f' f') -> Expression l l' f' f + + element :: f (Expression l' l' f' f') -> Element l l' f' f + range :: f (Expression l' l' f' f') -> f (Expression l' l' f' f') -> Element l l' f' f + + -- Value + integer :: Integer -> Value l l' f' f + nil, false, true :: Value l l' f' f + real :: Double -> Value l l' f' f + string :: Text -> Value l l' f' f + charCode :: Int -> Value l l' f' f + builtin :: Text -> Value l l' f' f + + -- Designator + variable :: QualIdent l' -> Designator l l' f' f + field :: f (Designator l' l' f' f') -> Ident -> Designator l l' f' f + index :: f (Designator l' l' f' f') -> NonEmpty (f (Expression l' l' f' f')) -> Designator l l' f' f + dereference :: f (Designator l' l' f' f') -> Designator l l' f' f + + -- Identifier + identDef :: Ident -> IdentDef l + nonQualIdent :: Ident -> QualIdent l + +-- | An instance of this type can convert its own constructs to another language that's an instance of 'TargetClass'. +class Wirthy l => CoWirthy l where + type TargetClass l :: * -> Constraint + type TargetClass l = Wirthy + coDeclaration :: TargetClass l l' => Declaration l l'' f' f -> Declaration l' l'' f' f + coType :: TargetClass l l' => Type l l'' f' f -> Type l' l'' f' f + coStatement :: TargetClass l l' => Statement l l'' f' f -> Statement l' l'' f' f + coExpression :: TargetClass l l' => Expression l l'' f' f -> Expression l' l'' f' f + coDesignator :: TargetClass l l' => Designator l l'' f' f -> Designator l' l'' f' f + coValue :: TargetClass l l' => Value l l'' f' f -> Value l' l'' f' f + +-- | A language with constructs beyond the base 'Wirthy' class will have constructs that cannot be converted to a +-- | 'Wirthy' target. It can declare its 'TargetClass' to be this transformed language instead, whose language +-- | constructs are all wrapped in 'Maybe' or 'Maybe3'. +data WirthySubsetOf l = WirthySubsetOf l + +-- | A modified 'Maybe' with kind that fits the types associated with 'Wirthy'. +newtype Maybe3 f a b c = Maybe3 (Maybe (f a b c)) deriving (Eq, Ord, Read, Show) + +-- | Smart 'Maybe3' constructor corresponding to 'Just' +just3 = Maybe3 . Just +-- | Smart 'Maybe3' constructor corresponding to 'Nothing' +nothing3 = Maybe3 Nothing +-- | Smart 'Maybe3' destructor corresponding to 'maybe' +maybe3 n f (Maybe3 x) = maybe n f x + +instance Wirthy l => Wirthy (WirthySubsetOf l) where + type Module (WirthySubsetOf l) = Maybe3 (Module l) + type Declaration (WirthySubsetOf l) = Maybe3 (Declaration l) + type Type (WirthySubsetOf l) = Maybe3 (Type l) + type Statement (WirthySubsetOf l) = Maybe3 (Statement l) + type Expression (WirthySubsetOf l) = Maybe3 (Expression l) + type Designator (WirthySubsetOf l) = Maybe3 (Designator l) + type Value (WirthySubsetOf l) = Maybe3 (Value l) + + type FieldList (WirthySubsetOf l) = Maybe3 (FieldList l) + type ProcedureHeading (WirthySubsetOf l) = Maybe3 (ProcedureHeading l) + type FormalParameters (WirthySubsetOf l) = Maybe3 (FormalParameters l) + type FPSection (WirthySubsetOf l) = Maybe3 (FPSection l) + type Block (WirthySubsetOf l) = Maybe3 (Block l) + type StatementSequence (WirthySubsetOf l) = Maybe3 (StatementSequence l) + type Case (WirthySubsetOf l) = Maybe3 (Case l) + type CaseLabels (WirthySubsetOf l) = Maybe3 (CaseLabels l) + type ConditionalBranch (WirthySubsetOf l) = Maybe3 (ConditionalBranch l) + type Element (WirthySubsetOf l) = Maybe3 (Element l) + + type Import (WirthySubsetOf l) = Maybe (Import l) + type IdentDef (WirthySubsetOf l) = Maybe (IdentDef l) + type QualIdent (WirthySubsetOf l) = Maybe (QualIdent l) + + -- Declaration + constantDeclaration = (just3 .) . constantDeclaration @l + typeDeclaration = (just3 .) . typeDeclaration @l + variableDeclaration = (just3 .) . variableDeclaration @l + procedureDeclaration = (just3 .) . procedureDeclaration @l + + formalParameters = (just3 .) . formalParameters @l + fpSection = ((just3 .) .) . fpSection @l + block = (just3 .) . block @l + + fieldList = (just3 .) . fieldList @l + + -- Type + pointerType = just3 . pointerType @l + procedureType = just3 . procedureType @l + typeReference = just3 . typeReference @l + + -- Statement + assignment = (just3 .) . assignment @l + caseStatement = ((just3 .) .) . caseStatement @l + emptyStatement = just3 (emptyStatement @l) + exitStatement = just3 (exitStatement @l) + ifStatement = (just3 .) . ifStatement @l + loopStatement = just3 . loopStatement @l + procedureCall = (just3 .) . procedureCall @l + repeatStatement = (just3 .) . repeatStatement @l + returnStatement = just3 . returnStatement @l + whileStatement = (just3 .) . whileStatement @l + + conditionalBranch = (just3 .) . conditionalBranch @l + caseAlternative = (just3 .) . caseAlternative @l + + singleLabel = just3 . singleLabel @l + labelRange = (just3 .) . labelRange @l + + statementSequence = just3 . statementSequence @l + + -- Expression + add = (just3 .) . add @l + subtract = (just3 .) . subtract @l + and = (just3 .) . and @l + or = (just3 .) . or @l + divide = (just3 .) . divide @l + integerDivide = (just3 .) . integerDivide @l + modulo = (just3 .) . modulo @l + multiply = (just3 .) . multiply @l + functionCall = (just3 .) . functionCall @l + literal = just3 . literal @l + negative = just3 . negative @l + positive = just3 . positive @l + not = just3 . not @l + read = just3 . read @l + relation = ((just3 .) .) . relation @l + + element = just3 . element @l + range = (just3 .) . range @l + + -- Value + integer = just3 . integer @l + nil = just3 (nil @l) + false = just3 (false @l) + true = just3 (true @l) + real = just3 . real @l + string = just3 . string @l + charCode = just3 . charCode @l + builtin = just3 . builtin @l + + -- Designator + variable = just3 . variable @l + field = (just3 .) . field @l + index = (just3 .) . index @l + dereference = just3 . dereference @l + + -- Identifier + identDef = Just . identDef @l + nonQualIdent = Just . nonQualIdent @l + +-- | Ability to deconstruct named constructs and obtain their 'Ident'. +class Wirthy l => Nameable l where + getProcedureName :: Nameable l' => ProcedureHeading l l' f' f -> Ident + getIdentDefName :: IdentDef l -> Ident + getNonQualIdentName :: QualIdent l -> Maybe Ident + +-- | The finally-tagless associated types and methods relevant to both versions of the Oberon language. +class Wirthy l => Oberon l where + type WithAlternative l = (x :: * -> (* -> *) -> (* -> *) -> *) | x -> l + + moduleUnit :: Ident -> [Import l] -> f (Block l' l' f' f') -> Module l l' f' f + moduleImport :: Maybe Ident -> Ident -> Import l + qualIdent :: Ident -> Ident -> QualIdent l + getQualIdentNames :: QualIdent l -> Maybe (Ident, Ident) + exported :: Ident -> IdentDef l + + forwardDeclaration :: IdentDef l' -> Maybe (f (FormalParameters l' l' f' f')) -> Declaration l l' f' f + procedureHeading :: Bool -> IdentDef l' -> Maybe (f (FormalParameters l' l' f' f')) -> ProcedureHeading l l' f' f + + arrayType :: [f (ConstExpression l' l' f' f')] -> f (Type l' l' f' f') -> Type l l' f' f + recordType :: Maybe (BaseType l') -> [f (FieldList l' l' f' f')] -> Type l l' f' f + + withStatement :: f (WithAlternative l' l' f' f') -> Statement l l' f' f + withAlternative :: QualIdent l' -> QualIdent l' -> f (StatementSequence l' l' f' f') -> WithAlternative l l' f' f + + is :: f (Expression l' l' f' f') -> QualIdent l' -> Expression l l' f' f + set :: [f (Element l' l' f' f')] -> Expression l l' f' f + + typeGuard :: f (Designator l' l' f' f') -> QualIdent l' -> Designator l l' f' f + +instance Wirthy l => Oberon (WirthySubsetOf l) where + type WithAlternative (WirthySubsetOf l) = Maybe3 (WithAlternative l) + moduleUnit = const $ const $ const nothing3 + moduleImport = const $ const Nothing + qualIdent = const $ const Nothing + getQualIdentNames = const Nothing + exported = const Nothing + + forwardDeclaration = const $ const nothing3 + procedureHeading = const $ const $ const nothing3 + + arrayType = const $ const nothing3 + recordType = const $ const nothing3 + + withStatement = const nothing3 + withAlternative = const $ const $ const nothing3 + + is = const $ const nothing3 + set = const nothing3 + + typeGuard = const $ const nothing3 + +-- | The finally-tagless associated types and methods relevant to the Oberon 2 language. +class Oberon l => Oberon2 l where + readOnly :: Ident -> IdentDef l + typeBoundHeading :: Bool -> Ident -> Ident -> Bool -> IdentDef l' -> Maybe (f (FormalParameters l' l' f' f')) + -> ProcedureHeading l l' f' f + forStatement :: Ident -> f (Expression l' l' f' f') -> f (Expression l' l' f' f') + -> Maybe (f (Expression l' l' f' f')) + -> f (StatementSequence l' l' f' f') + -> Statement l l' f' f + variantWithStatement :: NonEmpty (f (WithAlternative l' l' f' f')) -> Maybe (f (StatementSequence l' l' f' f')) + -> Statement l l' f' f + +instance Wirthy l => Oberon2 (WirthySubsetOf l) where + readOnly = const Nothing + typeBoundHeading = const $ const $ const $ const $ const $ const nothing3 + forStatement = const $ const $ const $ const $ const nothing3 + variantWithStatement = const $ const nothing3 + +type BaseType l = QualIdent l +type ReturnType l = QualIdent l +type ConstExpression l = Expression l +type IdentList l = NonEmpty (IdentDef l) diff --git a/src/Language/Oberon/ConstantFolder.hs b/src/Language/Oberon/ConstantFolder.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon/ConstantFolder.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, + TemplateHaskell, TypeFamilies, UndecidableInstances #-} + +-- | The main export of this module is the function 'foldConstants' that folds the constants in Oberon AST using a +-- attribute grammar. Other exports are helper functions and attribute types that can be reused for other languages or +-- attribute grammars. +-- +-- This module expects the ambiguities in the AST to be already resolved by the "Language.Oberon.Resolver" module. + +module Language.Oberon.ConstantFolder where + +import Control.Applicative (liftA2, ZipList(ZipList, getZipList)) +import Control.Arrow (first) +import Control.Monad (join) +import Data.Bits (shift) +import Data.Char (chr, ord, toUpper) +import Data.Functor.Identity (Identity(..)) +import Data.Int (Int32) +import Data.Map.Lazy (Map) +import qualified Data.Map.Lazy as Map +import Data.Semigroup (Semigroup(..)) +import qualified Data.Text as Text +import Foreign.Storable (sizeOf) +import GHC.Generics (Generic) +import Language.Haskell.TH (appT, conT, varT, varE, newName) +import Data.Text.Prettyprint.Doc (layoutCompact, Pretty(pretty)) +import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) + +import qualified Rank2 +import qualified Transformation +import qualified Transformation.Rank2 +import qualified Transformation.Deep as Deep +import qualified Transformation.Full as Full +import qualified Transformation.Full.TH +import qualified Transformation.Shallow as Shallow +import qualified Transformation.AG as AG +import Transformation.AG (Attribution(..), Atts, Inherited(..), Synthesized(..), Semantics) +import Transformation.AG.Generics (Auto(Auto), Bequether(..), Synthesizer(..), SynthesizedField(..), Mapped(..)) + +import qualified Language.Oberon.Abstract as Abstract +import qualified Language.Oberon.AST as AST +import qualified Language.Oberon.Pretty () +import Language.Oberon.Grammar (ParsedLexemes(Trailing), Lexeme(Token, WhiteSpace, lexemeType, lexemeText), + TokenType(Other)) + +-- | Fold the constants in the given collection of Oberon modules (a 'Map' of modules keyed by module name). It uses +-- the constant declarations from the modules as well as the given 'Environment' of predefined constants and +-- functions. The value of the latter argument is typically 'predefined' or 'predefined2'. +foldConstants :: (Abstract.Oberon l, Abstract.Nameable l, + Ord (Abstract.QualIdent l), Show (Abstract.QualIdent l), + Atts (Inherited (Auto ConstantFold)) (Abstract.Block l l Sem Sem) ~ InhCF l, + Atts (Synthesized (Auto ConstantFold)) (Abstract.Block l l Sem Sem) + ~ SynCFMod' l (Abstract.Block l l), + Full.Functor (Auto ConstantFold) (Abstract.Block l l), + Deep.Functor (Auto ConstantFold) (Abstract.Block l l)) + => Environment l -> Map AST.Ident (Placed (AST.Module l l Placed Placed)) + -> Map AST.Ident (Placed (AST.Module l l Placed Placed)) +foldConstants predef modules = + getModules (modulesFolded $ + syn (Transformation.apply (Auto ConstantFold) + (wrap (Auto ConstantFold Deep.<$> Modules modules)) + `Rank2.apply` + Inherited (InhCFRoot predef))) + where wrap = (,) (0, Trailing [], 0) + +type Placed = (,) (Int, ParsedLexemes, Int) + +type Environment l = Map (Abstract.QualIdent l) (Maybe (Abstract.Value l l Placed Placed)) + +newtype Modules l f' f = Modules {getModules :: Map AST.Ident (f (AST.Module l l f' f'))} + +data ConstantFold = ConstantFold + +type Sem = Semantics (Auto ConstantFold) + +instance Transformation.Transformation (Auto ConstantFold) where + type Domain (Auto ConstantFold) = Placed + type Codomain (Auto ConstantFold) = Semantics (Auto ConstantFold) + +data InhCFRoot l = InhCFRoot{rootEnv :: Environment l} deriving Generic + +data InhCF l = InhCF{env :: Environment l, + currentModule :: AST.Ident} + deriving Generic + +data SynCF a = SynCF{folded :: Mapped Placed a} deriving Generic + +data SynCFMod l a = SynCFMod{moduleEnv :: Environment l, + folded :: Mapped Placed a} + deriving Generic + +data SynCFExp λ l = SynCFExp{folded :: Mapped Placed (Abstract.Expression λ l Placed Placed), + foldedValue :: Maybe (Placed (Abstract.Value l l Placed Placed))} + +data SynCFDesignator l = SynCFDesignator{folded :: Mapped Placed (Abstract.Designator l l Placed Placed), + designatorValue :: Maybe (Placed (Abstract.Value l l Placed Placed))} + deriving Generic + +data SynCFRoot a = SynCFRoot{modulesFolded :: a} + +-- * Modules instances, TH candidates +instance (Transformation.Transformation t, Functor (Transformation.Domain t), Deep.Functor t (AST.Module l l), + Transformation.At t (AST.Module l l (Transformation.Codomain t) (Transformation.Codomain t))) => + Deep.Functor t (Modules l) where + t <$> ~(Modules ms) = Modules (mapModule <$> ms) + where mapModule m = t Transformation.$ ((t Deep.<$>) <$> m) + +instance Rank2.Functor (Modules l f') where + f <$> ~(Modules ms) = Modules (f <$> ms) + +instance Rank2.Apply (Modules l f') where + ~(Modules fs) <*> ~(Modules ms) = Modules (Map.intersectionWith Rank2.apply fs ms) + +instance (Transformation.Transformation t, Transformation.At t (AST.Module l l f f)) => + Shallow.Functor t (Modules l f) where + t <$> ~(Modules ms) = Modules ((t Transformation.$) <$> ms) + +-- * Boring attribute types +type instance Atts (Synthesized (Auto ConstantFold)) (Modules l _ _) = SynCFRoot (Modules l Placed Placed) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Module l l _ _) = SynCFMod' l (AST.Module l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Declaration l l _ _) = SynCFMod' l (AST.Declaration l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.ProcedureHeading l l _ _) = SynCF' (AST.ProcedureHeading l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Block l l _ _) = SynCFMod' l (AST.Block l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.FormalParameters l l _ _) = SynCF' (AST.FormalParameters l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.FPSection l l _ _) = SynCF' (AST.FPSection l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Type l l _ _) = SynCF' (AST.Type l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.FieldList l l _ _) = SynCF' (AST.FieldList l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.StatementSequence l l _ _) = + SynCF' (AST.StatementSequence l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Expression λ l _ _) = SynCFExp λ l +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Element l l _ _) = SynCF' (AST.Element l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Value l l _ _) = SynCF' (AST.Value l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Designator l l _ _) = SynCFDesignator l +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Statement l l _ _) = SynCF' (AST.Statement l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.Case l l _ _) = SynCF' (AST.Case l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.CaseLabels l l _ _) = SynCF' (AST.CaseLabels l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.ConditionalBranch l l _ _) = + SynCF' (AST.ConditionalBranch l l) +type instance Atts (Synthesized (Auto ConstantFold)) (AST.WithAlternative l l _ _) = SynCF' (AST.WithAlternative l l) + +type instance Atts (Inherited (Auto ConstantFold)) (Modules l _ _) = InhCFRoot l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Module l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Declaration l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.ProcedureHeading l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Block l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.FormalParameters l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.FPSection l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Type l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.FieldList l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.StatementSequence l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Expression l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Element l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Value l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Designator l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Statement l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.Case l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.CaseLabels l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.ConditionalBranch l l _ _) = InhCF l +type instance Atts (Inherited (Auto ConstantFold)) (AST.WithAlternative l l _ _) = InhCF l + +type SynCF' node = SynCF (node Placed Placed) +type SynCFMod' l node = SynCFMod l (node Placed Placed) + + +-- * Disambiguation + +folded' :: SynCF' node -> Mapped Placed (node Placed Placed) +foldedExp :: SynCFExp λ l -> Mapped Placed (Abstract.Expression λ l Placed Placed) +foldedExp' :: SynCFExp λ l -> Placed (Abstract.Expression λ l Placed Placed) + +folded' = folded +foldedExp = folded +foldedExp' = getMapped . foldedExp + +-- * Rules + +instance {-# overlaps #-} Ord (Abstract.QualIdent l) => + Synthesizer (Auto ConstantFold) (Modules l) Sem Placed where + synthesis _ (_, Modules self) inheritance (Modules ms) = + SynCFRoot{modulesFolded= (Modules (getMapped . foldedModule . syn <$> ms))} + where foldedModule :: SynCFMod' l (AST.Module l l) -> Mapped Placed (AST.Module l l Placed Placed) + foldedModule = folded + +instance {-# overlaps #-} Ord (Abstract.QualIdent l) => + Bequether (Auto ConstantFold) (Modules l) Sem Placed where + bequest _ (_, Modules self) inheritance (Modules ms) = Modules (Map.mapWithKey moduleInheritance self) + where moduleInheritance name mod = Inherited InhCF{env= rootEnv inheritance <> foldMap (moduleEnv . syn) ms, + currentModule= name} + +instance {-# overlaps #-} (Abstract.Oberon l, Abstract.Nameable l, Ord (Abstract.QualIdent l), Show (Abstract.QualIdent l), + Atts (Synthesized (Auto ConstantFold)) (Abstract.Block l l Sem Sem) ~ SynCFMod' l (Abstract.Block l l)) => + Synthesizer (Auto ConstantFold) (AST.Module l l) Sem Placed where + synthesis _ (pos, AST.Module moduleName imports _body) inheritance (AST.Module _ _ body) = + SynCFMod{moduleEnv= exportedEnv, + folded= Mapped (pos, + AST.Module moduleName imports $ getMapped + $ folded (syn body :: SynCFMod' l (Abstract.Block l l)))} + where exportedEnv = Map.mapKeysMonotonic export newEnv + newEnv = moduleEnv (syn body) + export q + | Just name <- Abstract.getNonQualIdentName q = Abstract.qualIdent moduleName name + | otherwise = q + +instance (Abstract.Nameable l, Ord (Abstract.QualIdent l), + Atts (Synthesized (Auto ConstantFold)) (Abstract.Declaration l l Sem Sem) ~ SynCFMod' l (Abstract.Declaration l l), + Atts (Inherited (Auto ConstantFold)) (Abstract.StatementSequence l l Sem Sem) ~ InhCF l, + Atts (Inherited (Auto ConstantFold)) (Abstract.Declaration l l Sem Sem) ~ InhCF l) => + Bequether (Auto ConstantFold) (AST.Block l l) Sem Placed where + bequest _ (pos, AST.Block _decls _stats) inheritance (AST.Block decls stats) = + AST.Block (pure $ Inherited localEnv) (pure $ Inherited localEnv) + where newEnv = Map.unions (moduleEnv . syn <$> decls) + localEnv = InhCF (newEnv `Map.union` env inheritance) (currentModule inheritance) + +instance (Abstract.Nameable l, k ~ Abstract.QualIdent l, v ~ Abstract.Value l l Placed Placed, Ord k, + Atts (Synthesized (Auto ConstantFold)) (Abstract.Declaration l l Sem Sem) + ~ SynCFMod' l (Abstract.Declaration l l)) => + SynthesizedField "moduleEnv" (Map k (Maybe v)) (Auto ConstantFold) (AST.Block l l) Sem Placed where + synthesizedField _ _ (_, AST.Block{}) _ (AST.Block decls _stats) = Map.unions (moduleEnv . syn <$> decls) + +instance (Abstract.Nameable l, k ~ Abstract.QualIdent l, v ~ Abstract.Value l l Placed Placed, Ord k, + Atts (Synthesized (Auto ConstantFold)) (Abstract.ConstExpression l l Sem Sem) ~ SynCFExp l l) => + SynthesizedField "moduleEnv" (Map k (Maybe v)) (Auto ConstantFold) (AST.Declaration l l) Sem Placed where + synthesizedField _ _ (_, AST.ConstantDeclaration namedef _) _ (AST.ConstantDeclaration _ expression) = + Map.singleton (Abstract.nonQualIdent $ Abstract.getIdentDefName namedef) + ((snd <$>) . foldedValue $ syn expression) + synthesizedField _ _ _ _ _ = mempty + +instance {-# overlaps #-} + (Abstract.Oberon l, Abstract.Nameable l, Ord (Abstract.QualIdent l), + Abstract.Value l ~ AST.Value l, InhCF l ~ InhCF λ, + Pretty (AST.Value λ λ Identity Identity), + Atts (Synthesized (Auto ConstantFold)) (Abstract.Expression l l Sem Sem) ~ SynCFExp l l, + Atts (Synthesized (Auto ConstantFold)) (Abstract.Element l l Sem Sem) ~ SynCF' (Abstract.Element l l), + Atts (Synthesized (Auto ConstantFold)) (Abstract.Designator l l Sem Sem) ~ SynCFDesignator l) => + Synthesizer (Auto ConstantFold) (AST.Expression λ l) Sem Placed where + synthesis _ (pos@(start, ls, end), AST.Relation op _ _) _ (AST.Relation _op left right) = + case join (compareValues <$> foldedValue (syn left) <*> foldedValue (syn right)) + of Just value -> literalSynthesis value + Nothing -> SynCFExp{folded= Mapped (pos, + Abstract.relation op (foldedExp' $ syn left) (foldedExp' $ syn right)), + foldedValue= Nothing} + where compareValues (_, AST.Boolean l) (ls, AST.Boolean r) = repos ls <$> relate op (compare l r) + compareValues (_, AST.Integer l) (ls, AST.Integer r) = repos ls <$> relate op (compare l r) + compareValues (_, AST.Real l) (ls, AST.Real r) = repos ls <$> relate op (compare l r) + compareValues (_, AST.Integer l) (ls, AST.Real r) = repos ls <$> relate op (compare (fromIntegral l) r) + compareValues (_, AST.Real l) (ls, AST.Integer r) = repos ls <$> relate op (compare l (fromIntegral r)) + compareValues (_, AST.CharCode l) (ls, AST.CharCode r) = repos ls <$> relate op (compare l r) + compareValues (_, AST.String l) (ls, AST.String r) = repos ls <$> relate op (compare l r) + compareValues (_, AST.CharCode l) (ls, AST.String r) = repos ls + <$> relate op (compare (Text.singleton $ chr l) r) + compareValues (_, AST.String l) (ls, AST.CharCode r) = repos ls + <$> relate op (compare l (Text.singleton $ chr r)) + compareValues _ _ = Nothing + repos (_, ls', _) v = ((start, anyWhitespace ls ls', end), v) + relate Abstract.Equal EQ = Just Abstract.true + relate Abstract.Equal _ = Just Abstract.false + relate Abstract.Unequal EQ = Just Abstract.false + relate Abstract.Unequal _ = Just Abstract.true + relate Abstract.Less LT = Just Abstract.true + relate Abstract.Less _ = Just Abstract.false + relate Abstract.LessOrEqual GT = Just Abstract.false + relate Abstract.LessOrEqual _ = Just Abstract.true + relate Abstract.Greater GT = Just Abstract.true + relate Abstract.Greater _ = Just Abstract.false + relate Abstract.GreaterOrEqual LT = Just Abstract.false + relate Abstract.GreaterOrEqual _ = Just Abstract.true + relate Abstract.In _ = Nothing + synthesis _ (pos@(start, ls, end), _) _ (AST.Positive expr) = + case foldedValue (syn expr) + of Just ((_, ls', _), AST.Integer n) -> literalSynthesis ((start, anyWhitespace ls ls', end), AST.Integer n) + Just ((_, ls', _), AST.Real n) -> literalSynthesis ((start, anyWhitespace ls ls', end), AST.Real n) + _ -> SynCFExp{folded= Mapped (pos, Abstract.positive $ foldedExp' $ syn expr), + foldedValue= Nothing} + synthesis _ (pos@(start, ls, end), _) _ (AST.Negative expr) = + case foldedValue (syn expr) + of Just ((_, ls', _), AST.Integer n) -> literalSynthesis ((start, anyWhitespace ls ls', end), + AST.Integer $ negate n) + Just ((_, ls', _), AST.Real n) -> literalSynthesis ((start, anyWhitespace ls ls', end), AST.Real $ negate n) + _ -> SynCFExp{folded= Mapped (pos, Abstract.negative $ foldedExp' $ syn expr), + foldedValue= Nothing} + synthesis _ (pos, _) _ (AST.Add left right) = + foldBinaryArithmetic pos Abstract.add (+) (syn left) (syn right) + synthesis _ (pos, _) _ (AST.Subtract left right) = + foldBinaryArithmetic pos Abstract.subtract (-) (syn left) (syn right) + synthesis _ (pos, _) _ (AST.Or left right) = + foldBinaryBoolean pos Abstract.or (||) (syn left) (syn right) + synthesis _ (pos, _) _ (AST.Multiply left right) = + foldBinaryArithmetic pos Abstract.multiply (*) (syn left) (syn right) + synthesis _ (pos, _) _ (AST.Divide left right) = + foldBinaryFractional pos Abstract.divide (/) (syn left) (syn right) + synthesis _ (pos, _) _ (AST.IntegerDivide left right) = + foldBinaryInteger pos Abstract.integerDivide div (syn left) (syn right) + synthesis _ (pos, _) _ (AST.Modulo left right) = + foldBinaryInteger pos Abstract.modulo mod (syn left) (syn right) + synthesis _ (pos, _) _ (AST.And left right) = + foldBinaryBoolean pos Abstract.and (&&) (syn left) (syn right) + synthesis _ (pos@(start, ls, end), _) _ (AST.Not expr) = + case foldedValue (syn expr) + of Just ((_, ls', _), AST.Boolean b) -> literalSynthesis ((start, anyWhitespace ls ls', end), + if b then Abstract.false else Abstract.true) + _ -> SynCFExp{folded= Mapped (pos, Abstract.not $ foldedExp' $ syn expr), + foldedValue= Nothing} + synthesis _ (pos, AST.IsA _ right) _ (AST.IsA left _) = + SynCFExp{folded= Mapped (pos, Abstract.is (foldedExp' $ syn left) right), + foldedValue= Nothing} + synthesis _ (pos, _) _ (AST.Set elements) = + SynCFExp{folded= Mapped (pos, Abstract.set (getMapped . folded' . syn <$> getZipList elements)), + foldedValue= Nothing} + synthesis _ (pos, _) _ (AST.Read des) = + case syn des :: SynCFDesignator l + of SynCFDesignator{designatorValue= Just val} -> literalSynthesis val + SynCFDesignator{folded= Mapped (pos', des'), + designatorValue= Nothing} -> SynCFExp{folded= Mapped (pos, Abstract.read (pos', des')), + foldedValue= Nothing} + synthesis _ (pos, _) _ (AST.FunctionCall fn args) = + case (snd <$> designatorValue (syn fn :: SynCFDesignator l), (snd <$>) . foldedValue . syn <$> getZipList args) + of (Just (AST.Builtin "CAP"), [Just (AST.String s)]) + | Text.length s == 1, capital <- Text.toUpper s -> fromValue (Abstract.string capital) + (Just (AST.Builtin "CAP"), [Just (AST.CharCode c)]) + | capital <- ord (toUpper $ chr c) -> fromValue (Abstract.charCode capital) + (Just (AST.Builtin "CHR"), [Just (AST.Integer code)]) -> fromValue (Abstract.charCode $ fromIntegral code) + (Just (AST.Builtin "ORD"), [Just (AST.String s)]) + | Text.length s == 1, code <- ord (Text.head s) -> fromValue (Abstract.integer $ toInteger code) + (Just (AST.Builtin "ORD"), [Just (AST.CharCode code)]) -> fromValue (Abstract.integer $ toInteger code) + (Just (AST.Builtin "ABS"), [Just (AST.Integer i)]) -> fromValue (Abstract.integer $ abs i) + (Just (AST.Builtin "ABS"), [Just (AST.Real r)]) -> fromValue (Abstract.real $ abs r) + (Just (AST.Builtin "ASH"), [Just (AST.Integer i), Just (AST.Integer j)]) + | shifted <- shift i (fromIntegral j) -> fromValue (Abstract.integer shifted) + (Just (AST.Builtin "ENTIER"), [Just (AST.Real x)]) -> fromValue (Abstract.integer $ ceiling x) + (Just (AST.Builtin "LEN"), [Just (AST.String s)]) -> fromValue (Abstract.integer + $ toInteger $ Text.length s) + (Just (AST.Builtin "LONG"), [Just (AST.Integer x)]) -> fromValue (Abstract.integer x) + (Just (AST.Builtin "LONG"), [Just (AST.Real x)]) -> fromValue (Abstract.real x) + (Just (AST.Builtin "SHORT"), [Just (AST.Integer x)]) -> fromValue (Abstract.integer x) + (Just (AST.Builtin "SHORT"), [Just (AST.Real x)]) -> fromValue (Abstract.real x) + (Just (AST.Builtin "ODD"), [Just (AST.Integer x)]) -> + fromValue (if x `mod` 2 == 1 then Abstract.true else Abstract.false) + (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "INTEGER")]) -> fromValue (Abstract.integer intSize) + (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "LONGINT")]) -> fromValue (Abstract.integer intSize) + (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "SHORTINT")]) -> fromValue (Abstract.integer int32Size) + (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "REAL")]) -> fromValue (Abstract.integer doubleSize) + (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "LONGREAL")]) -> fromValue (Abstract.integer doubleSize) + (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "SHORTREAL")]) -> fromValue (Abstract.integer floatSize) + (Just (AST.Builtin "MAX"), [Just (AST.Builtin "CHAR")]) -> fromValue (Abstract.charCode 0xff) + (Just (AST.Builtin "MAX"), [Just (AST.Builtin "INTEGER")]) -> fromValue (Abstract.integer maxInteger) + (Just (AST.Builtin "MAX"), [Just (AST.Builtin "LONGINT")]) -> fromValue (Abstract.integer maxInteger) + (Just (AST.Builtin "MAX"), [Just (AST.Builtin "SHORTINT")]) -> fromValue (Abstract.integer maxInt32) + (Just (AST.Builtin "MAX"), [Just (AST.Builtin "SET")]) -> fromValue (Abstract.integer maxSet) + (Just (AST.Builtin "MAX"), [Just (AST.Builtin "REAL")]) -> fromValue (Abstract.real maxReal) + (Just (AST.Builtin "MAX"), [Just (AST.Builtin "LONGREAL")]) -> fromValue (Abstract.real maxReal) + (Just (AST.Builtin "MIN"), [Just (AST.Builtin "CHAR")]) -> fromValue (Abstract.charCode 0) + (Just (AST.Builtin "MIN"), [Just (AST.Builtin "INTEGER")]) -> fromValue (Abstract.integer minInteger) + (Just (AST.Builtin "MIN"), [Just (AST.Builtin "LONGINT")]) -> fromValue (Abstract.integer minInteger) + (Just (AST.Builtin "MIN"), [Just (AST.Builtin "SHORTINT")]) -> fromValue (Abstract.integer minInt32) + (Just (AST.Builtin "MIN"), [Just (AST.Builtin "SET")]) -> fromValue (Abstract.integer minSet) + (Just (AST.Builtin "MIN"), [Just (AST.Builtin "REAL")]) -> fromValue (Abstract.real minReal) + (Just (AST.Builtin "MIN"), [Just (AST.Builtin "LONGREAL")]) -> fromValue (Abstract.real minReal) + _ -> SynCFExp{folded= Mapped (pos, + Abstract.functionCall (getMapped $ folded (syn fn :: SynCFDesignator l)) + (foldedExp' . syn <$> getZipList args)), + foldedValue= Nothing} + where fromValue v = literalSynthesis (pos, v) + synthesis _ (pos, _) _ (AST.Literal val) = + SynCFExp{folded= Mapped (pos, Abstract.literal $ getMapped $ folded' $ syn val), + foldedValue= Just (pos, snd $ getMapped $ folded' $ syn val)} + +literalSynthesis :: (Abstract.Wirthy λ, Deep.Functor (Transformation.Rank2.Map Placed Identity) (Abstract.Value l l), + Pretty (Abstract.Value l l Identity Identity)) => + Placed (Abstract.Value l l Placed Placed) -> SynCFExp λ l +literalSynthesis v@((start, Trailing l, end), value) = + SynCFExp{folded= Mapped ((start, mempty, end), + Abstract.literal ((start, lexemes, end), value)), + foldedValue= Just v} + where lexemes = Trailing ([Token{lexemeType= Other, + lexemeText= renderStrict $ layoutCompact $ pretty + $ (Identity . snd) Transformation.Rank2.<$> value}] + <> filter isWhiteSpace l) + isWhiteSpace WhiteSpace{} = True + isWhiteSpace _ = False + +maxInteger, minInteger, maxInt32, minInt32, maxSet, minSet :: Integer +maxInteger = toInteger (maxBound :: Int) +minInteger = toInteger (minBound :: Int) +maxInt32 = toInteger (maxBound :: Int32) +minInt32 = toInteger (minBound :: Int32) +maxSet = 63 +minSet = 0 + +doubleSize, floatSize, intSize, int32Size :: Integer +doubleSize = toInteger (sizeOf (0 :: Double)) +floatSize = toInteger (sizeOf (0 :: Float)) +intSize = toInteger (sizeOf (0 :: Int)) +int32Size = toInteger (sizeOf (0 :: Int32)) + +maxReal, minReal :: Double +maxReal = encodeFloat (floatRadix x - 1) (snd (floatRange x) - 1) + where x = 0 :: Double +minReal = encodeFloat (floatRadix x - 1) (fst (floatRange x)) + where x = 0 :: Double + +foldBinaryArithmetic :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ, + Pretty (Abstract.Value l l Identity Identity)) => + (Int, ParsedLexemes, Int) + -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f) + -> (forall n. Num n => n -> n -> n) + -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l +foldBinaryArithmetic pos@(start, ls, end) node op l r = + case join (foldValues <$> foldedValue l <*> foldedValue r) + of Just v -> literalSynthesis v + Nothing -> SynCFExp{folded= Mapped (pos, node (foldedExp' l) (foldedExp' r)), + foldedValue= Nothing} + where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f)) + foldBareValues :: AST.Value l l f f -> AST.Value l l f f -> Maybe (AST.Value l l f f) + foldValues (_, l') ((_, ls', _), r') = (,) (start, anyWhitespace ls ls', end) <$> foldBareValues l' r' + foldBareValues (AST.Integer l') (AST.Integer r') = Just (AST.Integer $ op l' r') + foldBareValues (AST.Real l') (AST.Real r') = Just (AST.Real $ op l' r') + foldBareValues (AST.Integer l') (AST.Real r') = Just (AST.Real $ op (fromIntegral l') r') + foldBareValues (AST.Real l') (AST.Integer r') = Just (AST.Real $ op l' (fromIntegral r')) + foldBareValues _ _ = Nothing + +foldBinaryFractional :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ, + Pretty (Abstract.Value l l Identity Identity)) => + (Int, ParsedLexemes, Int) + -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f) + -> (forall n. Fractional n => n -> n -> n) + -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l +foldBinaryFractional pos@(start, ls, end) node op l r = + case join (foldValues <$> foldedValue l <*> foldedValue r) + of Just v -> literalSynthesis v + Nothing -> SynCFExp{folded= Mapped (pos, node (foldedExp' l) (foldedExp' r)), + foldedValue= Nothing} + where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f)) + foldValues (_, AST.Real l') ((_, ls', _), AST.Real r') = Just ((start, anyWhitespace ls ls', end), + AST.Real $ op l' r') + foldValues _ _ = Nothing + +foldBinaryInteger :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ, + Pretty (Abstract.Value l l Identity Identity)) => + (Int, ParsedLexemes, Int) + -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f) + -> (forall n. Integral n => n -> n -> n) + -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l +foldBinaryInteger pos@(start, ls, end) node op l r = + case join (foldValues <$> foldedValue l <*> foldedValue r) + of Just v -> literalSynthesis v + Nothing -> SynCFExp{folded= Mapped (pos, node (foldedExp' l) (foldedExp' r)), + foldedValue= Nothing} + where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f)) + foldValues (_, AST.Integer l') ((_, ls', _), AST.Integer r') = Just ((start, anyWhitespace ls ls', end), + AST.Integer $ op l' r') + foldValues _ _ = Nothing + +foldBinaryBoolean :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ, + Pretty (Abstract.Value l l Identity Identity)) => + (Int, ParsedLexemes, Int) + -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f) + -> (Bool -> Bool -> Bool) + -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l +foldBinaryBoolean pos@(start, ls, end) node op l r = + case join (foldValues <$> foldedValue l <*> foldedValue r) + of Just v -> literalSynthesis v + Nothing -> SynCFExp{folded= Mapped (pos, node (foldedExp' l) (foldedExp' r)), + foldedValue= Nothing} + where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f)) + foldValues (_, AST.Boolean l') ((_, ls', _), AST.Boolean r') = Just ((start, anyWhitespace ls ls', end), + AST.Boolean $ op l' r') + foldValues _ _ = Nothing + +instance (Ord (Abstract.QualIdent l), v ~ Abstract.Value l l Placed Placed) => + SynthesizedField "designatorValue" (Maybe (Placed v)) (Auto ConstantFold) (AST.Designator l l) Sem Placed where + synthesizedField _ _ (pos, AST.Variable q) inheritance _ = (,) pos <$> join (Map.lookup q $ env inheritance) + synthesizedField _ _ _ _ _ = Nothing + +instance {-# overlaps #-} Ord (Abstract.QualIdent l) => Transformation.At (Auto ConstantFold) (Modules l Sem Sem) where + ($) = AG.applyDefault snd + +anyWhitespace :: ParsedLexemes -> ParsedLexemes -> ParsedLexemes +anyWhitespace outer inner@(Trailing ls) + | any isWhitespace ls = inner + | otherwise = inner <> lastWhitespace outer + where isWhitespace WhiteSpace{} = True + isWhitespace _ = False + +lastWhitespace :: ParsedLexemes -> ParsedLexemes +lastWhitespace ls@(Trailing []) = ls +lastWhitespace ls@(Trailing [WhiteSpace{}]) = ls +lastWhitespace (Trailing [_]) = mempty +lastWhitespace (Trailing (l:ls)) = lastWhitespace (Trailing ls) + +--- * Shortcut + +instance Full.Functor (Auto ConstantFold) (AST.Value l l) where + Auto ConstantFold <$> (pos, val) = Rank2.Arrow sem + where sem _inherited = Synthesized (SynCF $ Mapped (pos, val)) + +-- * Unsafe Rank2 AST instances + +instance Rank2.Apply (AST.Module l l f') where + AST.Module name1 imports1 body1 <*> ~(AST.Module _name _imports body2) = + AST.Module name1 imports1 (Rank2.apply body1 body2) + +predefined, predefined2 :: (Abstract.Wirthy l, Ord (Abstract.QualIdent l)) => Environment l +-- | The set of predefined types and procedures defined in the Oberon Language Report. +predefined = Map.fromList $ map (first Abstract.nonQualIdent) $ + [("TRUE", Just Abstract.true), + ("FALSE", Just Abstract.false)] + ++ map builtin ["BOOLEAN", "CHAR", "SHORTINT", "INTEGER", "LONGINT", "REAL", "LONGREAL", "SET", + "ABS", "ASH", "CAP", "LEN", "MAX", "MIN", + "ODD", "SIZE", "ORD", "CHR", "SHORT", "LONG", "ENTIER"] + where builtin name = (name, Just $ Abstract.builtin name) +predefined2 = predefined + +$(do l <- varT <$> newName "l" + mconcat <$> mapM (\g-> Transformation.Full.TH.deriveUpFunctor (conT ''Auto `appT` conT ''ConstantFold) + $ conT g `appT` l `appT` l) + [''AST.Declaration, ''AST.Type, ''AST.FieldList, + ''AST.ProcedureHeading, ''AST.FormalParameters, ''AST.FPSection, + ''AST.Expression, ''AST.Element, ''AST.Designator, + ''AST.Block, ''AST.StatementSequence, ''AST.Statement, + ''AST.Case, ''AST.CaseLabels, ''AST.ConditionalBranch, ''AST.WithAlternative]) + +$(do let sem = [t|Semantics (Auto ConstantFold)|] + let inst g = [d| instance Attribution (Auto ConstantFold) ($g l l) Sem Placed => + Transformation.At (Auto ConstantFold) ($g l l $sem $sem) + where ($) = AG.applyDefault snd |] + mconcat <$> mapM (inst . conT) + [''AST.Module, ''AST.Block, ''AST.Declaration, ''AST.Type, ''AST.FieldList, + ''AST.ProcedureHeading, ''AST.FormalParameters, ''AST.FPSection, + ''AST.StatementSequence, ''AST.Statement, + ''AST.Case, ''AST.CaseLabels, ''AST.ConditionalBranch, ''AST.WithAlternative, + ''AST.Element, ''AST.Expression, ''AST.Designator]) diff --git a/src/Language/Oberon/Grammar.hs b/src/Language/Oberon/Grammar.hs --- a/src/Language/Oberon/Grammar.hs +++ b/src/Language/Oberon/Grammar.hs @@ -1,120 +1,181 @@ -{-# Language OverloadedStrings, Rank2Types, RecordWildCards, TypeFamilies, TemplateHaskell #-} +{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, + OverloadedStrings, Rank2Types, RecordWildCards, ScopedTypeVariables, + TypeApplications, TypeFamilies, TypeSynonymInstances, TemplateHaskell #-} -- | Oberon grammar adapted from http://www.ethoberon.ethz.ch/EBNF.html --- Extracted from the book Programmieren in Oberon - Das neue Pascal by N. Wirth and M. Reiser and translated by J. Templ. +-- +-- Extracted from the book Programmieren in Oberon - Das neue Pascal by N. Wirth and M. Reiser and translated by +-- J. Templ. +-- +-- The grammars in this module attempt to follow the language grammars from the reports, while generating a +-- semantically meaningful abstract syntax tree; the latter is defined in "Language.Oberon.AST". As the grammars are +-- ambiguous, it is necessary to resolve the ambiguities after parsing all Oberon modules in use. +-- "Language.Oberon.Resolver" provides this functionality. Only after the ambiguity resolution can the abstract syntax +-- tree be pretty-printed using the instances from "Language.Oberon.Pretty". Alternatively, since the parsing +-- preserves the original parsed lexemes including comments in the AST, you can use "Language.Oberon.Reserializer" to +-- reproduce the original source code from the AST. -module Language.Oberon.Grammar (OberonGrammar(..), +module Language.Oberon.Grammar (OberonGrammar(..), Parser, NodeWrap, ParsedLexemes(..), Lexeme(..), TokenType(..), oberonGrammar, oberon2Grammar, oberonDefinitionGrammar, oberon2DefinitionGrammar) where import Control.Applicative +import Control.Arrow (first) import Control.Monad (guard) import Data.Char -import Data.List.NonEmpty (NonEmpty((:|)), fromList, toList) -import Data.Monoid ((<>), Endo(Endo, appEndo)) -import Numeric (readHex) +import Data.Data (Data) +import Data.Functor.Compose (Compose(..)) +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (catMaybes) +import Data.Monoid ((<>), Dual(Dual, getDual), Endo(Endo, appEndo)) +import Numeric (readDec, readHex, readFloat) import Data.Text (Text, unpack) import Text.Grampa -import Text.Grampa.ContextFree.LeftRecursive (Parser) import Text.Parser.Combinators (sepBy, sepBy1, sepByNonEmpty, try) +import Text.Grampa.ContextFree.LeftRecursive.Transformer (ParserT, lift, tmap) import Text.Parser.Token (braces, brackets, parens) -import Transformation.Deep as Deep (Product(Pair)) -import qualified Rank2 import qualified Rank2.TH -import Language.Oberon.AST +import qualified Language.Oberon.Abstract as Abstract +import qualified Language.Oberon.AST as AST import Prelude hiding (length, takeWhile) -- | All the productions of the Oberon grammar -data OberonGrammar f p = OberonGrammar { - module_prod :: p (Module f f), - ident :: p Ident, +data OberonGrammar l f p = OberonGrammar { + module_prod :: p (f (Abstract.Module l l f f)), + ident :: p Abstract.Ident, letter :: p Text, digit :: p Text, - importList :: p [Import], - import_prod :: p Import, - declarationSequence :: p [f (Declaration f f)], - constantDeclaration :: p (Declaration f f), - identdef :: p IdentDef, - 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), + importList :: p [Abstract.Import l], + import_prod :: p (Abstract.Import l), + declarationSequence :: p [f (Abstract.Declaration l l f f)], + constantDeclaration :: p (Abstract.Declaration l l f f), + identdef :: p (Abstract.IdentDef l), + constExpression :: p (f (Abstract.Expression l l f f)), + expression :: p (f (Abstract.Expression l l f f)), + simpleExpression :: p (f (Abstract.Expression l l f f)), + term :: p (f (Abstract.Expression l l f f)), + factor :: p (f (Abstract.Expression l l f f)), + number :: p (Abstract.Value l l f f), + integer :: p (Abstract.Value l l f f), hexDigit :: p Text, - real :: p (Expression f f), + real :: p (Abstract.Value l l f f), scaleFactor :: p Text, - charConstant :: p (Expression f f), + charConstant :: p (Abstract.Value l l f f), string_prod :: p Text, - 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 f), - type_prod :: p (Type f f), - qualident :: p QualIdent, - arrayType :: p (Type f f), - length :: p (f (Expression f f)), - recordType :: p (Type f f), - baseType :: p QualIdent, - fieldListSequence :: p (NonEmpty (f (FieldList f f))), - fieldList :: p (FieldList f f), - identList :: p IdentList, - 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)} + set :: p (Abstract.Expression l l f f), + element :: p (Abstract.Element l l f f), + designator :: p (f (Abstract.Designator l l f f)), + unguardedDesignator :: p (Abstract.Designator l l f f), + expList :: p (NonEmpty (f (Abstract.Expression l l f f))), + actualParameters :: p [f (Abstract.Expression l l f f)], + mulOperator :: p (BinOp l f), + addOperator :: p (BinOp l f), + relation :: p Abstract.RelOp, + typeDeclaration :: p (Abstract.Declaration l l f f), + type_prod :: p (Abstract.Type l l f f), + qualident :: p (Abstract.QualIdent l), + arrayType :: p (Abstract.Type l l f f), + length :: p (f (Abstract.Expression l l f f)), + recordType :: p (Abstract.Type l l f f), + baseType :: p (Abstract.BaseType l), + fieldListSequence :: p [f (Abstract.FieldList l l f f)], + fieldList :: p (Abstract.FieldList l l f f), + identList :: p (Abstract.IdentList l), + pointerType :: p (Abstract.Type l l f f), + procedureType :: p (Abstract.Type l l f f), + variableDeclaration :: p (Abstract.Declaration l l f f), + procedureDeclaration :: p (Abstract.Declaration l l f f), + procedureHeading :: p (Abstract.Ident, Abstract.ProcedureHeading l l f f), + formalParameters :: p (Abstract.FormalParameters l l f f), + fPSection :: p (Abstract.FPSection l l f f), + formalType :: p (Abstract.Type l l f f), + procedureBody :: p (Abstract.Block l l f f), + forwardDeclaration :: p (Abstract.Declaration l l f f), + statementSequence :: p (Abstract.StatementSequence l l f f), + statement :: p (f (Abstract.Statement l l f f)), + assignment :: p (Abstract.Statement l l f f), + procedureCall :: p (Abstract.Statement l l f f), + ifStatement :: p (Abstract.Statement l l f f), + caseStatement :: p (Abstract.Statement l l f f), + case_prod :: p (Abstract.Case l l f f), + caseLabelList :: p (NonEmpty (f (Abstract.CaseLabels l l f f))), + caseLabels :: p (Abstract.CaseLabels l l f f), + whileStatement :: p (Abstract.Statement l l f f), + repeatStatement :: p (Abstract.Statement l l f f), + forStatement :: p (Abstract.Statement l l f f), + loopStatement :: p (Abstract.Statement l l f f), + withStatement :: p (Abstract.Statement l l f f)} -newtype BinOp f = BinOp {applyBinOp :: (f (Expression f f) -> f (Expression f f) -> Expression f f)} +newtype BinOp l f = BinOp {applyBinOp :: (f (Abstract.Expression l l f f) + -> f (Abstract.Expression l l f f) + -> f (Abstract.Expression l l f f))} -instance Show (BinOp f) where +instance Show (BinOp l f) where show = const "BinOp{}" $(Rank2.TH.deriveAll ''OberonGrammar) -instance Lexical (OberonGrammar f) where - type LexicalConstraint p (OberonGrammar f) s = (s ~ Text, p ~ Parser) - lexicalComment = try (string "(*" - *> skipMany (lexicalComment - <|> notFollowedBy (string "*)") <* anyToken <* takeCharsWhile isCommentChar) - <* string "*)") - where isCommentChar c = c /= '*' && c /= '(' - lexicalWhiteSpace = takeCharsWhile isSpace *> skipMany (lexicalComment *> takeCharsWhile isSpace) +type Parser = ParserT ((,) [[Lexeme]]) +data Lexeme = WhiteSpace{lexemeText :: Text} + | Comment{lexemeText :: Text} + | Token{lexemeType :: TokenType, + lexemeText :: Text} + deriving (Data, Eq, Show) + +data TokenType = Delimiter | Keyword | Operator | Other + deriving (Data, Eq, Show) + +-- | Every node in the parsed AST will be wrapped in this data type. +type NodeWrap = Compose ((,) (Position, Position)) (Compose Ambiguous ((,) ParsedLexemes)) + +newtype ParsedLexemes = Trailing [Lexeme] + deriving (Data, Show, Semigroup, Monoid) + +instance TokenParsing (Parser (OberonGrammar l f) Text) where + someSpace = someLexicalSpace + token = lexicalToken + +instance LexicalParsing (Parser (OberonGrammar l f) Text) where + lexicalComment = do c <- comment + lift ([[Comment c]], ()) + lexicalWhiteSpace = whiteSpace isIdentifierStartChar = isLetter isIdentifierFollowChar = isAlphaNum identifierToken word = lexicalToken (do w <- word guard (w `notElem` reservedWords) return w) + lexicalToken p = snd <$> tmap addOtherToken (match p) <* lexicalWhiteSpace + where addOtherToken ([], (i, x)) = ([[Token Other i]], (i, x)) + addOtherToken (t, (i, x)) = (t, (i, x)) + keyword s = lexicalToken (string s + *> notSatisfyChar (isIdentifierFollowChar @(Parser (OberonGrammar l f) Text)) + <* lift ([[Token Keyword s]], ())) + ("keyword " <> show s) +comment :: Parser g Text Text +comment = try (string "(*" + <> concatMany (comment <<|> notFollowedBy (string "*)") *> anyToken <> takeCharsWhile isCommentChar) + <> string "*)") + where isCommentChar c = c /= '*' && c /= '(' + +whiteSpace :: LexicalParsing (Parser g Text) => Parser g Text () +whiteSpace = spaceChars *> skipMany (lexicalComment *> spaceChars) "whitespace" + where spaceChars = (takeCharsWhile1 isSpace >>= \ws-> lift ([[WhiteSpace ws]], ())) <<|> pure () + +clearConsumed = tmap clear + where clear (_, x) = ([], x) + +wrapAmbiguous, wrap :: Parser g Text a -> Parser g Text (NodeWrap a) +wrapAmbiguous = wrap +wrap = (Compose <$>) . (\p-> liftA3 surround getSourcePos p getSourcePos) + . (Compose <$>) . (ambiguous . tmap store) . ((,) (Trailing []) <$>) + where store (wss, (Trailing [], a)) = (mempty, (Trailing (concat wss), a)) + surround start val end = ((start, end), val) + oberonGrammar, oberon2Grammar, oberonDefinitionGrammar, oberon2DefinitionGrammar - :: Grammar (OberonGrammar Ambiguous) Parser Text + :: Grammar (OberonGrammar AST.Language NodeWrap) Parser Text -- | Grammar of an Oberon module oberonGrammar = fixGrammar grammar -- | Grammar of an Oberon-2 module @@ -124,179 +185,229 @@ -- | Grammar of an Oberon-2 definition module oberon2DefinitionGrammar = fixGrammar definitionGrammar2 -grammar, definitionGrammar :: GrammarBuilder (OberonGrammar Ambiguous) (OberonGrammar Ambiguous) Parser Text +grammar, definitionGrammar :: forall l. Abstract.Oberon l + => GrammarBuilder (OberonGrammar l NodeWrap) (OberonGrammar l NodeWrap) Parser Text +grammar2, definitionGrammar2 :: forall l. Abstract.Oberon2 l + => GrammarBuilder (OberonGrammar l NodeWrap) (OberonGrammar l NodeWrap) Parser Text definitionGrammar g@OberonGrammar{..} = definitionMixin (grammar g) definitionGrammar2 g@OberonGrammar{..} = definitionMixin (grammar2 g) +definitionMixin :: Abstract.Oberon l => GrammarBuilder (OberonGrammar l NodeWrap) (OberonGrammar l NodeWrap) Parser Text definitionMixin g@OberonGrammar{..} = g{ - module_prod = Module <$ (lexicalWhiteSpace *> keyword "DEFINITION") <*> ident <* delimiter ";" - <*> moptional importList <*> declarationSequence - <*> pure Nothing <* keyword "END" <*> ident <* delimiter ".", - procedureDeclaration = ProcedureDeclaration <$> procedureHeading - <*> (pure $ ProcedureBody [] Nothing) <*> pure mempty, - identdef = IdentDef <$> ident <*> pure Exported <* optional (delimiter "*")} + module_prod = wrap $ + do lexicalWhiteSpace + keyword "DEFINITION" + name <- ident + delimiter ";" + imports <- moptional importList + block <- wrap (Abstract.block <$> declarationSequence <*> pure Nothing) + keyword "END" + lexicalToken (string name) + delimiter "." + return (Abstract.moduleUnit name imports block), + procedureDeclaration = Abstract.procedureDeclaration . snd . sequenceA + <$> wrap procedureHeading + <*> wrap (pure $ Abstract.block [] Nothing), + identdef = Abstract.exported <$> ident <* optional (delimiter "*")} grammar2 g@OberonGrammar{..} = g1{ - identdef = IdentDef <$> ident <*> (Exported <$ delimiter "*" <|> ReadOnly <$ delimiter "-" <|> pure PrivateOnly), + identdef = ident + <**> (Abstract.exported <$ delimiter "*" + <|> Abstract.readOnly <$ delimiter "-" + <|> pure Abstract.identDef), string_prod = string_prod1 <|> lexicalToken (char '\'' *> takeWhile (/= "'") <* char '\''), - procedureHeading = ProcedureHeading <$ keyword "PROCEDURE" - <*> optional (parens - ((,,) <$> (True <$ keyword "VAR" <|> pure False) - <*> ident <* delimiter ":" <*> ident)) - <*> (True <$ delimiter "*" <|> pure False) - <*> identdef <*> optional (wrap formalParameters), - arrayType = - ArrayType <$ keyword "ARRAY" <*> sepBy length (delimiter ",") <* keyword "OF" <*> wrap type_prod, - statement = statement1 <|> forStatement, + procedureHeading = procedureHeading1 + <|> Abstract.typeBoundHeading <$ keyword "PROCEDURE" + <* delimiter "(" + <*> (True <$ keyword "VAR" <|> pure False) + <*> ident + <* delimiter ":" + <*> ident + <* delimiter ")" + <*> (True <$ delimiter "*" <|> pure False) + <**> do n <- clearConsumed (lookAhead ident) + idd <- identdef + params <- optional (wrap formalParameters) + pure (\proc-> (n, proc idd params)), + arrayType = + Abstract.arrayType <$ keyword "ARRAY" <*> sepBy length (delimiter ",") <* keyword "OF" <*> wrap type_prod, forStatement = - For <$ keyword "FOR" <*> ident <* delimiter ":=" <*> expression <* keyword "TO" <*> expression + Abstract.forStatement <$ 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" <*> wrap statementSequence - + withStatement = Abstract.variantWithStatement <$ keyword "WITH" + <*> sepByNonEmpty (wrap withAlternative) (delimiter "|") + <*> optional (keyword "ELSE" *> wrap statementSequence) <* keyword "END"} + where g1@OberonGrammar{string_prod= string_prod1, procedureHeading= procedureHeading1} = grammar g + withAlternative = Abstract.withAlternative <$> qualident <* delimiter ":" <*> qualident + <* keyword "DO" <*> wrap statementSequence + grammar OberonGrammar{..} = OberonGrammar{ - module_prod = Module <$ (lexicalWhiteSpace *> keyword "MODULE") <*> ident <* delimiter ";" - <*> moptional importList <*> declarationSequence - <*> optional (keyword "BEGIN" *> wrap statementSequence) <* keyword "END" <*> ident <* delimiter ".", + module_prod = wrap $ + do lexicalWhiteSpace + keyword "MODULE" + name <- ident + delimiter ";" + imports <- moptional importList + body <- wrap (Abstract.block <$> declarationSequence + <*> optional (wrap (keyword "BEGIN" *> statementSequence))) + keyword "END" + lexicalToken (string name) + delimiter "." + return (Abstract.moduleUnit name imports body), 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 (wrap constantDeclaration <* delimiter ";") - <|> keyword "TYPE" *> many (wrap typeDeclaration <* delimiter ";") - <|> keyword "VAR" *> many (wrap variableDeclaration <* delimiter ";")) - <> many (wrap procedureDeclaration <* delimiter ";" - <|> wrap forwardDeclaration <* delimiter ";") + import_prod = Abstract.moduleImport <$> optional (ident <* delimiter ":=") <*> ident, + declarationSequence = concatMany (((:) <$> wrap (keyword "CONST" *> constantDeclaration) + <*> many (wrap constantDeclaration) + <|> (:) <$> wrap (keyword "TYPE" *> typeDeclaration) + <*> many (wrap typeDeclaration) + <|> (:) <$> wrap (keyword "VAR" *> variableDeclaration) + <*> many (wrap variableDeclaration)) + <<|> [] <$ (keyword "CONST" <|> keyword "TYPE" <|> keyword "VAR")) + <> many (wrap (procedureDeclaration <* delimiter ";") + <|> wrap (forwardDeclaration <* delimiter ";")) "declarations", - constantDeclaration = ConstantDeclaration <$> identdef <* delimiter "=" <*> constExpression, - identdef = IdentDef <$> ident <*> (Exported <$ delimiter "*" <|> pure PrivateOnly), + constantDeclaration = Abstract.constantDeclaration <$> identdef <* delimiter "=" <*> constExpression <* delimiter ";", + identdef = ident <**> (Abstract.exported <$ delimiter "*" <|> pure Abstract.identDef), constExpression = expression, - expression = simpleExpression <**> (pure id <|> (pure .) <$> ((flip . Relation) <$> relation <*> simpleExpression)) + expression = simpleExpression + <|> wrap (flip Abstract.relation <$> simpleExpression <*> relation <*> simpleExpression) + <|> wrap (Abstract.is <$> simpleExpression <* keyword "IS" <*> qualident) "expression", 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) + (wrap (Abstract.positive <$ operator "+" <*> term) <|> wrap (Abstract.negative <$ operator "-" <*> term :: Parser (OberonGrammar l NodeWrap) Text (Abstract.Expression l l NodeWrap NodeWrap)) <|> term) + <**> (appEndo . getDual <$> concatMany (Dual . Endo <$> (flip . applyBinOp <$> addOperator <*> term))), + term = factor <**> (appEndo . getDual <$> concatMany (Dual . Endo <$> (flip . applyBinOp <$> mulOperator <*> factor))), + factor = wrapAmbiguous (Abstract.literal <$> wrap (number + <|> charConstant + <|> Abstract.string <$> string_prod + <|> Abstract.nil <$ keyword "NIL") + <|> set + <|> Abstract.read <$> designator + <|> Abstract.functionCall <$> wrapAmbiguous unguardedDesignator <*> actualParameters + <|> (Abstract.not <$ operator "~" <*> factor :: Parser (OberonGrammar l NodeWrap) Text (Abstract.Expression l l NodeWrap NodeWrap))) <|> parens expression, number = integer <|> real, - integer = Integer <$> lexicalToken (digit <> (takeCharsWhile isDigit <|> takeCharsWhile isHexDigit <> string "H")), + integer = Abstract.integer . fst . head + <$> lexicalToken (readDec . unpack <$> takeCharsWhile1 isDigit + <|> readHex . unpack <$> (digit <> takeCharsWhile isHexDigit <* string "H")), hexDigit = satisfyCharInput isHexDigit, - real = Real <$> lexicalToken (digit <> takeCharsWhile isDigit <> string "." - *> takeCharsWhile isDigit <> moptional scaleFactor), - scaleFactor = (string "E" <|> string "D") <> moptional (string "+" <|> string "-") <> digit <> takeCharsWhile isDigit, - charConstant = lexicalToken (empty -- CharConstant <$ char '"' <*> anyChar <* char '"' - <|> CharCode . fst . head . readHex . unpack + real = Abstract.real . fst . head . readFloat . unpack + <$> lexicalToken (takeCharsWhile1 isDigit <> string "." <> takeCharsWhile isDigit <> moptional scaleFactor), + scaleFactor = (string "E" <|> "E" <$ string "D") <> moptional (string "+" <|> string "-") <> takeCharsWhile1 isDigit, + charConstant = lexicalToken (Abstract.charCode . fst . head . readHex . unpack <$> (digit <> takeCharsWhile isHexDigit <* string "X")), string_prod = lexicalToken (char '"' *> takeWhile (/= "\"") <* char '"'), - set = Set <$> braces (sepBy (wrap element) (delimiter ",")), - element = Element <$> expression - <|> Range <$> expression <* delimiter ".." <*> expression, - designator = ambiguous $ - Variable <$> qualident - <|> Field <$> designator <* delimiter "." <*> ident - <|> Index <$> designator <*> brackets expList - <|> TypeGuard <$> designator <*> parens qualident - <|> Dereference <$> designator <* operator "^", + set = Abstract.set <$> braces (sepBy (wrap element) (delimiter ",")), + element = Abstract.element <$> expression + <|> Abstract.range <$> expression <* delimiter ".." <*> expression, + designator = wrapAmbiguous (unguardedDesignator + <|> Abstract.typeGuard <$> designator <*> parens qualident), + unguardedDesignator = Abstract.variable <$> qualident + <|> Abstract.field <$> designator <* delimiter "." <*> ident + <|> Abstract.index @l <$> designator <*> brackets expList + <|> Abstract.dereference <$> designator <* operator "^", expList = sepByNonEmpty expression (delimiter ","), actualParameters = parens (sepBy expression (delimiter ",")), - mulOperator = BinOp <$> (Multiply <$ operator "*" <|> Divide <$ operator "/" - <|> IntegerDivide <$ keyword "DIV" <|> Modulo <$ keyword "MOD" <|> And <$ operator "&"), - addOperator = BinOp <$> (Add <$ operator "+" <|> Subtract <$ operator "-" <|> Or <$ keyword "OR"), - relation = Equal <$ operator "=" <|> Unequal <$ operator "#" - <|> Less <$ operator "<" <|> LessOrEqual <$ operator "<=" - <|> Greater <$ operator ">" <|> GreaterOrEqual <$ operator ">=" - <|> In <$ keyword "IN" <|> Is <$ keyword "IS", - typeDeclaration = TypeDeclaration <$> identdef <* delimiter "=" <*> wrap type_prod, - type_prod = TypeReference <$> qualident + mulOperator = BinOp . wrapBinary + <$> (Abstract.multiply <$ operator "*" <|> Abstract.divide <$ operator "/" + <|> Abstract.integerDivide <$ keyword "DIV" <|> Abstract.modulo <$ keyword "MOD" + <|> Abstract.and <$ operator "&"), + addOperator = BinOp . wrapBinary + <$> (Abstract.add <$ operator "+" <|> Abstract.subtract <$ operator "-" + <|> Abstract.or <$ keyword "OR"), + relation = Abstract.Equal <$ operator "=" <|> Abstract.Unequal <$ operator "#" + <|> Abstract.Less <$ operator "<" <|> Abstract.LessOrEqual <$ operator "<=" + <|> Abstract.Greater <$ operator ">" <|> Abstract.GreaterOrEqual <$ operator ">=" + <|> Abstract.In <$ keyword "IN", + typeDeclaration = Abstract.typeDeclaration <$> identdef <* delimiter "=" <*> wrap type_prod <* delimiter ";", + type_prod = Abstract.typeReference <$> qualident <|> arrayType <|> recordType - <|> pointerType + <|> pointerType <|> procedureType, - qualident = QualIdent <$> ident <* delimiter "." <*> ident - <|> NonQualIdent <$> ident, - arrayType = ArrayType <$ keyword "ARRAY" <*> sepBy1 length (delimiter ",") <* keyword "OF" <*> wrap type_prod, + qualident = Abstract.qualIdent <$> ident <* delimiter "." <*> ident + <|> Abstract.nonQualIdent <$> ident, + arrayType = Abstract.arrayType <$ keyword "ARRAY" <*> sepBy1 length (delimiter ",") <* keyword "OF" <*> wrap type_prod, length = constExpression, - recordType = RecordType <$ keyword "RECORD" <*> optional (parens baseType) + recordType = Abstract.recordType <$ keyword "RECORD" <*> optional (parens baseType) <*> fieldListSequence <* keyword "END", baseType = qualident, - fieldListSequence = sepByNonEmpty (wrap fieldList) (delimiter ";"), - fieldList = (FieldList <$> identList <* delimiter ":" <*> wrap type_prod "record field declarations") - <|> pure EmptyFieldList, + fieldListSequence = catMaybes <$> sepBy1 (optional $ wrap fieldList) (delimiter ";"), + fieldList = Abstract.fieldList <$> identList <* delimiter ":" <*> wrap type_prod "record field declarations", identList = sepByNonEmpty identdef (delimiter ","), - 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 (wrap formalParameters), - formalParameters = FormalParameters <$> parens (sepBy (wrap fPSection) (delimiter ";")) + pointerType = Abstract.pointerType <$ keyword "POINTER" <* keyword "TO" <*> wrap type_prod, + procedureType = Abstract.procedureType <$ keyword "PROCEDURE" <*> optional (wrap formalParameters), + variableDeclaration = Abstract.variableDeclaration <$> identList <* delimiter ":" <*> wrap type_prod <* delimiter ";", + procedureDeclaration = do (procedureName, heading) <- sequenceA <$> wrap procedureHeading + delimiter ";" + body <- wrap procedureBody + lexicalToken (string procedureName) + return (Abstract.procedureDeclaration heading body), + procedureHeading = Abstract.procedureHeading <$ keyword "PROCEDURE" <*> (True <$ delimiter "*" <|> pure False) + <**> do n <- clearConsumed (lookAhead ident) + idd <- identdef + params <- optional (wrap formalParameters) + return (\proc-> (n, proc idd params)), + formalParameters = Abstract.formalParameters <$> parens (sepBy (wrap fPSection) (delimiter ";")) <*> optional (delimiter ":" *> qualident), - fPSection = FPSection <$> (True <$ keyword "VAR" <|> pure False) - <*> 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 + fPSection = Abstract.fpSection <$> (True <$ keyword "VAR" <|> pure False) + <*> sepBy1 ident (delimiter ",") <* delimiter ":" <*> wrap formalType, + formalType = Abstract.arrayType [] <$ keyword "ARRAY" <* keyword "OF" <*> wrap formalType + <|> Abstract.typeReference <$> qualident + <|> Abstract.procedureType <$ keyword "PROCEDURE" <*> optional (wrap formalParameters), + procedureBody = Abstract.block <$> declarationSequence <*> optional (keyword "BEGIN" *> wrap statementSequence) <* keyword "END", - forwardDeclaration = ForwardDeclaration <$ keyword "PROCEDURE" <* delimiter "^" + forwardDeclaration = Abstract.forwardDeclaration <$ keyword "PROCEDURE" <* 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 + statementSequence = Abstract.statementSequence <$> sepBy1 statement (delimiter ";"), + statement = wrapAmbiguous (assignment <|> procedureCall <|> ifStatement <|> caseStatement + <|> whileStatement <|> repeatStatement <|> loopStatement + <|> forStatement <|> withStatement + <|> Abstract.exitStatement <$ keyword "EXIT" + <|> Abstract.returnStatement <$ keyword "RETURN" <*> optional expression + <|> pure Abstract.emptyStatement) "statement", - assignment = Assignment <$> designator <* delimiter ":=" <*> expression, - procedureCall = ProcedureCall <$> designator <*> optional actualParameters, - ifStatement = If <$ keyword "IF" - <*> sepByNonEmpty (wrap $ Deep.Pair <$> expression <* keyword "THEN" <*> wrap statementSequence) + assignment = Abstract.assignment <$> designator <* delimiter ":=" <*> expression, + procedureCall = Abstract.procedureCall <$> wrapAmbiguous unguardedDesignator <*> optional actualParameters, + ifStatement = Abstract.ifStatement <$ keyword "IF" + <*> sepByNonEmpty (wrap $ Abstract.conditionalBranch <$> expression <* keyword "THEN" <*> wrap statementSequence) (keyword "ELSIF") <*> optional (keyword "ELSE" *> wrap statementSequence) <* keyword "END", - caseStatement = CaseStatement <$ keyword "CASE" <*> expression - <* keyword "OF" <*> sepByNonEmpty (wrap case_prod) (delimiter "|") + caseStatement = Abstract.caseStatement <$ keyword "CASE" <*> expression + <* keyword "OF" <*> (catMaybes <$> sepBy1 (optional $ wrap case_prod) (delimiter "|")) <*> optional (keyword "ELSE" *> wrap statementSequence) <* keyword "END", - case_prod = Case <$> caseLabelList <* delimiter ":" <*> wrap statementSequence - <|> pure EmptyCase, - caseLabelList = sepByNonEmpty (wrap caseLabels) (delimiter ","), - caseLabels = SingleLabel <$> constExpression - <|> LabelRange <$> constExpression <* delimiter ".." <*> constExpression, - whileStatement = While <$ keyword "WHILE" <*> expression <* keyword "DO" + case_prod = Abstract.caseAlternative <$> caseLabelList <* delimiter ":" <*> wrap statementSequence, + caseLabelList = sepByNonEmpty (wrap caseLabels) (delimiter ","), + caseLabels = Abstract.singleLabel <$> constExpression + <|> Abstract.labelRange <$> constExpression <* delimiter ".." <*> constExpression, + whileStatement = Abstract.whileStatement <$ 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", + repeatStatement = Abstract.repeatStatement <$ keyword "REPEAT" + <*> wrap statementSequence <* keyword "UNTIL" <*> expression, + loopStatement = Abstract.loopStatement <$ keyword "LOOP" <*> wrap statementSequence <* keyword "END", forStatement = empty, - withStatement = With <$ keyword "WITH" - <*> ((:| []) - <$> wrap (WithAlternative <$> qualident <* delimiter ":" <*> qualident - <* keyword "DO" <*> wrap statementSequence)) - <*> pure Nothing <* keyword "END"} + withStatement = Abstract.withStatement <$ keyword "WITH" + <*> wrap (Abstract.withAlternative <$> qualident <* delimiter ":" <*> qualident + <* keyword "DO" <*> wrap statementSequence) + <* keyword "END"} -wrap = ambiguous +wrapBinary :: (NodeWrap a -> NodeWrap a -> a) -> (NodeWrap a -> NodeWrap a -> NodeWrap a) +wrapBinary op a@(Compose (pos, _)) b = Compose (pos, Compose $ pure (Trailing [], op a b)) +moptional :: (Alternative f, Monoid (f a)) => f a -> f a moptional p = p <|> mempty -delimiter, operator :: Text -> Parser (OberonGrammar f) Text Text +delimiter, operator :: Abstract.Oberon l => Text -> Parser (OberonGrammar l f) Text Text -delimiter s = lexicalToken (string s) ("delimiter " <> show s) -operator s = lexicalToken (string s) ("operator " <> show s) +delimiter s = lexicalToken (string s <* lift ([[Token Delimiter s]], ())) ("delimiter " <> show s) +operator s = lexicalToken (string s <* lift ([[Token Operator s]], ())) ("operator " <> show s) reservedWords :: [Text] reservedWords = ["ARRAY", "IMPORT", "RETURN", diff --git a/src/Language/Oberon/Pretty.hs b/src/Language/Oberon/Pretty.hs --- a/src/Language/Oberon/Pretty.hs +++ b/src/Language/Oberon/Pretty.hs @@ -1,77 +1,94 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, UndecidableInstances #-} -- | This module exports the instances of the 'Pretty' type class necessary for printing of an Oberon abstract syntax -- tree. Note that the AST cannot be ambiguous to be pretty-printed, so it must be resolved after parsing. -module Language.Oberon.Pretty () where +module Language.Oberon.Pretty (Precedence(Precedence)) where +import Control.Applicative (ZipList(ZipList, getZipList)) +import Data.Char (toUpper) import Data.Functor.Identity (Identity(..)) import Data.List (intersperse) -import Data.List.NonEmpty (NonEmpty((:|)), fromList, toList) +import Data.List.NonEmpty (NonEmpty((:|)), toList) import qualified Data.Text as Text import Data.Text.Prettyprint.Doc import Numeric (showHex) -import Transformation.Deep as Deep (Product(Pair)) +import qualified Language.Oberon.Abstract as Abstract import Language.Oberon.AST -instance Pretty (Module Identity Identity) where - pretty (Module name imports declarations body name') = +data Precedence e = Precedence Int e + +instance (Pretty (Abstract.Import l), Pretty (Abstract.Block l l Identity Identity)) => + Pretty (Module λ l Identity Identity) where + pretty (Module name imports body) = vsep $ intersperse mempty $ ["MODULE" <+> pretty name <> semi, if null imports then mempty - else "IMPORT" <+> align (fillSep (punctuate comma $ prettyImport <$> imports)) <> semi] - <> (pretty <$> declarations) - <> [vsep (foldMap (\statements-> ["BEGIN" <#> prettyBlock statements]) body - <> ["END" <+> pretty name' <> "." <> line])] + else "IMPORT" <+> align (fillSep (punctuate comma $ prettyImport <$> imports)) <> semi, + pretty body, + "END" <+> pretty name <> "." <> line] where prettyImport (Nothing, mod) = pretty mod prettyImport (Just inner, mod) = pretty inner <> ":=" <+> pretty mod -instance Pretty (Declaration Identity Identity) where +instance (Abstract.Nameable l, Pretty (Abstract.IdentDef l), Pretty (Abstract.Type l l Identity Identity), + Pretty (Abstract.Declaration l l Identity Identity), + Pretty (Abstract.Expression l l Identity Identity), Pretty (Abstract.FormalParameters l l Identity Identity), + Pretty (Abstract.ProcedureHeading l l Identity Identity), + Pretty (Abstract.Block l l Identity Identity)) => + Pretty (Declaration λ l 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) = - "VAR" <+> hsep (punctuate comma $ pretty <$> toList idents) <+> colon <+> pretty varType <> semi - pretty (ProcedureDeclaration heading body name) = vsep [pretty heading <> semi, - pretty body, - "END" <+> pretty name <> semi] + "VAR" <+> hsep (punctuate comma $ pretty <$> toList idents) <> colon <+> pretty varType <> semi + pretty (ProcedureDeclaration heading body) = vsep [pretty heading <> semi, + pretty body, + "END" <+> pretty (Abstract.getProcedureName $ runIdentity heading) + <> semi] pretty (ForwardDeclaration ident parameters) = "PROCEDURE" <+> "^" <+> pretty ident <+> pretty parameters <> semi -instance Pretty IdentDef where +instance Pretty (IdentDef l) where pretty (IdentDef name Exported) = pretty name <> "*" pretty (IdentDef name ReadOnly) = pretty name <> "-" pretty (IdentDef name PrivateOnly) = pretty name -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 - 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) - | 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 e = parens (prettyPrec 0 e) - prettyPrec' p (Identity e) = prettyPrec p e +instance (Pretty (Precedence (Abstract.Expression l l Identity Identity)), + Pretty (Abstract.Expression l l Identity Identity), + Pretty (Abstract.Element l l Identity Identity), + Pretty (Abstract.Designator l l Identity Identity), + Pretty (Abstract.Value l l Identity Identity), + Pretty (Abstract.QualIdent l)) => Pretty (Expression λ l Identity Identity) where + pretty e = pretty (Precedence 0 e) + +instance (Pretty (Precedence (Abstract.Expression l l Identity Identity)), + Pretty (Abstract.Expression l l Identity Identity), + Pretty (Abstract.Element l l Identity Identity), + Pretty (Abstract.Designator l l Identity Identity), + Pretty (Abstract.QualIdent l), + Pretty (Abstract.Value l l Identity Identity)) => + Pretty (Precedence (Expression λ l Identity Identity)) where + pretty (Precedence 0 (Relation op left right)) = prettyPrec' 1 left <+> pretty op <+> prettyPrec' 1 right + pretty (Precedence 0 (IsA left right)) = prettyPrec' 1 left <+> "IS" <+> pretty right + pretty (Precedence p (Add left right)) | p < 2 = prettyPrec' 2 left <> "+" <> prettyPrec' 2 right + pretty (Precedence p (Subtract left right)) | p < 2 = prettyPrec' 2 left <> "-" <> prettyPrec' 2 right + pretty (Precedence p (Or left right)) | p < 2 = prettyPrec' 2 left <+> "OR" <+> prettyPrec' 2 right + pretty (Precedence p (Positive e)) | p < 3 = "+" <> prettyPrec' 3 e + pretty (Precedence p (Negative e)) | p < 3 = "-" <> prettyPrec' 3 e + pretty (Precedence p (Multiply left right)) | p < 4 = prettyPrec' 4 left <> "*" <> prettyPrec' 4 right + pretty (Precedence p (Divide left right)) | p < 4 = prettyPrec' 4 left <> "/" <> prettyPrec' 4 right + pretty (Precedence p (IntegerDivide left right)) | p < 4 = prettyPrec' 4 left <+> "DIV" <+> prettyPrec' 4 right + pretty (Precedence p (Modulo left right)) | p < 4 = prettyPrec' 4 left <+> "MOD" <+> prettyPrec' 4 right + pretty (Precedence p (And left right)) | p < 4 = prettyPrec' 4 left <+> "&" <+> prettyPrec' 4 right + pretty (Precedence _ (Set elements)) = braces (hsep $ punctuate comma $ pretty . runIdentity <$> getZipList elements) + pretty (Precedence _ (Read (Identity var))) = pretty var + pretty (Precedence _ (FunctionCall (Identity fun) parameters)) = + pretty fun <> parens (hsep $ punctuate comma $ pretty . runIdentity <$> getZipList parameters) + pretty (Precedence _ (Literal (Identity val))) = pretty val + pretty (Precedence p (Not e)) | p < 5 = "~" <> prettyPrec' 5 e + pretty (Precedence _ e) = parens (pretty e) +prettyPrec' p (Identity e) = pretty (Precedence p e) + instance Pretty RelOp where pretty Equal = "=" pretty Unequal = "#" @@ -80,62 +97,87 @@ pretty Greater = ">" pretty GreaterOrEqual = ">=" pretty In = "IN" - pretty Is = "IS" -instance Pretty (Element Identity Identity) where +instance Pretty (Abstract.Expression l l Identity Identity) => Pretty (Element λ l Identity Identity) where pretty (Element e) = pretty e pretty (Range from to) = pretty from <+> ".." <+> pretty to -instance Pretty (Designator Identity Identity) where +instance Pretty (Value Language l Identity Identity) where + pretty (Boolean False) = "FALSE" + pretty (Boolean True) = "TRUE" + pretty (Integer n) = pretty n + pretty (Real r) = pretty (map toUpper $ show r) + pretty (CharCode c) = "0" <> pretty (showHex c "") <> "X" + pretty (String s) + | Text.any (== '"') s = squotes (pretty s) + | otherwise = dquotes (pretty s) + pretty Nil = "NIL" + pretty (Builtin name) = pretty name + + +instance (Pretty (Abstract.QualIdent l), Pretty (Abstract.Designator l l Identity Identity), + Pretty (Abstract.Expression l l Identity Identity)) => Pretty (Designator λ l 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 (Index array index indexes) = pretty array <> brackets (hsep $ punctuate comma + $ pretty <$> index : getZipList indexes) pretty (TypeGuard scrutinee typeName) = pretty scrutinee <> parens (pretty typeName) pretty (Dereference pointer) = pretty pointer <> "^" -instance Pretty (Type Identity Identity) where +instance (Pretty (Abstract.FormalParameters l l Identity Identity), Pretty (Abstract.FieldList l l Identity Identity), + Pretty (Abstract.ConstExpression l l Identity Identity), Pretty (Abstract.Type l l Identity Identity), + Pretty (Abstract.BaseType l)) => Pretty (Type λ l Identity Identity) where pretty (TypeReference q) = pretty q pretty (ArrayType dimensions itemType) = - "ARRAY" <+> hsep (punctuate comma $ pretty . runIdentity <$> dimensions) <+> "OF" <+> pretty itemType + hsep ("ARRAY" : punctuate comma (pretty . runIdentity <$> getZipList dimensions)) <+> "OF" <+> pretty itemType pretty (RecordType baseType fields) = vsep ["RECORD" <+> foldMap (parens . pretty) baseType, - indent 3 (vsep $ punctuate semi $ pretty <$> toList fields), + indent 3 (vsep $ punctuate semi $ pretty <$> getZipList fields), "END"] pretty (PointerType pointed) = "POINTER" <+> "TO" <+> pretty pointed pretty (ProcedureType parameters) = "PROCEDURE" <+> pretty parameters -instance Pretty QualIdent where +instance Pretty (QualIdent l) where pretty (QualIdent moduleName memberName) = pretty moduleName <> "." <> pretty memberName pretty (NonQualIdent localName) = pretty localName -instance Pretty (FieldList Identity Identity) where - pretty (FieldList names t) = hsep (punctuate comma $ pretty <$> toList names) <+> ":" <+> pretty t - pretty EmptyFieldList = mempty +instance (Pretty (Abstract.IdentDef l), Pretty (Abstract.Type l l Identity Identity)) => + Pretty (FieldList λ l Identity Identity) where + pretty (FieldList names t) = hsep (punctuate comma $ pretty <$> toList names) <> colon <+> pretty t -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 - where prettyReceiver (var, name, t) = parens ((if var then "VAR " else mempty) - <> pretty name <> colon <+> pretty t) - <> space +instance (Pretty (Abstract.IdentDef l), Pretty (Abstract.FormalParameters l l Identity Identity), + Pretty (Abstract.Type l l Identity Identity)) => + Pretty (ProcedureHeading λ l Identity Identity) where + pretty (ProcedureHeading indirect ident parameters) = + "PROCEDURE" <> (if indirect then "* " else space) <> pretty ident <> pretty parameters + pretty (TypeBoundHeading var receiverName receiverType indirect ident parameters) = + "PROCEDURE" <> space + <> parens ((if var then "VAR " else mempty) <> pretty receiverName <> colon <+> pretty receiverType) + <> space <> (if indirect then "* " else space) <> pretty ident <> pretty parameters -instance Pretty (FormalParameters Identity Identity) where +instance (Pretty (Abstract.FPSection l l Identity Identity), + Pretty (Abstract.ReturnType l)) => Pretty (FormalParameters λ l Identity Identity) where pretty (FormalParameters sections result) = - lparen <> hsep (punctuate semi $ pretty <$> sections) <> rparen <> foldMap (colon <+>) (pretty <$> result) + lparen <> hsep (punctuate semi $ pretty <$> getZipList sections) <> rparen <> foldMap (colon <+>) (pretty <$> result) -instance Pretty (FPSection Identity Identity) where +instance Pretty (Abstract.Type l l Identity Identity) => Pretty (FPSection λ l Identity Identity) where pretty (FPSection var names t) = - (if var then ("VAR" <+>) else id) $ hsep (punctuate comma $ pretty <$> toList names) <+> colon <+> pretty t + (if var then ("VAR" <+>) else id) $ hsep (punctuate comma $ pretty <$> names) <+> (colon <+> pretty t) -instance Pretty (ProcedureBody Identity Identity) where - pretty (ProcedureBody declarations body) = - vsep ((indent 3 . pretty <$> declarations) +instance (Pretty (Abstract.Declaration l l Identity Identity), Pretty (Abstract.StatementSequence l l Identity Identity)) => + Pretty (Block λ l Identity Identity) where + pretty (Block declarations body) = + vsep ((indent 3 . pretty <$> getZipList declarations) ++ foldMap (\statements-> ["BEGIN", prettyBlock statements]) body) -instance Pretty (StatementSequence Identity Identity) where - pretty (StatementSequence statements) = pretty (runIdentity <$> statements) +instance Pretty (Abstract.Statement l l Identity Identity) => Pretty (StatementSequence λ l Identity Identity) where + pretty (StatementSequence statements) = pretty (runIdentity <$> getZipList statements) -instance Pretty (Statement Identity Identity) where +instance (Pretty (Abstract.ConstExpression l l Identity Identity), + Pretty (Abstract.Designator l l Identity Identity), + Pretty (Abstract.Case l l Identity Identity), + Pretty (Abstract.ConditionalBranch l l Identity Identity), + Pretty (Abstract.WithAlternative l l Identity Identity), + Pretty (Abstract.StatementSequence l l Identity Identity)) => Pretty (Statement λ l Identity Identity) where prettyList l = vsep (dropEmptyTail $ punctuate semi $ pretty <$> l) where dropEmptyTail | not (null l), EmptyStatement <- last l = init @@ -143,20 +185,16 @@ pretty EmptyStatement = mempty pretty (Assignment (Identity destination) expression) = pretty destination <+> ":=" <+> pretty expression pretty (ProcedureCall (Identity procedure) parameters) = - pretty procedure <> foldMap (parens . hsep . punctuate comma . (pretty <$>)) parameters - pretty (If (ifThen :| elsifs) fallback) = vsep (branch "IF" ifThen - : (branch "ELSIF" <$> elsifs) - ++ foldMap (\x-> ["ELSE", prettyBlock x]) fallback - ++ ["END"]) - where branch kwd (Identity (Deep.Pair (Identity condition) (Identity body))) = - vsep [kwd <+> pretty condition <+> "THEN", - prettyBlock (Identity body)] + pretty procedure <> foldMap (parens . hsep . punctuate comma . (pretty <$>)) (getZipList <$> parameters) + pretty (If ifThen (ZipList elsifs) fallback) = vsep ("IF" <+> pretty ifThen + : ((("ELSIF" <+>) . pretty) <$> elsifs) + ++ foldMap (\x-> ["ELSE", prettyBlock x]) fallback + ++ ["END"]) pretty (CaseStatement scrutinee cases fallback) = vsep ["CASE" <+> pretty scrutinee <+> "OF", align (encloseSep mempty mempty "| " - $ pretty <$> toList cases), + $ pretty <$> getZipList cases), foldMap ("ELSE" <#>) (prettyBlock <$> fallback), "END"] - pretty (While condition body) = vsep ["WHILE" <+> pretty condition <+> "DO", prettyBlock body, "END"] @@ -170,28 +208,37 @@ pretty (Loop body) = vsep ["LOOP", prettyBlock body, "END"] - pretty (With alternatives fallback) = + pretty (With alternative (ZipList alternatives) fallback) = "WITH" <+> - vsep (punctuate pipe (pretty <$> toList alternatives) ++ + vsep (punctuate pipe (pretty <$> alternative : alternatives) ++ foldMap (\x-> ["ELSE", prettyBlock x]) fallback ++ ["END"]) pretty Exit = "EXIT" pretty (Return result) = "RETURN" <+> foldMap pretty result + +instance (Pretty (Abstract.Expression l l Identity Identity), + Pretty (Abstract.StatementSequence l l Identity Identity)) => + Pretty (ConditionalBranch λ l Identity Identity) where + pretty (ConditionalBranch condition body) = vsep [pretty condition <+> "THEN", + prettyBlock body] -instance Pretty (Case Identity Identity) where - pretty (Case labels body) = vsep [hsep (punctuate comma (pretty <$> toList labels)) <+> colon, +instance (Pretty (Abstract.CaseLabels l l Identity Identity), + Pretty (Abstract.ConstExpression l l Identity Identity), + Pretty (Abstract.StatementSequence l l Identity Identity)) => Pretty (Case λ l Identity Identity) where + pretty (Case label labels body) = vsep [hsep (punctuate comma (pretty <$> label : getZipList labels)) <> colon, prettyBlock body] - pretty EmptyCase = mempty -instance Pretty (WithAlternative Identity Identity) where - pretty (WithAlternative name t body) = vsep [pretty name <+> colon <+> pretty t <+> "DO", +instance (Pretty (Abstract.QualIdent l), Pretty (Abstract.StatementSequence l l Identity Identity)) => + Pretty (WithAlternative λ l Identity Identity) where + pretty (WithAlternative name t body) = vsep [pretty name <> colon <+> pretty t <+> "DO", prettyBlock body] -instance Pretty (CaseLabels Identity Identity) where +instance Pretty (Abstract.ConstExpression l l Identity Identity) => Pretty (CaseLabels λ l Identity Identity) where pretty (SingleLabel expression) = pretty expression pretty (LabelRange from to) = pretty from <+> ".." <+> pretty to -prettyBlock :: Identity (StatementSequence Identity Identity) -> Doc ann -prettyBlock (Identity (StatementSequence statements)) = indent 3 (pretty $ runIdentity <$> statements) +prettyBlock :: Pretty (Abstract.StatementSequence l l Identity Identity) => + Identity (Abstract.StatementSequence l l Identity Identity) -> Doc ann +prettyBlock (Identity statements) = indent 3 (pretty statements) a <#> b = vsep [a, b] diff --git a/src/Language/Oberon/Reserializer.hs b/src/Language/Oberon/Reserializer.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon/Reserializer.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +-- | This module exports functions for reserializing the parsed tree from the tokens stored with every node. + +module Language.Oberon.Reserializer (adjustPositions, reserialize, sourceLength, PositionAdjustment, Serialization) where + +import Control.Arrow (first) +import Control.Monad.Trans.State.Strict (State, StateT(..), evalState, runState, state) +import Data.Either (partitionEithers) +import Data.Either.Validation (Validation(..), validationToEither) +import Data.Foldable (toList) +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Const (Const(..)) +import Data.Monoid (Ap(Ap, getAp), Sum(Sum, getSum)) +import Data.Text (Text) +import qualified Data.Text as Text + +import qualified Rank2 +import qualified Transformation +import qualified Transformation.Rank2 +import qualified Transformation.Deep as Deep +import qualified Transformation.Full as Full + +import qualified Language.Oberon.Abstract as Abstract +import Language.Oberon.AST +import Language.Oberon.Grammar (ParsedLexemes(Trailing), Lexeme(..)) + +-- | Re-calculates the position of every node in the parse tree from the tokens stored with it and its children. +adjustPositions :: (Rank2.Foldable (g (Const (Sum Int))), + Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g, + Deep.Traversable PositionAdjustment g) => Parsed (g Parsed Parsed) -> Parsed (g Parsed Parsed) +adjustPositions node@((pos, _, _), _) = evalState (Full.traverse PositionAdjustment node) 0 + +-- | Serializes the tree back into the text it was parsed from. +reserialize :: Deep.Foldable Serialization g => Parsed (g Parsed Parsed) -> Text +reserialize = finalize . (`runState` (0, [])) . getAp . Full.foldMap Serialization + where finalize (s, (_pos, rest)) = s <> foldMap lexemeText rest + +-- | The length of the source code parsed into the argument node +sourceLength :: (Rank2.Foldable (g (Const (Sum Int))), + Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g) => Parsed (g Parsed Parsed) -> Int +sourceLength root@((_, Trailing rootLexemes, _), node) = getSum (nodeLength root + <> Transformation.Rank2.foldMap nodeLength node) + where nodeLength ((_, Trailing lexemes, _), _) = foldMap (Sum . Text.length . lexemeText) lexemes + +type Parsed = (,) (Int, ParsedLexemes, Int) + +-- | Transformation type used by 'reserialize' +data Serialization = Serialization +-- | Transformation type used by 'adjustPositions' +data PositionAdjustment = PositionAdjustment + +instance Transformation.Transformation Serialization where + type Domain Serialization = Parsed + type Codomain Serialization = Const (Ap (State (Int, [Lexeme])) Text) + +instance Transformation.Transformation PositionAdjustment where + type Domain PositionAdjustment = Parsed + type Codomain PositionAdjustment = Compose (State Int) Parsed + +instance Serialization `Transformation.At` g Parsed Parsed where + Serialization $ ((nodePos, Trailing nodeLexemes, _), _) = Const (Ap $ state f) + where f :: (Int, [Lexeme]) -> (Text, (Int, [Lexeme])) + f (pos, lexemes) + | nodePos > pos, l:ls <- lexemes, t <- lexemeText l = first (t <>) (f (pos + Text.length t, ls)) + | otherwise = (mempty, (pos, nodeLexemes <> lexemes)) + +instance (Rank2.Foldable (g Parsed), Deep.Foldable Serialization g) => Full.Foldable Serialization g where + foldMap trans ((nodeStart, Trailing nodeLexemes, _), node) = Ap (state f) + where f :: (Int, [Lexeme]) -> (Text, (Int, [Lexeme])) + f (pos, lexemes) + | nodeStart > pos, l:ls <- lexemes, t <- lexemeText l = first (t <>) (f (pos + Text.length t, ls)) + | otherwise = let (t, (pos', lexemes')) = runState (getAp $ Deep.foldMap trans node) (pos, nodeLexemes) + t' = foldMap lexemeText lexemes' + in (t <> t', (pos' + Text.length t', lexemes)) + +instance (Rank2.Foldable (g (Const (Sum Int))), + Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g) => + PositionAdjustment `Transformation.At` g Parsed Parsed where + PositionAdjustment $ root@((nodeStart, lexemes, nodeEnd), node) = Compose (state f) + where f adjustment = (((nodeStart + adjustment, lexemes, nodeEnd' + adjustment), node), + adjustment + nodeEnd' - nodeEnd) + where nodeEnd' = nodeStart + sourceLength root + +instance (Rank2.Foldable (g (Const (Sum Int))), + Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g, + Deep.Traversable PositionAdjustment g) => Full.Traversable PositionAdjustment g where + traverse PositionAdjustment root@((nodeStart, lexemes, nodeEnd), node) = state f + where f adjustment = (((nodeStart + adjustment, lexemes, nodeEnd' + adjustment), + evalState (Deep.traverse PositionAdjustment node) adjustment), + adjustment + nodeEnd' - nodeEnd) + where nodeEnd' = nodeStart + sourceLength root + +instance (Rank2.Foldable (g Parsed), + Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g) => + Full.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g where + foldMap = Full.foldMapDownDefault diff --git a/src/Language/Oberon/Resolver.hs b/src/Language/Oberon/Resolver.hs --- a/src/Language/Oberon/Resolver.hs +++ b/src/Language/Oberon/Resolver.hs @@ -1,74 +1,107 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, - OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, OverloadedStrings, + ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeFamilies, TypeOperators, + 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 -- @foo@ casting it to type @bar@. -module Language.Oberon.Resolver (Error(..), - Predefined, predefined, predefined2, resolveModule, resolveModules) where +module Language.Oberon.Resolver (resolveModules, resolveModule, resolvePositions, resolvePosition, + Error(..), Predefined, Placed, NodeWrap, predefined, predefined2) where -import Control.Applicative (Alternative) -import Control.Monad ((>=>)) -import Control.Monad.Trans.State (StateT(..), evalStateT) +import Control.Applicative (ZipList(ZipList, getZipList)) +import Control.Arrow (first) +import Control.Monad.Trans.State (StateT(..), evalStateT, execStateT, get, put) import Data.Either (partitionEithers) import Data.Either.Validation (Validation(..), validationToEither) import Data.Foldable (toList) -import Data.Functor.Identity (Identity(..)) +import Data.Functor.Compose (Compose(..)) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List as List -import Data.Monoid (Alt(..)) import Data.Map.Lazy (Map, traverseWithKey) import qualified Data.Map.Lazy as Map import Data.Semigroup (Semigroup(..), sconcat) +import Data.Text (Text) +import Language.Haskell.TH (appT, conT, varT, newName) +import qualified Text.Parser.Input.Position as Position import qualified Rank2.TH -import qualified Transformation as Shallow +import qualified Transformation import qualified Transformation.Deep as Deep import qualified Transformation.Deep.TH +import qualified Transformation.Full as Full +import qualified Transformation.Full.TH import qualified Transformation.Rank2 as Rank2 -import Text.Grampa (Ambiguous(..), ParseFailure) +import Text.Grampa (Ambiguous(..)) +import qualified Language.Oberon.Abstract as Abstract import Language.Oberon.AST +import Language.Oberon.Grammar (ParsedLexemes(Trailing)) +import qualified Language.Oberon.Grammar as Grammar -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) +-- | Replace the stored positions in the entire ambiguous parsed tree, as obtained from "Language.Oberon.Grammar", +-- | with offsets from the start of the given source text +resolvePositions :: (p ~ Grammar.NodeWrap, q ~ NodeWrap, Deep.Functor (Rank2.Map p q) g) + => Text -> p (g p p) -> q (g q q) +resolvePositions src t = Rank2.Map (resolvePosition src) Full.<$> t +-- | Replace the stored positions of the given node, as obtained from "Language.Oberon.Grammar", with offset from the +-- | start of the given source text +resolvePosition :: Text -> Grammar.NodeWrap a -> NodeWrap a +resolvePosition src = \(Compose ((start, end), a))-> Compose ((Position.offset src start, Position.offset src end), a) + +data DeclarationRHS l f' f = DeclaredConstant (f (Abstract.ConstExpression l l f' f')) + | DeclaredType (f (Abstract.Type l l f' f')) + | DeclaredVariable (f (Abstract.Type l l f' f')) + | DeclaredProcedure Bool (Maybe (f (Abstract.FormalParameters l l f' f'))) +deriving instance (Show (Abstract.FormalParameters l l Placed Placed), Show (Abstract.Type l l Placed Placed), + Show (Abstract.ConstExpression l l Placed Placed)) => + Show (DeclarationRHS l Placed Placed) +deriving instance (Show (Abstract.FormalParameters l l NodeWrap NodeWrap), Show (Abstract.Type l l NodeWrap NodeWrap), + Show (Abstract.ConstExpression l l NodeWrap NodeWrap)) => + Show (DeclarationRHS l NodeWrap NodeWrap) + -- | All possible resolution errors -data Error = UnknownModule QualIdent - | UnknownLocal Ident - | UnknownImport QualIdent - | AmbiguousParses - | 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) - | NotARecord QualIdent - | NotAType QualIdent - | NotAValue QualIdent - | ClashingImports - | UnparseableModule ParseFailure - deriving (Show) +data Error l = UnknownModule (Abstract.QualIdent l) + | UnknownLocal Ident + | UnknownImport (Abstract.QualIdent l) + | AmbiguousParses + | AmbiguousDeclaration [Declaration l l NodeWrap NodeWrap] + | AmbiguousDesignator [Designator l l NodeWrap NodeWrap] + | AmbiguousExpression [Expression l l NodeWrap NodeWrap] + | AmbiguousRecord [Designator l l NodeWrap NodeWrap] + | AmbiguousStatement [Statement l l NodeWrap NodeWrap] + | InvalidExpression (NonEmpty (Error l)) + | InvalidFunctionParameters [NodeWrap (Abstract.Expression l l NodeWrap NodeWrap)] + | InvalidRecord (NonEmpty (Error l)) + | InvalidStatement (NonEmpty (Error l)) + | NotARecord (Abstract.QualIdent l) + | NotAType (Abstract.QualIdent l) + | NotAValue (Abstract.QualIdent l) + | ClashingImports + | UnparseableModule Text +deriving instance (Show (Abstract.QualIdent l), + Show (Declaration l l NodeWrap NodeWrap), Show (Statement l l NodeWrap NodeWrap), + Show (Expression l l NodeWrap NodeWrap), Show (Abstract.Expression l l NodeWrap NodeWrap), + Show (Designator l l NodeWrap NodeWrap)) => Show (Error l) -type Scope = Map Ident (Validation (NonEmpty Error) (DeclarationRHS Identity Identity)) +-- | The node wrapper in a fully resolved AST +type Placed = (,) (Int, ParsedLexemes, Int) +-- | The node wrapper in an ambiguous, freshly parsed AST, only with 'Position.Position' replaced with an offset from +-- the beginning of the source. +type NodeWrap = Compose ((,) (Int, Int)) (Compose Ambiguous ((,) ParsedLexemes)) + +type Scope l = Map Ident (Validation (NonEmpty (Error l)) (DeclarationRHS l Placed Placed)) + -- | A set of predefined declarations. -type Predefined = Scope +type Predefined l = Scope l -data Resolution = Resolution{_modules :: Map Ident Scope} +data Resolution l = Resolution{_modules :: Map Ident (Scope l)} -type Resolved = StateT (Scope, ResolutionState) (Validation (NonEmpty Error)) +type Resolved l = StateT (Scope l, ResolutionState) (Validation (NonEmpty (Error l))) data ResolutionState = ModuleState | DeclarationState @@ -77,158 +110,274 @@ | ExpressionOrTypeState deriving (Eq, Show) -instance Monad (Validation (NonEmpty Error)) where +instance Monad (Validation (NonEmpty (Error l))) where Success s >>= f = f s Failure errors >>= _ = Failure errors -instance Shallow.Functor Resolution Ambiguous Resolved (Module Resolved Resolved) where - (<$>) = mapResolveDefault +instance Transformation.Transformation (Resolution l) where + type Domain (Resolution l) = NodeWrap + type Codomain (Resolution l) = Compose (Resolved l) Placed -instance {-# overlappable #-} Show (g Identity Identity) => - Shallow.Traversable Resolution Ambiguous Identity Resolved (g Identity Identity) where - traverse = traverseResolveDefault +instance {-# overlappable #-} Resolution l `Transformation.At` g Placed Placed where + ($) = traverseResolveDefault -instance {-# overlappable #-} Show (g Ambiguous Ambiguous) => - Shallow.Traversable Resolution Ambiguous Identity Resolved (g Ambiguous Ambiguous) where - traverse = traverseResolveDefault +instance {-# overlappable #-} Resolution l `Transformation.At` g NodeWrap NodeWrap where + ($) = 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) +instance {-# overlaps #-} Resolvable l => Resolution l `Transformation.At` Designator l l NodeWrap NodeWrap where + res $ Compose ((start, end), Compose (Ambiguous designators)) = Compose $ StateT $ \s@(scope, state)-> + case partitionEithers (NonEmpty.toList (traverse (validationToEither . resolveDesignator res scope state) + <$> designators)) + of (_, [(ws, x)]) -> Success (((start, ws, end), x), s) (errors, []) -> Failure (sconcat $ NonEmpty.fromList errors) - (_, multi) -> Failure (AmbiguousDesignator multi :| []) + (_, multi) -> Failure (AmbiguousDesignator (snd <$> 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) +class Readable l where + getVariableName :: Abstract.Designator l l f' f -> Maybe (Abstract.QualIdent l) + +instance Readable Language where + getVariableName (Variable q) = Just q + getVariableName _ = Nothing + +instance {-# overlaps #-} + (Readable l, Abstract.Nameable l, Abstract.Oberon l, + Deep.Traversable (Resolution l) (Abstract.Expression l l), + Deep.Traversable (Resolution l) (Abstract.Designator l l), + Resolution l `Transformation.At` Abstract.Expression l l NodeWrap NodeWrap, + Resolution l `Transformation.At` Abstract.Designator l l NodeWrap NodeWrap) => + Resolution l `Transformation.At` Expression l l NodeWrap NodeWrap where + res $ expressions = Compose $ StateT $ \s@(scope, state)-> + let resolveExpression :: Expression l l NodeWrap NodeWrap + -> Validation (NonEmpty (Error l)) (Expression l l NodeWrap NodeWrap, ResolutionState) resolveExpression e@(Read designators) = - case evalStateT (Shallow.traverse res designators) s + case evalStateT (getCompose $ res Transformation.$ designators) s of Failure errors -> Failure errors Success{} -> pure (e, state) resolveExpression e@(FunctionCall functions parameters) = - case evalStateT (Shallow.traverse res functions) s + case evalStateT (getCompose $ res Transformation.$ functions) s of Failure errors -> Failure errors - Success (Identity d) - | Variable q <- d, Success (DeclaredProcedure True _) <- resolveName res scope q + Success (_pos, d) + | Just q <- getVariableName d, Success (DeclaredProcedure True _) <- resolveName res scope q -> pure (e, ExpressionOrTypeState) - | Success{} <- evalStateT (traverse (Shallow.traverse res) parameters) (scope, ExpressionState) + | Success{} <- evalStateT (traverse (getCompose . (res Transformation.$)) parameters) + (scope, ExpressionState) -> pure (e, ExpressionState) - | otherwise -> Failure (pure $ InvalidFunctionParameters parameters) - resolveExpression e@(Relation Is lefts rights) = pure (e, ExpressionOrTypeState) + | otherwise -> Failure (pure $ InvalidFunctionParameters $ getZipList parameters) + resolveExpression e@(IsA _lefts q) = + case resolveName res scope q + of Failure err -> Failure err + Success DeclaredType{} -> pure (e, ExpressionState) + Success _ -> Failure (NotAType q :| []) resolveExpression e = pure (e, state) - in (\(r, s)-> (Identity r, (scope, s))) + in (\(pos, (r, s'))-> ((pos, 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) +instance {-# overlaps #-} + (BindableDeclaration l, CoFormalParameters l, Abstract.Wirthy l, + Full.Traversable (Resolution l) (Abstract.Type l l), + Full.Traversable (Resolution l) (Abstract.FormalParameters l l), + Full.Traversable (Resolution l) (Abstract.ConstExpression l l), + Deep.Traversable (Resolution l) (Abstract.Type l l), + Deep.Traversable (Resolution l) (Abstract.ProcedureHeading l l), + Deep.Traversable (Resolution l) (Abstract.FormalParameters l l), + Deep.Traversable (Resolution l) (Abstract.ConstExpression l l), + Resolution l `Transformation.At` Abstract.ProcedureHeading l l NodeWrap NodeWrap, + Resolution l `Transformation.At` Abstract.Block l l NodeWrap NodeWrap) => + Resolution l `Transformation.At` Declaration l l NodeWrap NodeWrap where + res $ Compose ((start, end), Compose (Ambiguous ((ws, proc@(ProcedureDeclaration heading body)) :| []))) = + Compose $ + do s@(scope, state) <- get + let Success (headingScope, _) = execStateT (getCompose $ res Transformation.$ heading) s + Success (_, body') = evalStateT (getCompose $ res Transformation.$ body) s + innerScope = localScope res "" (getLocalDeclarations body') (headingScope `Map.union` scope) + put (innerScope, state) + return ((start, ws, end), proc) + _ $ Compose ((start, end), Compose (Ambiguous ((ws, dec) :| []))) = Compose (pure ((start, ws, end), dec)) + _ $ declarations = Compose (StateT $ const $ Failure $ pure $ AmbiguousDeclaration $ toList declarations) + +class CoFormalParameters l where + getFPSections :: Abstract.FormalParameters l l f' f -> [f (Abstract.FPSection l l f' f')] + evalFPSection :: Abstract.FPSection l l f' f -> (Bool -> [Ident] -> f (Abstract.Type l l f' f') -> r) -> r + getLocalDeclarations :: Abstract.Block l l f' f -> [f (Abstract.Declaration l l f' f')] + +instance CoFormalParameters Language where + getFPSections (FormalParameters sections _) = getZipList sections + evalFPSection (FPSection var names types) f = f var names types + getLocalDeclarations (Block declarations _statements) = getZipList declarations + +instance {-# overlaps #-} + (Abstract.Wirthy l, CoFormalParameters l, + Full.Traversable (Resolution l) (Abstract.Type l l), + Full.Traversable (Resolution l) (Abstract.FormalParameters l l), + Full.Traversable (Resolution l) (Abstract.ConstExpression l l), + Deep.Traversable (Resolution l) (Abstract.Type l l), + Deep.Traversable (Resolution l) (Abstract.FormalParameters l l), + Deep.Traversable (Resolution l) (Abstract.ConstExpression l l)) => + Resolution l `Transformation.At` ProcedureHeading l l NodeWrap NodeWrap where + res $ Compose ((start, end), Compose (Ambiguous ((ws, proc@(ProcedureHeading _ _ parameters)) :| []))) = + Compose $ StateT $ \s@(scope, state)-> + let innerScope = parameterScope `Map.union` scope parameterScope = case parameters of Nothing -> mempty - Just (Ambiguous (FormalParameters sections _ :| [])) + Just (Compose (_, Compose (Ambiguous ((ws, fp) :| [])))) | sections <- getFPSections fp -> 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) + binding (Compose (_, Compose (Ambiguous ((_, section) :| [])))) = evalFPSection section $ \ _ names types-> + [(v, evalStateT (Deep.traverse res $ DeclaredVariable types) s) | v <- names] + in Success (((start, ws, end), proc), (innerScope, state)) + res $ Compose ((start, end), + Compose (Ambiguous ((ws, proc@(TypeBoundHeading _var receiverName receiverType _ _ parameters)) + :| []))) = + Compose $ StateT $ \s@(scope, state)-> + let innerScope = parameterScope `Map.union` receiverBinding `Map.union` scope + receiverBinding :: Map Ident (Validation e (DeclarationRHS l f' Placed)) + receiverBinding = Map.singleton receiverName (Success $ DeclaredVariable $ (,) (start, ws, end) + $ Abstract.typeReference + $ Abstract.nonQualIdent receiverType) + parameterScope = case parameters + of Nothing -> mempty + Just (Compose (_, Compose (Ambiguous ((ws, fp) :| [])))) | sections <- getFPSections fp + -> Map.fromList (concatMap binding sections) + binding (Compose (_, Compose (Ambiguous ((_, section) :| [])))) = evalFPSection section $ \ _ names types-> + [(v, evalStateT (Deep.traverse res $ DeclaredVariable types) s) | v <- names] + in Success (((start, ws, end), proc), (innerScope, state)) -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 #-} + (BindableDeclaration l, + Full.Traversable (Resolution l) (Abstract.Type l l), + Full.Traversable (Resolution l) (Abstract.FormalParameters l l), + Full.Traversable (Resolution l) (Abstract.ConstExpression l l), + Deep.Traversable (Resolution l) (Abstract.Type l l), + Deep.Traversable (Resolution l) (Abstract.FormalParameters l l), + Deep.Traversable (Resolution l) (Abstract.ConstExpression l l)) => + Resolution l `Transformation.At` Block l l NodeWrap NodeWrap where + res $ Compose ((start, end), Compose (Ambiguous ((ws, body@(Block (ZipList declarations) _statements)) :| []))) = + Compose $ StateT $ \(scope, state)-> Success (((start, ws, end), body), + (localScope res "" declarations scope, state)) + _ $ _ = Compose (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 +instance {-# overlaps #-} + (Deep.Traversable (Resolution l) (Abstract.Designator l l), + Resolution l `Transformation.At` Abstract.Designator l l NodeWrap NodeWrap) => + Resolution l `Transformation.At` Statement l l NodeWrap NodeWrap where + res $ statements = Compose $ StateT $ \s@(scope, _state)-> + let resolveStatement :: Statement l l NodeWrap NodeWrap + -> Validation (NonEmpty (Error l)) (Statement l l NodeWrap NodeWrap, ResolutionState) + resolveStatement p@(ProcedureCall procedures _parameters) = + case evalStateT (getCompose $ res Transformation.$ procedures) s of Failure errors -> Failure errors Success{} -> pure (p, StatementState) resolveStatement stat = pure (stat, StatementState) - in (\(r, s)-> (Identity r, (scope, s))) + in (\(pos, (r, s'))-> ((pos, 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 :: Resolution l -> NodeWrap (g (f :: * -> *) f) -> Compose (Resolved l) Placed (g f f) +traverseResolveDefault Resolution{} (Compose ((start, end), Compose (Ambiguous ((ws, x) :| [])))) = + Compose (StateT $ \s-> Success (((start, ws, end), x), s)) +traverseResolveDefault Resolution{} _ = Compose (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) +class Resolvable l where + resolveDesignator :: Resolution l -> Scope l -> ResolutionState -> (Designator l l NodeWrap NodeWrap) + -> Validation (NonEmpty (Error l)) (Designator l l NodeWrap NodeWrap) + resolveRecord :: Resolution l -> Scope l -> ResolutionState -> (Designator l l NodeWrap NodeWrap) + -> Validation (NonEmpty (Error l)) (Designator l l NodeWrap NodeWrap) -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 +instance Resolvable Language where + resolveDesignator res scope state (Variable q) = + case resolveName res scope q + of Failure err -> Failure err + Success DeclaredType{} | state /= ExpressionOrTypeState -> Failure (NotAValue q :| []) + Success _ -> Success (Variable q) + resolveDesignator res scope state d@(Field records field) = + case evalStateT (getCompose $ res Transformation.$ records) (scope, state) + of Failure errors -> Failure errors + Success{} -> pure d + resolveDesignator res scope state (TypeGuard records subtypes) = + case unique InvalidRecord AmbiguousRecord (resolveRecord res scope state <$> records) + of Failure errors -> Failure errors + Success{} -> TypeGuard records <$> resolveTypeName res scope subtypes + resolveDesignator res scope state d@(Dereference pointers) = + case evalStateT (getCompose $ res Transformation.$ pointers) (scope, state) + of Failure errors -> Failure errors + Success{} -> pure d + resolveDesignator _ _ _ d = pure d - resolveTypeName q = - case resolveName res scope q - of Failure err -> Failure err - Success DeclaredType{} -> Success q - Success _ -> Failure (NotAType q :| []) + resolveRecord res scope state 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{} -> resolveDesignator res scope state d + resolveRecord res scope state d = resolveDesignator res scope state d -resolveName :: Resolution -> Scope -> QualIdent -> Validation (NonEmpty Error) (DeclarationRHS Identity Identity) -resolveName res scope q@(QualIdent moduleName name) = - case Map.lookup moduleName (_modules res) - of Nothing -> Failure (UnknownModule q :| []) - Just exports -> case Map.lookup name exports - of Just rhs -> rhs - Nothing -> Failure (UnknownImport q :| []) -resolveName res scope (NonQualIdent name) = - case Map.lookup name scope - of Just (Success rhs) -> Success rhs - _ -> Failure (UnknownLocal name :| []) +resolveTypeName res scope q = + case resolveName res scope q + of Failure err -> Failure err + Success DeclaredType{} -> Success q + Success _ -> Failure (NotAType q :| []) -resolveModules :: Predefined -> Map Ident (Module Ambiguous Ambiguous) - -> Validation (NonEmpty (Ident, NonEmpty Error)) (Map Ident (Module Identity Identity)) +resolveName :: (Abstract.Nameable l, Abstract.Oberon l) + => Resolution l -> Scope l -> Abstract.QualIdent l + -> Validation (NonEmpty (Error l)) (DeclarationRHS l Placed Placed) +resolveName res scope q + | Just (moduleName, name) <- Abstract.getQualIdentNames q = + 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 :| []) + | Just name <- Abstract.getNonQualIdentName q = + case Map.lookup name scope + of Just (Success rhs) -> Success rhs + _ -> Failure (UnknownLocal name :| []) + +-- | Resolve ambiguities in the given collection of modules, a 'Map' keyed by module name. The value for the first +-- argument is typically 'predefined' or 'predefined2'. Note that all class constraints in the function's type +-- signature are satisfied by the Oberon 'Language'. +resolveModules :: forall l. (BindableDeclaration l, CoFormalParameters l, Abstract.Wirthy l, + Deep.Traversable (Resolution l) (Abstract.Declaration l l), + Deep.Traversable (Resolution l) (Abstract.Type l l), + Deep.Traversable (Resolution l) (Abstract.ProcedureHeading l l), + Deep.Traversable (Resolution l) (Abstract.FormalParameters l l), + Deep.Traversable (Resolution l) (Abstract.Expression l l), + Deep.Traversable (Resolution l) (Abstract.Block l l), + Deep.Traversable (Resolution l) (Abstract.StatementSequence l l), + Full.Traversable (Resolution l) (Abstract.Declaration l l), + Full.Traversable (Resolution l) (Abstract.Type l l), + Full.Traversable (Resolution l) (Abstract.ProcedureHeading l l), + Full.Traversable (Resolution l) (Abstract.FormalParameters l l), + Full.Traversable (Resolution l) (Abstract.Expression l l), + Full.Traversable (Resolution l) (Abstract.Block l l), + Full.Traversable (Resolution l) (Abstract.StatementSequence l l), + Resolution l `Transformation.At` Abstract.Block l l NodeWrap NodeWrap) => + Predefined l -> Map Ident (NodeWrap (Module l l NodeWrap NodeWrap)) + -> Validation (NonEmpty (Ident, NonEmpty (Error l))) (Map Ident (Placed (Module l l Placed Placed))) resolveModules predefinedScope modules = traverseWithKey extractErrors modules' where modules' = resolveModule predefinedScope modules' <$> modules extractErrors moduleKey (Failure e) = Failure ((moduleKey, e) :| []) extractErrors _ (Success mod) = Success mod -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) +-- | Resolve ambiguities in a single module. The value for the first argument is typically 'predefined' or +-- 'predefined2'. The imports are resolved using the given map of already resolved modules. Note that all class +-- constraints in the function's type signature are satisfied by the Oberon 'Language'. +resolveModule :: forall l. (BindableDeclaration l, CoFormalParameters l, + Full.Traversable (Resolution l) (Abstract.Block l l), + Full.Traversable (Resolution l) (Abstract.Declaration l l), + Full.Traversable (Resolution l) (Abstract.Type l l), + Full.Traversable (Resolution l) (Abstract.FormalParameters l l), + Full.Traversable (Resolution l) (Abstract.ConstExpression l l), + Full.Traversable (Resolution l) (Abstract.StatementSequence l l), + Deep.Traversable (Resolution l) (Declaration l l), + Deep.Traversable (Resolution l) (Abstract.Declaration l l), + Deep.Traversable (Resolution l) (Abstract.StatementSequence l l), + Deep.Traversable (Resolution l) (Abstract.Type l l), + Deep.Traversable (Resolution l) (Abstract.FormalParameters l l), + Deep.Traversable (Resolution l) (Abstract.ConstExpression l l), + Resolution l `Transformation.At` Abstract.Block l l NodeWrap NodeWrap) => + Scope l -> Map Ident (Validation (NonEmpty (Error l)) (Placed (Module l l Placed Placed))) + -> NodeWrap (Module l l NodeWrap NodeWrap) + -> Validation (NonEmpty (Error l)) (Placed (Module l l Placed Placed)) +resolveModule predefined modules m@(Compose (pos, Compose (Ambiguous ((ls, Module moduleName imports body) :| [])))) = + evalStateT (Full.traverse 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 @@ -236,129 +385,177 @@ Just (Just innerKey, _) -> innerKey Nothing -> mempty clashingRenames _ _ = Failure (ClashingImports :| []) - resolveDeclaration :: Ambiguous (Declaration Ambiguous Ambiguous) -> Resolved (Declaration Identity Identity) - resolveDeclaration d = runIdentity <$> (traverse (Deep.traverseDown res) d >>= Shallow.traverse res) - moduleExports = foldMap exportsOfModule <$> importedModules - moduleGlobalScope = localScope res moduleName declarations predefined + resolveDeclaration :: NodeWrap (Declaration l l NodeWrap NodeWrap) -> Resolved l (Declaration l l Placed Placed) + resolveDeclaration d = snd <$> (traverse (Deep.traverse res) d >>= getCompose . (res Transformation.$)) + moduleExports = foldMap (exportsOfModule . snd) <$> importedModules + Success (_, body') = evalStateT (getCompose $ res Transformation.$ body) (predefined, ModuleState) + moduleGlobalScope = localScope res moduleName (getLocalDeclarations body') predefined -localScope :: Resolution -> Ident -> [Ambiguous (Declaration Ambiguous Ambiguous)] -> Scope -> Scope +localScope :: forall l. (BindableDeclaration l, + Full.Traversable (Resolution l) (Abstract.Type l l), + Full.Traversable (Resolution l) (Abstract.FormalParameters l l), + Full.Traversable (Resolution l) (Abstract.ConstExpression l l)) => + Resolution l -> Ident -> [NodeWrap (Abstract.Declaration l l NodeWrap NodeWrap)] -> Scope l -> Scope l 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) + unamb (Compose (offset, Compose (Ambiguous ((_, x) :| [])))) = x + resolveBinding :: Resolution l -> Scope l -> DeclarationRHS l NodeWrap NodeWrap + -> Validation (NonEmpty (Error l)) (DeclarationRHS l Placed Placed) + resolveBinding res scope dr = evalStateT (Deep.traverse 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) = - [(name, (export, DeclaredType typeDef))] -declarationBinding _ (VariableDeclaration names typeDef) = - [(name, (export, DeclaredVariable typeDef)) | (IdentDef name export) <- NonEmpty.toList names] -declarationBinding moduleName (ProcedureDeclaration (ProcedureHeading _ _ (IdentDef name export) parameters) _ _) = - [(name, (export, DeclaredProcedure (moduleName == "SYSTEM") parameters))] -declarationBinding _ (ForwardDeclaration (IdentDef name export) parameters) = - [(name, (export, DeclaredProcedure False parameters))] +class BindableDeclaration l where + declarationBinding :: Foldable f => Ident -> Abstract.Declaration l l f f -> [(Ident, (AccessMode, DeclarationRHS l f f))] + +instance BindableDeclaration Language where + declarationBinding _ (ConstantDeclaration (IdentDef name export) expr) = + [(name, (export, DeclaredConstant expr))] + declarationBinding _ (TypeDeclaration (IdentDef name export) typeDef) = + [(name, (export, DeclaredType typeDef))] + declarationBinding _ (VariableDeclaration names typeDef) = + [(name, (export, DeclaredVariable typeDef)) | (IdentDef name export) <- NonEmpty.toList names] + declarationBinding moduleName (ProcedureDeclaration heading _) = procedureHeadBinding (foldr1 const heading) + where procedureHeadBinding (ProcedureHeading _ (IdentDef name export) parameters) = + [(name, (export, DeclaredProcedure (moduleName == "SYSTEM") parameters))] + procedureHeadBinding (TypeBoundHeading _ _ _ _ (IdentDef name export) parameters) = + [(name, (export, DeclaredProcedure (moduleName == "SYSTEM") parameters))] + declarationBinding _ (ForwardDeclaration (IdentDef name export) parameters) = + [(name, (export, DeclaredProcedure False parameters))] -predefined, predefined2 :: Predefined +predefined, predefined2 :: Abstract.Oberon l => Predefined l -- | The set of 'Predefined' types and procedures defined in the Oberon Language Report. predefined = Success <$> Map.fromList - [("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 $ Identity $ - FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ - Just $ NonQualIdent "INTEGER"), - ("ASH", DeclaredProcedure False $ Just $ Identity $ - FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ - Just $ NonQualIdent "INTEGER"), - ("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 $ Identity $ - FormalParameters [Identity $ FPSection False (pure "c") $ Identity $ TypeReference $ NonQualIdent "SET"] $ - Just $ NonQualIdent "INTEGER"), - ("MIN", DeclaredProcedure True $ Just $ Identity $ - FormalParameters [Identity $ FPSection False (pure "c") $ Identity $ TypeReference $ NonQualIdent "SET"] $ - Just $ NonQualIdent "INTEGER"), - ("ODD", DeclaredProcedure False $ Just $ Identity $ - FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "CHAR"] $ - Just $ NonQualIdent "BOOLEAN"), - ("SIZE", DeclaredProcedure True $ Just $ Identity $ - FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "CHAR"] $ - Just $ NonQualIdent "INTEGER"), - ("ORD", DeclaredProcedure False $ Just $ Identity $ - FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "CHAR"] $ - Just $ NonQualIdent "INTEGER"), - ("CHR", DeclaredProcedure False $ Just $ Identity $ - FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ - Just $ NonQualIdent "CHAR"), - ("SHORT", DeclaredProcedure False $ Just $ Identity $ - FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ - Just $ NonQualIdent "INTEGER"), - ("LONG", DeclaredProcedure False $ Just $ Identity $ - FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "INTEGER"] $ - Just $ NonQualIdent "INTEGER"), - ("ENTIER", DeclaredProcedure False $ Just $ Identity $ - FormalParameters [Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "REAL"] $ - Just $ NonQualIdent "INTEGER"), - ("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)] + [("BOOLEAN", DeclaredType (wrap $ Abstract.typeReference $ Abstract.nonQualIdent "BOOLEAN")), + ("CHAR", DeclaredType (wrap $ Abstract.typeReference $ Abstract.nonQualIdent "CHAR")), + ("SHORTINT", DeclaredType (wrap $ Abstract.typeReference $ Abstract.nonQualIdent "SHORTINT")), + ("INTEGER", DeclaredType (wrap $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER")), + ("LONGINT", DeclaredType (wrap $ Abstract.typeReference $ Abstract.nonQualIdent "LONGINT")), + ("REAL", DeclaredType (wrap $ Abstract.typeReference $ Abstract.nonQualIdent "REAL")), + ("LONGREAL", DeclaredType (wrap $ Abstract.typeReference $ Abstract.nonQualIdent "LONGREAL")), + ("SET", DeclaredType (wrap $ Abstract.typeReference $ Abstract.nonQualIdent "SET")), + ("TRUE", DeclaredConstant (wrap $ Abstract.read $ wrap $ Abstract.variable $ Abstract.nonQualIdent "TRUE")), + ("FALSE", DeclaredConstant (wrap $ Abstract.read $ wrap $ Abstract.variable $ Abstract.nonQualIdent "FALSE")), + ("ABS", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER"] $ + Just $ Abstract.nonQualIdent "INTEGER"), + ("ASH", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER"] $ + Just $ Abstract.nonQualIdent "INTEGER"), + ("CAP", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "c") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "CHAR"] $ + Just $ Abstract.nonQualIdent "CHAR"), + ("LEN", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "c") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "ARRAY"] $ + Just $ Abstract.nonQualIdent "LONGINT"), + ("MAX", DeclaredProcedure True $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "c") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "SET"] $ + Just $ Abstract.nonQualIdent "INTEGER"), + ("MIN", DeclaredProcedure True $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "c") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "SET"] $ + Just $ Abstract.nonQualIdent "INTEGER"), + ("ODD", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "CHAR"] $ + Just $ Abstract.nonQualIdent "BOOLEAN"), + ("SIZE", DeclaredProcedure True $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "CHAR"] $ + Just $ Abstract.nonQualIdent "INTEGER"), + ("ORD", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "CHAR"] $ + Just $ Abstract.nonQualIdent "INTEGER"), + ("CHR", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER"] $ + Just $ Abstract.nonQualIdent "CHAR"), + ("SHORT", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER"] $ + Just $ Abstract.nonQualIdent "INTEGER"), + ("LONG", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER"] $ + Just $ Abstract.nonQualIdent "INTEGER"), + ("ENTIER", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "REAL"] $ + Just $ Abstract.nonQualIdent "INTEGER"), + ("INC", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER"] Nothing), + ("DEC", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER"] Nothing), + ("INCL", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "s") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "SET", + wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER"] Nothing), + ("EXCL", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "s") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "SET", + wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "INTEGER"] Nothing), + ("COPY", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "s") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "ARRAY", + wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "ARRAY"] Nothing), + ("NEW", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.nonQualIdent "POINTER"] Nothing), + ("HALT", DeclaredProcedure False $ Just $ wrap $ + Abstract.formalParameters [wrap $ Abstract.fpSection False (pure "n") $ wrap + $ Abstract.typeReference $ Abstract.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 $ Identity $ - FormalParameters [Identity $ FPSection False (pure "s") $ Identity $ TypeReference $ NonQualIdent "ARRAY", - Identity $ FPSection False (pure "n") $ Identity $ TypeReference $ NonQualIdent "ARRAY"] Nothing)]) + [("ASSERT", + DeclaredProcedure False $ Just $ wrap $ Abstract.formalParameters + [wrap $ Abstract.fpSection False (pure "s") $ wrap $ Abstract.typeReference $ Abstract.nonQualIdent "ARRAY", + wrap $ Abstract.fpSection False (pure "n") $ wrap $ Abstract.typeReference $ Abstract.nonQualIdent "ARRAY"] + Nothing)]) -exportsOfModule :: Module Identity Identity -> Scope +wrap = (,) (0, Trailing [], 0) + +exportsOfModule :: (BindableDeclaration l, CoFormalParameters l) => Module l l Placed Placed -> Scope l exportsOfModule = fmap Success . Map.mapMaybe isExported . globalsOfModule where isExported (PrivateOnly, _) = Nothing isExported (_, binding) = Just binding -globalsOfModule :: Module Identity Identity -> Map Ident (AccessMode, DeclarationRHS Identity Identity) -globalsOfModule (Module name imports declarations _ _) = - Map.fromList (concatMap (declarationBinding name . runIdentity) declarations) +globalsOfModule :: forall l. (BindableDeclaration l, CoFormalParameters l) => + Module l l Placed Placed -> Map Ident (AccessMode, DeclarationRHS l Placed Placed) +globalsOfModule (Module name imports (_, body)) = + Map.fromList (concatMap (declarationBinding name . snd) (getLocalDeclarations body)) -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 +unique :: (NonEmpty (Error l) -> Error l) -> ([a] -> Error l) -> NodeWrap (Validation (NonEmpty (Error l)) a) + -> Validation (NonEmpty (Error l)) (Placed a) +unique _ _ (Compose ((start, end), Compose (Ambiguous (x :| [])))) = first (flip ((,,) start) end) <$> (sequenceA x) +unique inv amb (Compose ((start, end), Compose (Ambiguous xs))) = + case partitionEithers (traverse validationToEither <$> NonEmpty.toList xs) + of (_, [(ws, x)]) -> Success ((start, ws, end), x) (errors, []) -> Failure (inv (sconcat $ NonEmpty.fromList errors) :| []) - (_, multi) -> Failure (amb multi :| []) + (_, multi) -> Failure (amb (snd <$> multi) :| []) $(Rank2.TH.deriveFunctor ''DeclarationRHS) $(Rank2.TH.deriveFoldable ''DeclarationRHS) $(Rank2.TH.deriveTraversable ''DeclarationRHS) -$(Transformation.Deep.TH.deriveDownTraversable ''DeclarationRHS) +$(Transformation.Deep.TH.deriveTraversable ''DeclarationRHS) + +$(do l <- varT <$> newName "l" + mconcat <$> mapM (\t-> Transformation.Full.TH.deriveDownTraversable (conT ''Resolution `appT` l) + $ conT t `appT` l `appT` l) + [''Module, ''Declaration, ''Type, ''FieldList, + ''ProcedureHeading, ''FormalParameters, ''FPSection, + ''Expression, ''Element, ''Designator, + ''Block, ''StatementSequence, ''Statement, + ''Case, ''CaseLabels, ''ConditionalBranch, ''Value, ''WithAlternative]) diff --git a/src/Language/Oberon/TypeChecker.hs b/src/Language/Oberon/TypeChecker.hs --- a/src/Language/Oberon/TypeChecker.hs +++ b/src/Language/Oberon/TypeChecker.hs @@ -1,880 +1,1099 @@ -{-# 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]) +{-# LANGUAGE DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, + TemplateHaskell, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns #-} + +-- | Type checker for Oberon AST. The AST must have its ambiguities previously resolved by "Language.Oberon.Resolver". +module Language.Oberon.TypeChecker (checkModules, errorMessage, Error, ErrorType(..), predefined, predefined2) where + +import Control.Applicative (liftA2, (<|>), ZipList(ZipList, getZipList)) +import Control.Arrow (first) +import Data.Coerce (coerce) +import Data.Proxy (Proxy(..)) +import qualified Data.List as List +import Data.Functor.Const (Const(..)) +import Data.Maybe (fromMaybe) +import Data.Map.Lazy (Map) +import qualified Data.Map.Lazy as Map +import Data.Semigroup (Semigroup(..)) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Language.Haskell.TH (appT, conT, varT, newName) + +import qualified Rank2 +import qualified Transformation +import qualified Transformation.Shallow as Shallow +import qualified Transformation.Deep as Deep +import qualified Transformation.Full as Full +import qualified Transformation.Full.TH +import qualified Transformation.AG as AG +import qualified Transformation.AG.Generics as AG +import Transformation.AG (Attribution(..), Atts, Inherited(..), Synthesized(..), Semantics) +import Transformation.AG.Generics (Auto(Auto), Folded(..), Bequether(..), Synthesizer(..), SynthesizedField) + +import qualified Language.Oberon.Abstract as Abstract +import qualified Language.Oberon.AST as AST +import Language.Oberon.Grammar (ParsedLexemes(Trailing)) +import Language.Oberon.Resolver (Placed) + +data Type l = NominalType (Abstract.QualIdent l) (Maybe (Type l)) + | RecordType{ancestry :: [Abstract.QualIdent l], + recordFields :: Map AST.Ident (Type l)} + | NilType + | IntegerType Int + | StringType Int + | ArrayType [Int] (Type l) + | PointerType (Type l) + | ReceiverType (Type l) + | ProcedureType Bool [(Bool, Type l)] (Maybe (Type l)) + | BuiltinType Text.Text + | UnknownType + +data ErrorType l = ArgumentCountMismatch Int Int + | ExtraDimensionalIndex Int Int + | IncomparableTypes (Type l) (Type l) + | IncompatibleTypes (Type l) (Type l) + | TooSmallArrayType Int Int + | OpenArrayVariable + | NonArrayType (Type l) + | NonBooleanType (Type l) + | NonFunctionType (Type l) + | NonIntegerType (Type l) + | NonNumericType (Type l) + | NonPointerType (Type l) + | NonProcedureType (Type l) + | NonRecordType (Type l) + | TypeMismatch (Type l) (Type l) + | UnequalTypes (Type l) (Type l) + | UnrealType (Type l) + | UnknownName (Abstract.QualIdent l) + | UnknownField AST.Ident (Type l) + +type Error l = (AST.Ident, (Int, ParsedLexemes, Int), ErrorType l) + +instance Eq (Abstract.QualIdent l) => Eq (Type l) where + NominalType q1 (Just t1) == t2@(NominalType q2 _) = q1 == q2 || t1 == t2 + t1@(NominalType q1 _) == NominalType q2 (Just t2) = q1 == q2 || t1 == t2 + NominalType q1 Nothing == NominalType q2 Nothing = 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 + BuiltinType name1 == BuiltinType name2 = name1 == name2 + ReceiverType t1 == t2 = t1 == t2 + t1 == ReceiverType t2 = t1 == t2 + _ == _ = False + +instance Show (Abstract.QualIdent l) => Show (Type l) where + show (NominalType q t) = "Nominal " ++ show q ++ " (" ++ shows t ")" + show (RecordType ancestry fields) = "RecordType " ++ show ancestry ++ show (fst <$> Map.toList fields) + show (ArrayType dimensions itemType) = "ArrayType " ++ show dimensions ++ " (" ++ shows itemType ")" + show (PointerType targetType) = "PointerType " ++ show targetType + show (ProcedureType _ parameters result) = "ProcedureType (" ++ show parameters ++ "): " ++ show result + show (ReceiverType t) = "ReceiverType " ++ show t + show (IntegerType n) = "IntegerType " ++ show n + show (StringType len) = "StringType " ++ show len + show (BuiltinType name) = "BuiltinType " ++ show name + show NilType = "NilType" + show UnknownType = "UnknownType" + +errorMessage :: (Abstract.Nameable l, Abstract.Oberon l, Show (Abstract.QualIdent l)) => ErrorType l -> String +errorMessage (ArgumentCountMismatch expected actual) = + "Expected " <> show expected <> ", received " <> show actual <> " arguments" +errorMessage (ExtraDimensionalIndex expected actual) = + "Expected " <> show expected <> ", received " <> show actual <> " indexes" +errorMessage (IncomparableTypes left right) = + "Values of types " <> typeMessage left <> " and " <> typeMessage right <> " cannot be compared" +errorMessage (IncompatibleTypes left right) = + "Incompatible types " <> typeMessage left <> " and " <> typeMessage right +errorMessage (TooSmallArrayType expected actual) = + "The array of length " <> show expected <> " cannot contain " <> show actual <> " items" +errorMessage OpenArrayVariable = "A variable cannot be declared an open array" +errorMessage (NonArrayType t) = "Trying to index a non-array type " <> typeMessage t +errorMessage (NonBooleanType t) = "Type " <> typeMessage t <> " is not Boolean" +errorMessage (NonFunctionType t) = "Trying to invoke a " <> typeMessage t <> " as a function" +errorMessage (NonIntegerType t) = "Type " <> typeMessage t <> " is not an integer type" +errorMessage (NonNumericType t) = "Type " <> typeMessage t <> " is not a numeric type" +errorMessage (NonPointerType t) = "Trying to dereference a non-pointer type " <> typeMessage t +errorMessage (NonProcedureType t) = "Trying to invoke a " <> typeMessage t <> " as a procedure" +errorMessage (NonRecordType t) = "Non-record type " <> typeMessage t +errorMessage (TypeMismatch t1 t2) = "Type mismatch between " <> typeMessage t1 <> " and " <> typeMessage t2 +errorMessage (UnequalTypes t1 t2) = "Unequal types " <> typeMessage t1 <> " and " <> typeMessage t2 +errorMessage (UnrealType t) = "Type " <> typeMessage t <> " is not a numeric real type" +errorMessage (UnknownName q) = "Unknown name " <> show q +errorMessage (UnknownField name t) = "Record type " <> typeMessage t <> " has no field " <> show name + +typeMessage :: (Abstract.Nameable l, Abstract.Oberon l) => Type l -> String +typeMessage (BuiltinType name) = Text.unpack name +typeMessage (NominalType name _) = nameMessage name +typeMessage (RecordType ancestry fields) = + "RECORD " ++ foldMap (("(" ++) . (++ ") ") . nameMessage) ancestry + ++ List.intercalate ";\n" (fieldMessage <$> Map.toList fields) ++ "END" + where fieldMessage (name, t) = "\n " <> Text.unpack name <> ": " <> typeMessage t +typeMessage (ArrayType dimensions itemType) = + "ARRAY " ++ List.intercalate ", " (show <$> dimensions) ++ " OF " ++ typeMessage itemType +typeMessage (PointerType targetType) = "POINTER TO " ++ typeMessage targetType +typeMessage (ProcedureType _ parameters result) = + "PROCEDURE (" ++ List.intercalate ", " (argMessage <$> parameters) ++ "): " ++ foldMap typeMessage result + where argMessage (True, t) = "VAR " <> typeMessage t + argMessage (False, t) = typeMessage t +typeMessage (ReceiverType t) = typeMessage t +typeMessage (IntegerType n) = "INTEGER" +typeMessage (StringType len) = "STRING [" ++ shows len "]" +typeMessage NilType = "NIL" +typeMessage UnknownType = "[Unknown]" + +nameMessage :: (Abstract.Nameable l, Abstract.Oberon l) => Abstract.QualIdent l -> String +nameMessage q + | Just (mod, name) <- Abstract.getQualIdentNames q = Text.unpack mod <> "." <> Text.unpack name + | Just name <- Abstract.getNonQualIdentName q = Text.unpack name + +type Environment l = Map (Abstract.QualIdent l) (Type l) + +newtype Modules l f' f = Modules (Map AST.Ident (f (AST.Module l l f' f'))) + +data TypeCheck = TypeCheck + +type Sem = Semantics (Auto TypeCheck) + +data InhTCRoot l = InhTCRoot{rootEnv :: Environment l} + +data InhTC l = InhTC{env :: Environment l, + currentModule :: AST.Ident} + deriving Generic + +data InhTCExp l = InhTCExp{env :: Environment l, + currentModule :: AST.Ident, + expectedType :: Type l} + deriving Generic + +data InhTCDecl l = InhTCDecl{env :: Environment l, + currentModule :: AST.Ident, + pointerTargets :: Map AST.Ident AST.Ident} + deriving Generic + +data SynTC l = SynTC{errors :: Folded [Error l]} + deriving Generic + +data SynTCMod l = SynTCMod{errors :: Folded [Error l], + moduleEnv :: Environment l, + pointerTargets :: Folded (Map AST.Ident AST.Ident)} + deriving Generic + +data SynTCType l = SynTCType{errors :: Folded [Error l], + typeName :: Maybe AST.Ident, + definedType :: Type l, + pointerTarget :: Maybe AST.Ident} + deriving Generic + +data SynTCFields l = SynTCFields{errors :: Folded [Error l], + fieldEnv :: Map AST.Ident (Type l)} + deriving Generic + +data SynTCHead l = SynTCHead{errors :: Folded [Error l], + insideEnv :: Environment l, + outsideEnv :: Environment l} + deriving Generic + +data SynTCSig l = SynTCSig{errors :: Folded [Error l], + signatureEnv :: Environment l, + signatureType :: Type l} + deriving Generic + +data SynTCSec l = SynTCSec{errors :: Folded [Error l], + sectionEnv :: Environment l, + sectionParameters :: [(Bool, Type l)]} + deriving Generic + +data SynTCDes l = SynTCDes{errors :: Folded [Error l], + designatorName :: Maybe (Maybe Abstract.Ident, Abstract.Ident), + designatorType :: Type l} + deriving Generic + +data SynTCExp l = SynTCExp{errors :: Folded [Error l], + inferredType :: Type l} + deriving Generic + +-- * Modules instances, TH candidates +instance (Transformation.Transformation t, Functor (Transformation.Domain t), Deep.Functor t (AST.Module l l), + Transformation.At t (AST.Module l l (Transformation.Codomain t) (Transformation.Codomain t))) => + Deep.Functor t (Modules l) where + t <$> ~(Modules ms) = Modules (mapModule <$> ms) + where mapModule m = t Transformation.$ ((t Deep.<$>) <$> m) +instance (Transformation.Transformation t, Functor (Transformation.Domain t), + Transformation.At t (AST.Module l l f f)) => + Shallow.Functor t (Modules l f) where + t <$> ~(Modules ms) = Modules ((t Transformation.$) <$> ms) +instance (Transformation.Transformation t, Functor (Transformation.Domain t), Shallow.Foldable t (AST.Module l l f), + Transformation.At t (AST.Module l l f f)) => + Shallow.Foldable t (Modules l f) where + foldMap t ~(Modules ms) = getConst (foldMap (t Transformation.$) ms) + +instance Rank2.Functor (Modules l f') where + f <$> ~(Modules ms) = Modules (f <$> ms) +instance Rank2.Foldable (Modules l f) where + foldMap f ~(Modules ms) = foldMap f ms +instance Rank2.Apply (Modules l f') where + ~(Modules fs) <*> ~(Modules ms) = Modules (Map.intersectionWith Rank2.apply fs ms) + +-- * Boring attribute types +type instance Atts (Inherited (Auto TypeCheck)) (Modules l _ _) = InhTCRoot l +type instance Atts (Synthesized (Auto TypeCheck)) (Modules l _ _) = SynTC l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Module l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Module l l _ _) = SynTCMod l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Declaration l l _ _) = InhTCDecl l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Declaration l l _ _) = SynTCMod l +type instance Atts (Inherited (Auto TypeCheck)) (AST.ProcedureHeading l l _ _) = InhTCDecl l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.ProcedureHeading l l _ _) = SynTCHead l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Block l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Block l l _ _) = SynTCMod l +type instance Atts (Inherited (Auto TypeCheck)) (AST.FormalParameters l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.FormalParameters l l _ _) = SynTCSig l +type instance Atts (Inherited (Auto TypeCheck)) (AST.FPSection l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.FPSection l l _ _) = SynTCSec l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Type l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Type l l _ _) = SynTCType l +type instance Atts (Inherited (Auto TypeCheck)) (AST.FieldList l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.FieldList l l _ _) = SynTCFields l +type instance Atts (Inherited (Auto TypeCheck)) (AST.StatementSequence l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.StatementSequence l l _ _) = SynTC l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Expression l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Expression l l _ _) = SynTCExp l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Element l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Element l l _ _) = SynTCExp l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Value l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Value l l _ _) = SynTCExp l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Designator l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Designator l l _ _) = SynTCDes l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Statement l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Statement l l _ _) = SynTC l +type instance Atts (Inherited (Auto TypeCheck)) (AST.ConditionalBranch l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.ConditionalBranch l l _ _) = SynTC l +type instance Atts (Inherited (Auto TypeCheck)) (AST.Case l l _ _) = InhTCExp l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.Case l l _ _) = SynTC l +type instance Atts (Inherited (Auto TypeCheck)) (AST.CaseLabels l l _ _) = InhTCExp l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.CaseLabels l l _ _) = SynTC l +type instance Atts (Inherited (Auto TypeCheck)) (AST.WithAlternative l l _ _) = InhTC l +type instance Atts (Synthesized (Auto TypeCheck)) (AST.WithAlternative l l _ _) = SynTC l + +-- * Rules + +instance Ord (Abstract.QualIdent l) => Bequether (Auto TypeCheck) (Modules l) Sem Placed where + bequest _ (_, Modules self) inheritance (Modules ms) = + Modules (Map.mapWithKey moduleInheritance self) + where moduleInheritance name mod = Inherited InhTC{env= rootEnv inheritance <> foldMap (moduleEnv . syn) ms, + currentModule= name} +instance Ord (Abstract.QualIdent l) => Synthesizer (Auto TypeCheck) (Modules l) Sem Placed where + synthesis _ _ _ (Modules ms) = SynTC{errors= foldMap (\m-> errors (syn m :: SynTCMod l)) ms} + +instance (Abstract.Oberon l, Abstract.Nameable l, k ~ Abstract.QualIdent l, Ord k, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Block l l Sem Sem) ~ SynTCMod l) => + SynthesizedField "moduleEnv" (Map k (Type l)) (Auto TypeCheck) (AST.Module l l) Sem Placed where + synthesizedField _ _ (pos, AST.Module moduleName imports body) _inheritance (AST.Module _ _ body') = exportedEnv + where exportedEnv = exportNominal <$> Map.mapKeysMonotonic export (moduleEnv $ syn body') + export q + | Just name <- Abstract.getNonQualIdentName q = Abstract.qualIdent moduleName name + | otherwise = q + exportNominal (NominalType q (Just t)) + | Just name <- Abstract.getNonQualIdentName q = + NominalType (Abstract.qualIdent moduleName name) (Just $ exportNominal' t) + exportNominal t = exportNominal' t + exportNominal' (RecordType ancestry fields) = RecordType (export <$> ancestry) (exportNominal' <$> fields) + exportNominal' (ProcedureType False parameters result) = + ProcedureType False ((exportNominal' <$>) <$> parameters) (exportNominal' <$> result) + exportNominal' (PointerType target) = PointerType (exportNominal' target) + exportNominal' (ArrayType dimensions itemType) = ArrayType dimensions (exportNominal' itemType) + exportNominal' (NominalType q (Just t)) + | Just name <- Abstract.getNonQualIdentName q = + fromMaybe (NominalType (Abstract.qualIdent moduleName name) $ Just $ exportNominal' t) + (Map.lookup q exportedEnv) + exportNominal' t = t + +instance (Abstract.Nameable l, Ord (Abstract.QualIdent l), + Atts (Inherited (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ InhTCDecl l, + Atts (Inherited (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ InhTC l, + Atts (Inherited (Auto TypeCheck)) (Abstract.ProcedureHeading l l Sem Sem) ~ InhTCDecl l, + Atts (Inherited (Auto TypeCheck)) (Abstract.Block l l Sem Sem) ~ InhTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.ProcedureHeading l l Sem Sem) ~ SynTCHead l, + Atts (Inherited (Auto TypeCheck)) (Abstract.FormalParameters l l Sem Sem) ~ InhTC l, + Atts (Inherited (Auto TypeCheck)) (Abstract.ConstExpression l l Sem Sem) ~ InhTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ SynTCMod l) => + Bequether (Auto TypeCheck) (AST.Declaration l l) Sem Placed where + bequest _ (pos, AST.ProcedureDeclaration{}) + inheritance@InhTCDecl{env= declEnv, currentModule= m} (AST.ProcedureDeclaration heading body) = + AST.ProcedureDeclaration (Inherited inheritance) (Inherited bodyInherited) + where bodyInherited = InhTC{env= insideEnv (syn heading) `Map.union` declEnv, currentModule= m} + bequest t local inheritance synthesized = AG.bequestDefault t local inheritance synthesized + +instance (Abstract.Nameable l, k ~ Abstract.QualIdent l, Ord k, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ SynTCMod l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.FormalParameters l l Sem Sem) ~ SynTCSig l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.ProcedureHeading l l Sem Sem) ~ SynTCHead l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Block l l Sem Sem) ~ SynTCMod l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.ConstExpression l l Sem Sem) ~ SynTCExp l) => + SynthesizedField "moduleEnv" (Map k (Type l)) (Auto TypeCheck) (AST.Declaration l l) Sem Placed where + synthesizedField _ _ (pos, AST.ConstantDeclaration namedef _) _ (AST.ConstantDeclaration _ expression) = + Map.singleton (Abstract.nonQualIdent $ Abstract.getIdentDefName namedef) (inferredType $ syn expression) + synthesizedField _ _ (pos, AST.TypeDeclaration namedef _) _ (AST.TypeDeclaration _ definition) = + Map.singleton qname (nominal $ definedType $ syn definition) + where nominal t@BuiltinType{} = t + nominal t@NominalType{} = t + nominal (PointerType t@RecordType{}) = + NominalType qname (Just $ PointerType $ NominalType (Abstract.nonQualIdent $ name<>"^") (Just t)) + nominal t = NominalType qname (Just t) + qname = Abstract.nonQualIdent name + name = Abstract.getIdentDefName namedef + synthesizedField _ _ (pos, AST.VariableDeclaration names _) _ (AST.VariableDeclaration _names declaredType) = + foldMap binding names + where binding name = Map.singleton (Abstract.nonQualIdent $ Abstract.getIdentDefName name) + (definedType $ syn declaredType) + synthesizedField _ _ (pos, AST.ProcedureDeclaration{}) _ (AST.ProcedureDeclaration heading body) = + outsideEnv (syn heading) + synthesizedField _ _ (pos, AST.ForwardDeclaration namedef _sig) _ (AST.ForwardDeclaration _namedef sig) = + foldMap (Map.singleton (Abstract.nonQualIdent $ Abstract.getIdentDefName namedef) . signatureType . syn) sig + +instance (Abstract.Nameable l, k ~ Abstract.QualIdent l, Ord k, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ SynTCMod l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.FormalParameters l l Sem Sem) ~ SynTCSig l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.ProcedureHeading l l Sem Sem) ~ SynTCHead l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Block l l Sem Sem) ~ SynTCMod l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.ConstExpression l l Sem Sem) ~ SynTCExp l) => + SynthesizedField "pointerTargets" (Folded (Map AST.Ident AST.Ident)) (Auto TypeCheck) + (AST.Declaration l l) Sem Placed where + synthesizedField _ _ (pos, AST.TypeDeclaration namedef _) _ (AST.TypeDeclaration _ definition) = + foldMap (Folded . Map.singleton name) (pointerTarget $ syn definition) + where name = Abstract.getIdentDefName namedef + synthesizedField _ _ _ _ _ = mempty + +instance (Abstract.Nameable l, Ord (Abstract.QualIdent l), + Atts (Synthesized (Auto TypeCheck)) (Abstract.FormalParameters l l Sem Sem) ~ SynTCSig l) => + Synthesizer (Auto TypeCheck) (AST.ProcedureHeading l l) Sem Placed where + synthesis _ (pos, AST.ProcedureHeading indirect namedef _sig) inheritance (AST.ProcedureHeading _indirect _ sig) = + SynTCHead{errors= foldMap (\s-> errors (syn s :: SynTCSig l)) sig, + outsideEnv= Map.singleton (Abstract.nonQualIdent name) $ + maybe (ProcedureType False [] Nothing) (signatureType . syn) sig, + insideEnv= foldMap (signatureEnv . syn) sig} + where name = Abstract.getIdentDefName namedef + synthesis _ (pos, AST.TypeBoundHeading var receiverName receiverType indirect namedef _sig) + inheritance (AST.TypeBoundHeading _var _name _type _indirect _ sig) = + SynTCHead{errors= receiverError <> foldMap (\s-> errors (syn s :: SynTCSig l)) sig, + outsideEnv= case Map.lookup receiverType (pointerTargets (inheritance :: InhTCDecl l)) + of Just targetName -> Map.singleton (Abstract.nonQualIdent targetName) methodType + Nothing -> Map.singleton (Abstract.nonQualIdent receiverType) methodType, + insideEnv= receiverEnv `Map.union` foldMap (signatureEnv . syn) sig} + where receiverEnv = + foldMap (Map.singleton (Abstract.nonQualIdent receiverName) . ReceiverType) + (Map.lookup (Abstract.nonQualIdent receiverType) $ env (inheritance :: InhTCDecl l)) + methodType = NominalType (Abstract.nonQualIdent "") + (Just $ RecordType [] $ Map.singleton name procedureType) + name = Abstract.getIdentDefName namedef + procedureType = maybe (ProcedureType False [] Nothing) (signatureType . syn) sig + receiverError = + case Map.lookup (Abstract.nonQualIdent receiverType) (env (inheritance :: InhTCDecl l)) + of Nothing -> Folded [(currentModule (inheritance :: InhTCDecl l), pos, + UnknownName $ Abstract.nonQualIdent receiverType)] + Just t + | RecordType{} <- ultimate t -> mempty + | PointerType t' <- ultimate t, RecordType{} <- ultimate t' -> mempty + | otherwise -> Folded [(currentModule (inheritance :: InhTCDecl l), pos, NonRecordType t)] + +instance (Abstract.Nameable l, Ord (Abstract.QualIdent l), Show (Abstract.QualIdent l), + Atts (Synthesized (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ SynTCMod l, + Atts (Inherited (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ InhTCDecl l, + Atts (Inherited (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ InhTC l) => + Bequether (Auto TypeCheck) (AST.Block l l) Sem Placed where + bequest _ (pos, AST.Block{}) inheritance (AST.Block declarations statements) = + AST.Block (pure $ Inherited InhTCDecl{env= localEnv, + currentModule= currentModule (inheritance :: InhTC l), + pointerTargets= getFolded pointers}) + (pure $ Inherited localInherited) + where localInherited = (inheritance :: InhTC l){env= localEnv} -- (currentModule (inheritance :: InhTC l)) + localEnv = newEnv declarations <> env (inheritance :: InhTC l) + pointers= foldMap (\d-> pointerTargets (syn d :: SynTCMod l)) declarations + +instance (Abstract.Nameable l, k ~ Abstract.QualIdent l, Ord k, Show k, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ SynTCMod l) => + SynthesizedField "moduleEnv" (Map k (Type l)) (Auto TypeCheck) (AST.Block l l) Sem Placed where + synthesizedField _ _ (pos, AST.Block{}) inheritance (AST.Block declarations _statements) = newEnv declarations + +newEnv :: (Abstract.Nameable l, Ord (Abstract.QualIdent l), Show (Abstract.QualIdent l), + Atts (Synthesized (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ SynTCMod l) => + ZipList (Synthesized (Auto TypeCheck) (Abstract.Declaration l l Sem Sem)) -> Environment l +newEnv declarations = Map.unionsWith mergeTypeBoundProcedures (moduleEnv . syn <$> declarations) + where mergeTypeBoundProcedures (NominalType q (Just t1)) t2 + | Abstract.getNonQualIdentName q == Just "" = mergeTypeBoundProcedures t1 t2 + | otherwise = NominalType q (Just $ mergeTypeBoundProcedures t1 t2) + mergeTypeBoundProcedures t1 (NominalType q (Just t2)) + | Abstract.getNonQualIdentName q == Just "" = mergeTypeBoundProcedures t1 t2 + | otherwise = 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 (PointerType (NominalType q (Just (RecordType ancestry1 fields1)))) + (RecordType ancestry2 fields2) = + PointerType (NominalType q $ Just $ RecordType (ancestry1 <> ancestry2) (fields1 <> fields2)) + mergeTypeBoundProcedures (RecordType ancestry1 fields1) + (PointerType (NominalType q (Just (RecordType ancestry2 fields2)))) = + PointerType (NominalType q $ Just $ RecordType (ancestry1 <> ancestry2) (fields1 <> fields2)) + mergeTypeBoundProcedures t1 t2 = error (take 90 $ show t1) + +instance (Ord (Abstract.QualIdent l), + Atts (Synthesized (Auto TypeCheck)) (Abstract.FPSection l l Sem Sem) ~ SynTCSec l) => + Synthesizer (Auto TypeCheck) (AST.FormalParameters l l) Sem Placed where + synthesis _ (pos, AST.FormalParameters sections returnType) inheritance (AST.FormalParameters sections' _) = + SynTCSig{errors= foldMap (\s-> errors (syn s :: SynTCSec l)) sections' + <> foldMap typeRefErrors returnType, + signatureType= ProcedureType False (foldMap (sectionParameters . syn) sections') + $ returnType >>= (`Map.lookup` env (inheritance :: InhTC l)), + signatureEnv= foldMap (sectionEnv . syn) sections'} + where typeRefErrors q + | Map.member q (env (inheritance :: InhTC l)) = mempty + | otherwise = Folded [(currentModule (inheritance :: InhTC l), pos, UnknownName q)] + +instance (Abstract.Wirthy l, Ord (Abstract.QualIdent l), + Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l) => + Synthesizer (Auto TypeCheck) (AST.FPSection l l) Sem Placed where + synthesis _ (pos, AST.FPSection var names _typeDef) _inheritance (AST.FPSection _var _names typeDef) = + SynTCSec{errors= errors (syn typeDef :: SynTCType l), + sectionParameters= (var, definedType (syn typeDef)) <$ names, + sectionEnv= Map.fromList (flip (,) (definedType $ syn typeDef) . Abstract.nonQualIdent <$> names)} + +instance (Abstract.Nameable l, Ord (Abstract.QualIdent l), + Atts (Synthesized (Auto TypeCheck)) (Abstract.FormalParameters l l Sem Sem) ~ SynTCSig l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.FieldList l l Sem Sem) ~ SynTCFields l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.ConstExpression l l Sem Sem) ~ SynTCExp l) => + Synthesizer (Auto TypeCheck) (AST.Type l l) Sem Placed where + synthesis _ (pos, AST.TypeReference q) inheritance _ = + SynTCType{errors= if Map.member q (env (inheritance :: InhTC l)) then mempty + else Folded [(currentModule (inheritance :: InhTC l), pos, UnknownName q)], + typeName= Abstract.getNonQualIdentName q, + pointerTarget= Nothing, + definedType= fromMaybe UnknownType (Map.lookup q $ env (inheritance :: InhTC l))} + synthesis _ (pos, AST.ArrayType _dims _itemType) inheritance (AST.ArrayType dimensions itemType) = + SynTCType{errors= foldMap (\d-> errors (syn d :: SynTCExp l)) dimensions + <> errors (syn itemType :: SynTCType l) + <> foldMap (expectInteger . syn) dimensions, + typeName= Nothing, + pointerTarget= Nothing, + definedType= ArrayType (integerValue . syn <$> getZipList dimensions) (definedType $ syn itemType)} + where expectInteger SynTCExp{inferredType= IntegerType{}} = mempty + expectInteger SynTCExp{inferredType= t} = + Folded [(currentModule (inheritance :: InhTC l), pos, NonIntegerType t)] + integerValue SynTCExp{inferredType= IntegerType n} = n + integerValue _ = 0 + synthesis _ (pos, AST.RecordType base fields) inheritance (AST.RecordType _base fields') = + SynTCType{errors= fst baseRecord <> foldMap (\f-> errors (syn f :: SynTCFields l)) fields', + typeName= Nothing, + pointerTarget= Nothing, + definedType= RecordType (maybe [] (maybe id (:) base . ancestry) $ snd baseRecord) + (maybe Map.empty recordFields (snd baseRecord) + <> foldMap (fieldEnv . syn) fields')} + where baseRecord = case flip Map.lookup (env (inheritance :: InhTC l)) <$> base + of Just (Just t@RecordType{}) -> (mempty, Just t) + Just (Just (NominalType _ (Just t@RecordType{}))) -> (mempty, Just t) + Just (Just t) -> + (Folded [(currentModule (inheritance :: InhTC l), pos, NonRecordType t)], Nothing) + Just Nothing -> + (foldMap (Folded . (:[]) + . (,,) (currentModule (inheritance :: InhTC l)) pos . UnknownName) base, + Nothing) + Nothing -> (mempty, Nothing) + synthesis (Auto TypeCheck) _self inheritance (AST.PointerType targetType') = + SynTCType{errors= errors (syn targetType' :: SynTCType l), + typeName= Nothing, + pointerTarget= typeName (syn targetType'), + definedType= PointerType (definedType $ syn targetType')} + synthesis _ (pos, AST.ProcedureType signature) inheritance (AST.ProcedureType signature') = + SynTCType{errors= foldMap (\s-> errors (syn s :: SynTCSig l)) signature', + typeName= Nothing, + pointerTarget= Nothing, + definedType= maybe (ProcedureType False [] Nothing) (signatureType . syn) signature'} + +instance (Abstract.Nameable l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l) => + SynthesizedField "fieldEnv" (Map AST.Ident (Type l)) (Auto TypeCheck) (AST.FieldList l l) Sem Placed where + synthesizedField _ _ (_, AST.FieldList names _declaredType) _inheritance (AST.FieldList _names declaredType) = + foldMap (\name-> Map.singleton (Abstract.getIdentDefName name) (definedType $ syn declaredType)) names + +instance (Abstract.Wirthy l, Abstract.Nameable l, Ord (Abstract.QualIdent l), + Atts (Inherited (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ InhTC l, + Atts (Inherited (Auto TypeCheck)) (Abstract.ConditionalBranch l l Sem Sem) ~ InhTC l, + Atts (Inherited (Auto TypeCheck)) (Abstract.Case l l Sem Sem) ~ InhTCExp l, + Atts (Inherited (Auto TypeCheck)) (Abstract.WithAlternative l l Sem Sem) ~ InhTC l, + Atts (Inherited (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ InhTC l, + Atts (Inherited (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ InhTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l) => + Bequether (Auto TypeCheck) (AST.Statement l l) Sem Placed where + bequest _ (_pos, AST.EmptyStatement) i _ = AST.EmptyStatement + bequest _ (_pos, AST.Assignment{}) i _ = AST.Assignment (AG.Inherited i) (AG.Inherited i) + bequest _ (_pos, AST.ProcedureCall proc args) i _ = + AST.ProcedureCall (AG.Inherited i) ((AG.Inherited i <$) <$> args) + bequest _ (_pos, AST.If _branch branches _fallback) i _ = + AST.If (AG.Inherited i) (AG.Inherited i <$ branches) (Just $ AG.Inherited i) + bequest _ (_pos, AST.CaseStatement{}) i (AST.CaseStatement value _branches _fallback) = + AST.CaseStatement (Inherited i) (pure $ Inherited InhTCExp{currentModule= currentModule (i :: InhTC l), + env= env (i :: InhTC l), + expectedType= inferredType $ syn value}) + (Just $ Inherited i) + bequest _ (_pos, AST.While{}) i _ = AST.While (AG.Inherited i) (AG.Inherited i) + bequest _ (_pos, AST.Repeat{}) i _ = AST.Repeat (AG.Inherited i) (AG.Inherited i) + bequest _ (_pos, AST.For name _ _ _ _) i _ = + AST.For name (AG.Inherited i) (AG.Inherited i) (pure $ AG.Inherited i) (AG.Inherited i) -- Oberon2 + bequest _ (_pos, AST.Loop{}) i _ = AST.Loop (AG.Inherited i) + bequest _ (_pos, AST.With{}) i _ = + AST.With (AG.Inherited i) (pure $ AG.Inherited i) (Just $ AG.Inherited i) + bequest _ (_pos, AST.Exit{}) i _ = AST.Exit + bequest _ (_pos, AST.Return{}) i _ = AST.Return (Just $ AG.Inherited i) + +instance {-# overlaps #-} (Abstract.Wirthy l, Abstract.Nameable l, Ord (Abstract.QualIdent l), + Atts (Synthesized (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ SynTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ SynTCDes l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Case l l Sem Sem) ~ SynTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.ConditionalBranch l l Sem Sem) ~ SynTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.WithAlternative l l Sem Sem) ~ SynTC l) => + Synthesizer (Auto TypeCheck) (AST.Statement l l) Sem Placed where + synthesis t (pos, _) inheritance statement@(AST.Assignment var value) = {-# SCC "Assignment" #-} + SynTC{errors= assignmentCompatible (currentModule (inheritance :: InhTC l)) pos + (designatorType $ syn var) (inferredType $ syn value) + <> AG.foldedField (Proxy :: Proxy "errors") t statement} + synthesis _ (pos, AST.ProcedureCall _proc parameters) inheritance (AST.ProcedureCall procedure' parameters') = + SynTC{errors= (case syn procedure' + of SynTCDes{errors= Folded [], + designatorType= t} -> procedureErrors t + SynTCDes{errors= errs} -> errs) + <> foldMap (foldMap (\p-> errors (syn p :: SynTCExp l))) parameters'} + where procedureErrors (ProcedureType _ formalTypes Nothing) + | length formalTypes /= maybe 0 (length . getZipList) parameters, + not (length formalTypes == 2 && (length . getZipList <$> parameters) == Just 1 + && designatorName (syn procedure') == Just (Nothing, "ASSERT") + || length formalTypes == 1 && (length . getZipList <$> parameters) == Just 2 + && designatorName (syn procedure') == Just (Nothing, "NEW") + && all (all (isIntegerType . inferredType . syn) . tail . getZipList) parameters') = + Folded [(currentModule (inheritance :: InhTC l), pos, + ArgumentCountMismatch (length formalTypes) $ maybe 0 (length . getZipList) parameters)] + | otherwise = mconcat (zipWith (parameterCompatible inheritance pos) formalTypes + $ maybe [] ((inferredType . syn <$>) . getZipList) parameters') + procedureErrors (NominalType _ (Just t)) = procedureErrors t + procedureErrors t = Folded [(currentModule (inheritance :: InhTC l), pos, NonProcedureType t)] + synthesis _ (pos, _) inheritance (AST.While condition body) = + SynTC{errors= booleanExpressionErrors inheritance pos (syn condition) <> errors (syn body :: SynTC l)} + synthesis _ (pos, _) inheritance (AST.Repeat body condition) = + SynTC{errors= booleanExpressionErrors inheritance pos (syn condition) <> errors (syn body :: SynTC l)} + synthesis _ (pos, _) inheritance (AST.For _counter start end step body) = + SynTC{errors= integerExpressionErrors inheritance pos (syn start) + <> integerExpressionErrors inheritance pos (syn end) + <> foldMap (integerExpressionErrors inheritance pos . syn) step <> errors (syn body :: SynTC l)} + synthesis t self _ statement = SynTC{errors= AG.foldedField (Proxy :: Proxy "errors") t statement} + +instance (Abstract.Nameable l, Ord (Abstract.QualIdent l), + Atts (Inherited (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ InhTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ SynTC l) => + Attribution (Auto TypeCheck) (AST.WithAlternative l l) Sem Placed where + attribution _ (pos, AST.WithAlternative var subtype _body) + (Inherited inheritance, AST.WithAlternative _var _subtype body) = + (Synthesized SynTC{errors= case (Map.lookup var $ env (inheritance :: InhTC l), + Map.lookup subtype $ env (inheritance :: InhTC l)) + of (Just supertype, Just subtypeDef) -> + assignmentCompatible (currentModule (inheritance :: InhTC l)) pos + supertype subtypeDef + (Nothing, _) -> + Folded [(currentModule (inheritance :: InhTC l), pos, UnknownName var)] + (_, Nothing) -> + Folded [(currentModule (inheritance :: InhTC l), pos, UnknownName subtype)] + <> errors (syn body :: SynTC l)}, + AST.WithAlternative var subtype (Inherited $ + InhTC (maybe id (Map.insert var) (Map.lookup subtype + $ env (inheritance :: InhTC l)) + $ env (inheritance :: InhTC l)) + (currentModule (inheritance :: InhTC l)))) + +instance (Abstract.Nameable l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ SynTC l) => + Synthesizer (Auto TypeCheck) (AST.ConditionalBranch l l) Sem Placed where + synthesis _ (pos, _) inheritance (AST.ConditionalBranch condition body) = + SynTC{errors= booleanExpressionErrors inheritance pos (syn condition) <> errors (syn body :: SynTC l)} + +instance {-# overlaps #-} (Abstract.Nameable l, Eq (Abstract.QualIdent l), + Atts (Synthesized (Auto TypeCheck)) (Abstract.ConstExpression l l Sem Sem) ~ SynTCExp l) => + Synthesizer (Auto TypeCheck) (AST.CaseLabels l l) Sem Placed where + synthesis _ (pos, _) inheritance (AST.SingleLabel value) = + SynTC{errors= assignmentCompatibleIn inheritance pos (inferredType $ syn value)} + synthesis _ (pos, _) inheritance (AST.LabelRange start end) = + SynTC{errors= assignmentCompatibleIn inheritance pos (inferredType $ syn start) + <> assignmentCompatibleIn inheritance pos (inferredType $ syn end)} + +instance {-# overlaps #-} (Abstract.Nameable l, Ord (Abstract.QualIdent l), + Atts (Inherited (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ InhTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Element l l Sem Sem) ~ SynTCExp l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Value l l Sem Sem) ~ SynTCExp l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ SynTCDes l) => + Synthesizer (Auto TypeCheck) (AST.Expression l l) Sem Placed where + synthesis _ (pos, AST.Relation op _ _) inheritance (AST.Relation _op left right) = + SynTCExp{errors= case errors (syn left :: SynTCExp l) <> errors (syn right :: SynTCExp l) + of Folded [] + | t1 == t2 -> mempty + | AST.In <- op -> membershipCompatible (ultimate t1) (ultimate t2) + | equality op, + Folded [] <- assignmentCompatible (currentModule (inheritance :: InhTC l)) pos t1 t2 + -> mempty + | equality op, + Folded [] <- assignmentCompatible (currentModule (inheritance :: InhTC l)) pos t2 t1 + -> mempty + | otherwise -> comparable (ultimate t1) (ultimate t2) + errs -> errs, + inferredType= BuiltinType "BOOLEAN"} + where t1 = inferredType (syn left) + t2 = inferredType (syn right) + equality AST.Equal = True + equality AST.Unequal = True + equality _ = False + comparable (BuiltinType "BOOLEAN") (BuiltinType "BOOLEAN") = mempty + comparable (BuiltinType "CHAR") (BuiltinType "CHAR") = mempty + comparable StringType{} StringType{} = mempty + comparable (StringType 1) (BuiltinType "CHAR") = mempty + comparable (BuiltinType "CHAR") (StringType 1) = mempty + comparable StringType{} (ArrayType _ (BuiltinType "CHAR")) = mempty + comparable (ArrayType _ (BuiltinType "CHAR")) StringType{} = mempty + comparable (ArrayType _ (BuiltinType "CHAR")) (ArrayType _ (BuiltinType "CHAR")) = mempty + comparable (BuiltinType t1) (BuiltinType t2) + | isNumerical t1 && isNumerical t2 = mempty + comparable (BuiltinType t1) IntegerType{} + | isNumerical t1 = mempty + comparable IntegerType{} (BuiltinType t2) + | isNumerical t2 = mempty + comparable t1 t2 = Folded [(currentModule (inheritance :: InhTC l), pos, IncomparableTypes t1 t2)] + membershipCompatible IntegerType{} (BuiltinType "SET") = mempty + membershipCompatible (BuiltinType t1) (BuiltinType "SET") + | isNumerical t1 = mempty + synthesis _ (pos, AST.IsA _ q) inheritance (AST.IsA left _) = + SynTCExp{errors= case Map.lookup q (env (inheritance :: InhTC l)) + of Nothing -> Folded [(currentModule (inheritance :: InhTC l), pos, UnknownName q)] + Just t -> assignmentCompatible (currentModule (inheritance :: InhTC l)) pos + (inferredType $ syn left) t, + inferredType= BuiltinType "BOOLEAN"} + synthesis _ (pos, _) inheritance (AST.Positive expr) = + SynTCExp{errors= unaryNumericOrSetOperatorErrors inheritance pos (syn expr), + inferredType= inferredType (syn expr)} + synthesis _ (pos, _) inheritance (AST.Negative expr) = + SynTCExp{errors= unaryNumericOrSetOperatorErrors inheritance pos (syn expr), + inferredType= unaryNumericOrSetOperatorType negate (syn expr)} + synthesis _ (pos, _) inheritance (AST.Add left right) = + binaryNumericOrSetSynthesis inheritance pos left right + synthesis _ (pos, _) inheritance (AST.Subtract left right) = + binaryNumericOrSetSynthesis inheritance pos left right + synthesis _ (pos, _) inheritance (AST.Or left right) = binaryBooleanSynthesis inheritance pos left right + synthesis _ (pos, _) inheritance (AST.Multiply left right) = + binaryNumericOrSetSynthesis inheritance pos left right + synthesis _ (pos, _) inheritance (AST.Divide left right) = + SynTCExp{errors= + case (syn left, syn right) + of (SynTCExp{errors= Folded [], inferredType= BuiltinType t1}, + SynTCExp{errors= Folded [], inferredType= BuiltinType t2}) + | t1 == "REAL", t2 == "REAL" -> mempty + | t1 == "SET", t2 == "SET" -> mempty + (SynTCExp{errors= Folded [], inferredType= t1}, + SynTCExp{errors= Folded [], inferredType= t2}) + | t1 == t2 -> Folded [(currentModule (inheritance :: InhTC l), pos, UnrealType t1)] + | otherwise -> Folded [(currentModule (inheritance :: InhTC l), pos, TypeMismatch t1 t2)], + inferredType= BuiltinType "REAL"} + synthesis _ (pos, _) inheritance (AST.IntegerDivide left right) = + binaryIntegerSynthesis inheritance pos left right + synthesis _ (pos, _) inheritance (AST.Modulo left right) = binaryIntegerSynthesis inheritance pos left right + synthesis _ (pos, _) inheritance (AST.And left right) = binaryBooleanSynthesis inheritance pos left right + synthesis (Auto TypeCheck) _self _ (AST.Set elements) = + SynTCExp{errors= mempty, + inferredType= BuiltinType "SET"} + synthesis (Auto TypeCheck) _self _ (AST.Read designator) = + SynTCExp{errors= errors (syn designator :: SynTCDes l), + inferredType= designatorType (syn designator)} + synthesis (Auto TypeCheck) _self _ (AST.Literal value) = + SynTCExp{errors= errors (syn value :: SynTCExp l), + inferredType= inferredType (syn value)} + synthesis _ (pos, AST.FunctionCall _designator (ZipList parameters)) inheritance + (AST.FunctionCall designator (ZipList parameters')) = + SynTCExp{errors= + case {-# SCC "FunctionCall" #-} syn designator + of SynTCDes{errors= Folded [], + designatorName= name, + designatorType= ultimate -> ProcedureType _ formalTypes Just{}} + | length formalTypes /= length parameters -> + Folded [(currentModule (inheritance :: InhTC l), pos, + ArgumentCountMismatch (length formalTypes) (length parameters))] + | name == Just (Just "SYSTEM", "VAL") -> mempty + | otherwise -> mconcat (zipWith (parameterCompatible inheritance pos) formalTypes + $ inferredType . syn <$> parameters') + SynTCDes{errors= Folded [], + designatorType= t} -> Folded [(currentModule (inheritance :: InhTC l), + pos, NonFunctionType t)] + SynTCDes{errors= errs} -> errs + <> foldMap (\p-> errors (syn p :: SynTCExp l)) parameters', + inferredType= + case syn designator + of SynTCDes{designatorName= Just (Just "SYSTEM", name)} + | Just t <- systemCallType name (inferredType . syn <$> parameters') -> t + SynTCDes{designatorName= d, designatorType= t} + | ProcedureType _ _ (Just returnType) <- ultimate t -> returnType + _ -> UnknownType} + where systemCallType "VAL" [t1, t2] = Just t1 + systemCallType _ _ = Nothing + synthesis _ (pos, _) inheritance (AST.Not expr) = + SynTCExp{errors= booleanExpressionErrors inheritance pos (syn expr), + inferredType= BuiltinType "BOOLEAN"} + +instance SynthesizedField "errors" (Folded [Error l]) (Auto TypeCheck) (AST.Value l l) Sem Placed where + synthesizedField = mempty + +instance Abstract.Wirthy l => SynthesizedField "inferredType" (Type l) (Auto TypeCheck) (AST.Value l l) Sem Placed where + synthesizedField _ _ (_, AST.Integer x) _ _ = IntegerType (fromIntegral x) + synthesizedField _ _ (_, AST.Real x) _ _ = BuiltinType "REAL" + synthesizedField _ _ (_, AST.Boolean x) _ _ = BuiltinType "BOOLEAN" + synthesizedField _ _ (_, AST.CharCode x) _ _ = BuiltinType "CHAR" + synthesizedField _ _ (_, AST.String x) _ _ = StringType (Text.length x) + synthesizedField _ _ (_, AST.Nil) _ _ = NilType + synthesizedField _ _ (_, AST.Builtin x) _ _ = BuiltinType x + +instance (Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l) => + SynthesizedField "errors" (Folded [Error l]) (Auto TypeCheck) (AST.Element l l) Sem Placed where + synthesizedField _ _ (pos, _) inheritance (AST.Element expr) = integerExpressionErrors inheritance pos (syn expr) + synthesizedField _ _ (pos, _) inheritance (AST.Range low high) = integerExpressionErrors inheritance pos (syn high) + <> integerExpressionErrors inheritance pos (syn low) + +instance SynthesizedField "inferredType" (Type l) (Auto TypeCheck) (AST.Element l l) Sem Placed where + synthesizedField _ _ _ _ _ = BuiltinType "SET" + +instance {-# overlaps #-} (Abstract.Nameable l, Abstract.Oberon l, Ord (Abstract.QualIdent l), + Show (Abstract.QualIdent l), + Atts (Inherited (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ InhTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ SynTCDes l) => + Synthesizer (Auto TypeCheck) (AST.Designator l l) Sem Placed where + synthesis _ (pos, AST.Variable q) inheritance _ = + SynTCDes{errors= case designatorType + of Nothing -> Folded [(currentModule (inheritance :: InhTC l), pos, UnknownName q)] + Just{} -> mempty, + designatorName= (,) Nothing <$> Abstract.getNonQualIdentName q + <|> first Just <$> Abstract.getQualIdentNames q, + designatorType= fromMaybe UnknownType designatorType} + where designatorType = Map.lookup q (env (inheritance :: InhTC l)) + synthesis _ (pos, AST.Field _record fieldName) inheritance (AST.Field record _fieldName) = + SynTCDes{errors= case syn record + of SynTCDes{errors= Folded [], + designatorType= t} -> + maybe (Folded [(currentModule (inheritance :: InhTC l), pos, NonRecordType t)]) + (maybe (Folded [(currentModule (inheritance :: InhTC l), pos, + UnknownField fieldName t)]) + $ const mempty) + (access True t) + SynTCDes{errors= errors} -> errors, + designatorName= Nothing, + designatorType= fromMaybe UnknownType (fromMaybe Nothing $ access True + $ designatorType $ syn record)} + 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 allowPtr (ReceiverType t) = (receive <$>) <$> access allowPtr t + access _ _ = Nothing + receive (ProcedureType _ params result) = ProcedureType True params result + receive t = t + synthesis _ (pos, AST.Index _array index indexes) inheritance (AST.Index array _index _indexes) = + SynTCDes{errors= case syn array + of SynTCDes{errors= Folded [], + designatorType= t} -> either id (const mempty) (access True t) + SynTCDes{errors= errors} -> errors, + designatorType= either (const UnknownType) id (access True $ designatorType $ syn array)} + where access _ (ArrayType dimensions t) + | length dimensions == length indexes + 1 = Right t + | length dimensions == 0 && length indexes == 0 = Right t + | otherwise = Left (Folded [(currentModule (inheritance :: InhTC l), pos, + ExtraDimensionalIndex (length dimensions) (1 + length indexes))]) + access allowPtr (NominalType _ (Just t)) = access allowPtr t + access allowPtr (ReceiverType t) = access allowPtr t + access True (PointerType t) = access False t + access _ t = Left (Folded [(currentModule (inheritance :: InhTC l), pos, NonArrayType t)]) + synthesis _ (pos, AST.TypeGuard _designator q) inheritance (AST.TypeGuard designator _q) = + SynTCDes{errors= case (syn designator, targetType) + of (SynTCDes{errors= Folded [], + designatorType= t}, + Just t') -> assignmentCompatible (currentModule (inheritance :: InhTC l)) pos t t' + (SynTCDes{errors= errors}, + Nothing) -> Folded ((currentModule (inheritance :: InhTC l), + pos, UnknownName q) : getFolded errors) + (SynTCDes{errors= errors}, _) -> errors, + designatorType= fromMaybe UnknownType targetType} + where targetType = Map.lookup q (env (inheritance :: InhTC l)) + synthesis _ (pos, _) inheritance (AST.Dereference pointer) = + SynTCDes{errors= case syn pointer + of SynTCDes{errors= Folded [], + designatorType= PointerType{}} -> mempty + SynTCDes{errors= Folded [], + designatorType= NominalType _ (Just PointerType{})} -> mempty + SynTCDes{errors= Folded [], + designatorType= ProcedureType True _ _} -> mempty + SynTCDes{errors= Folded [], + designatorType= t} -> Folded [(currentModule (inheritance :: InhTC l), + pos, NonPointerType t)] + SynTCDes{errors= es} -> es, + designatorType= case designatorType (syn pointer) + of NominalType _ (Just (PointerType t)) -> t + ProcedureType True params result -> ProcedureType False params result + PointerType t -> t + _ -> UnknownType} + +binaryNumericOrSetSynthesis inheritance pos left right = + SynTCExp{errors= binarySetOrNumericOperatorErrors inheritance pos (syn left) (syn right), + inferredType= binaryNumericOperatorType (syn left) (syn right)} + +binaryIntegerSynthesis inheritance pos left right = + SynTCExp{errors= binaryIntegerOperatorErrors inheritance pos (syn left) (syn right), + inferredType= binaryNumericOperatorType (syn left) (syn right)} + +binaryBooleanSynthesis inheritance pos left right = + SynTCExp{errors= binaryBooleanOperatorErrors inheritance pos (syn left) (syn right), + inferredType= BuiltinType "BOOLEAN"} + +unaryNumericOrSetOperatorErrors :: forall l. Abstract.Nameable l => + InhTC l -> (Int, ParsedLexemes, Int) -> SynTCExp l -> Folded [Error l] +unaryNumericOrSetOperatorErrors _ _ SynTCExp{errors= Folded [], inferredType= IntegerType{}} = mempty +unaryNumericOrSetOperatorErrors _ _ SynTCExp{errors= Folded [], + inferredType= BuiltinType name} + | isNumerical name = mempty + | name == "SET" = mempty +unaryNumericOrSetOperatorErrors inheritance pos SynTCExp{errors= Folded [], inferredType= t} = + Folded [(currentModule (inheritance :: InhTC l), pos, NonNumericType t)] +unaryNumericOrSetOperatorErrors _ _ SynTCExp{errors= errs} = errs + +unaryNumericOrSetOperatorType :: (Int -> Int) -> SynTCExp l -> Type l +unaryNumericOrSetOperatorType f SynTCExp{inferredType= IntegerType x} = IntegerType (f x) +unaryNumericOrSetOperatorType _ SynTCExp{inferredType= t} = t + +binarySetOrNumericOperatorErrors :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l)) + => InhTC l -> (Int, ParsedLexemes, Int) -> SynTCExp l -> SynTCExp l -> Folded [Error l] +binarySetOrNumericOperatorErrors _ _ + SynTCExp{errors= Folded [], inferredType= BuiltinType name1} + SynTCExp{errors= Folded [], inferredType= BuiltinType name2} + | isNumerical name1 && isNumerical name2 || name1 == "SET" && name2 == "SET" = mempty +binarySetOrNumericOperatorErrors _ _ + SynTCExp{errors= Folded [], inferredType= IntegerType{}} + SynTCExp{errors= Folded [], inferredType= BuiltinType name} + | isNumerical name = mempty +binarySetOrNumericOperatorErrors _ _ + SynTCExp{errors= Folded [], inferredType= BuiltinType name} + SynTCExp{errors= Folded [], inferredType= IntegerType{}} + | isNumerical name = mempty +binarySetOrNumericOperatorErrors _ _ + SynTCExp{errors= Folded [], inferredType= IntegerType{}} + SynTCExp{errors= Folded [], inferredType= IntegerType{}} = mempty +binarySetOrNumericOperatorErrors inheritance pos SynTCExp{errors= Folded [], inferredType= t1} + SynTCExp{errors= Folded [], inferredType= t2} + | t1 == t2 = Folded [(currentModule (inheritance :: InhTC l), pos, NonNumericType t1)] + | otherwise = Folded [(currentModule (inheritance :: InhTC l), pos, TypeMismatch t1 t2)] +binarySetOrNumericOperatorErrors _ _ SynTCExp{errors= errs1} SynTCExp{errors= errs2} = errs1 <> errs2 + +binaryNumericOperatorType :: (Abstract.Nameable l, Eq (Abstract.QualIdent l)) => SynTCExp l -> SynTCExp l -> Type l +binaryNumericOperatorType SynTCExp{inferredType= t1} SynTCExp{inferredType= t2} + | t1 == t2 = t1 + | IntegerType{} <- t1 = t2 + | IntegerType{} <- t2 = t1 + | BuiltinType name1 <- t1, BuiltinType name2 <- t2, + Just index1 <- List.elemIndex name1 numericTypeNames, + Just index2 <- List.elemIndex name2 numericTypeNames = BuiltinType (numericTypeNames !! max index1 index2) + | otherwise = t1 + +binaryIntegerOperatorErrors :: Abstract.Nameable l => + InhTC l -> (Int, ParsedLexemes, Int) -> SynTCExp l -> SynTCExp l -> Folded [Error l] +binaryIntegerOperatorErrors inheritance pos syn1 syn2 = integerExpressionErrors inheritance pos syn1 + <> integerExpressionErrors inheritance pos syn2 + +integerExpressionErrors :: forall l. InhTC l -> (Int, ParsedLexemes, Int) -> SynTCExp l -> Folded [Error l] +integerExpressionErrors inheritance pos SynTCExp{errors= Folded [], inferredType= t} + | isIntegerType t = mempty + | otherwise = Folded [(currentModule (inheritance :: InhTC l), pos, NonIntegerType t)] +integerExpressionErrors _ _ SynTCExp{errors= errs} = errs + +isIntegerType IntegerType{} = True +isIntegerType (BuiltinType "SHORTINT") = True +isIntegerType (BuiltinType "INTEGER") = True +isIntegerType (BuiltinType "LONGINT") = True +isIntegerType t = False + +booleanExpressionErrors :: forall l. InhTC l -> (Int, ParsedLexemes, Int) -> SynTCExp l -> Folded [Error l] +booleanExpressionErrors _ _ SynTCExp{errors= Folded [], + inferredType= BuiltinType "BOOLEAN"} = mempty +booleanExpressionErrors inheritance pos SynTCExp{errors= Folded [], inferredType= t} = + Folded [(currentModule (inheritance :: InhTC l), pos, NonBooleanType t)] +booleanExpressionErrors _ _ SynTCExp{errors= errs} = errs + +binaryBooleanOperatorErrors :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l)) + => InhTC l -> (Int, ParsedLexemes, Int) -> SynTCExp l -> SynTCExp l -> Folded [Error l] +binaryBooleanOperatorErrors _inh _pos + SynTCExp{errors= Folded [], inferredType= BuiltinType "BOOLEAN"} + SynTCExp{errors= Folded [], inferredType= BuiltinType "BOOLEAN"} = mempty +binaryBooleanOperatorErrors inheritance pos + SynTCExp{errors= Folded [], inferredType= t1} + SynTCExp{errors= Folded [], inferredType= t2} + | t1 == t2 = Folded [(currentModule (inheritance :: InhTC l), pos, NonBooleanType t1)] + | otherwise = Folded [(currentModule (inheritance :: InhTC l), pos, TypeMismatch t1 t2)] +binaryBooleanOperatorErrors _ _ SynTCExp{errors= errs1} SynTCExp{errors= errs2} = errs1 <> errs2 + +parameterCompatible :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l)) + => InhTC l -> (Int, ParsedLexemes, Int) -> (Bool, Type l) -> Type l -> Folded [Error l] +parameterCompatible _ _ (_, expected@(ArrayType [] _)) actual + | arrayCompatible expected actual = mempty +parameterCompatible inheritance pos (True, expected) actual + | expected == actual = mempty + | otherwise = Folded [(currentModule (inheritance :: InhTC l), pos, UnequalTypes expected actual)] +parameterCompatible inheritance pos (False, expected) actual + | BuiltinType "ARRAY" <- expected, ArrayType{} <- actual = mempty + | otherwise = assignmentCompatible (currentModule (inheritance :: InhTC l)) pos expected actual + +assignmentCompatibleIn :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l)) + => InhTCExp l -> (Int, ParsedLexemes, Int) -> Type l -> Folded [Error l] +assignmentCompatibleIn inheritance pos = + assignmentCompatible (currentModule (inheritance :: InhTCExp l)) pos (expectedType (inheritance :: InhTCExp l)) + +assignmentCompatible :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l)) + => AST.Ident -> (Int, ParsedLexemes, Int) -> Type l -> Type l -> Folded [Error l] +assignmentCompatible currModule pos expected actual + | expected == actual = mempty + | BuiltinType name1 <- expected, BuiltinType name2 <- actual, + Just index1 <- List.elemIndex name1 numericTypeNames, + Just index2 <- List.elemIndex name2 numericTypeNames, + index1 >= index2 = mempty + | BuiltinType name <- expected, IntegerType{} <- actual, isNumerical name = mempty + | BuiltinType "BASIC TYPE" <- expected, BuiltinType name <- actual, + name `elem` ["BOOLEAN", "CHAR", "SHORTINT", "INTEGER", "LONGINT", "REAL", "LONGREAL", "SET"] = mempty + | BuiltinType "POINTER" <- expected, PointerType{} <- actual = mempty + | BuiltinType "POINTER" <- expected, NominalType _ (Just t) <- actual = + assignmentCompatible currModule pos expected t + | BuiltinType "CHAR" <- expected, actual == StringType 1 = mempty + | ReceiverType t <- actual = assignmentCompatible currModule pos expected t + | ReceiverType t <- expected = assignmentCompatible currModule pos t actual + | NilType <- actual, PointerType{} <- expected = mempty + | NilType <- actual, ProcedureType{} <- expected = mempty + | NilType <- actual, NominalType _ (Just t) <- expected = assignmentCompatible currModule pos t actual +-- | ArrayType [] (BuiltinType "CHAR") <- expected, StringType{} <- actual = mempty + | ArrayType [m] (BuiltinType "CHAR") <- expected, StringType n <- actual = + Folded (if m < n then [(currModule, pos, TooSmallArrayType m n)] else []) + | targetExtends actual expected = mempty + | NominalType _ (Just t) <- expected, ProcedureType{} <- actual = assignmentCompatible currModule pos t actual + | otherwise = Folded [(currModule, pos, IncompatibleTypes expected actual)] + +arrayCompatible (ArrayType [] t1) (ArrayType _ t2) = t1 == t2 || arrayCompatible t1 t2 +arrayCompatible (ArrayType [] (BuiltinType "CHAR")) StringType{} = True +arrayCompatible (NominalType _ (Just t1)) t2 = arrayCompatible t1 t2 +arrayCompatible t1 (NominalType _ (Just t2)) = arrayCompatible t1 t2 +arrayCompatible _ _ = False + +extends, targetExtends :: Eq (Abstract.QualIdent l) => Type l -> Type l -> 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)) + +ultimate :: Type l -> Type l +ultimate (NominalType _ (Just t)) = ultimate t +ultimate t = t + +isNumerical t = t `elem` numericTypeNames +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 + +instance Transformation.Transformation (Auto TypeCheck) where + type Domain (Auto TypeCheck) = Placed + type Codomain (Auto TypeCheck) = Semantics (Auto TypeCheck) + +instance Ord (Abstract.QualIdent l) => Transformation.At (Auto TypeCheck) (Modules l Sem Sem) where + ($) = AG.applyDefault snd + +-- * Unsafe Rank2 AST instances + +instance Rank2.Apply (AST.Module l l f') where + AST.Module name1 imports1 body1 <*> ~(AST.Module name2 imports2 body2) = + AST.Module name1 imports1 (Rank2.apply body1 body2) + +-- | Check if the given collection of modules is well typed and return all type errors found. The collection is a +-- 'Map' keyed by module name. The first argument's value is typically 'predefined' or 'predefined2'. +checkModules :: forall l. (Abstract.Oberon l, Abstract.Nameable l, + Ord (Abstract.QualIdent l), Show (Abstract.QualIdent l), + Atts (Inherited (Auto TypeCheck)) (Abstract.Block l l Sem Sem) ~ InhTC l, + Atts (Synthesized (Auto TypeCheck)) (Abstract.Block l l Sem Sem) ~ SynTCMod l, + Full.Functor (Auto TypeCheck) (Abstract.Block l l)) + => Environment l -> Map AST.Ident (Placed (AST.Module l l Placed Placed)) -> [Error l] +checkModules predef modules = + getFolded (errors (syn (Transformation.apply (Auto TypeCheck) (wrap $ Auto TypeCheck Deep.<$> Modules modules) + `Rank2.apply` + Inherited (InhTCRoot predef)) :: SynTC l)) + where wrap = (,) (0, Trailing [], 0) + +predefined, predefined2 :: (Abstract.Wirthy l, Ord (Abstract.QualIdent l)) => Environment l +-- | The set of 'Predefined' types and procedures defined in the Oberon Language Report. +predefined = Map.fromList $ map (first Abstract.nonQualIdent) $ + [("BOOLEAN", BuiltinType "BOOLEAN"), + ("CHAR", BuiltinType "CHAR"), + ("SHORTINT", BuiltinType "SHORTINT"), + ("INTEGER", BuiltinType "INTEGER"), + ("LONGINT", BuiltinType "LONGINT"), + ("REAL", BuiltinType "REAL"), + ("LONGREAL", BuiltinType "LONGREAL"), + ("SET", BuiltinType "SET"), + ("TRUE", BuiltinType "BOOLEAN"), + ("FALSE", BuiltinType "BOOLEAN"), + ("ABS", ProcedureType False [(False, BuiltinType "INTEGER")] $ Just $ BuiltinType "INTEGER"), + ("ASH", ProcedureType False [(False, BuiltinType "INTEGER")] $ Just $ BuiltinType "INTEGER"), + ("CAP", ProcedureType False [(False, BuiltinType "CHAR")] $ Just $ BuiltinType "CHAR"), + ("LEN", ProcedureType False [(False, BuiltinType "ARRAY")] $ Just $ BuiltinType "LONGINT"), + ("MAX", ProcedureType False [(False, BuiltinType "BASIC TYPE")] $ Just UnknownType), + ("MIN", ProcedureType False [(False, BuiltinType "BASIC TYPE")] $ Just UnknownType), + ("ODD", ProcedureType False [(False, BuiltinType "CHAR")] $ Just $ BuiltinType "BOOLEAN"), + ("SIZE", ProcedureType False [(False, BuiltinType "CHAR")] $ Just $ BuiltinType "INTEGER"), + ("ORD", ProcedureType False [(False, BuiltinType "CHAR")] $ Just $ BuiltinType "INTEGER"), + ("CHR", ProcedureType False [(False, BuiltinType "LONGINT")] $ Just $ BuiltinType "CHAR"), + ("SHORT", ProcedureType False [(False, BuiltinType "LONGINT")] $ Just $ BuiltinType "SHORTINT"), + ("LONG", ProcedureType False [(False, BuiltinType "INTEGER")] $ Just $ BuiltinType "INTEGER"), + ("ENTIER", ProcedureType False [(False, BuiltinType "REAL")] $ Just $ BuiltinType "INTEGER"), + ("INC", ProcedureType False [(False, BuiltinType "LONGINT")] Nothing), + ("DEC", ProcedureType False [(False, BuiltinType "LONGINT")] Nothing), + ("INCL", ProcedureType False [(False, BuiltinType "SET"), (False, BuiltinType "INTEGER")] Nothing), + ("EXCL", ProcedureType False [(False, BuiltinType "SET"), (False, BuiltinType "INTEGER")] Nothing), + ("COPY", ProcedureType False [(False, BuiltinType "ARRAY"), (False, BuiltinType "ARRAY")] Nothing), + ("NEW", ProcedureType False [(False, BuiltinType "POINTER")] Nothing), + ("HALT", ProcedureType False [(False, BuiltinType "INTEGER")] Nothing)] + +-- | The set of 'Predefined' types and procedures defined in the Oberon-2 Language Report. +predefined2 = predefined <> + Map.fromList (first Abstract.nonQualIdent <$> + [("ASSERT", ProcedureType False [(False, BuiltinType "BOOLEAN"), + (False, BuiltinType "INTEGER")] Nothing)]) + +$(do l <- varT <$> newName "l" + mconcat <$> mapM (\t-> Transformation.Full.TH.deriveUpFunctor (conT ''Auto `appT` conT ''TypeCheck) + $ conT t `appT` l `appT` l) + [''AST.Declaration, ''AST.Type, ''AST.FieldList, + ''AST.ProcedureHeading, ''AST.FormalParameters, ''AST.FPSection, + ''AST.Expression, ''AST.Element, ''AST.Designator, + ''AST.Block, ''AST.StatementSequence, ''AST.Statement, + ''AST.Case, ''AST.CaseLabels, ''AST.ConditionalBranch, ''AST.Value, ''AST.WithAlternative]) + +$(do let sem = [t|Semantics (Auto TypeCheck)|] + let inst g = [d| instance Attribution (Auto TypeCheck) ($g l l) Sem Placed => + Transformation.At (Auto TypeCheck) ($g l l $sem $sem) + where ($) = AG.applyDefault snd |] + mconcat <$> mapM (inst . conT) + [''AST.Module, ''AST.Declaration, ''AST.Type, ''AST.FieldList, + ''AST.ProcedureHeading, ''AST.FormalParameters, ''AST.FPSection, + ''AST.Block, ''AST.StatementSequence, ''AST.Statement, + ''AST.Case, ''AST.CaseLabels, ''AST.ConditionalBranch, ''AST.WithAlternative, + ''AST.Expression, ''AST.Element, ''AST.Designator, ''AST.Value]) diff --git a/src/Transformation.hs b/src/Transformation.hs deleted file mode 100644 --- a/src/Transformation.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Transformation/AG.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Transformation/Deep.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Transformation/Deep/TH.hs +++ /dev/null @@ -1,287 +0,0 @@ --- | 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 deleted file mode 100644 --- a/src/Transformation/Rank2.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, - PolyKinds, RankNTypes, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} - -module Transformation.Rank2 where - -import qualified Transformation as Shallow -import qualified Transformation.Deep as Deep - -import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd) - -newtype Map p q = Map (forall x. p x -> q x) - -newtype Fold p m = Fold (forall x. p x -> m) - -newtype Traversal p q m = Traversal (forall x. p x -> m (q x)) - -instance Shallow.Functor (Map p q) p q x where - (<$>) (Map f) = f - -instance Shallow.Foldable (Fold p m) p m x where - foldMap (Fold f) = f - -instance Shallow.Traversable (Traversal p q m) p q m x where - traverse (Traversal t) = t - -(<$>) :: Deep.Functor (Map p q) g p q => (forall a. p a -> q a) -> g p p -> g q q -(<$>) f = (Deep.<$>) (Map f) - -foldMap :: (Deep.Foldable (Fold p m) g p m, Monoid m) => (forall a. p a -> m) -> g p p -> m -foldMap f = Deep.foldMap (Fold f) - -traverseDown :: Deep.DownTraversable (Traversal p q m) g p q m => (forall a. p a -> m (q a)) -> g p p -> m (g q q) -traverseDown f = Deep.traverseDown (Traversal f) - -traverseUp :: Deep.UpTraversable (Traversal p q m) g p q m => (forall a. p a -> m (q a)) -> g p p -> m (g q q) -traverseUp f = Deep.traverseUp (Traversal f) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,22 +1,32 @@ +{-# Language FlexibleInstances #-} module Main where import Data.Either.Validation (Validation(..)) +import Data.Functor.Identity (Identity(Identity)) import Data.List (isSuffixOf) import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Text (Text) +import Data.Text (Text, unpack) 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, assertEqual, testCase) -import Language.Oberon (parseAndResolveModule) +import qualified Transformation.Rank2 as Rank2 + +import Language.Oberon (parseAndResolveModule, LanguageVersion(Oberon2), Options(..), Placed) +import Language.Oberon.AST (Language, Module) import Language.Oberon.Pretty () import qualified Language.Oberon.Resolver as Resolver +import qualified Language.Oberon.TypeChecker as TypeChecker +import qualified Language.Oberon.AST as AST +import qualified Language.Oberon.Grammar as Grammar +import qualified Language.Oberon.Reserializer as Reserializer +import qualified Transformation.Deep as Deep + import Prelude hiding (readFile) main = exampleTree "" "examples" >>= defaultMain . testGroup "Oberon" @@ -40,8 +50,16 @@ prettyFile :: FilePath -> Text -> IO Text prettyFile dirPath source = do - resolvedModule <- parseAndResolveModule True True dirPath source + resolvedModule <- parseAndResolveModule Options{foldConstants= True, + checkTypes= True, + version= Oberon2} + dirPath source case resolvedModule - of Failure (Resolver.UnparseableModule err :| []) -> assertFailure (showFailure source err contextLines) - Failure errs -> assertFailure (show errs) + of Failure (Left (Resolver.UnparseableModule err :| [])) -> assertFailure (unpack err) + Failure errs -> assertFailure (show $ (onLastOfThree TypeChecker.errorMessage <$>) <$> errs) Success mod -> return (renderStrict $ layoutPretty defaultLayoutOptions $ pretty mod) + +onLastOfThree f (a, b, c) = (a, b, f c) + +instance {-# overlaps #-} Pretty (Placed (Module Language Language Placed Placed)) where + pretty (_, m) = pretty ((Identity . snd) Rank2.<$> m)