packages feed

language-oberon 0.2.1 → 0.3

raw patch · 20 files changed

+3686/−2180 lines, 20 filesdep +base-orphansdep +deep-transformationsdep +input-parsersdep ~basedep ~grammatical-parsersdep ~prettyprinter

Dependencies added: base-orphans, deep-transformations, input-parsers

Dependency ranges changed: base, grammatical-parsers, prettyprinter, rank2classes, template-haskell

Files

ChangeLog.md view
@@ -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
+ README.md view
@@ -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.
app/Parse.hs view
@@ -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 "<stdin>"                 AmbiguousModuleMode -> go pure Grammar.module_prod chosenGrammar "<stdin>"                 DefinitionMode      -> go (Resolver.resolveModule predefined mempty) Grammar.module_prod                                           Grammar.oberonDefinitionGrammar "<stdin>"                 StatementMode       -> go pure Grammar.statement chosenGrammar "<stdin>"-                StatementsMode      -> go pure Grammar.statementSequence chosenGrammar "<stdin>"                 ExpressionMode      -> go pure Grammar.expression chosenGrammar "<stdin>"+   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"
examples/AGRS/Texts.Def view
@@ -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. *)
language-oberon.cabal view
@@ -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 <http://www.ethoberon.ethz.ch/compiler/index.html#report language reports>.    .-   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-   <http://hackage.haskell.org/package/grammatical-parsers grammatical-parsers> library. The experiment succeeded, so    the package can be used in practice.+   <http://hackage.haskell.org/package/grammatical-parsers grammatical-parsers> 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
src/Language/Oberon.hs view
@@ -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)
src/Language/Oberon/AST.hs view
@@ -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])
+ src/Language/Oberon/Abstract.hs view
@@ -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)
+ src/Language/Oberon/ConstantFolder.hs view
@@ -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])
src/Language/Oberon/Grammar.hs view
@@ -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",
src/Language/Oberon/Pretty.hs view
@@ -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]
+ src/Language/Oberon/Reserializer.hs view
@@ -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
src/Language/Oberon/Resolver.hs view
@@ -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])
src/Language/Oberon/TypeChecker.hs view
@@ -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])
− src/Transformation.hs 
@@ -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
− src/Transformation/AG.hs 
@@ -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 #-}
− src/Transformation/Deep.hs 
@@ -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 = (<$>)
− src/Transformation/Deep/TH.hs 
@@ -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 |]
− src/Transformation/Rank2.hs 
@@ -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)
test/Test.hs view
@@ -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)