language-oberon 0.3 → 0.3.1
raw patch · 10 files changed
+358/−436 lines, 10 filesdep ~deep-transformationsdep ~grammatical-parsersdep ~input-parsers
Dependency ranges changed: deep-transformations, grammatical-parsers, input-parsers, template-haskell, text
Files
- ChangeLog.md +5/−0
- app/Parse.hs +3/−3
- language-oberon.cabal +10/−9
- src/Language/Oberon.hs +4/−3
- src/Language/Oberon/AST.hs +2/−1
- src/Language/Oberon/ConstantFolder.hs +55/−83
- src/Language/Oberon/Grammar.hs +12/−9
- src/Language/Oberon/Resolver.hs +8/−0
- src/Language/Oberon/TypeChecker.hs +254/−324
- test/Test.hs +5/−4
ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for language-oberon +## 0.3.1 -- 2022-10-09++* Incremented the upper bound of the `input-parsers` dependency+* Minor fixes for GHC 9 compatibility+ ## 0.3 -- 2020-11-01 * Preserving the parsed start and end positions and lexemes of every node
app/Parse.hs view
@@ -154,8 +154,8 @@ 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)))+ => Output -> (TypeChecker.Error AST.Ident Language -> IO ())+ -> (err -> Either (NonEmpty (Resolver.Error Language)) (NonEmpty (TypeChecker.Error AST.Ident 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@@ -167,7 +167,7 @@ Tree -> putStrLn . reprTreeString Plain -> print -reportTypeErrorIn directory (moduleName, (pos, _, _), err) =+reportTypeErrorIn directory (TypeChecker.Error 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)
language-oberon.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-oberon-version: 0.3+version: 0.3.1 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@@ -31,30 +31,31 @@ 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,+ text < 3, containers >= 0.5 && < 1.0, filepath < 1.5, directory < 1.4,+ parsers >= 0.12.7 && < 0.13, input-parsers >= 0.2.2 && < 0.4, prettyprinter >= 1.2.1 && < 1.8, either == 5.*,- rank2classes >= 1.3 && < 1.5, grammatical-parsers >= 0.5 && < 0.6, deep-transformations < 0.2,+ rank2classes >= 1.3 && < 1.5, grammatical-parsers >= 0.5 && < 0.7,+ deep-transformations == 0.2.*, transformers == 0.5.*,- template-haskell >= 2.11 && < 2.17+ template-haskell >= 2.11 && < 2.20 default-language: Haskell2010 executable parse main-is: app/Parse.hs -- other-modules: other-extensions: RankNTypes, RecordWildCards, ScopedTypeVariables, FlexibleInstances, DeriveDataTypeable- build-depends: base >= 4.12 && < 5, text < 1.3, either == 5.*, containers >= 0.5 && < 1.0,+ build-depends: base >= 4.12 && < 5, text, 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,+ rank2classes, input-parsers, grammatical-parsers, deep-transformations, language-oberon, optparse-applicative default-language: Haskell2010 test-suite examples type: exitcode-stdio-1.0- build-depends: base >= 4.12 && < 5, text < 1.3, grammatical-parsers,+ build-depends: base >= 4.12 && < 5, text, grammatical-parsers, either == 5.*, directory < 2, filepath < 1.5, prettyprinter,- deep-transformations < 0.2,+ deep-transformations, tasty >= 0.7, tasty-hunit, language-oberon main-is: test/Test.hs
src/Language/Oberon.hs view
@@ -5,7 +5,7 @@ module Language.Oberon (parseModule, parseAndResolveModule, parseAndResolveModuleFile, LanguageVersion(..), Options(..), NodeWrap, Placed) where -import Language.Oberon.AST (Language, Module(..))+import Language.Oberon.AST (Language, Module(..), Ident) import qualified Language.Oberon.Grammar as Grammar import qualified Language.Oberon.Resolver as Resolver import qualified Language.Oberon.Reserializer as Reserializer@@ -91,7 +91,7 @@ -- use all the information to resolve the syntactic ambiguities. parseAndResolveModule :: Options -> FilePath -> Text -> IO (Validation (Either (NonEmpty (Resolver.Error Language))- (NonEmpty (TypeChecker.Error Language)))+ (NonEmpty (TypeChecker.Error Ident Language))) (Placed (Module Language Language Placed Placed))) parseAndResolveModule Options{..} path source = case parseModule version source@@ -125,7 +125,8 @@ -- | Parse the module file at the given path, assuming all its imports are in the same directory. parseAndResolveModuleFile :: Options -> FilePath- -> IO (Validation (Either (NonEmpty (Resolver.Error Language)) (NonEmpty (TypeChecker.Error Language)))+ -> IO (Validation (Either (NonEmpty (Resolver.Error Language))+ (NonEmpty (TypeChecker.Error Ident Language))) (Placed (Module Language Language Placed Placed))) parseAndResolveModuleFile options path = readFile path >>= parseAndResolveModule options (takeDirectory path)
src/Language/Oberon/AST.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances,+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, OverloadedStrings, StandaloneDeriving, TemplateHaskell, TypeFamilies #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} @@ -171,6 +171,7 @@ coExpression (Read var) = Abstract.read var coExpression (FunctionCall function parameters) = Abstract.functionCall function $ getZipList parameters coExpression (Not e) = Abstract.not e+ coExpression (Literal value) = Abstract.literal value coValue Nil = Abstract.nil coValue (Boolean False) = Abstract.false
src/Language/Oberon/ConstantFolder.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables,- TemplateHaskell, TypeFamilies, UndecidableInstances #-}+ 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@@ -23,7 +23,6 @@ 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) @@ -35,6 +34,7 @@ import qualified Transformation.Full.TH import qualified Transformation.Shallow as Shallow 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), Bequether(..), Synthesizer(..), SynthesizedField(..), Mapped(..)) @@ -78,6 +78,9 @@ type Domain (Auto ConstantFold) = Placed type Codomain (Auto ConstantFold) = Semantics (Auto ConstantFold) +instance AG.Revelation (Auto ConstantFold) where+ reveal (Auto ConstantFold) = snd+ data InhCFRoot l = InhCFRoot{rootEnv :: Environment l} deriving Generic data InhCF l = InhCF{env :: Environment l,@@ -117,47 +120,47 @@ 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 _ _) =+type instance Atts (Synthesized ConstantFold) (Modules l _ _) = SynCFRoot (Modules l Placed Placed)+type instance Atts (Synthesized ConstantFold) (AST.Module l l _ _) = SynCFMod' l (AST.Module l l)+type instance Atts (Synthesized ConstantFold) (AST.Declaration l l _ _) = SynCFMod' l (AST.Declaration l l)+type instance Atts (Synthesized ConstantFold) (AST.ProcedureHeading l l _ _) = SynCF' (AST.ProcedureHeading l l)+type instance Atts (Synthesized ConstantFold) (AST.Block l l _ _) = SynCFMod' l (AST.Block l l)+type instance Atts (Synthesized ConstantFold) (AST.FormalParameters l l _ _) = SynCF' (AST.FormalParameters l l)+type instance Atts (Synthesized ConstantFold) (AST.FPSection l l _ _) = SynCF' (AST.FPSection l l)+type instance Atts (Synthesized ConstantFold) (AST.Type l l _ _) = SynCF' (AST.Type l l)+type instance Atts (Synthesized ConstantFold) (AST.FieldList l l _ _) = SynCF' (AST.FieldList l l)+type instance Atts (Synthesized 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 _ _) =+type instance Atts (Synthesized ConstantFold) (AST.Expression λ l _ _) = SynCFExp λ l+type instance Atts (Synthesized ConstantFold) (AST.Element l l _ _) = SynCF' (AST.Element l l)+type instance Atts (Synthesized ConstantFold) (AST.Value l l _ _) = SynCF' (AST.Value l l)+type instance Atts (Synthesized ConstantFold) (AST.Designator l l _ _) = SynCFDesignator l+type instance Atts (Synthesized ConstantFold) (AST.Statement l l _ _) = SynCF' (AST.Statement l l)+type instance Atts (Synthesized ConstantFold) (AST.Case l l _ _) = SynCF' (AST.Case l l)+type instance Atts (Synthesized ConstantFold) (AST.CaseLabels l l _ _) = SynCF' (AST.CaseLabels l l)+type instance Atts (Synthesized 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 (Synthesized 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 instance Atts (Inherited ConstantFold) (Modules l _ _) = InhCFRoot l+type instance Atts (Inherited ConstantFold) (AST.Module λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.Declaration λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.ProcedureHeading λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.Block λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.FormalParameters λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.FPSection λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.Type λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.FieldList λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.StatementSequence λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.Expression λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.Element λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.Value l l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.Designator λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.Statement λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.Case λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.CaseLabels λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.ConditionalBranch λ l _ _) = InhCF l+type instance Atts (Inherited ConstantFold) (AST.WithAlternative λ l _ _) = InhCF l type SynCF' node = SynCF (node Placed Placed) type SynCFMod' l node = SynCFMod l (node Placed Placed)@@ -168,19 +171,18 @@ 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)+foldedMod :: SynCFMod' l node -> Mapped Placed (node Placed Placed) -folded' = folded-foldedExp = folded+folded' SynCF{folded= x} = x+foldedExp SynCFExp{folded= x} = x foldedExp' = getMapped . foldedExp-+foldedMod SynCFMod{folded= x} = x -- * 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+ SynCFRoot{modulesFolded= (Modules (getMapped . foldedMod . syn <$> ms))} instance {-# overlaps #-} Ord (Abstract.QualIdent l) => Bequether (Auto ConstantFold) (Modules l) Sem Placed where@@ -193,9 +195,7 @@ 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)))}+ folded= Mapped (pos, AST.Module moduleName imports $ getMapped $ foldedMod (syn body))} where exportedEnv = Map.mapKeysMonotonic export newEnv newEnv = moduleEnv (syn body) export q@@ -227,9 +227,9 @@ 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),+ (Abstract.Oberon λ, Abstract.Nameable l, Ord (Abstract.QualIdent l),+ Abstract.Value l ~ AST.Value l,+ Pretty (AST.Value l l 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) =>@@ -357,13 +357,14 @@ (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))+ Abstract.functionCall (getMapped $ foldedDes $ syn fn) (foldedExp' . syn <$> getZipList args)), foldedValue= Nothing} where fromValue v = literalSynthesis (pos, v)+ foldedDes SynCFDesignator{folded= x} = x synthesis _ (pos, _) _ (AST.Literal val) = SynCFExp{folded= Mapped (pos, Abstract.literal $ getMapped $ folded' $ syn val),- foldedValue= Just (pos, snd $ getMapped $ folded' $ syn val)}+ foldedValue= Just (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)) =>@@ -472,9 +473,6 @@ 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@@ -488,12 +486,6 @@ 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@@ -510,23 +502,3 @@ "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
@@ -25,15 +25,18 @@ import Data.Data (Data) import Data.Functor.Compose (Compose(..)) import Data.List.NonEmpty (NonEmpty)+import Data.Ord (Down) 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.Parser.Combinators (sepBy, sepBy1, sepByNonEmpty, try)+import Text.Grampa.ContextFree.LeftRecursive (autochain) import Text.Grampa.ContextFree.LeftRecursive.Transformer (ParserT, lift, tmap) import Text.Parser.Token (braces, brackets, parens) +import qualified Rank2 import qualified Rank2.TH import qualified Language.Oberon.Abstract as Abstract@@ -128,10 +131,10 @@ 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))+type NodeWrap = Compose ((,) (Down Int, Down Int)) (Compose Ambiguous ((,) ParsedLexemes)) newtype ParsedLexemes = Trailing [Lexeme]- deriving (Data, Show, Semigroup, Monoid)+ deriving (Data, Eq, Show, Semigroup, Monoid) instance TokenParsing (Parser (OberonGrammar l f) Text) where someSpace = someLexicalSpace@@ -154,20 +157,20 @@ <* lift ([[Token Keyword s]], ())) <?> ("keyword " <> show s) -comment :: Parser g Text Text+comment :: Rank2.Apply g => 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 :: Rank2.Apply g => 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 :: Rank2.Apply g => Parser g Text a -> Parser g Text (NodeWrap a) wrapAmbiguous = wrap wrap = (Compose <$>) . (\p-> liftA3 surround getSourcePos p getSourcePos) . (Compose <$>) . (ambiguous . tmap store) . ((,) (Trailing []) <$>)@@ -177,13 +180,13 @@ oberonGrammar, oberon2Grammar, oberonDefinitionGrammar, oberon2DefinitionGrammar :: Grammar (OberonGrammar AST.Language NodeWrap) Parser Text -- | Grammar of an Oberon module-oberonGrammar = fixGrammar grammar+oberonGrammar = autochain $ fixGrammar grammar -- | Grammar of an Oberon-2 module-oberon2Grammar = fixGrammar grammar2+oberon2Grammar = autochain $ fixGrammar grammar2 -- | Grammar of an Oberon definition module-oberonDefinitionGrammar = fixGrammar definitionGrammar+oberonDefinitionGrammar = autochain $ fixGrammar definitionGrammar -- | Grammar of an Oberon-2 definition module-oberon2DefinitionGrammar = fixGrammar definitionGrammar2+oberon2DefinitionGrammar = autochain $ fixGrammar definitionGrammar2 grammar, definitionGrammar :: forall l. Abstract.Oberon l => GrammarBuilder (OberonGrammar l NodeWrap) (OberonGrammar l NodeWrap) Parser Text
src/Language/Oberon/Resolver.hs view
@@ -177,6 +177,7 @@ 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) (DeclarationRHS 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),@@ -210,6 +211,7 @@ 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) (DeclarationRHS 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)) =>@@ -246,6 +248,7 @@ 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) (DeclarationRHS 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)) =>@@ -335,12 +338,14 @@ -- 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) (DeclarationRHS 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) (Module 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),@@ -360,6 +365,7 @@ -- '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) (Module l 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),@@ -367,6 +373,7 @@ 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) (DeclarationRHS 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),@@ -392,6 +399,7 @@ moduleGlobalScope = localScope res moduleName (getLocalDeclarations body') predefined localScope :: forall l. (BindableDeclaration l,+ Deep.Traversable (Resolution l) (DeclarationRHS 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)) =>
src/Language/Oberon/TypeChecker.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleContexts, FlexibleInstances,- MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables,- TemplateHaskell, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns #-}+ MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving,+ 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+module Language.Oberon.TypeChecker (checkModules, errorMessage, Error(..), ErrorType(..), predefined, predefined2) where import Control.Applicative (liftA2, (<|>), ZipList(ZipList, getZipList)) import Control.Arrow (first)@@ -17,7 +17,6 @@ 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@@ -68,8 +67,12 @@ | UnknownName (Abstract.QualIdent l) | UnknownField AST.Ident (Type l) -type Error l = (AST.Ident, (Int, ParsedLexemes, Int), ErrorType l)+data Error m l = Error{errorModule :: m,+ errorPosition :: LexicalPosition,+ errorType :: ErrorType l} +type LexicalPosition = (Int, ParsedLexemes, Int)+ 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@@ -83,19 +86,14 @@ 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"+deriving instance Show (Abstract.QualIdent l) => Show (Type l) +deriving instance Eq (Abstract.QualIdent l) => Eq (ErrorType l)+deriving instance Show (Abstract.QualIdent l) => Show (ErrorType l)++deriving instance (Eq m, Eq (Abstract.QualIdent l)) => Eq (Error m l)+deriving instance (Show m, Show (Abstract.QualIdent l)) => Show (Error m l)+ 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"@@ -157,59 +155,59 @@ data InhTCRoot l = InhTCRoot{rootEnv :: Environment l} -data InhTC l = InhTC{env :: Environment l,- currentModule :: AST.Ident}+data InhTC l = InhTC{env :: Environment l} deriving Generic -data InhTCExp l = InhTCExp{env :: Environment l,- currentModule :: AST.Ident,- expectedType :: Type l}+data InhTCExp l = InhTCExp{env :: Environment l,+ 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]}+data SynTC l = SynTC{errors :: Folded [Error () l]} deriving Generic -data SynTCMod l = SynTCMod{errors :: Folded [Error l],+data SynTCMods l = SynTCMods{errors :: Folded [Error AST.Ident 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],+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],+data SynTCFields l = SynTCFields{errors :: Folded [Error () l], fieldEnv :: Map AST.Ident (Type l)} deriving Generic -data SynTCHead l = SynTCHead{errors :: Folded [Error l],+data SynTCHead l = SynTCHead{errors :: Folded [Error () l], insideEnv :: Environment l, outsideEnv :: Environment l} deriving Generic -data SynTCSig l = SynTCSig{errors :: Folded [Error l],+data SynTCSig l = SynTCSig{errors :: Folded [Error () l], signatureEnv :: Environment l, signatureType :: Type l} deriving Generic -data SynTCSec l = SynTCSec{errors :: Folded [Error l],+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],+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],+data SynTCExp l = SynTCExp{errors :: Folded [Error () l], inferredType :: Type l} deriving Generic @@ -236,54 +234,55 @@ ~(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+type instance Atts (Inherited TypeCheck) (Modules l _ _) = InhTCRoot l+type instance Atts (Synthesized TypeCheck) (Modules l _ _) = SynTCMods l+type instance Atts (Inherited TypeCheck) (AST.Module l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.Module l l _ _) = SynTCMod l+type instance Atts (Inherited TypeCheck) (AST.Declaration l l _ _) = InhTCDecl l+type instance Atts (Synthesized TypeCheck) (AST.Declaration l l _ _) = SynTCMod l+type instance Atts (Inherited TypeCheck) (AST.ProcedureHeading l l _ _) = InhTCDecl l+type instance Atts (Synthesized TypeCheck) (AST.ProcedureHeading l l _ _) = SynTCHead l+type instance Atts (Inherited TypeCheck) (AST.Block l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.Block l l _ _) = SynTCMod l+type instance Atts (Inherited TypeCheck) (AST.FormalParameters l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.FormalParameters l l _ _) = SynTCSig l+type instance Atts (Inherited TypeCheck) (AST.FPSection l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.FPSection l l _ _) = SynTCSec l+type instance Atts (Inherited TypeCheck) (AST.Type l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.Type l l _ _) = SynTCType l+type instance Atts (Inherited TypeCheck) (AST.FieldList l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.FieldList l l _ _) = SynTCFields l+type instance Atts (Inherited TypeCheck) (AST.StatementSequence l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.StatementSequence l l _ _) = SynTC l+type instance Atts (Inherited TypeCheck) (AST.Expression l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.Expression l l _ _) = SynTCExp l+type instance Atts (Inherited TypeCheck) (AST.Element l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.Element l l _ _) = SynTCExp l+type instance Atts (Inherited TypeCheck) (AST.Value l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.Value l l _ _) = SynTCExp l+type instance Atts (Inherited TypeCheck) (AST.Designator l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.Designator l l _ _) = SynTCDes l+type instance Atts (Inherited TypeCheck) (AST.Statement l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.Statement l l _ _) = SynTC l+type instance Atts (Inherited TypeCheck) (AST.ConditionalBranch l l _ _) = InhTC l+type instance Atts (Synthesized TypeCheck) (AST.ConditionalBranch l l _ _) = SynTC l+type instance Atts (Inherited TypeCheck) (AST.Case l l _ _) = InhTCExp l+type instance Atts (Synthesized TypeCheck) (AST.Case l l _ _) = SynTC l+type instance Atts (Inherited TypeCheck) (AST.CaseLabels l l _ _) = InhTCExp l+type instance Atts (Synthesized TypeCheck) (AST.CaseLabels l l _ _) = SynTC l+type instance Atts (Inherited TypeCheck) (AST.WithAlternative l l _ _) = InhTC l+type instance Atts (Synthesized 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}+ where moduleInheritance name mod = Inherited InhTC{env= rootEnv inheritance <> foldMap (moduleEnv . syn) ms} 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}+ synthesis _ _ _ (Modules ms) = SynTCMods{errors= Map.foldMapWithKey moduleErrors ms}+ where moduleErrors name (Synthesized SynTCMod{errors= Folded errs}) =+ Folded [Error name pos t | Error () pos t <- errs] 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) =>@@ -309,19 +308,17 @@ 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) =>+ Atts (Inherited (Auto TypeCheck)) (Abstract.ConstExpression l l Sem Sem) ~ InhTC 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) =+ inheritance@InhTCDecl{env= declEnv} (AST.ProcedureDeclaration heading _body) = AST.ProcedureDeclaration (Inherited inheritance) (Inherited bodyInherited)- where bodyInherited = InhTC{env= insideEnv (syn heading) `Map.union` declEnv, currentModule= m}+ where bodyInherited = InhTC{env= insideEnv (syn heading) `Map.union` declEnv} bequest t local inheritance synthesized = AG.bequestDefault t local inheritance synthesized instance (Abstract.Nameable l, k ~ Abstract.QualIdent l, Ord k,@@ -329,7 +326,6 @@ 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) =@@ -353,12 +349,7 @@ 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) =>+ Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType 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) =@@ -369,53 +360,52 @@ 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) =+ 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) =+ InhTCDecl{env, pointerTargets} (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))+ outsideEnv= case Map.lookup receiverType pointerTargets 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))+ (Map.lookup (Abstract.nonQualIdent receiverType) env) 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)]+ case Map.lookup (Abstract.nonQualIdent receiverType) env+ of Nothing -> Folded [Error () 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)]+ | otherwise -> Folded [Error () 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) =+ bequest _ (pos, AST.Block{}) inheritance@InhTC{env} (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+ (pure $ Inherited localInheritance)+ where localInheritance :: InhTC l+ localInheritance = inheritance{env= localEnv}+ localEnv = newEnv declarations <> env+ pointers= foldMap (\Synthesized{syn= SynTCMod{pointerTargets= ptrs}}-> ptrs) 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+ 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) =>@@ -444,15 +434,16 @@ 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' _) =+ synthesis _ (pos, AST.FormalParameters sections returnType) InhTC{env}+ (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)),+ $ returnType >>= (`Map.lookup` env), 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)]+ | Map.member q env = mempty+ | otherwise = Folded [Error () pos (UnknownName q)] instance (Abstract.Wirthy l, Ord (Abstract.QualIdent l), Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l) =>@@ -468,13 +459,12 @@ 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)],+ synthesis _ (pos, AST.TypeReference q) InhTC{env} _ = + SynTCType{errors= if Map.member q env then mempty else Folded [Error () 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) = + definedType= fromMaybe UnknownType (Map.lookup q env)}+ synthesis _ (pos, AST.ArrayType _dims _itemType) InhTC{} (AST.ArrayType dimensions itemType) = SynTCType{errors= foldMap (\d-> errors (syn d :: SynTCExp l)) dimensions <> errors (syn itemType :: SynTCType l) <> foldMap (expectInteger . syn) dimensions,@@ -482,40 +472,35 @@ 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)]+ expectInteger SynTCExp{inferredType= t} = Folded [Error () pos (NonIntegerType t)] integerValue SynTCExp{inferredType= IntegerType n} = n integerValue _ = 0- synthesis _ (pos, AST.RecordType base fields) inheritance (AST.RecordType _base fields') =+ synthesis _ (pos, AST.RecordType base fields) InhTC{env} (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+ where baseRecord = case flip Map.lookup env <$> 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 (Just t) -> (Folded [Error () pos (NonRecordType t)], Nothing) Just Nothing ->- (foldMap (Folded . (:[])- . (,,) (currentModule (inheritance :: InhTC l)) pos . UnknownName) base,- Nothing)+ (foldMap (Folded . (:[]) . Error () pos . UnknownName) base, Nothing) Nothing -> (mempty, Nothing)- synthesis (Auto TypeCheck) _self inheritance (AST.PointerType targetType') =+ 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') = + 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) =>+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@@ -529,26 +514,13 @@ 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),+ bequest _ (_pos, AST.CaseStatement{}) i@InhTC{env} (AST.CaseStatement value _branches _fallback) =+ AST.CaseStatement (Inherited i) (pure $ Inherited InhTCExp{env= env, 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)+ bequest _ (_pos, statement) InhTC{env} _ =+ AG.passDown InhTCExp{env= env,+ expectedType= error "No statement except CASE needs expectedType"} statement instance {-# overlaps #-} (Abstract.Wirthy l, Abstract.Nameable l, Ord (Abstract.QualIdent l), Atts (Synthesized (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ SynTC l,@@ -558,11 +530,11 @@ 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)+ synthesis t (pos, _) InhTC{} statement@(AST.Assignment var value) =+ {-# SCC "Assignment" #-}+ SynTC{errors= assignmentCompatible 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') =+ synthesis _ (pos, AST.ProcedureCall _proc parameters) _inheritance (AST.ProcedureCall procedure' parameters') = SynTC{errors= (case syn procedure' of SynTCDes{errors= Folded [], designatorType= t} -> procedureErrors t@@ -575,20 +547,20 @@ || 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+ Folded [Error () pos+ $ ArgumentCountMismatch (length formalTypes) $ maybe 0 (length . getZipList) parameters]+ | otherwise = mconcat (zipWith (parameterCompatible 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)}+ procedureErrors t = Folded [Error () pos (NonProcedureType t)]+ synthesis _ (pos, _) _inheritance (AST.While condition body) =+ SynTC{errors= booleanExpressionErrors pos (syn condition) <> errors (syn body :: SynTC l)}+ synthesis _ (pos, _) _inheritance (AST.Repeat body condition) =+ SynTC{errors= booleanExpressionErrors pos (syn condition) <> errors (syn body :: SynTC l)}+ synthesis _ (pos, _) _inheritance (AST.For _counter start end step body) =+ SynTC{errors= integerExpressionErrors pos (syn start) + <> integerExpressionErrors pos (syn end)+ <> foldMap (integerExpressionErrors 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),@@ -596,29 +568,22 @@ 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))+ (Inherited InhTC{env},+ AST.WithAlternative _var _subtype body) =+ (Synthesized SynTC{errors= case (Map.lookup var env, Map.lookup subtype env) 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)]+ assignmentCompatible pos supertype subtypeDef+ (Nothing, _) -> Folded [Error () pos (UnknownName var)]+ (_, Nothing) -> Folded [Error () 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))))+ AST.WithAlternative var subtype (Inherited $ InhTC $ maybe id (Map.insert var) (Map.lookup subtype env) env)) 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)}+ synthesis _ (pos, _) _inheritance (AST.ConditionalBranch condition body) =+ SynTC{errors= booleanExpressionErrors 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) =>@@ -636,16 +601,16 @@ 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) =+ synthesis _ (pos, AST.Relation op _ _) InhTC{} (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+ Folded [] <- assignmentCompatible pos t1 t2 -> mempty | equality op,- Folded [] <- assignmentCompatible (currentModule (inheritance :: InhTC l)) pos t2 t1+ Folded [] <- assignmentCompatible pos t2 t1 -> mempty | otherwise -> comparable (ultimate t1) (ultimate t2) errs -> errs,@@ -669,30 +634,26 @@ | isNumerical t1 = mempty comparable IntegerType{} (BuiltinType t2) | isNumerical t2 = mempty- comparable t1 t2 = Folded [(currentModule (inheritance :: InhTC l), pos, IncomparableTypes t1 t2)]+ comparable t1 t2 = Folded [Error () 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,+ synthesis _ (pos, AST.IsA _ q) InhTC{env} (AST.IsA left _) =+ SynTCExp{errors= case Map.lookup q env+ of Nothing -> Folded [Error () pos (UnknownName q)]+ Just t -> assignmentCompatible pos (inferredType $ syn left) t, inferredType= BuiltinType "BOOLEAN"}- synthesis _ (pos, _) inheritance (AST.Positive expr) =- SynTCExp{errors= unaryNumericOrSetOperatorErrors inheritance pos (syn expr),+ synthesis _ (pos, _) _inheritance (AST.Positive expr) =+ SynTCExp{errors= unaryNumericOrSetOperatorErrors pos (syn expr), inferredType= inferredType (syn expr)}- synthesis _ (pos, _) inheritance (AST.Negative expr) =- SynTCExp{errors= unaryNumericOrSetOperatorErrors inheritance pos (syn expr),+ synthesis _ (pos, _) _inheritance (AST.Negative expr) =+ SynTCExp{errors= unaryNumericOrSetOperatorErrors 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) =+ synthesis _ (pos, _) _inheritance (AST.Add left right) = binaryNumericOrSetSynthesis pos left right+ synthesis _ (pos, _) _inheritance (AST.Subtract left right) = binaryNumericOrSetSynthesis pos left right+ synthesis _ (pos, _) _inheritance (AST.Or left right) = binaryBooleanSynthesis pos left right+ synthesis _ (pos, _) _inheritance (AST.Multiply left right) = binaryNumericOrSetSynthesis pos left right+ synthesis _ (pos, _) InhTC{} (AST.Divide left right) = SynTCExp{errors= case (syn left, syn right) of (SynTCExp{errors= Folded [], inferredType= BuiltinType t1},@@ -701,13 +662,12 @@ | 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)],+ | t1 == t2 -> Folded [Error () pos (UnrealType t1)]+ | otherwise -> Folded [Error () 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 _ (pos, _) _inheritance (AST.IntegerDivide left right) = binaryIntegerSynthesis pos left right+ synthesis _ (pos, _) _inheritance (AST.Modulo left right) = binaryIntegerSynthesis pos left right+ synthesis _ (pos, _) _inheritance (AST.And left right) = binaryBooleanSynthesis pos left right synthesis (Auto TypeCheck) _self _ (AST.Set elements) = SynTCExp{errors= mempty, inferredType= BuiltinType "SET"}@@ -717,7 +677,7 @@ 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+ synthesis _ (pos, AST.FunctionCall _designator (ZipList parameters)) _inheritance (AST.FunctionCall designator (ZipList parameters')) = SynTCExp{errors= case {-# SCC "FunctionCall" #-} syn designator@@ -725,14 +685,13 @@ designatorName= name, designatorType= ultimate -> ProcedureType _ formalTypes Just{}} | length formalTypes /= length parameters ->- Folded [(currentModule (inheritance :: InhTC l), pos,- ArgumentCountMismatch (length formalTypes) (length parameters))]+ Folded [Error () pos+ $ ArgumentCountMismatch (length formalTypes) (length parameters)] | name == Just (Just "SYSTEM", "VAL") -> mempty- | otherwise -> mconcat (zipWith (parameterCompatible inheritance pos) formalTypes+ | otherwise -> mconcat (zipWith (parameterCompatible pos) formalTypes $ inferredType . syn <$> parameters') SynTCDes{errors= Folded [],- designatorType= t} -> Folded [(currentModule (inheritance :: InhTC l),- pos, NonFunctionType t)]+ designatorType= t} -> Folded [Error () pos (NonFunctionType t)] SynTCDes{errors= errs} -> errs <> foldMap (\p-> errors (syn p :: SynTCExp l)) parameters', inferredType=@@ -744,12 +703,9 @@ _ -> UnknownType} where systemCallType "VAL" [t1, t2] = Just t1 systemCallType _ _ = Nothing- synthesis _ (pos, _) inheritance (AST.Not expr) =- SynTCExp{errors= booleanExpressionErrors inheritance pos (syn expr),+ synthesis _ (pos, _) _inheritance (AST.Not expr) =+ SynTCExp{errors= booleanExpressionErrors 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)@@ -761,10 +717,10 @@ 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)+ SynthesizedField "errors" (Folded [Error () l]) (Auto TypeCheck) (AST.Element l l) Sem Placed where+ synthesizedField _ _ (pos, _) _inheritance (AST.Element expr) = integerExpressionErrors pos (syn expr)+ synthesizedField _ _ (pos, _) _inheritance (AST.Range low high) = integerExpressionErrors pos (syn high)+ <> integerExpressionErrors pos (syn low) instance SynthesizedField "inferredType" (Type l) (Auto TypeCheck) (AST.Element l l) Sem Placed where synthesizedField _ _ _ _ _ = BuiltinType "SET"@@ -775,22 +731,20 @@ 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 _ =+ synthesis _ (pos, AST.Variable q) InhTC{env} _ = SynTCDes{errors= case designatorType- of Nothing -> Folded [(currentModule (inheritance :: InhTC l), pos, UnknownName q)]+ of Nothing -> Folded [Error () 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) =+ where designatorType = Map.lookup q env+ synthesis _ (pos, AST.Field _record fieldName) InhTC{} (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)+ maybe (Folded [Error () pos (NonRecordType t)])+ (maybe (Folded [Error () pos (UnknownField fieldName t)]) $ const mempty) (access True t) SynTCDes{errors= errors} -> errors, designatorName= Nothing,@@ -803,99 +757,94 @@ 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) =+ synthesis _ (pos, AST.Index _array index indexes) InhTC{} (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,+ designatorName= Nothing, 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))])+ | otherwise = Left (Folded [Error () 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) =+ access _ t = Left (Folded [Error () pos (NonArrayType t)])+ synthesis _ (pos, AST.TypeGuard _designator q) InhTC{env} (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'+ Just t') -> assignmentCompatible pos t t' (SynTCDes{errors= errors}, - Nothing) -> Folded ((currentModule (inheritance :: InhTC l),- pos, UnknownName q) : getFolded errors)+ Nothing) -> Folded (Error () pos (UnknownName q) : getFolded errors) (SynTCDes{errors= errors}, _) -> errors,+ designatorName= Nothing, designatorType= fromMaybe UnknownType targetType}- where targetType = Map.lookup q (env (inheritance :: InhTC l))- synthesis _ (pos, _) inheritance (AST.Dereference pointer) =+ where targetType = Map.lookup q env+ synthesis _ (pos, _) InhTC{} (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)]+ designatorType= t}+ | PointerType{} <- t -> mempty+ | NominalType _ (Just PointerType{}) <- t -> mempty+ | ProcedureType True _ _ <- t -> mempty+ | otherwise -> Folded [Error () pos (NonPointerType t)] SynTCDes{errors= es} -> es,+ designatorName= Nothing, 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),+binaryNumericOrSetSynthesis pos left right =+ SynTCExp{errors= binarySetOrNumericOperatorErrors 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),+binaryIntegerSynthesis pos left right =+ SynTCExp{errors= binaryIntegerOperatorErrors 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),+binaryBooleanSynthesis pos left right =+ SynTCExp{errors= binaryBooleanOperatorErrors 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+unaryNumericOrSetOperatorErrors :: forall l. Abstract.Nameable l => LexicalPosition -> SynTCExp l -> Folded [Error () l]+unaryNumericOrSetOperatorErrors pos SynTCExp{errors= Folded [], inferredType= t}+ | IntegerType{} <- t = mempty+ | BuiltinType name <- t, isNumerical name || name == "SET" = mempty+ | otherwise = Folded [Error () 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 _ _+ => LexicalPosition -> 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 _ _+binarySetOrNumericOperatorErrors _ SynTCExp{errors= Folded [], inferredType= IntegerType{}} SynTCExp{errors= Folded [], inferredType= BuiltinType name} | isNumerical name = mempty-binarySetOrNumericOperatorErrors _ _+binarySetOrNumericOperatorErrors _ SynTCExp{errors= Folded [], inferredType= BuiltinType name} SynTCExp{errors= Folded [], inferredType= IntegerType{}} | isNumerical name = mempty-binarySetOrNumericOperatorErrors _ _+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+binarySetOrNumericOperatorErrors pos SynTCExp{errors= Folded [], inferredType= t1}+ SynTCExp{errors= Folded [], inferredType= t2}+ | t1 == t2 = Folded [Error () pos (NonNumericType t1)]+ | otherwise = Folded [Error () 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}@@ -908,15 +857,14 @@ | 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+ LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]+binaryIntegerOperatorErrors pos syn1 syn2 = integerExpressionErrors pos syn1 <> integerExpressionErrors pos syn2 -integerExpressionErrors :: forall l. InhTC l -> (Int, ParsedLexemes, Int) -> SynTCExp l -> Folded [Error l]-integerExpressionErrors inheritance pos SynTCExp{errors= Folded [], inferredType= t}+integerExpressionErrors :: forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]+integerExpressionErrors pos SynTCExp{errors= Folded [], inferredType= t} | isIntegerType t = mempty- | otherwise = Folded [(currentModule (inheritance :: InhTC l), pos, NonIntegerType t)]-integerExpressionErrors _ _ SynTCExp{errors= errs} = errs+ | otherwise = Folded [Error () pos (NonIntegerType t)]+integerExpressionErrors _ SynTCExp{errors= errs} = errs isIntegerType IntegerType{} = True isIntegerType (BuiltinType "SHORTINT") = True@@ -924,44 +872,43 @@ isIntegerType (BuiltinType "LONGINT") = True isIntegerType t = False -booleanExpressionErrors :: forall l. InhTC l -> (Int, ParsedLexemes, Int) -> SynTCExp l -> Folded [Error l]-booleanExpressionErrors _ _ SynTCExp{errors= Folded [],+booleanExpressionErrors :: forall l. LexicalPosition -> 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+booleanExpressionErrors pos SynTCExp{errors= Folded [], inferredType= t} = + Folded [Error () 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+ => LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]+binaryBooleanOperatorErrors _pos SynTCExp{errors= Folded [], inferredType= BuiltinType "BOOLEAN"} SynTCExp{errors= Folded [], inferredType= BuiltinType "BOOLEAN"} = mempty-binaryBooleanOperatorErrors inheritance pos+binaryBooleanOperatorErrors 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+ | t1 == t2 = Folded [Error () pos (NonBooleanType t1)]+ | otherwise = Folded [Error () 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+ => LexicalPosition -> (Bool, Type l) -> Type l -> Folded [Error () l]+parameterCompatible _ (_, expected@(ArrayType [] _)) actual | arrayCompatible expected actual = mempty-parameterCompatible inheritance pos (True, expected) actual+parameterCompatible pos (True, expected) actual | expected == actual = mempty- | otherwise = Folded [(currentModule (inheritance :: InhTC l), pos, UnequalTypes expected actual)]-parameterCompatible inheritance pos (False, expected) actual+ | otherwise = Folded [Error () pos (UnequalTypes expected actual)]+parameterCompatible pos (False, expected) actual | BuiltinType "ARRAY" <- expected, ArrayType{} <- actual = mempty- | otherwise = assignmentCompatible (currentModule (inheritance :: InhTC l)) pos expected actual+ | otherwise = assignmentCompatible 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))+ => InhTCExp l -> LexicalPosition -> Type l -> Folded [Error () l]+assignmentCompatibleIn InhTCExp{expectedType} pos = assignmentCompatible pos expectedType 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+ => LexicalPosition -> Type l -> Type l -> Folded [Error () l]+assignmentCompatible pos expected actual | expected == actual = mempty | BuiltinType name1 <- expected, BuiltinType name2 <- actual, Just index1 <- List.elemIndex name1 numericTypeNames,@@ -972,19 +919,19 @@ 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+ assignmentCompatible 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+ | ReceiverType t <- actual = assignmentCompatible pos expected t+ | ReceiverType t <- expected = assignmentCompatible pos t actual | NilType <- actual, PointerType{} <- expected = mempty | NilType <- actual, ProcedureType{} <- expected = mempty- | NilType <- actual, NominalType _ (Just t) <- expected = assignmentCompatible currModule pos t actual+ | NilType <- actual, NominalType _ (Just t) <- expected = assignmentCompatible 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 [])+ Folded (if m < n then [Error () 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)]+ | NominalType _ (Just t) <- expected, ProcedureType{} <- actual = assignmentCompatible pos t actual+ | otherwise = Folded [Error () pos (IncompatibleTypes expected actual)] arrayCompatible (ArrayType [] t1) (ArrayType _ t2) = t1 == t2 || arrayCompatible t1 t2 arrayCompatible (ArrayType [] (BuiltinType "CHAR")) StringType{} = True@@ -1015,6 +962,9 @@ type Domain (Auto TypeCheck) = Placed type Codomain (Auto TypeCheck) = Semantics (Auto TypeCheck) +instance AG.Revelation (Auto TypeCheck) where+ reveal (Auto TypeCheck) = snd+ instance Ord (Abstract.QualIdent l) => Transformation.At (Auto TypeCheck) (Modules l Sem Sem) where ($) = AG.applyDefault snd @@ -1031,11 +981,11 @@ 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]+ => Environment l -> Map AST.Ident (Placed (AST.Module l l Placed Placed)) -> [Error AST.Ident l] checkModules predef modules = getFolded (errors (syn (Transformation.apply (Auto TypeCheck) (wrap $ Auto TypeCheck Deep.<$> Modules modules) `Rank2.apply`- Inherited (InhTCRoot predef)) :: SynTC l))+ Inherited (InhTCRoot predef)) :: SynTCMods l)) where wrap = (,) (0, Trailing [], 0) predefined, predefined2 :: (Abstract.Wirthy l, Ord (Abstract.QualIdent l)) => Environment l@@ -1077,23 +1027,3 @@ 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])
test/Test.hs view
@@ -4,7 +4,7 @@ import Data.Either.Validation (Validation(..)) import Data.Functor.Identity (Identity(Identity)) import Data.List (isSuffixOf)-import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty (NonEmpty((:|)), toList) import Data.Text (Text, unpack) import Data.Text.IO (readFile) import Data.Text.Prettyprint.Doc (Pretty(pretty), layoutPretty, defaultLayoutOptions)@@ -56,10 +56,11 @@ dirPath source case resolvedModule of Failure (Left (Resolver.UnparseableModule err :| [])) -> assertFailure (unpack err)- Failure errs -> assertFailure (show $ (onLastOfThree TypeChecker.errorMessage <$>) <$> errs)+ Failure (Right errs) -> assertFailure $ show+ $ [(TypeChecker.errorModule err,+ TypeChecker.errorPosition err,+ TypeChecker.errorMessage $ TypeChecker.errorType err) | err <- toList 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)