diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/app/Parse.hs b/app/Parse.hs --- a/app/Parse.hs +++ b/app/Parse.hs @@ -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) diff --git a/language-oberon.cabal b/language-oberon.cabal --- a/language-oberon.cabal +++ b/language-oberon.cabal @@ -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 diff --git a/src/Language/Oberon.hs b/src/Language/Oberon.hs --- a/src/Language/Oberon.hs +++ b/src/Language/Oberon.hs @@ -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) diff --git a/src/Language/Oberon/AST.hs b/src/Language/Oberon/AST.hs --- a/src/Language/Oberon/AST.hs +++ b/src/Language/Oberon/AST.hs @@ -1,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 diff --git a/src/Language/Oberon/ConstantFolder.hs b/src/Language/Oberon/ConstantFolder.hs --- a/src/Language/Oberon/ConstantFolder.hs +++ b/src/Language/Oberon/ConstantFolder.hs @@ -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]) diff --git a/src/Language/Oberon/Grammar.hs b/src/Language/Oberon/Grammar.hs --- a/src/Language/Oberon/Grammar.hs +++ b/src/Language/Oberon/Grammar.hs @@ -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 diff --git a/src/Language/Oberon/Resolver.hs b/src/Language/Oberon/Resolver.hs --- a/src/Language/Oberon/Resolver.hs +++ b/src/Language/Oberon/Resolver.hs @@ -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)) => diff --git a/src/Language/Oberon/TypeChecker.hs b/src/Language/Oberon/TypeChecker.hs --- a/src/Language/Oberon/TypeChecker.hs +++ b/src/Language/Oberon/TypeChecker.hs @@ -1,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]) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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)