{-# LANGUAGE DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleContexts, FlexibleInstances,
             MultiParamTypeClasses, NamedFieldPuns, OverloadedRecordDot, 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

import Control.Applicative (liftA2, (<|>), ZipList(ZipList, getZipList))
import Control.Arrow (first)
import Data.Coerce (coerce)
import Data.Proxy (Proxy(..))
import qualified Data.List as List
import Data.Functor.Const (Const(..))
import Data.Maybe (fromMaybe)
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as Map
import Data.Semigroup (Semigroup(..))
import qualified Data.Text as Text
import GHC.Generics (Generic)

import qualified Rank2
import qualified Transformation
import qualified Transformation.Shallow as Shallow
import qualified Transformation.Deep as Deep
import qualified Transformation.Full as Full
import qualified Transformation.Full.TH
import qualified Transformation.AG as AG
import qualified Transformation.AG.Generics as AG
import Transformation.AG (Attribution(..), Atts, Inherited(..), Synthesized(..), Semantics)
import Transformation.AG.Generics (Auto(Auto), Folded(..), Bequether(..), Synthesizer(..), SynthesizedField)

import qualified Language.Oberon.Abstract as Abstract
import qualified Language.Oberon.AST as AST
import Language.Oberon.Grammar (ParsedLexemes(Trailing))
import Language.Oberon.Resolver (Placed)

data Type l = NominalType (Abstract.QualIdent l) (Maybe (Type l))
            | RecordType{forall l. Type l -> [QualIdent l]
ancestry :: [Abstract.QualIdent l],
                         forall l. Type l -> Map Text (Type l)
recordFields :: Map AST.Ident (Type l)}
            | NilType
            | IntegerType Int
            | StringType Int
            | ArrayType [Int] (Type l)
            | PointerType (Type l)
            | ReceiverType (Type l)
            | ProcedureType Bool [(Bool, Type l)] (Maybe (Type l))
            | BuiltinType Text.Text
            | UnknownType

data ErrorType l = ArgumentCountMismatch Int Int
                 | ExtraDimensionalIndex Int Int
                 | IncomparableTypes (Type l) (Type l)
                 | IncompatibleTypes (Type l) (Type l)
                 | TooSmallArrayType Int Int
                 | OpenArrayVariable
                 | NonArrayType (Type l)
                 | NonBooleanType (Type l)
                 | NonFunctionType (Type l)
                 | NonIntegerType (Type l)
                 | NonNumericType (Type l)
                 | NonPointerType (Type l)
                 | NonProcedureType (Type l)
                 | NonRecordType (Type l)
                 | TypeMismatch (Type l) (Type l)
                 | UnequalTypes (Type l) (Type l)
                 | UnrealType (Type l)
                 | UnknownName (Abstract.QualIdent l)
                 | UnknownField AST.Ident (Type l)

data Error m l = Error{forall m l. Error m l -> m
errorModule   :: m,
                       forall m l. Error m l -> LexicalPosition
errorPosition :: LexicalPosition,
                       forall m l. Error m l -> ErrorType l
errorType     :: ErrorType l}

type LexicalPosition = (Int, ParsedLexemes, Int)

instance Eq (Abstract.QualIdent l) => Eq (Type l) where
  NominalType QualIdent l
q1 (Just Type l
t1) == :: Type l -> Type l -> Bool
== t2 :: Type l
t2@(NominalType QualIdent l
q2 Maybe (Type l)
_) = QualIdent l
q1 forall a. Eq a => a -> a -> Bool
== QualIdent l
q2 Bool -> Bool -> Bool
|| Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2
  t1 :: Type l
t1@(NominalType QualIdent l
q1 Maybe (Type l)
_) == NominalType QualIdent l
q2 (Just Type l
t2) = QualIdent l
q1 forall a. Eq a => a -> a -> Bool
== QualIdent l
q2 Bool -> Bool -> Bool
|| Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2
  NominalType QualIdent l
q1 Maybe (Type l)
Nothing == NominalType QualIdent l
q2 Maybe (Type l)
Nothing = QualIdent l
q1 forall a. Eq a => a -> a -> Bool
== QualIdent l
q2
  ArrayType [] Type l
t1 == ArrayType [] Type l
t2 = Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2
  ProcedureType Bool
_ [(Bool, Type l)]
p1 Maybe (Type l)
r1 == ProcedureType Bool
_ [(Bool, Type l)]
p2 Maybe (Type l)
r2 = Maybe (Type l)
r1 forall a. Eq a => a -> a -> Bool
== Maybe (Type l)
r2 Bool -> Bool -> Bool
&& [(Bool, Type l)]
p1 forall a. Eq a => a -> a -> Bool
== [(Bool, Type l)]
p2
  StringType Int
len1 == StringType Int
len2 = Int
len1 forall a. Eq a => a -> a -> Bool
== Int
len2
  Type l
NilType == Type l
NilType = Bool
True
  BuiltinType Text
name1 == BuiltinType Text
name2 = Text
name1 forall a. Eq a => a -> a -> Bool
== Text
name2
  ReceiverType Type l
t1 == Type l
t2 = Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2
  Type l
t1 == ReceiverType Type l
t2 = Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2
  Type l
_ == Type l
_ = Bool
False

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 :: forall l.
(Nameable l, Oberon l, Show (QualIdent l)) =>
ErrorType l -> String
errorMessage (ArgumentCountMismatch Int
expected Int
actual) =
   String
"Expected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
expected forall a. Semigroup a => a -> a -> a
<> String
", received " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actual forall a. Semigroup a => a -> a -> a
<> String
" arguments"
errorMessage (ExtraDimensionalIndex Int
expected Int
actual) =
   String
"Expected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
expected forall a. Semigroup a => a -> a -> a
<> String
", received " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actual forall a. Semigroup a => a -> a -> a
<> String
" indexes"
errorMessage (IncomparableTypes Type l
left Type l
right) = 
   String
"Values of types " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
left forall a. Semigroup a => a -> a -> a
<> String
" and " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
right forall a. Semigroup a => a -> a -> a
<> String
" cannot be compared"
errorMessage (IncompatibleTypes Type l
left Type l
right) =
   String
"Incompatible types " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
left forall a. Semigroup a => a -> a -> a
<> String
" and " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
right
errorMessage (TooSmallArrayType Int
expected Int
actual) = 
   String
"The array of length " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
expected forall a. Semigroup a => a -> a -> a
<> String
" cannot contain " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actual forall a. Semigroup a => a -> a -> a
<> String
" items"
errorMessage ErrorType l
OpenArrayVariable = String
"A variable cannot be declared an open array"
errorMessage (NonArrayType Type l
t) = String
"Trying to index a non-array type " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t
errorMessage (NonBooleanType Type l
t) = String
"Type " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t forall a. Semigroup a => a -> a -> a
<> String
" is not Boolean"
errorMessage (NonFunctionType Type l
t) = String
"Trying to invoke a " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t forall a. Semigroup a => a -> a -> a
<> String
" as a function"
errorMessage (NonIntegerType Type l
t) = String
"Type " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t forall a. Semigroup a => a -> a -> a
<> String
" is not an integer type"
errorMessage (NonNumericType Type l
t) = String
"Type " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t forall a. Semigroup a => a -> a -> a
<> String
" is not a numeric type"
errorMessage (NonPointerType Type l
t) = String
"Trying to dereference a non-pointer type " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t
errorMessage (NonProcedureType Type l
t) = String
"Trying to invoke a " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t forall a. Semigroup a => a -> a -> a
<> String
" as a procedure"
errorMessage (NonRecordType Type l
t) = String
"Non-record type " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t
errorMessage (TypeMismatch Type l
t1 Type l
t2) = String
"Type mismatch between " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t1 forall a. Semigroup a => a -> a -> a
<> String
" and " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t2
errorMessage (UnequalTypes Type l
t1 Type l
t2) = String
"Unequal types " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t1 forall a. Semigroup a => a -> a -> a
<> String
" and " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t2
errorMessage (UnrealType Type l
t) = String
"Type " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t forall a. Semigroup a => a -> a -> a
<> String
" is not a numeric real type"
errorMessage (UnknownName QualIdent l
q) = String
"Unknown name " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show QualIdent l
q
errorMessage (UnknownField Text
name Type l
t) = String
"Record type " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t forall a. Semigroup a => a -> a -> a
<> String
" has no field " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
name

typeMessage :: (Abstract.Nameable l, Abstract.Oberon l) => Type l -> String
typeMessage :: forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage (BuiltinType Text
name) = Text -> String
Text.unpack Text
name
typeMessage (NominalType QualIdent l
name Maybe (Type l)
_) = forall l. (Nameable l, Oberon l) => QualIdent l -> String
nameMessage QualIdent l
name
typeMessage (RecordType [QualIdent l]
ancestry Map Text (Type l)
fields) = 
   String
"RECORD " forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((String
"(" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ String
") ") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. (Nameable l, Oberon l) => QualIdent l -> String
nameMessage) [QualIdent l]
ancestry
   forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
List.intercalate String
";\n" (forall {l}. (Nameable l, Oberon l) => (Text, Type l) -> String
fieldMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Type l)
fields) forall a. [a] -> [a] -> [a]
++ String
"END"
   where fieldMessage :: (Text, Type l) -> String
fieldMessage (Text
name, Type l
t) = String
"\n  " forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
name forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t
typeMessage (ArrayType [Int]
dimensions Type l
itemType) = 
   String
"ARRAY " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " (forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
dimensions) forall a. [a] -> [a] -> [a]
++ String
" OF " forall a. [a] -> [a] -> [a]
++ forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
itemType
typeMessage (PointerType Type l
targetType) = String
"POINTER TO " forall a. [a] -> [a] -> [a]
++ forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
targetType
typeMessage (ProcedureType Bool
_ [(Bool, Type l)]
parameters Maybe (Type l)
result) =
   String
"PROCEDURE (" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " (forall {l}. (Nameable l, Oberon l) => (Bool, Type l) -> String
argMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Bool, Type l)]
parameters) forall a. [a] -> [a] -> [a]
++ String
"): " forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Maybe (Type l)
result
   where argMessage :: (Bool, Type l) -> String
argMessage (Bool
True, Type l
t) = String
"VAR " forall a. Semigroup a => a -> a -> a
<> forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t
         argMessage (Bool
False, Type l
t) = forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t
typeMessage (ReceiverType Type l
t) = forall l. (Nameable l, Oberon l) => Type l -> String
typeMessage Type l
t
typeMessage (IntegerType Int
n) = String
"INTEGER"
typeMessage (StringType Int
len) = String
"STRING [" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ShowS
shows Int
len String
"]"
typeMessage Type l
NilType = String
"NIL"
typeMessage Type l
UnknownType = String
"[Unknown]"

nameMessage :: (Abstract.Nameable l, Abstract.Oberon l) => Abstract.QualIdent l -> String
nameMessage :: forall l. (Nameable l, Oberon l) => QualIdent l -> String
nameMessage QualIdent l
q
   | Just (Text
mod, Text
name) <- forall l. Oberon l => QualIdent l -> Maybe (Text, Text)
Abstract.getQualIdentNames QualIdent l
q = Text -> String
Text.unpack Text
mod forall a. Semigroup a => a -> a -> a
<> String
"." forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
name
   | Just Text
name <- forall l. Nameable l => QualIdent l -> Maybe Text
Abstract.getNonQualIdentName QualIdent l
q = Text -> String
Text.unpack Text
name

type Environment l = Map (Abstract.QualIdent l) (Type l)

newtype Modules l f' f = Modules (Map AST.Ident (f (AST.Module l l f' f')))

data TypeCheck = TypeCheck

type Sem = Semantics (Auto TypeCheck)

data InhTCRoot l = InhTCRoot{forall l. InhTCRoot l -> Environment l
rootEnv :: Environment l}

data InhTC l = InhTC{forall l. InhTC l -> Environment l
env :: Environment l}
               deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (InhTC l) x -> InhTC l
forall l x. InhTC l -> Rep (InhTC l) x
$cto :: forall l x. Rep (InhTC l) x -> InhTC l
$cfrom :: forall l x. InhTC l -> Rep (InhTC l) x
Generic

data InhTCExp l = InhTCExp{forall l. InhTCExp l -> Environment l
env          :: Environment l,
                           forall l. InhTCExp l -> Type l
expectedType :: Type l}
                  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (InhTCExp l) x -> InhTCExp l
forall l x. InhTCExp l -> Rep (InhTCExp l) x
$cto :: forall l x. Rep (InhTCExp l) x -> InhTCExp l
$cfrom :: forall l x. InhTCExp l -> Rep (InhTCExp l) x
Generic

data InhTCDecl l = InhTCDecl{forall l. InhTCDecl l -> Environment l
env           :: Environment l,
                             forall l. InhTCDecl l -> Map Text Text
pointerTargets :: Map AST.Ident AST.Ident}
                   deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (InhTCDecl l) x -> InhTCDecl l
forall l x. InhTCDecl l -> Rep (InhTCDecl l) x
$cto :: forall l x. Rep (InhTCDecl l) x -> InhTCDecl l
$cfrom :: forall l x. InhTCDecl l -> Rep (InhTCDecl l) x
Generic

data SynTC l = SynTC{forall l. SynTC l -> Folded [Error () l]
errors :: Folded [Error () l]}
               deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTC l) x -> SynTC l
forall l x. SynTC l -> Rep (SynTC l) x
$cto :: forall l x. Rep (SynTC l) x -> SynTC l
$cfrom :: forall l x. SynTC l -> Rep (SynTC l) x
Generic

data SynTCMods l = SynTCMods{forall l. SynTCMods l -> Folded [Error Text l]
errors :: Folded [Error AST.Ident l]}
                   deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTCMods l) x -> SynTCMods l
forall l x. SynTCMods l -> Rep (SynTCMods l) x
$cto :: forall l x. Rep (SynTCMods l) x -> SynTCMods l
$cfrom :: forall l x. SynTCMods l -> Rep (SynTCMods l) x
Generic

data SynTCMod l = SynTCMod{forall l. SynTCMod l -> Folded [Error () l]
errors :: Folded [Error () l],
                           forall l. SynTCMod l -> Environment l
moduleEnv :: Environment l,
                           forall l. SynTCMod l -> Folded (Map Text Text)
pointerTargets :: Folded (Map AST.Ident AST.Ident)}
                  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTCMod l) x -> SynTCMod l
forall l x. SynTCMod l -> Rep (SynTCMod l) x
$cto :: forall l x. Rep (SynTCMod l) x -> SynTCMod l
$cfrom :: forall l x. SynTCMod l -> Rep (SynTCMod l) x
Generic

data SynTCType l = SynTCType{forall l. SynTCType l -> Folded [Error () l]
errors :: Folded [Error () l],
                             forall l. SynTCType l -> Maybe Text
typeName   :: Maybe AST.Ident,
                             forall l. SynTCType l -> Type l
definedType :: Type l,
                             forall l. SynTCType l -> Maybe Text
pointerTarget :: Maybe AST.Ident}
                   deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTCType l) x -> SynTCType l
forall l x. SynTCType l -> Rep (SynTCType l) x
$cto :: forall l x. Rep (SynTCType l) x -> SynTCType l
$cfrom :: forall l x. SynTCType l -> Rep (SynTCType l) x
Generic

data SynTCFields l = SynTCFields{forall l. SynTCFields l -> Folded [Error () l]
errors :: Folded [Error () l],
                                 forall l. SynTCFields l -> Map Text (Type l)
fieldEnv :: Map AST.Ident (Type l)}
                     deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTCFields l) x -> SynTCFields l
forall l x. SynTCFields l -> Rep (SynTCFields l) x
$cto :: forall l x. Rep (SynTCFields l) x -> SynTCFields l
$cfrom :: forall l x. SynTCFields l -> Rep (SynTCFields l) x
Generic

data SynTCHead l = SynTCHead{forall l. SynTCHead l -> Folded [Error () l]
errors :: Folded [Error () l],
                             forall l. SynTCHead l -> Environment l
insideEnv :: Environment l,
                             forall l. SynTCHead l -> Environment l
outsideEnv :: Environment l}
                   deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTCHead l) x -> SynTCHead l
forall l x. SynTCHead l -> Rep (SynTCHead l) x
$cto :: forall l x. Rep (SynTCHead l) x -> SynTCHead l
$cfrom :: forall l x. SynTCHead l -> Rep (SynTCHead l) x
Generic

data SynTCSig l = SynTCSig{forall l. SynTCSig l -> Folded [Error () l]
errors :: Folded [Error () l],
                           forall l. SynTCSig l -> Environment l
signatureEnv :: Environment l,
                           forall l. SynTCSig l -> Type l
signatureType :: Type l}
                  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTCSig l) x -> SynTCSig l
forall l x. SynTCSig l -> Rep (SynTCSig l) x
$cto :: forall l x. Rep (SynTCSig l) x -> SynTCSig l
$cfrom :: forall l x. SynTCSig l -> Rep (SynTCSig l) x
Generic

data SynTCSec l = SynTCSec{forall l. SynTCSec l -> Folded [Error () l]
errors :: Folded [Error () l],
                           forall l. SynTCSec l -> Environment l
sectionEnv :: Environment l,
                           forall l. SynTCSec l -> [(Bool, Type l)]
sectionParameters :: [(Bool, Type l)]}
                  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTCSec l) x -> SynTCSec l
forall l x. SynTCSec l -> Rep (SynTCSec l) x
$cto :: forall l x. Rep (SynTCSec l) x -> SynTCSec l
$cfrom :: forall l x. SynTCSec l -> Rep (SynTCSec l) x
Generic

data SynTCDes l = SynTCDes{forall l. SynTCDes l -> Folded [Error () l]
errors :: Folded [Error () l],
                           forall l. SynTCDes l -> Maybe (Maybe Text, Text)
designatorName   :: Maybe (Maybe Abstract.Ident, Abstract.Ident),
                           forall l. SynTCDes l -> Type l
designatorType :: Type l}
                  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTCDes l) x -> SynTCDes l
forall l x. SynTCDes l -> Rep (SynTCDes l) x
$cto :: forall l x. Rep (SynTCDes l) x -> SynTCDes l
$cfrom :: forall l x. SynTCDes l -> Rep (SynTCDes l) x
Generic

data SynTCExp l = SynTCExp{forall l. SynTCExp l -> Folded [Error () l]
errors :: Folded [Error () l],
                           forall l. SynTCExp l -> Type l
inferredType :: Type l}
                  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (SynTCExp l) x -> SynTCExp l
forall l x. SynTCExp l -> Rep (SynTCExp l) x
$cto :: forall l x. Rep (SynTCExp l) x -> SynTCExp l
$cfrom :: forall l x. SynTCExp l -> Rep (SynTCExp l) x
Generic

-- * Modules instances, TH candidates
instance (Transformation.Transformation t, Functor (Transformation.Domain t), Deep.Functor t (AST.Module l l),
          Transformation.At t (AST.Module l l (Transformation.Codomain t) (Transformation.Codomain t))) =>
         Deep.Functor t (Modules l) where
   t
t <$> :: t
-> Modules l (Domain t) (Domain t)
-> Modules l (Codomain t) (Codomain t)
<$> ~(Modules Map Text (Domain t (Module l l (Domain t) (Domain t)))
ms) = forall l (f' :: * -> *) (f :: * -> *).
Map Text (f (Module l l f' f')) -> Modules l f' f
Modules (Domain t (Module l l (Domain t) (Domain t))
-> Codomain t (Module l l (Codomain t) (Codomain t))
mapModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (Domain t (Module l l (Domain t) (Domain t)))
ms)
      where mapModule :: Domain t (Module l l (Domain t) (Domain t))
-> Codomain t (Module l l (Codomain t) (Codomain t))
mapModule Domain t (Module l l (Domain t) (Domain t))
m = t
t forall t x. At t x => t -> Domain t x -> Codomain t x
Transformation.$ ((t
t forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
Deep.<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Domain t (Module l l (Domain t) (Domain t))
m)
instance (Transformation.Transformation t, Functor (Transformation.Domain t),
          Transformation.At t (AST.Module l l f f)) =>
         Shallow.Functor t (Modules l f) where
   t
t <$> :: t -> Modules l f (Domain t) -> Modules l f (Codomain t)
<$> ~(Modules Map Text (Domain t (Module l l f f))
ms) = forall l (f' :: * -> *) (f :: * -> *).
Map Text (f (Module l l f' f')) -> Modules l f' f
Modules ((t
t forall t x. At t x => t -> Domain t x -> Codomain t x
Transformation.$) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (Domain t (Module l l f f))
ms)
instance (Transformation.Transformation t, Functor (Transformation.Domain t), Shallow.Foldable t (AST.Module l l f),
          Transformation.At t (AST.Module l l f f)) =>
         Shallow.Foldable t (Modules l f) where
   foldMap :: forall m.
(Codomain t ~ Const m, Monoid m) =>
t -> Modules l f (Domain t) -> m
foldMap t
t ~(Modules Map Text (Domain t (Module l l f f))
ms) = forall {k} a (b :: k). Const a b -> a
getConst (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (t
t forall t x. At t x => t -> Domain t x -> Codomain t x
Transformation.$) Map Text (Domain t (Module l l f f))
ms)

instance Rank2.Functor (Modules l f') where
   forall a. p a -> q a
f <$> :: forall (p :: * -> *) (q :: * -> *).
(forall a. p a -> q a) -> Modules l f' p -> Modules l f' q
<$> ~(Modules Map Text (p (Module l l f' f'))
ms) = forall l (f' :: * -> *) (f :: * -> *).
Map Text (f (Module l l f' f')) -> Modules l f' f
Modules (forall a. p a -> q a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (p (Module l l f' f'))
ms)
instance Rank2.Foldable (Modules l f) where
   foldMap :: forall m (p :: * -> *).
Monoid m =>
(forall a. p a -> m) -> Modules l f p -> m
foldMap forall a. p a -> m
f ~(Modules Map Text (p (Module l l f f))
ms) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. p a -> m
f Map Text (p (Module l l f f))
ms
instance Rank2.Apply (Modules l f') where
   ~(Modules Map Text ((~>) p q (Module l l f' f'))
fs) <*> :: forall (p :: * -> *) (q :: * -> *).
Modules l f' (p ~> q) -> Modules l f' p -> Modules l f' q
<*> ~(Modules Map Text (p (Module l l f' f'))
ms) = forall l (f' :: * -> *) (f :: * -> *).
Map Text (f (Module l l f' f')) -> Modules l f' f
Modules (forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith forall {k} (p :: k -> *) (q :: k -> *) (a :: k).
Arrow p q a -> p a -> q a
Rank2.apply Map Text ((~>) p q (Module l l f' f'))
fs Map Text (p (Module l l f' f'))
ms)

-- * Boring attribute types
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 :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (Modules
        l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Modules l sem sem)
-> Modules l sem (Synthesized (Auto TypeCheck))
-> Modules l sem (Inherited (Auto TypeCheck))
bequest Auto TypeCheck
_ (LexicalPosition
_, Modules Map
  Text
  (Sem
     (Module
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
self) Atts (Inherited (Auto TypeCheck)) (Modules l sem sem)
inheritance (Modules Map Text (Synthesized (Auto TypeCheck) (Module l l sem sem))
ms) =
     forall l (f' :: * -> *) (f :: * -> *).
Map Text (f (Module l l f' f')) -> Modules l f' f
Modules (forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Text
-> Sem
     (Module
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Inherited (Auto TypeCheck) (Module l l sem sem)
moduleInheritance Map
  Text
  (Sem
     (Module
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
self)
     where moduleInheritance :: Text
-> Sem
     (Module
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Inherited (Auto TypeCheck) (Module l l sem sem)
moduleInheritance Text
name Sem
  (Module
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
mod = forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhTC{$sel:env:InhTC :: Map (QualIdent l) (Type l)
env= forall l. InhTCRoot l -> Environment l
rootEnv Atts (Inherited (Auto TypeCheck)) (Modules l sem sem)
inheritance forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l. SynTCMod l -> Environment l
moduleEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Map Text (Synthesized (Auto TypeCheck) (Module l l sem sem))
ms}
instance Ord (Abstract.QualIdent l) => Synthesizer (Auto TypeCheck) (Modules l) Sem Placed where
  synthesis :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (Modules
        l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Modules l sem sem)
-> Modules l sem (Synthesized (Auto TypeCheck))
-> Atts (Synthesized (Auto TypeCheck)) (Modules l sem sem)
synthesis Auto TypeCheck
_ Placed
  (Modules
     l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_ Atts (Inherited (Auto TypeCheck)) (Modules l sem sem)
_ (Modules Map Text (Synthesized (Auto TypeCheck) (Module l l sem sem))
ms) = SynTCMods{$sel:errors:SynTCMods :: Folded [Error Text l]
errors= forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey forall {t} {a} {l} {m}.
(Atts (Synthesized t) a ~ SynTCMod l) =>
m -> Synthesized t a -> Folded [Error m l]
moduleErrors Map Text (Synthesized (Auto TypeCheck) (Module l l sem sem))
ms}
     where moduleErrors :: m -> Synthesized t a -> Folded [Error m l]
moduleErrors m
name (Synthesized SynTCMod{$sel:errors:SynTCMod :: forall l. SynTCMod l -> Folded [Error () l]
errors= Folded [Error () l]
errs}) =
              forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error m
name LexicalPosition
pos ErrorType l
t | Error () LexicalPosition
pos ErrorType l
t <- [Error () l]
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) =>
         SynthesizedField "moduleEnv" (Map k (Type l)) (Auto TypeCheck) (AST.Module l l) Sem Placed where
   synthesizedField :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Proxy "moduleEnv"
-> Auto TypeCheck
-> Placed
     (Module
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Module l l sem sem)
-> Module l l sem (Synthesized (Auto TypeCheck))
-> Map k (Type l)
synthesizedField Proxy "moduleEnv"
_ Auto TypeCheck
_ (LexicalPosition
pos, AST.Module Text
moduleName [(Maybe Text, Text)]
imports Sem
  (Block
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
body) Atts (Inherited (Auto TypeCheck)) (Module l l sem sem)
_inheritance (AST.Module Text
_ [(Maybe Text, Text)]
_ Synthesized (Auto TypeCheck) (Block l l sem sem)
body') = Map k (Type l)
exportedEnv
      where exportedEnv :: Map k (Type l)
exportedEnv = Type l -> Type l
exportNominal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic QualIdent l -> QualIdent l
export (forall l. SynTCMod l -> Environment l
moduleEnv forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Block l l sem sem)
body')
            export :: QualIdent l -> QualIdent l
export QualIdent l
q
               | Just Text
name <- forall l. Nameable l => QualIdent l -> Maybe Text
Abstract.getNonQualIdentName QualIdent l
q = forall l. Oberon l => Text -> Text -> QualIdent l
Abstract.qualIdent Text
moduleName Text
name
               | Bool
otherwise = QualIdent l
q
            exportNominal :: Type l -> Type l
exportNominal (NominalType QualIdent l
q (Just Type l
t))
               | Just Text
name <- forall l. Nameable l => QualIdent l -> Maybe Text
Abstract.getNonQualIdentName QualIdent l
q =
                 forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType (forall l. Oberon l => Text -> Text -> QualIdent l
Abstract.qualIdent Text
moduleName Text
name) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Type l -> Type l
exportNominal' Type l
t)
            exportNominal Type l
t = Type l -> Type l
exportNominal' Type l
t
            exportNominal' :: Type l -> Type l
exportNominal' (RecordType [QualIdent l]
ancestry Map Text (Type l)
fields) = forall l. [QualIdent l] -> Map Text (Type l) -> Type l
RecordType (QualIdent l -> QualIdent l
export forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QualIdent l]
ancestry) (Type l -> Type l
exportNominal' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (Type l)
fields)
            exportNominal' (ProcedureType Bool
False [(Bool, Type l)]
parameters Maybe (Type l)
result) =
              forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False ((Type l -> Type l
exportNominal' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Bool, Type l)]
parameters) (Type l -> Type l
exportNominal' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Type l)
result)
            exportNominal' (PointerType Type l
target) = forall l. Type l -> Type l
PointerType (Type l -> Type l
exportNominal' Type l
target)
            exportNominal' (ArrayType [Int]
dimensions Type l
itemType) = forall l. [Int] -> Type l -> Type l
ArrayType [Int]
dimensions (Type l -> Type l
exportNominal' Type l
itemType)
            exportNominal' (NominalType QualIdent l
q (Just Type l
t))
              | Just Text
name <- forall l. Nameable l => QualIdent l -> Maybe Text
Abstract.getNonQualIdentName QualIdent l
q =
                forall a. a -> Maybe a -> a
fromMaybe (forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType (forall l. Oberon l => Text -> Text -> QualIdent l
Abstract.qualIdent Text
moduleName Text
name) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Type l -> Type l
exportNominal' Type l
t)
                          (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent l
q Map k (Type l)
exportedEnv)
            exportNominal' Type l
t = Type l
t

instance (Abstract.Nameable l, Ord (Abstract.QualIdent 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) =>
         Bequether (Auto TypeCheck) (AST.Declaration l l) Sem Placed where
   bequest :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (Declaration
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
-> Declaration l l sem (Synthesized (Auto TypeCheck))
-> Declaration l l sem (Inherited (Auto TypeCheck))
bequest Auto TypeCheck
_ (LexicalPosition
pos, AST.ProcedureDeclaration{})
           inheritance :: Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
inheritance@InhTCDecl{$sel:env:InhTCDecl :: forall l. InhTCDecl l -> Environment l
env= Map (QualIdent l) (Type l)
declEnv} (AST.ProcedureDeclaration Synthesized (Auto TypeCheck) (ProcedureHeading l l sem sem)
heading Synthesized (Auto TypeCheck) (Block l l sem sem)
_body) =
      forall λ l (f' :: * -> *) (f :: * -> *).
f (ProcedureHeading l l f' f')
-> f (Block l l f' f') -> Declaration λ l f' f
AST.ProcedureDeclaration (forall t a. Atts (Inherited t) a -> Inherited t a
Inherited Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
inheritance) (forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhTC l
bodyInherited)
      where bodyInherited :: InhTC l
bodyInherited = InhTC{$sel:env:InhTC :: Map (QualIdent l) (Type l)
env= forall l. SynTCHead l -> Environment l
insideEnv (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (ProcedureHeading l l sem sem)
heading) forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map (QualIdent l) (Type l)
declEnv}
   bequest Auto TypeCheck
t Placed
  (Declaration
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
local Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
inheritance Declaration l l sem (Synthesized (Auto TypeCheck))
synthesized = forall t (g :: (* -> *) -> (* -> *) -> *) (shallow :: * -> *)
       (sem :: * -> *).
(sem ~ Semantics t, Domain t ~ shallow, Revelation t,
 Functor
   (PassDown t sem (Atts (Inherited t) (g sem sem))) (g sem)) =>
t
-> shallow (g sem sem)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> g sem (Inherited t)
AG.bequestDefault Auto TypeCheck
t Placed
  (Declaration
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
local Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
inheritance Declaration l l sem (Synthesized (Auto TypeCheck))
synthesized

instance (Abstract.Nameable l, k ~ Abstract.QualIdent l, Ord k,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ SynTCMod l,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.FormalParameters l l Sem Sem) ~ SynTCSig l,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.ProcedureHeading l l Sem Sem) ~ SynTCHead l,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.ConstExpression l l Sem Sem) ~ SynTCExp l) =>
         SynthesizedField "moduleEnv" (Map k (Type l)) (Auto TypeCheck) (AST.Declaration l l) Sem Placed where
   synthesizedField :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Proxy "moduleEnv"
-> Auto TypeCheck
-> Placed
     (Declaration
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
-> Declaration l l sem (Synthesized (Auto TypeCheck))
-> Map k (Type l)
synthesizedField Proxy "moduleEnv"
_ Auto TypeCheck
_ (LexicalPosition
pos, AST.ConstantDeclaration IdentDef l
namedef Sem
  (ConstExpression
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_) Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
_ (AST.ConstantDeclaration IdentDef l
_ Synthesized (Auto TypeCheck) (ConstExpression l l sem sem)
expression) =
      forall k a. k -> a -> Map k a
Map.singleton (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent forall a b. (a -> b) -> a -> b
$ forall l. Nameable l => IdentDef l -> Text
Abstract.getIdentDefName IdentDef l
namedef) (forall l. SynTCExp l -> Type l
inferredType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (ConstExpression l l sem sem)
expression)
   synthesizedField Proxy "moduleEnv"
_ Auto TypeCheck
_ (LexicalPosition
pos, AST.TypeDeclaration IdentDef l
namedef Sem
  (Type
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_) Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
_ (AST.TypeDeclaration IdentDef l
_ Synthesized (Auto TypeCheck) (Type l l sem sem)
definition) =
      forall k a. k -> a -> Map k a
Map.singleton QualIdent l
qname (Type l -> Type l
nominal forall a b. (a -> b) -> a -> b
$ forall l. SynTCType l -> Type l
definedType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
definition)
      where nominal :: Type l -> Type l
nominal t :: Type l
t@BuiltinType{} = Type l
t
            nominal t :: Type l
t@NominalType{} = Type l
t
            nominal (PointerType t :: Type l
t@RecordType{}) =
               forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType QualIdent l
qname (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Type l -> Type l
PointerType forall a b. (a -> b) -> a -> b
$ forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent forall a b. (a -> b) -> a -> b
$ Text
nameforall a. Semigroup a => a -> a -> a
<>Text
"^") (forall a. a -> Maybe a
Just Type l
t))
            nominal Type l
t = forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType QualIdent l
qname (forall a. a -> Maybe a
Just Type l
t)
            qname :: QualIdent l
qname = forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent Text
name
            name :: Text
name = forall l. Nameable l => IdentDef l -> Text
Abstract.getIdentDefName IdentDef l
namedef
   synthesizedField Proxy "moduleEnv"
_ Auto TypeCheck
_ (LexicalPosition
pos, AST.VariableDeclaration IdentList l
names Sem
  (Type
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_) Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
_ (AST.VariableDeclaration IdentList l
_names Synthesized (Auto TypeCheck) (Type l l sem sem)
declaredType) =
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap IdentDef l -> Map k (Type l)
binding IdentList l
names
      where binding :: IdentDef l -> Map k (Type l)
binding IdentDef l
name = forall k a. k -> a -> Map k a
Map.singleton (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent forall a b. (a -> b) -> a -> b
$ forall l. Nameable l => IdentDef l -> Text
Abstract.getIdentDefName IdentDef l
name)
                                         (forall l. SynTCType l -> Type l
definedType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
declaredType)
   synthesizedField Proxy "moduleEnv"
_ Auto TypeCheck
_ (LexicalPosition
pos, AST.ProcedureDeclaration{}) Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
_ (AST.ProcedureDeclaration Synthesized (Auto TypeCheck) (ProcedureHeading l l sem sem)
heading Synthesized (Auto TypeCheck) (Block l l sem sem)
body) =
      forall l. SynTCHead l -> Environment l
outsideEnv (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (ProcedureHeading l l sem sem)
heading)
   synthesizedField Proxy "moduleEnv"
_ Auto TypeCheck
_ (LexicalPosition
pos, AST.ForwardDeclaration IdentDef l
namedef Maybe
  (Sem
     (FormalParameters
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
_sig) Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
_ (AST.ForwardDeclaration IdentDef l
_namedef Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig) =
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall k a. k -> a -> Map k a
Map.singleton (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent forall a b. (a -> b) -> a -> b
$ forall l. Nameable l => IdentDef l -> Text
Abstract.getIdentDefName IdentDef l
namedef) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. SynTCSig l -> Type l
signatureType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig

instance (Abstract.Nameable l, k ~ Abstract.QualIdent l, Ord k,
          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 :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Proxy "pointerTargets"
-> Auto TypeCheck
-> Placed
     (Declaration
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
-> Declaration l l sem (Synthesized (Auto TypeCheck))
-> Folded (Map Text Text)
synthesizedField Proxy "pointerTargets"
_ Auto TypeCheck
_ (LexicalPosition
pos, AST.TypeDeclaration IdentDef l
namedef Sem
  (Type
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_) Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
_ (AST.TypeDeclaration IdentDef l
_ Synthesized (Auto TypeCheck) (Type l l sem sem)
definition) =
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> Folded a
Folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. k -> a -> Map k a
Map.singleton Text
name) (forall l. SynTCType l -> Maybe Text
pointerTarget forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
definition)
      where name :: Text
name = forall l. Nameable l => IdentDef l -> Text
Abstract.getIdentDefName IdentDef l
namedef
   synthesizedField Proxy "pointerTargets"
_ Auto TypeCheck
_ Placed
  (Declaration
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_ Atts (Inherited (Auto TypeCheck)) (Declaration l l sem sem)
_ Declaration l l sem (Synthesized (Auto TypeCheck))
_ = forall a. Monoid a => a
mempty

instance (Abstract.Nameable l, Ord (Abstract.QualIdent l),
          Atts (Synthesized (Auto TypeCheck)) (Abstract.FormalParameters l l Sem Sem) ~ SynTCSig l) =>
         Synthesizer (Auto TypeCheck) (AST.ProcedureHeading l l) Sem Placed where
   synthesis :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (ProcedureHeading
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (ProcedureHeading l l sem sem)
-> ProcedureHeading l l sem (Synthesized (Auto TypeCheck))
-> Atts
     (Synthesized (Auto TypeCheck)) (ProcedureHeading l l sem sem)
synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.ProcedureHeading Bool
indirect IdentDef l
namedef Maybe
  (Sem
     (FormalParameters
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
_sig) Atts (Inherited (Auto TypeCheck)) (ProcedureHeading l l sem sem)
_inheritance (AST.ProcedureHeading Bool
_indirect IdentDef l
_ Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig) =
      SynTCHead{$sel:errors:SynTCHead :: Folded [Error () l]
errors= forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((.errors) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig,
                $sel:outsideEnv:SynTCHead :: Map (QualIdent l) (Type l)
outsideEnv= forall k a. k -> a -> Map k a
Map.singleton (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent Text
name) forall a b. (a -> b) -> a -> b
$
                            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [] forall a. Maybe a
Nothing) (forall l. SynTCSig l -> Type l
signatureType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig,
                $sel:insideEnv:SynTCHead :: Map (QualIdent l) (Type l)
insideEnv= forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l. SynTCSig l -> Environment l
signatureEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig}
      where name :: Text
name = forall l. Nameable l => IdentDef l -> Text
Abstract.getIdentDefName IdentDef l
namedef
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.TypeBoundHeading Bool
var Text
receiverName Text
receiverType Bool
indirect IdentDef l
namedef Maybe
  (Sem
     (FormalParameters
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
_sig)
             InhTCDecl{Map (QualIdent l) (Type l)
env :: Map (QualIdent l) (Type l)
$sel:env:InhTCDecl :: forall l. InhTCDecl l -> Environment l
env, Map Text Text
pointerTargets :: Map Text Text
$sel:pointerTargets:InhTCDecl :: forall l. InhTCDecl l -> Map Text Text
pointerTargets} (AST.TypeBoundHeading Bool
_var Text
_name Text
_type Bool
_indirect IdentDef l
_ Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig) =
      SynTCHead{$sel:errors:SynTCHead :: Folded [Error () l]
errors= Folded [Error () l]
receiverError forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((.errors) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig,
                $sel:outsideEnv:SynTCHead :: Map (QualIdent l) (Type l)
outsideEnv= case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
receiverType Map Text Text
pointerTargets
                            of Just Text
targetName -> forall k a. k -> a -> Map k a
Map.singleton (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent Text
targetName) Type l
methodType
                               Maybe Text
Nothing -> forall k a. k -> a -> Map k a
Map.singleton (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent Text
receiverType) Type l
methodType,
                $sel:insideEnv:SynTCHead :: Map (QualIdent l) (Type l)
insideEnv= Map (QualIdent l) (Type l)
receiverEnv forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l. SynTCSig l -> Environment l
signatureEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig}
      where receiverEnv :: Map (QualIdent l) (Type l)
receiverEnv =
               forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall k a. k -> a -> Map k a
Map.singleton (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent Text
receiverName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. Type l -> Type l
ReceiverType)
                       (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent Text
receiverType) Map (QualIdent l) (Type l)
env)
            methodType :: Type l
methodType = forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent Text
"")
                                     (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. [QualIdent l] -> Map Text (Type l) -> Type l
RecordType [] forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Text
name Type l
procedureType)
            name :: Text
name = forall l. Nameable l => IdentDef l -> Text
Abstract.getIdentDefName IdentDef l
namedef
            procedureType :: Type l
procedureType = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [] forall a. Maybe a
Nothing) (forall l. SynTCSig l -> Type l
signatureType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
sig
            receiverError :: Folded [Error () l]
receiverError =
               case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent Text
receiverType) Map (QualIdent l) (Type l)
env
               of Maybe (Type l)
Nothing -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. QualIdent l -> ErrorType l
UnknownName forall a b. (a -> b) -> a -> b
$ forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent Text
receiverType)]
                  Just Type l
t 
                     | RecordType{} <- forall l. Type l -> Type l
ultimate Type l
t -> forall a. Monoid a => a
mempty
                     | PointerType Type l
t' <- forall l. Type l -> Type l
ultimate Type l
t, RecordType{} <- forall l. Type l -> Type l
ultimate Type l
t' -> forall a. Monoid a => a
mempty
                     | Bool
otherwise -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonRecordType Type l
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 :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (Block
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Block l l sem sem)
-> Block l l sem (Synthesized (Auto TypeCheck))
-> Block l l sem (Inherited (Auto TypeCheck))
bequest Auto TypeCheck
_ (LexicalPosition
pos, AST.Block{}) inheritance :: Atts (Inherited (Auto TypeCheck)) (Block l l sem sem)
inheritance@InhTC{Map (QualIdent l) (Type l)
env :: Map (QualIdent l) (Type l)
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env} (AST.Block ZipList (Synthesized (Auto TypeCheck) (Declaration l l sem sem))
declarations Maybe
  (Synthesized (Auto TypeCheck) (StatementSequence l l sem sem))
_statements) =
      forall λ l (f' :: * -> *) (f :: * -> *).
ZipList (f (Declaration l l f' f'))
-> Maybe (f (StatementSequence l l f' f')) -> Block λ l f' f
AST.Block (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhTCDecl{$sel:env:InhTCDecl :: Map (QualIdent l) (Type l)
env= Map (QualIdent l) (Type l)
localEnv,
                                            $sel:pointerTargets:InhTCDecl :: Map Text Text
pointerTargets= forall a. Folded a -> a
getFolded Folded (Map Text Text)
pointers})
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhTC l
localInheritance)
      where localInheritance :: InhTC l
            localInheritance :: InhTC l
localInheritance = Atts (Inherited (Auto TypeCheck)) (Block l l sem sem)
inheritance{$sel:env:InhTC :: Map (QualIdent l) (Type l)
env= Map (QualIdent l) (Type l)
localEnv}
            localEnv :: Map (QualIdent l) (Type l)
localEnv = forall l.
(Nameable l, Ord (QualIdent l), Show (QualIdent l),
 Atts
   (Synthesized (Auto TypeCheck))
   (Declaration
      l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
 ~ SynTCMod l) =>
ZipList
  (Synthesized
     (Auto TypeCheck)
     (Declaration
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
-> Environment l
newEnv ZipList (Synthesized (Auto TypeCheck) (Declaration l l sem sem))
declarations forall a. Semigroup a => a -> a -> a
<> Map (QualIdent l) (Type l)
env
            pointers :: Folded (Map Text Text)
pointers= forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Synthesized{syn :: forall t a. Synthesized t a -> Atts (Synthesized t) a
syn= SynTCMod{$sel:pointerTargets:SynTCMod :: forall l. SynTCMod l -> Folded (Map Text Text)
pointerTargets= Folded (Map Text Text)
ptrs}}-> Folded (Map Text Text)
ptrs) ZipList (Synthesized (Auto TypeCheck) (Declaration l l sem sem))
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 :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Proxy "moduleEnv"
-> Auto TypeCheck
-> Placed
     (Block
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Block l l sem sem)
-> Block l l sem (Synthesized (Auto TypeCheck))
-> Map k (Type l)
synthesizedField Proxy "moduleEnv"
_ Auto TypeCheck
_ (LexicalPosition
pos, AST.Block{}) Atts (Inherited (Auto TypeCheck)) (Block l l sem sem)
_inheritance (AST.Block ZipList (Synthesized (Auto TypeCheck) (Declaration l l sem sem))
declarations Maybe
  (Synthesized (Auto TypeCheck) (StatementSequence l l sem sem))
_statements) = forall l.
(Nameable l, Ord (QualIdent l), Show (QualIdent l),
 Atts
   (Synthesized (Auto TypeCheck))
   (Declaration
      l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
 ~ SynTCMod l) =>
ZipList
  (Synthesized
     (Auto TypeCheck)
     (Declaration
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
-> Environment l
newEnv ZipList (Synthesized (Auto TypeCheck) (Declaration l l sem sem))
declarations

newEnv :: (Abstract.Nameable l, Ord (Abstract.QualIdent l), Show (Abstract.QualIdent l),
           Atts (Synthesized (Auto TypeCheck)) (Abstract.Declaration l l Sem Sem) ~ SynTCMod l) =>
          ZipList (Synthesized (Auto TypeCheck) (Abstract.Declaration l l Sem Sem)) -> Environment l
newEnv :: forall l.
(Nameable l, Ord (QualIdent l), Show (QualIdent l),
 Atts
   (Synthesized (Auto TypeCheck))
   (Declaration
      l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
 ~ SynTCMod l) =>
ZipList
  (Synthesized
     (Auto TypeCheck)
     (Declaration
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
-> Environment l
newEnv ZipList
  (Synthesized
     (Auto TypeCheck)
     (Declaration
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
declarations = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall {l}.
(Nameable l, Show (QualIdent l)) =>
Type l -> Type l -> Type l
mergeTypeBoundProcedures (forall l. SynTCMod l -> Environment l
moduleEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList
  (Synthesized
     (Auto TypeCheck)
     (Declaration
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
declarations)
   where mergeTypeBoundProcedures :: Type l -> Type l -> Type l
mergeTypeBoundProcedures (NominalType QualIdent l
q (Just Type l
t1)) Type l
t2
            | forall l. Nameable l => QualIdent l -> Maybe Text
Abstract.getNonQualIdentName QualIdent l
q forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"" = Type l -> Type l -> Type l
mergeTypeBoundProcedures Type l
t1 Type l
t2
            | Bool
otherwise = forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType QualIdent l
q (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Type l -> Type l -> Type l
mergeTypeBoundProcedures Type l
t1 Type l
t2)
         mergeTypeBoundProcedures Type l
t1 (NominalType QualIdent l
q (Just Type l
t2))
            | forall l. Nameable l => QualIdent l -> Maybe Text
Abstract.getNonQualIdentName QualIdent l
q forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"" = Type l -> Type l -> Type l
mergeTypeBoundProcedures Type l
t1 Type l
t2
            | Bool
otherwise = forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType QualIdent l
q (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Type l -> Type l -> Type l
mergeTypeBoundProcedures Type l
t1 Type l
t2)
         mergeTypeBoundProcedures (RecordType [QualIdent l]
ancestry1 Map Text (Type l)
fields1) (RecordType [QualIdent l]
ancestry2 Map Text (Type l)
fields2) =
            forall l. [QualIdent l] -> Map Text (Type l) -> Type l
RecordType ([QualIdent l]
ancestry1 forall a. Semigroup a => a -> a -> a
<> [QualIdent l]
ancestry2) (Map Text (Type l)
fields1 forall a. Semigroup a => a -> a -> a
<> Map Text (Type l)
fields2)
         mergeTypeBoundProcedures (PointerType (RecordType [QualIdent l]
ancestry1 Map Text (Type l)
fields1)) (RecordType [QualIdent l]
ancestry2 Map Text (Type l)
fields2) =
            forall l. Type l -> Type l
PointerType (forall l. [QualIdent l] -> Map Text (Type l) -> Type l
RecordType ([QualIdent l]
ancestry1 forall a. Semigroup a => a -> a -> a
<> [QualIdent l]
ancestry2) (Map Text (Type l)
fields1 forall a. Semigroup a => a -> a -> a
<> Map Text (Type l)
fields2))
         mergeTypeBoundProcedures (RecordType [QualIdent l]
ancestry1 Map Text (Type l)
fields1) (PointerType (RecordType [QualIdent l]
ancestry2 Map Text (Type l)
fields2)) =
            forall l. Type l -> Type l
PointerType (forall l. [QualIdent l] -> Map Text (Type l) -> Type l
RecordType ([QualIdent l]
ancestry1 forall a. Semigroup a => a -> a -> a
<> [QualIdent l]
ancestry2) (Map Text (Type l)
fields1 forall a. Semigroup a => a -> a -> a
<> Map Text (Type l)
fields2))
         mergeTypeBoundProcedures (PointerType (NominalType QualIdent l
q (Just (RecordType [QualIdent l]
ancestry1 Map Text (Type l)
fields1))))
                                  (RecordType [QualIdent l]
ancestry2 Map Text (Type l)
fields2) =
            forall l. Type l -> Type l
PointerType (forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType QualIdent l
q forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. [QualIdent l] -> Map Text (Type l) -> Type l
RecordType ([QualIdent l]
ancestry1 forall a. Semigroup a => a -> a -> a
<> [QualIdent l]
ancestry2) (Map Text (Type l)
fields1 forall a. Semigroup a => a -> a -> a
<> Map Text (Type l)
fields2))
         mergeTypeBoundProcedures (RecordType [QualIdent l]
ancestry1 Map Text (Type l)
fields1)
                                  (PointerType (NominalType QualIdent l
q (Just (RecordType [QualIdent l]
ancestry2 Map Text (Type l)
fields2)))) =
            forall l. Type l -> Type l
PointerType (forall l. QualIdent l -> Maybe (Type l) -> Type l
NominalType QualIdent l
q forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. [QualIdent l] -> Map Text (Type l) -> Type l
RecordType ([QualIdent l]
ancestry1 forall a. Semigroup a => a -> a -> a
<> [QualIdent l]
ancestry2) (Map Text (Type l)
fields1 forall a. Semigroup a => a -> a -> a
<> Map Text (Type l)
fields2))
         mergeTypeBoundProcedures Type l
t1 Type l
t2 = forall a. HasCallStack => String -> a
error (forall a. Int -> [a] -> [a]
take Int
90 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Type l
t1)
            
instance (Ord (Abstract.QualIdent l),
          Atts (Synthesized (Auto TypeCheck)) (Abstract.FPSection l l Sem Sem) ~ SynTCSec l) =>
         Synthesizer (Auto TypeCheck) (AST.FormalParameters l l) Sem Placed where
   synthesis :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (FormalParameters
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (FormalParameters l l sem sem)
-> FormalParameters l l sem (Synthesized (Auto TypeCheck))
-> Atts
     (Synthesized (Auto TypeCheck)) (FormalParameters l l sem sem)
synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.FormalParameters ZipList
  (Sem
     (FPSection
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
sections Maybe (QualIdent l)
returnType) InhTC{Map (QualIdent l) (Type l)
env :: Map (QualIdent l) (Type l)
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env}
             (AST.FormalParameters ZipList (Synthesized (Auto TypeCheck) (FPSection l l sem sem))
sections' Maybe (QualIdent l)
_) =
      SynTCSig{$sel:errors:SynTCSig :: Folded [Error () l]
errors= forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((.errors) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) ZipList (Synthesized (Auto TypeCheck) (FPSection l l sem sem))
sections' forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap QualIdent l -> Folded [Error () l]
typeRefErrors Maybe (QualIdent l)
returnType,
               $sel:signatureType:SynTCSig :: Type l
signatureType= forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l. SynTCSec l -> [(Bool, Type l)]
sectionParameters forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) ZipList (Synthesized (Auto TypeCheck) (FPSection l l sem sem))
sections')
                              forall a b. (a -> b) -> a -> b
$ Maybe (QualIdent l)
returnType forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map (QualIdent l) (Type l)
env),
               $sel:signatureEnv:SynTCSig :: Map (QualIdent l) (Type l)
signatureEnv= forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l. SynTCSec l -> Environment l
sectionEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) ZipList (Synthesized (Auto TypeCheck) (FPSection l l sem sem))
sections'}
      where typeRefErrors :: QualIdent l -> Folded [Error () l]
typeRefErrors QualIdent l
q
               | forall k a. Ord k => k -> Map k a -> Bool
Map.member QualIdent l
q Map (QualIdent l) (Type l)
env = forall a. Monoid a => a
mempty
               | Bool
otherwise = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. QualIdent l -> ErrorType l
UnknownName QualIdent l
q)]

instance (Abstract.Wirthy l, Ord (Abstract.QualIdent l),
          Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l) =>
         Synthesizer (Auto TypeCheck) (AST.FPSection l l) Sem Placed where
   synthesis :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (FPSection
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (FPSection l l sem sem)
-> FPSection l l sem (Synthesized (Auto TypeCheck))
-> Atts (Synthesized (Auto TypeCheck)) (FPSection l l sem sem)
synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.FPSection Bool
var [Text]
names Sem
  (Type
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_typeDef) Atts (Inherited (Auto TypeCheck)) (FPSection l l sem sem)
_inheritance (AST.FPSection Bool
_var [Text]
_names Synthesized (Auto TypeCheck) (Type l l sem sem)
typeDef) =
      SynTCSec{$sel:errors:SynTCSec :: Folded [Error () l]
errors= (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
typeDef).errors,
               $sel:sectionParameters:SynTCSec :: [(Bool, Type l)]
sectionParameters= (Bool
var, forall l. SynTCType l -> Type l
definedType (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
typeDef)) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Text]
names,
               $sel:sectionEnv:SynTCSec :: Environment l
sectionEnv= forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) (forall l. SynTCType l -> Type l
definedType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
typeDef) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
names)}

instance (Abstract.Nameable l, Ord (Abstract.QualIdent l),
          Atts (Synthesized (Auto TypeCheck)) (Abstract.FormalParameters l l Sem Sem) ~ SynTCSig l,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.FieldList l l Sem Sem) ~ SynTCFields l,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.ConstExpression l l Sem Sem) ~ SynTCExp l) =>
         Synthesizer (Auto TypeCheck) (AST.Type l l) Sem Placed where
   synthesis :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (Type
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Type l l sem sem)
-> Type l l sem (Synthesized (Auto TypeCheck))
-> Atts (Synthesized (Auto TypeCheck)) (Type l l sem sem)
synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.TypeReference QualIdent l
q) InhTC{Environment l
env :: Environment l
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env} Type l l sem (Synthesized (Auto TypeCheck))
_ = 
      SynTCType{$sel:errors:SynTCType :: Folded [Error () l]
errors= if forall k a. Ord k => k -> Map k a -> Bool
Map.member QualIdent l
q Environment l
env then forall a. Monoid a => a
mempty else forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. QualIdent l -> ErrorType l
UnknownName QualIdent l
q)],
                $sel:typeName:SynTCType :: Maybe Text
typeName= forall l. Nameable l => QualIdent l -> Maybe Text
Abstract.getNonQualIdentName QualIdent l
q,
                $sel:pointerTarget:SynTCType :: Maybe Text
pointerTarget= forall a. Maybe a
Nothing,
                $sel:definedType:SynTCType :: Type l
definedType= forall a. a -> Maybe a -> a
fromMaybe forall l. Type l
UnknownType (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent l
q Environment l
env)}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.ArrayType ZipList
  (Sem
     (ConstExpression
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
_dims Sem
  (Type
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_itemType) InhTC{} (AST.ArrayType ZipList
  (Synthesized (Auto TypeCheck) (ConstExpression l l sem sem))
dimensions Synthesized (Auto TypeCheck) (Type l l sem sem)
itemType) =
      SynTCType{$sel:errors:SynTCType :: Folded [Error () l]
errors= forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((.errors) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) ZipList
  (Synthesized (Auto TypeCheck) (ConstExpression l l sem sem))
dimensions
                        forall a. Semigroup a => a -> a -> a
<> (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
itemType).errors
                        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (SynTCExp l -> Folded [Error () l]
expectInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) ZipList
  (Synthesized (Auto TypeCheck) (ConstExpression l l sem sem))
dimensions,
                $sel:typeName:SynTCType :: Maybe Text
typeName= forall a. Maybe a
Nothing,
                $sel:pointerTarget:SynTCType :: Maybe Text
pointerTarget= forall a. Maybe a
Nothing,
                $sel:definedType:SynTCType :: Type l
definedType= forall l. [Int] -> Type l -> Type l
ArrayType (forall {l}. SynTCExp l -> Int
integerValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ZipList a -> [a]
getZipList ZipList
  (Synthesized (Auto TypeCheck) (ConstExpression l l sem sem))
dimensions) (forall l. SynTCType l -> Type l
definedType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
itemType)}
     where expectInteger :: SynTCExp l -> Folded [Error () l]
expectInteger SynTCExp{$sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= IntegerType{}} = forall a. Monoid a => a
mempty
           expectInteger SynTCExp{$sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t} = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonIntegerType Type l
t)]
           integerValue :: SynTCExp l -> Int
integerValue SynTCExp{$sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= IntegerType Int
n} = Int
n
           integerValue SynTCExp l
_ = Int
0
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.RecordType Maybe (QualIdent l)
base ZipList
  (Sem
     (FieldList
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
fields) InhTC{Environment l
env :: Environment l
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env} (AST.RecordType Maybe (QualIdent l)
_base ZipList (Synthesized (Auto TypeCheck) (FieldList l l sem sem))
fields') =
      SynTCType{$sel:errors:SynTCType :: Folded [Error () l]
errors= forall a b. (a, b) -> a
fst (Folded [Error () l], Maybe (Type l))
baseRecord forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((.errors) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) ZipList (Synthesized (Auto TypeCheck) (FieldList l l sem sem))
fields',
                $sel:typeName:SynTCType :: Maybe Text
typeName= forall a. Maybe a
Nothing,
                $sel:pointerTarget:SynTCType :: Maybe Text
pointerTarget= forall a. Maybe a
Nothing,
                $sel:definedType:SynTCType :: Type l
definedType= forall l. [QualIdent l] -> Map Text (Type l) -> Type l
RecordType (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe (QualIdent l)
base forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. Type l -> [QualIdent l]
ancestry) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (Folded [Error () l], Maybe (Type l))
baseRecord)
                                        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall k a. Map k a
Map.empty forall l. Type l -> Map Text (Type l)
recordFields (forall a b. (a, b) -> b
snd (Folded [Error () l], Maybe (Type l))
baseRecord)
                                         forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l. SynTCFields l -> Map Text (Type l)
fieldEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) ZipList (Synthesized (Auto TypeCheck) (FieldList l l sem sem))
fields')}
     where baseRecord :: (Folded [Error () l], Maybe (Type l))
baseRecord = case forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Environment l
env forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (QualIdent l)
base
                        of Just (Just t :: Type l
t@RecordType{}) -> (forall a. Monoid a => a
mempty, forall a. a -> Maybe a
Just Type l
t)
                           Just (Just (NominalType QualIdent l
_ (Just t :: Type l
t@RecordType{}))) -> (forall a. Monoid a => a
mempty, forall a. a -> Maybe a
Just Type l
t)
                           Just (Just Type l
t) -> (forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonRecordType Type l
t)], forall a. Maybe a
Nothing)
                           Just Maybe (Type l)
Nothing ->
                              (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> Folded a
Folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. QualIdent l -> ErrorType l
UnknownName) Maybe (QualIdent l)
base, forall a. Maybe a
Nothing)
                           Maybe (Maybe (Type l))
Nothing -> (forall a. Monoid a => a
mempty, forall a. Maybe a
Nothing)
   synthesis (Auto TypeCheck
TypeCheck) Placed
  (Type
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_self Atts (Inherited (Auto TypeCheck)) (Type l l sem sem)
_inheritance (AST.PointerType Synthesized (Auto TypeCheck) (Type l l sem sem)
targetType') =
      SynTCType{$sel:errors:SynTCType :: Folded [Error () l]
errors= (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
targetType').errors,
                $sel:typeName:SynTCType :: Maybe Text
typeName= forall a. Maybe a
Nothing,
                $sel:pointerTarget:SynTCType :: Maybe Text
pointerTarget= forall l. SynTCType l -> Maybe Text
typeName (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
targetType'),
                $sel:definedType:SynTCType :: Type l
definedType= forall l. Type l -> Type l
PointerType (forall l. SynTCType l -> Type l
definedType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
targetType')}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.ProcedureType Maybe
  (Sem
     (FormalParameters
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
signature) Atts (Inherited (Auto TypeCheck)) (Type l l sem sem)
_inheritance (AST.ProcedureType Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
signature') = 
      SynTCType{$sel:errors:SynTCType :: Folded [Error () l]
errors= forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((.errors) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
signature',
                $sel:typeName:SynTCType :: Maybe Text
typeName= forall a. Maybe a
Nothing,
                $sel:pointerTarget:SynTCType :: Maybe Text
pointerTarget= forall a. Maybe a
Nothing,
                $sel:definedType:SynTCType :: Type l
definedType= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [] forall a. Maybe a
Nothing) (forall l. SynTCSig l -> Type l
signatureType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (FormalParameters l l sem sem))
signature'}

instance (Abstract.Nameable l, Atts (Synthesized (Auto TypeCheck)) (Abstract.Type l l Sem Sem) ~ SynTCType l) =>
         SynthesizedField "fieldEnv" (Map AST.Ident (Type l)) (Auto TypeCheck) (AST.FieldList l l) Sem Placed where
   synthesizedField :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Proxy "fieldEnv"
-> Auto TypeCheck
-> Placed
     (FieldList
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (FieldList l l sem sem)
-> FieldList l l sem (Synthesized (Auto TypeCheck))
-> Map Text (Type l)
synthesizedField Proxy "fieldEnv"
_ Auto TypeCheck
_ (LexicalPosition
_, AST.FieldList IdentList l
names Sem
  (Type
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_declaredType) Atts (Inherited (Auto TypeCheck)) (FieldList l l sem sem)
_inheritance (AST.FieldList IdentList l
_names Synthesized (Auto TypeCheck) (Type l l sem sem)
declaredType) =
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\IdentDef l
name-> forall k a. k -> a -> Map k a
Map.singleton (forall l. Nameable l => IdentDef l -> Text
Abstract.getIdentDefName IdentDef l
name) (forall l. SynTCType l -> Type l
definedType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Type l l sem sem)
declaredType)) IdentList l
names

instance (Abstract.Wirthy l, Abstract.Nameable l, Ord (Abstract.QualIdent l),
          Atts (Inherited (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ InhTC l,
          Atts (Inherited (Auto TypeCheck)) (Abstract.ConditionalBranch l l Sem Sem) ~ InhTC l,
          Atts (Inherited (Auto TypeCheck)) (Abstract.Case l l Sem Sem) ~ InhTCExp l,
          Atts (Inherited (Auto TypeCheck)) (Abstract.WithAlternative l l Sem Sem) ~ InhTC l,
          Atts (Inherited (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ InhTC l,
          Atts (Inherited (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ InhTC l,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l) =>
         Bequether (Auto TypeCheck) (AST.Statement l l) Sem Placed where
   bequest :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (Statement
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
-> Statement l l sem (Synthesized (Auto TypeCheck))
-> Statement l l sem (Inherited (Auto TypeCheck))
bequest Auto TypeCheck
_ (LexicalPosition
_pos, AST.CaseStatement{}) i :: Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
i@InhTC{Map (QualIdent l) (Type l)
env :: Map (QualIdent l) (Type l)
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env} (AST.CaseStatement Synthesized (Auto TypeCheck) (Expression l l sem sem)
value ZipList (Synthesized (Auto TypeCheck) (Case l l sem sem))
_branches Maybe
  (Synthesized (Auto TypeCheck) (StatementSequence l l sem sem))
_fallback) =
      forall λ l (f' :: * -> *) (f :: * -> *).
f (Expression l l f' f')
-> ZipList (f (Case l l f' f'))
-> Maybe (f (StatementSequence l l f' f'))
-> Statement λ l f' f
AST.CaseStatement (forall t a. Atts (Inherited t) a -> Inherited t a
Inherited Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
i) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhTCExp{$sel:env:InhTCExp :: Map (QualIdent l) (Type l)
env= Map (QualIdent l) (Type l)
env,
                                                                 $sel:expectedType:InhTCExp :: Type l
expectedType= forall l. SynTCExp l -> Type l
inferredType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
value})
                        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
i)
   bequest Auto TypeCheck
_ (LexicalPosition
_pos, Statement
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
statement) InhTC{Map (QualIdent l) (Type l)
env :: Map (QualIdent l) (Type l)
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env} Statement l l sem (Synthesized (Auto TypeCheck))
_ =
      forall {k} t (g :: k -> (* -> *) -> *) (shallow :: * -> *)
       (deep :: k) atts.
Functor (PassDown t shallow atts) (g deep) =>
atts -> g deep shallow -> g deep (Inherited t)
AG.passDown InhTCExp{$sel:env:InhTCExp :: Map (QualIdent l) (Type l)
env= Map (QualIdent l) (Type l)
env,
                           $sel:expectedType:InhTCExp :: Type l
expectedType= forall a. HasCallStack => String -> a
error String
"No statement except CASE needs expectedType"} Statement
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
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,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ SynTCDes l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Case l l Sem Sem) ~ SynTC l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.ConditionalBranch l l Sem Sem) ~ SynTC l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.WithAlternative l l Sem Sem) ~ SynTC l) =>
                          Synthesizer (Auto TypeCheck) (AST.Statement l l) Sem Placed where
   synthesis :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (Statement
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
-> Statement l l sem (Synthesized (Auto TypeCheck))
-> Atts (Synthesized (Auto TypeCheck)) (Statement l l sem sem)
synthesis Auto TypeCheck
t (LexicalPosition
pos, Statement
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) InhTC{} statement :: Statement l l sem (Synthesized (Auto TypeCheck))
statement@(AST.Assignment Synthesized (Auto TypeCheck) (Designator l l sem sem)
var Synthesized (Auto TypeCheck) (Expression l l sem sem)
value) =
      {-# SCC "Assignment" #-}
      SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos (forall l. SynTCDes l -> Type l
designatorType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
var) (forall l. SynTCExp l -> Type l
inferredType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
value)
                    forall a. Semigroup a => a -> a -> a
<> forall {k} (name :: Symbol) t (g :: k -> (* -> *) -> *) a
       (sem :: k).
(Monoid a, Foldable (Accumulator t name a) (g sem)) =>
Proxy name -> t -> g sem (Synthesized t) -> Folded a
AG.foldedField (forall {k} (t :: k). Proxy t
Proxy :: Proxy "errors") Auto TypeCheck
t Statement l l sem (Synthesized (Auto TypeCheck))
statement}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.ProcedureCall Sem
  (Designator
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_proc Maybe
  (ZipList
     (Sem
        (Expression
           l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))))
parameters) Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
_inheritance (AST.ProcedureCall Synthesized (Auto TypeCheck) (Designator l l sem sem)
procedure' Maybe
  (ZipList (Synthesized (Auto TypeCheck) (Expression l l sem sem)))
parameters') =
      SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= (case forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
procedure'
                     of SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [],
                                 $sel:designatorType:SynTCDes :: forall l. SynTCDes l -> Type l
designatorType= Type l
t} -> Type l -> Folded [Error () l]
procedureErrors Type l
t
                        SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [Error () l]
errs} -> Folded [Error () l]
errs)
                    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((.errors) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn)) Maybe
  (ZipList (Synthesized (Auto TypeCheck) (Expression l l sem sem)))
parameters'}
     where procedureErrors :: Type l -> Folded [Error () l]
procedureErrors (ProcedureType Bool
_ [(Bool, Type l)]
formalTypes Maybe (Type l)
Nothing)
             | forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Type l)]
formalTypes forall a. Eq a => a -> a -> Bool
/= forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ZipList a -> [a]
getZipList) Maybe
  (ZipList
     (Sem
        (Expression
           l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))))
parameters,
               Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Type l)]
formalTypes forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ZipList a -> [a]
getZipList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe
  (ZipList
     (Sem
        (Expression
           l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))))
parameters) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
1
                    Bool -> Bool -> Bool
&& forall l. SynTCDes l -> Maybe (Maybe Text, Text)
designatorName (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
procedure') forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (forall a. Maybe a
Nothing, Text
"ASSERT")
                    Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Type l)]
formalTypes forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ZipList a -> [a]
getZipList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe
  (ZipList
     (Sem
        (Expression
           l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))))
parameters) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
2
                    Bool -> Bool -> Bool
&& forall l. SynTCDes l -> Maybe (Maybe Text, Text)
designatorName (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
procedure') forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (forall a. Maybe a
Nothing, Text
"NEW")
                    Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall {l}. Type l -> Bool
isIntegerType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. SynTCExp l -> Type l
inferredType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ZipList a -> [a]
getZipList) Maybe
  (ZipList (Synthesized (Auto TypeCheck) (Expression l l sem sem)))
parameters') =
                 forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos
                         forall a b. (a -> b) -> a -> b
$ forall l. Int -> Int -> ErrorType l
ArgumentCountMismatch (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Type l)]
formalTypes) forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ZipList a -> [a]
getZipList) Maybe
  (ZipList
     (Sem
        (Expression
           l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))))
parameters]
             | Bool
otherwise = forall a. Monoid a => [a] -> a
mconcat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> (Bool, Type l) -> Type l -> Folded [Error () l]
parameterCompatible LexicalPosition
pos) [(Bool, Type l)]
formalTypes
                                    forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall l. SynTCExp l -> Type l
inferredType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ZipList a -> [a]
getZipList) Maybe
  (ZipList (Synthesized (Auto TypeCheck) (Expression l l sem sem)))
parameters')
           procedureErrors (NominalType QualIdent l
_ (Just Type l
t)) = Type l -> Folded [Error () l]
procedureErrors Type l
t
           procedureErrors Type l
t = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonProcedureType Type l
t)]
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Statement
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
_inheritance (AST.While Synthesized (Auto TypeCheck) (Expression l l sem sem)
condition Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body) =
      SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
booleanExpressionErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
condition) forall a. Semigroup a => a -> a -> a
<> (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body).errors}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Statement
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
_inheritance (AST.Repeat Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body Synthesized (Auto TypeCheck) (Expression l l sem sem)
condition) =
      SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
booleanExpressionErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
condition) forall a. Semigroup a => a -> a -> a
<> (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body).errors}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Statement
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
_inheritance (AST.For Text
_counter Synthesized (Auto TypeCheck) (Expression l l sem sem)
start Synthesized (Auto TypeCheck) (Expression l l sem sem)
end Maybe (Synthesized (Auto TypeCheck) (Expression l l sem sem))
step Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body) =
      SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
start) 
                    forall a. Semigroup a => a -> a -> a
<> forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
end)
                    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors LexicalPosition
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Maybe (Synthesized (Auto TypeCheck) (Expression l l sem sem))
step forall a. Semigroup a => a -> a -> a
<> (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body).errors}
   synthesis Auto TypeCheck
t Placed
  (Statement
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
self Atts (Inherited (Auto TypeCheck)) (Statement l l sem sem)
_ Statement l l sem (Synthesized (Auto TypeCheck))
statement = SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= forall {k} (name :: Symbol) t (g :: k -> (* -> *) -> *) a
       (sem :: k).
(Monoid a, Foldable (Accumulator t name a) (g sem)) =>
Proxy name -> t -> g sem (Synthesized t) -> Folded a
AG.foldedField (forall {k} (t :: k). Proxy t
Proxy :: Proxy "errors") Auto TypeCheck
t Statement l l sem (Synthesized (Auto TypeCheck))
statement}

instance (Abstract.Nameable l, Ord (Abstract.QualIdent l),
          Atts (Inherited (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ InhTC l,
          Atts (Synthesized (Auto TypeCheck)) (Abstract.StatementSequence l l Sem Sem) ~ SynTC l) =>
         Attribution (Auto TypeCheck) (AST.WithAlternative l l) Sem Placed where
   attribution :: Auto TypeCheck
-> Placed
     (WithAlternative
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Rule (Auto TypeCheck) (WithAlternative l l)
attribution Auto TypeCheck
_ (LexicalPosition
pos, AST.WithAlternative QualIdent l
var QualIdent l
subtype Sem
  (StatementSequence
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_body)
               (Inherited InhTC{Environment l
env :: Environment l
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env},
                AST.WithAlternative QualIdent l
_var QualIdent l
_subtype Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body) =
      (forall t a. Atts (Synthesized t) a -> Synthesized t a
Synthesized SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= case (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent l
var Environment l
env, forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent l
subtype Environment l
env)
                                 of (Just Type l
supertype, Just Type l
subtypeDef) ->
                                      forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
supertype Type l
subtypeDef
                                    (Maybe (Type l)
Nothing, Maybe (Type l)
_) -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. QualIdent l -> ErrorType l
UnknownName QualIdent l
var)]
                                    (Maybe (Type l)
_, Maybe (Type l)
Nothing) -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. QualIdent l -> ErrorType l
UnknownName QualIdent l
subtype)]
                                 forall a. Semigroup a => a -> a -> a
<> (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body).errors},
       forall λ l (f' :: * -> *) (f :: * -> *).
QualIdent l
-> QualIdent l
-> f (StatementSequence l l f' f')
-> WithAlternative λ l f' f
AST.WithAlternative QualIdent l
var QualIdent l
subtype (forall t a. Atts (Inherited t) a -> Inherited t a
Inherited forall a b. (a -> b) -> a -> b
$ forall l. Environment l -> InhTC l
InhTC forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QualIdent l
var) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent l
subtype Environment l
env) Environment l
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 :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (ConditionalBranch
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts
     (Inherited (Auto TypeCheck)) (ConditionalBranch l l sem sem)
-> ConditionalBranch l l sem (Synthesized (Auto TypeCheck))
-> Atts
     (Synthesized (Auto TypeCheck)) (ConditionalBranch l l sem sem)
synthesis Auto TypeCheck
_ (LexicalPosition
pos, ConditionalBranch
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (ConditionalBranch l l sem sem)
_inheritance (AST.ConditionalBranch Synthesized (Auto TypeCheck) (Expression l l sem sem)
condition Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body) =
      SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
booleanExpressionErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
condition) forall a. Semigroup a => a -> a -> a
<> (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (StatementSequence l l sem sem)
body).errors}

instance {-# overlaps #-} (Abstract.Nameable l, Eq (Abstract.QualIdent l),
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.ConstExpression l l Sem Sem) ~ SynTCExp l) =>
                          Synthesizer (Auto TypeCheck) (AST.CaseLabels l l) Sem Placed where
   synthesis :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (CaseLabels
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (CaseLabels l l sem sem)
-> CaseLabels l l sem (Synthesized (Auto TypeCheck))
-> Atts (Synthesized (Auto TypeCheck)) (CaseLabels l l sem sem)
synthesis Auto TypeCheck
_ (LexicalPosition
pos, CaseLabels
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (CaseLabels l l sem sem)
inheritance (AST.SingleLabel Synthesized (Auto TypeCheck) (ConstExpression l l sem sem)
value) =
      SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= forall l.
(Nameable l, Eq (QualIdent l)) =>
InhTCExp l -> LexicalPosition -> Type l -> Folded [Error () l]
assignmentCompatibleIn Atts (Inherited (Auto TypeCheck)) (CaseLabels l l sem sem)
inheritance LexicalPosition
pos (forall l. SynTCExp l -> Type l
inferredType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (ConstExpression l l sem sem)
value)}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, CaseLabels
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (CaseLabels l l sem sem)
inheritance (AST.LabelRange Synthesized (Auto TypeCheck) (ConstExpression l l sem sem)
start Synthesized (Auto TypeCheck) (ConstExpression l l sem sem)
end) =
      SynTC{$sel:errors:SynTC :: Folded [Error () l]
errors= forall l.
(Nameable l, Eq (QualIdent l)) =>
InhTCExp l -> LexicalPosition -> Type l -> Folded [Error () l]
assignmentCompatibleIn Atts (Inherited (Auto TypeCheck)) (CaseLabels l l sem sem)
inheritance LexicalPosition
pos (forall l. SynTCExp l -> Type l
inferredType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (ConstExpression l l sem sem)
start)
                    forall a. Semigroup a => a -> a -> a
<> forall l.
(Nameable l, Eq (QualIdent l)) =>
InhTCExp l -> LexicalPosition -> Type l -> Folded [Error () l]
assignmentCompatibleIn Atts (Inherited (Auto TypeCheck)) (CaseLabels l l sem sem)
inheritance LexicalPosition
pos (forall l. SynTCExp l -> Type l
inferredType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (ConstExpression l l sem sem)
end)}

instance {-# overlaps #-} (Abstract.Nameable l, Ord (Abstract.QualIdent l),
                           Atts (Inherited (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ InhTC l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Element l l Sem Sem) ~ SynTCExp l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Value l l Sem Sem) ~ SynTCExp l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ SynTCDes l) =>
                          Synthesizer (Auto TypeCheck) (AST.Expression l l) Sem Placed where
   synthesis :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (Expression
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
-> Expression l l sem (Synthesized (Auto TypeCheck))
-> Atts (Synthesized (Auto TypeCheck)) (Expression l l sem sem)
synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.Relation RelOp
op Sem
  (Expression
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_ Sem
  (Expression
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_) InhTC{} (AST.Relation RelOp
_op Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= case (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
left).errors forall a. Semigroup a => a -> a -> a
<> (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
right).errors
                       of Folded []
                            | Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2 -> forall a. Monoid a => a
mempty
                            | RelOp
AST.In <- RelOp
op -> Type l -> Type l -> Folded [Error () l]
membershipCompatible (forall l. Type l -> Type l
ultimate Type l
t1) (forall l. Type l -> Type l
ultimate Type l
t2)
                            | RelOp -> Bool
equality RelOp
op,
                              Folded [] <- forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
t1 Type l
t2
                              -> forall a. Monoid a => a
mempty
                            | RelOp -> Bool
equality RelOp
op,
                              Folded [] <- forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
t2 Type l
t1
                              -> forall a. Monoid a => a
mempty
                            | Bool
otherwise -> Type l -> Type l -> Folded [Error () l]
comparable (forall l. Type l -> Type l
ultimate Type l
t1) (forall l. Type l -> Type l
ultimate Type l
t2)
                          Folded [Error () l]
errs -> Folded [Error () l]
errs,
               $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"}
      where t1 :: Type l
t1 = forall l. SynTCExp l -> Type l
inferredType (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
left)
            t2 :: Type l
t2 = forall l. SynTCExp l -> Type l
inferredType (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
right)
            equality :: RelOp -> Bool
equality RelOp
AST.Equal = Bool
True
            equality RelOp
AST.Unequal = Bool
True
            equality RelOp
_ = Bool
False
            comparable :: Type l -> Type l -> Folded [Error () l]
comparable (BuiltinType Text
"BOOLEAN") (BuiltinType Text
"BOOLEAN") = forall a. Monoid a => a
mempty
            comparable (BuiltinType Text
"CHAR") (BuiltinType Text
"CHAR") = forall a. Monoid a => a
mempty
            comparable StringType{} StringType{} = forall a. Monoid a => a
mempty
            comparable (StringType Int
1) (BuiltinType Text
"CHAR") = forall a. Monoid a => a
mempty
            comparable (BuiltinType Text
"CHAR") (StringType Int
1) = forall a. Monoid a => a
mempty
            comparable StringType{} (ArrayType [Int]
_ (BuiltinType Text
"CHAR")) = forall a. Monoid a => a
mempty
            comparable (ArrayType [Int]
_ (BuiltinType Text
"CHAR")) StringType{} = forall a. Monoid a => a
mempty
            comparable (ArrayType [Int]
_ (BuiltinType Text
"CHAR")) (ArrayType [Int]
_ (BuiltinType Text
"CHAR")) = forall a. Monoid a => a
mempty
            comparable (BuiltinType Text
t1) (BuiltinType Text
t2)
               | Text -> Bool
isNumerical Text
t1 Bool -> Bool -> Bool
&& Text -> Bool
isNumerical Text
t2 = forall a. Monoid a => a
mempty
            comparable (BuiltinType Text
t1) IntegerType{}
               | Text -> Bool
isNumerical Text
t1 = forall a. Monoid a => a
mempty
            comparable IntegerType{} (BuiltinType Text
t2)
               | Text -> Bool
isNumerical Text
t2 = forall a. Monoid a => a
mempty
            comparable Type l
t1 Type l
t2 = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> Type l -> ErrorType l
IncomparableTypes Type l
t1 Type l
t2)]
            membershipCompatible :: Type l -> Type l -> Folded [Error () l]
membershipCompatible IntegerType{} (BuiltinType Text
"SET") = forall a. Monoid a => a
mempty
            membershipCompatible (BuiltinType Text
t1) (BuiltinType Text
"SET")
               | Text -> Bool
isNumerical Text
t1 = forall a. Monoid a => a
mempty
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.IsA Sem
  (Expression
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_ QualIdent l
q) InhTC{Environment l
env :: Environment l
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env} (AST.IsA Synthesized (Auto TypeCheck) (Expression l l sem sem)
left QualIdent l
_) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent l
q Environment l
env
                       of Maybe (Type l)
Nothing -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. QualIdent l -> ErrorType l
UnknownName QualIdent l
q)]
                          Just Type l
t -> forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos (forall l. SynTCExp l -> Type l
inferredType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
left) Type l
t,
               $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.Positive Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= forall l.
Nameable l =>
LexicalPosition -> SynTCExp l -> Folded [Error () l]
unaryNumericOrSetOperatorErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr),
               $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. SynTCExp l -> Type l
inferredType (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr)}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.Negative Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= forall l.
Nameable l =>
LexicalPosition -> SynTCExp l -> Folded [Error () l]
unaryNumericOrSetOperatorErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr),
               $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. (Int -> Int) -> SynTCExp l -> Type l
unaryNumericOrSetOperatorType forall a. Num a => a -> a
negate (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr)}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.Add Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right) = forall {t} {a} {l} {t} {a}.
(Atts (Synthesized t) a ~ SynTCExp l,
 Atts (Synthesized t) a ~ SynTCExp l, Nameable l,
 Eq (QualIdent l)) =>
LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryNumericOrSetSynthesis LexicalPosition
pos Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.Subtract Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right) = forall {t} {a} {l} {t} {a}.
(Atts (Synthesized t) a ~ SynTCExp l,
 Atts (Synthesized t) a ~ SynTCExp l, Nameable l,
 Eq (QualIdent l)) =>
LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryNumericOrSetSynthesis LexicalPosition
pos Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.Or Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right) = forall {t} {a} {l} {t} {a}.
(Atts (Synthesized t) a ~ SynTCExp l,
 Atts (Synthesized t) a ~ SynTCExp l, Nameable l,
 Eq (QualIdent l)) =>
LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryBooleanSynthesis LexicalPosition
pos Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.Multiply Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right) = forall {t} {a} {l} {t} {a}.
(Atts (Synthesized t) a ~ SynTCExp l,
 Atts (Synthesized t) a ~ SynTCExp l, Nameable l,
 Eq (QualIdent l)) =>
LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryNumericOrSetSynthesis LexicalPosition
pos Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) InhTC{} (AST.Divide Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors=
                  case (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
left, forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
right)
                  of (SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= BuiltinType Text
t1},
                      SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= BuiltinType Text
t2})
                        | Text
t1 forall a. Eq a => a -> a -> Bool
== Text
"REAL", Text
t2 forall a. Eq a => a -> a -> Bool
== Text
"REAL" -> forall a. Monoid a => a
mempty
                        | Text
t1 forall a. Eq a => a -> a -> Bool
== Text
"SET", Text
t2 forall a. Eq a => a -> a -> Bool
== Text
"SET" -> forall a. Monoid a => a
mempty
                     (SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t1},
                      SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t2})
                       | Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2 -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
UnrealType Type l
t1)]
                       | Bool
otherwise -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> Type l -> ErrorType l
TypeMismatch Type l
t1 Type l
t2)],
               $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. Text -> Type l
BuiltinType Text
"REAL"}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.IntegerDivide Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right) = forall {t} {a} {l} {t} {a}.
(Atts (Synthesized t) a ~ SynTCExp l,
 Atts (Synthesized t) a ~ SynTCExp l, Nameable l,
 Eq (QualIdent l)) =>
LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryIntegerSynthesis LexicalPosition
pos Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.Modulo Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right) = forall {t} {a} {l} {t} {a}.
(Atts (Synthesized t) a ~ SynTCExp l,
 Atts (Synthesized t) a ~ SynTCExp l, Nameable l,
 Eq (QualIdent l)) =>
LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryIntegerSynthesis LexicalPosition
pos Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.And Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right) = forall {t} {a} {l} {t} {a}.
(Atts (Synthesized t) a ~ SynTCExp l,
 Atts (Synthesized t) a ~ SynTCExp l, Nameable l,
 Eq (QualIdent l)) =>
LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryBooleanSynthesis LexicalPosition
pos Synthesized (Auto TypeCheck) (Expression l l sem sem)
left Synthesized (Auto TypeCheck) (Expression l l sem sem)
right
   synthesis (Auto TypeCheck
TypeCheck) Placed
  (Expression
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_self Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_ (AST.Set ZipList (Synthesized (Auto TypeCheck) (Element l l sem sem))
elements) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= forall a. Monoid a => a
mempty,
               $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. Text -> Type l
BuiltinType Text
"SET"}
   synthesis (Auto TypeCheck
TypeCheck) Placed
  (Expression
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_self Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_ (AST.Read Synthesized (Auto TypeCheck) (Designator l l sem sem)
designator) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
designator).errors,
               $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. SynTCDes l -> Type l
designatorType (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
designator)}
   synthesis (Auto TypeCheck
TypeCheck) Placed
  (Expression
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_self Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_ (AST.Literal Synthesized (Auto TypeCheck) (Value l l sem sem)
value) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Value l l sem sem)
value).errors,
               $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. SynTCExp l -> Type l
inferredType (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Value l l sem sem)
value)}
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.FunctionCall Sem
  (Designator
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_designator (ZipList [Sem
   (Expression
      l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))]
parameters)) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance
             (AST.FunctionCall Synthesized (Auto TypeCheck) (Designator l l sem sem)
designator (ZipList [Synthesized (Auto TypeCheck) (Expression l l sem sem)]
parameters')) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors=
                   case {-# SCC "FunctionCall" #-} forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
designator
                   of SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [],
                               $sel:designatorName:SynTCDes :: forall l. SynTCDes l -> Maybe (Maybe Text, Text)
designatorName= Maybe (Maybe Text, Text)
name,
                               $sel:designatorType:SynTCDes :: forall l. SynTCDes l -> Type l
designatorType= forall l. Type l -> Type l
ultimate -> ProcedureType Bool
_ [(Bool, Type l)]
formalTypes Just{}}
                        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Type l)]
formalTypes forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Sem
   (Expression
      l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))]
parameters ->
                            forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos
                                    forall a b. (a -> b) -> a -> b
$ forall l. Int -> Int -> ErrorType l
ArgumentCountMismatch (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Type l)]
formalTypes) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Sem
   (Expression
      l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))]
parameters)]
                        | Maybe (Maybe Text, Text)
name forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just Text
"SYSTEM", Text
"VAL") -> forall a. Monoid a => a
mempty
                        | Bool
otherwise -> forall a. Monoid a => [a] -> a
mconcat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> (Bool, Type l) -> Type l -> Folded [Error () l]
parameterCompatible LexicalPosition
pos) [(Bool, Type l)]
formalTypes
                                                forall a b. (a -> b) -> a -> b
$ forall l. SynTCExp l -> Type l
inferredType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Synthesized (Auto TypeCheck) (Expression l l sem sem)]
parameters')
                      SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [],
                               $sel:designatorType:SynTCDes :: forall l. SynTCDes l -> Type l
designatorType= Type l
t} -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonFunctionType Type l
t)]
                      SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [Error () l]
errs} -> Folded [Error () l]
errs
                   forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((.errors) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) [Synthesized (Auto TypeCheck) (Expression l l sem sem)]
parameters',
               $sel:inferredType:SynTCExp :: Type l
inferredType=
                   case forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
designator
                   of SynTCDes{$sel:designatorName:SynTCDes :: forall l. SynTCDes l -> Maybe (Maybe Text, Text)
designatorName= Just (Just Text
"SYSTEM", Text
name)}
                        | Just Type l
t <- forall {a} {a}. (Eq a, IsString a) => a -> [a] -> Maybe a
systemCallType Text
name (forall l. SynTCExp l -> Type l
inferredType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Synthesized (Auto TypeCheck) (Expression l l sem sem)]
parameters') -> Type l
t
                      SynTCDes{$sel:designatorName:SynTCDes :: forall l. SynTCDes l -> Maybe (Maybe Text, Text)
designatorName= Maybe (Maybe Text, Text)
d, $sel:designatorType:SynTCDes :: forall l. SynTCDes l -> Type l
designatorType= Type l
t}
                        | ProcedureType Bool
_ [(Bool, Type l)]
_ (Just Type l
returnType) <- forall l. Type l -> Type l
ultimate Type l
t -> Type l
returnType
                      Atts
  (Synthesized (Auto TypeCheck))
  (Designator
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_ -> forall l. Type l
UnknownType}
     where systemCallType :: a -> [a] -> Maybe a
systemCallType a
"VAL" [a
t1, a
t2] = forall a. a -> Maybe a
Just a
t1
           systemCallType a
_ [a]
_ = forall a. Maybe a
Nothing
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Expression
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Expression l l sem sem)
_inheritance (AST.Not Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr) =
      SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
booleanExpressionErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr),
               $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"}
  
instance Abstract.Wirthy l => SynthesizedField "inferredType" (Type l) (Auto TypeCheck) (AST.Value l l) Sem Placed where
   synthesizedField :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Proxy "inferredType"
-> Auto TypeCheck
-> Placed
     (Value
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Value l l sem sem)
-> Value l l sem (Synthesized (Auto TypeCheck))
-> Type l
synthesizedField Proxy "inferredType"
_ Auto TypeCheck
_ (LexicalPosition
_, AST.Integer Integer
x) Atts (Inherited (Auto TypeCheck)) (Value l l sem sem)
_ Value l l sem (Synthesized (Auto TypeCheck))
_  = forall l. Int -> Type l
IntegerType (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x)
   synthesizedField Proxy "inferredType"
_ Auto TypeCheck
_ (LexicalPosition
_, AST.Real Double
x) Atts (Inherited (Auto TypeCheck)) (Value l l sem sem)
_ Value l l sem (Synthesized (Auto TypeCheck))
_     = forall l. Text -> Type l
BuiltinType Text
"REAL"
   synthesizedField Proxy "inferredType"
_ Auto TypeCheck
_ (LexicalPosition
_, AST.Boolean Bool
x) Atts (Inherited (Auto TypeCheck)) (Value l l sem sem)
_ Value l l sem (Synthesized (Auto TypeCheck))
_  = forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"
   synthesizedField Proxy "inferredType"
_ Auto TypeCheck
_ (LexicalPosition
_, AST.CharCode Int
x) Atts (Inherited (Auto TypeCheck)) (Value l l sem sem)
_ Value l l sem (Synthesized (Auto TypeCheck))
_ = forall l. Text -> Type l
BuiltinType Text
"CHAR"
   synthesizedField Proxy "inferredType"
_ Auto TypeCheck
_ (LexicalPosition
_, AST.String Text
x) Atts (Inherited (Auto TypeCheck)) (Value l l sem sem)
_ Value l l sem (Synthesized (Auto TypeCheck))
_   = forall l. Int -> Type l
StringType (Text -> Int
Text.length Text
x)
   synthesizedField Proxy "inferredType"
_ Auto TypeCheck
_ (LexicalPosition
_, Value l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
AST.Nil) Atts (Inherited (Auto TypeCheck)) (Value l l sem sem)
_ Value l l sem (Synthesized (Auto TypeCheck))
_        = forall l. Type l
NilType
   synthesizedField Proxy "inferredType"
_ Auto TypeCheck
_ (LexicalPosition
_, AST.Builtin Text
x) Atts (Inherited (Auto TypeCheck)) (Value l l sem sem)
_ Value l l sem (Synthesized (Auto TypeCheck))
_  = forall l. Text -> Type l
BuiltinType Text
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 :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Proxy "errors"
-> Auto TypeCheck
-> Placed
     (Element
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Element l l sem sem)
-> Element l l sem (Synthesized (Auto TypeCheck))
-> Folded [Error () l]
synthesizedField Proxy "errors"
_ Auto TypeCheck
_ (LexicalPosition
pos, Element
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Element l l sem sem)
_inheritance (AST.Element Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr) = forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
expr)
   synthesizedField Proxy "errors"
_ Auto TypeCheck
_ (LexicalPosition
pos, Element
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) Atts (Inherited (Auto TypeCheck)) (Element l l sem sem)
_inheritance (AST.Range Synthesized (Auto TypeCheck) (Expression l l sem sem)
low Synthesized (Auto TypeCheck) (Expression l l sem sem)
high) = forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
high)
                                                                     forall a. Semigroup a => a -> a -> a
<> forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Expression l l sem sem)
low)

instance SynthesizedField "inferredType" (Type l) (Auto TypeCheck) (AST.Element l l) Sem Placed where
   synthesizedField :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Proxy "inferredType"
-> Auto TypeCheck
-> Placed
     (Element
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Element l l sem sem)
-> Element l l sem (Synthesized (Auto TypeCheck))
-> Type l
synthesizedField Proxy "inferredType"
_ Auto TypeCheck
_ Placed
  (Element
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_ Atts (Inherited (Auto TypeCheck)) (Element l l sem sem)
_ Element l l sem (Synthesized (Auto TypeCheck))
_ = forall l. Text -> Type l
BuiltinType Text
"SET"

instance {-# overlaps #-} (Abstract.Nameable l, Abstract.Oberon l, Ord (Abstract.QualIdent l),
                           Show (Abstract.QualIdent l),
                           Atts (Inherited (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ InhTC l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Expression l l Sem Sem) ~ SynTCExp l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Designator l l Sem Sem) ~ SynTCDes l) =>
                          Synthesizer (Auto TypeCheck) (AST.Designator l l) Sem Placed where
   synthesis :: forall (sem :: * -> *).
(sem ~ Semantics (Auto TypeCheck)) =>
Auto TypeCheck
-> Placed
     (Designator
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Atts (Inherited (Auto TypeCheck)) (Designator l l sem sem)
-> Designator l l sem (Synthesized (Auto TypeCheck))
-> Atts (Synthesized (Auto TypeCheck)) (Designator l l sem sem)
synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.Variable QualIdent l
q) InhTC{Environment l
env :: Environment l
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env} Designator l l sem (Synthesized (Auto TypeCheck))
_ =
      SynTCDes{$sel:errors:SynTCDes :: Folded [Error () l]
errors= case Maybe (Type l)
designatorType
                       of Maybe (Type l)
Nothing -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. QualIdent l -> ErrorType l
UnknownName QualIdent l
q)]
                          Just{} -> forall a. Monoid a => a
mempty,
               $sel:designatorName:SynTCDes :: Maybe (Maybe Text, Text)
designatorName= (,) forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall l. Nameable l => QualIdent l -> Maybe Text
Abstract.getNonQualIdentName QualIdent l
q
                               forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall l. Oberon l => QualIdent l -> Maybe (Text, Text)
Abstract.getQualIdentNames QualIdent l
q,
               $sel:designatorType:SynTCDes :: Type l
designatorType= forall a. a -> Maybe a -> a
fromMaybe forall l. Type l
UnknownType Maybe (Type l)
designatorType}
      where designatorType :: Maybe (Type l)
designatorType = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent l
q Environment l
env
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.Field Sem
  (Designator
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_record Text
fieldName) InhTC{} (AST.Field Synthesized (Auto TypeCheck) (Designator l l sem sem)
record Text
_fieldName) =
      SynTCDes{$sel:errors:SynTCDes :: Folded [Error () l]
errors= case forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
record
                       of SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [],
                                   $sel:designatorType:SynTCDes :: forall l. SynTCDes l -> Type l
designatorType= Type l
t} ->
                             forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonRecordType Type l
t)])
                                   (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Text -> Type l -> ErrorType l
UnknownField Text
fieldName Type l
t)]) forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. Monoid a => a
mempty)
                                   (Bool -> Type l -> Maybe (Maybe (Type l))
access Bool
True Type l
t)
                          SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [Error () l]
errors} -> Folded [Error () l]
errors,
               $sel:designatorName:SynTCDes :: Maybe (Maybe Text, Text)
designatorName= forall a. Maybe a
Nothing,
               $sel:designatorType:SynTCDes :: Type l
designatorType= forall a. a -> Maybe a -> a
fromMaybe forall l. Type l
UnknownType (forall a. a -> Maybe a -> a
fromMaybe forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Bool -> Type l -> Maybe (Maybe (Type l))
access Bool
True
                                                      forall a b. (a -> b) -> a -> b
$ forall l. SynTCDes l -> Type l
designatorType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
record)}
     where access :: Bool -> Type l -> Maybe (Maybe (Type l))
access Bool
_ (RecordType [QualIdent l]
_ Map Text (Type l)
fields) = forall a. a -> Maybe a
Just (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
fieldName Map Text (Type l)
fields)
           access Bool
True (PointerType Type l
t) = Bool -> Type l -> Maybe (Maybe (Type l))
access Bool
False Type l
t
           access Bool
allowPtr (NominalType QualIdent l
_ (Just Type l
t)) = Bool -> Type l -> Maybe (Maybe (Type l))
access Bool
allowPtr Type l
t
           access Bool
allowPtr (ReceiverType Type l
t) = (forall l. Type l -> Type l
receive forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Type l -> Maybe (Maybe (Type l))
access Bool
allowPtr Type l
t
           access Bool
_ Type l
_ = forall a. Maybe a
Nothing
           receive :: Type l -> Type l
receive (ProcedureType Bool
_ [(Bool, Type l)]
params Maybe (Type l)
result) = forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
True [(Bool, Type l)]
params Maybe (Type l)
result
           receive Type l
t = Type l
t
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.Index Sem
  (Designator
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_array Sem
  (Expression
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
index ZipList
  (Sem
     (Expression
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
indexes) InhTC{} (AST.Index Synthesized (Auto TypeCheck) (Designator l l sem sem)
array Synthesized (Auto TypeCheck) (Expression l l sem sem)
_index ZipList (Synthesized (Auto TypeCheck) (Expression l l sem sem))
_indexes) =
      SynTCDes{$sel:errors:SynTCDes :: Folded [Error () l]
errors= case forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
array
                       of SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [],
                                   $sel:designatorType:SynTCDes :: forall l. SynTCDes l -> Type l
designatorType= Type l
t} -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) (Bool -> Type l -> Either (Folded [Error () l]) (Type l)
access Bool
True Type l
t)
                          SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [Error () l]
errors} -> Folded [Error () l]
errors,
               $sel:designatorName:SynTCDes :: Maybe (Maybe Text, Text)
designatorName= forall a. Maybe a
Nothing,
               $sel:designatorType:SynTCDes :: Type l
designatorType= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall l. Type l
UnknownType) forall a. a -> a
id (Bool -> Type l -> Either (Folded [Error () l]) (Type l)
access Bool
True forall a b. (a -> b) -> a -> b
$ forall l. SynTCDes l -> Type l
designatorType forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
array)}
      where access :: Bool -> Type l -> Either (Folded [Error () l]) (Type l)
access Bool
_ (ArrayType [Int]
dimensions Type l
t)
              | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
dimensions forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length ZipList
  (Sem
     (Expression
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
indexes forall a. Num a => a -> a -> a
+ Int
1 = forall a b. b -> Either a b
Right Type l
t
              | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
dimensions forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length ZipList
  (Sem
     (Expression
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
indexes forall a. Eq a => a -> a -> Bool
== Int
0 = forall a b. b -> Either a b
Right Type l
t
              | Bool
otherwise = forall a b. a -> Either a b
Left (forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos
                                          forall a b. (a -> b) -> a -> b
$ forall l. Int -> Int -> ErrorType l
ExtraDimensionalIndex (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
dimensions) (Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length ZipList
  (Sem
     (Expression
        l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))))
indexes)])
            access Bool
allowPtr (NominalType QualIdent l
_ (Just Type l
t)) = Bool -> Type l -> Either (Folded [Error () l]) (Type l)
access Bool
allowPtr Type l
t
            access Bool
allowPtr (ReceiverType Type l
t) = Bool -> Type l -> Either (Folded [Error () l]) (Type l)
access Bool
allowPtr Type l
t
            access Bool
True (PointerType Type l
t) = Bool -> Type l -> Either (Folded [Error () l]) (Type l)
access Bool
False Type l
t
            access Bool
_ Type l
t = forall a b. a -> Either a b
Left (forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonArrayType Type l
t)])
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, AST.TypeGuard Sem
  (Designator
     l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
_designator QualIdent l
q) InhTC{Environment l
env :: Environment l
$sel:env:InhTC :: forall l. InhTC l -> Environment l
env} (AST.TypeGuard Synthesized (Auto TypeCheck) (Designator l l sem sem)
designator QualIdent l
_q) =
      SynTCDes{$sel:errors:SynTCDes :: Folded [Error () l]
errors= case (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
designator, Maybe (Type l)
targetType)
                                 of (SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [],
                                              $sel:designatorType:SynTCDes :: forall l. SynTCDes l -> Type l
designatorType= Type l
t}, 
                                     Just Type l
t') -> forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
t Type l
t'
                                    (SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [Error () l]
errors}, 
                                     Maybe (Type l)
Nothing) -> forall a. a -> Folded a
Folded (forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. QualIdent l -> ErrorType l
UnknownName QualIdent l
q) forall a. a -> [a] -> [a]
: forall a. Folded a -> a
getFolded Folded [Error () l]
errors)
                                    (SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [Error () l]
errors}, Maybe (Type l)
_) -> Folded [Error () l]
errors,
               $sel:designatorName:SynTCDes :: Maybe (Maybe Text, Text)
designatorName= forall a. Maybe a
Nothing,
               $sel:designatorType:SynTCDes :: Type l
designatorType= forall a. a -> Maybe a -> a
fromMaybe forall l. Type l
UnknownType Maybe (Type l)
targetType}
      where targetType :: Maybe (Type l)
targetType = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent l
q Environment l
env
   synthesis Auto TypeCheck
_ (LexicalPosition
pos, Designator
  l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck))
_) InhTC{} (AST.Dereference Synthesized (Auto TypeCheck) (Designator l l sem sem)
pointer) =
      SynTCDes{$sel:errors:SynTCDes :: Folded [Error () l]
errors= case forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
pointer
                       of SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [],
                                   $sel:designatorType:SynTCDes :: forall l. SynTCDes l -> Type l
designatorType= Type l
t}
                             | PointerType{} <- Type l
t -> forall a. Monoid a => a
mempty
                             | NominalType QualIdent l
_ (Just PointerType{}) <- Type l
t -> forall a. Monoid a => a
mempty
                             | ProcedureType Bool
True [(Bool, Type l)]
_ Maybe (Type l)
_ <- Type l
t -> forall a. Monoid a => a
mempty
                             | Bool
otherwise -> forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonPointerType Type l
t)]
                          SynTCDes{$sel:errors:SynTCDes :: forall l. SynTCDes l -> Folded [Error () l]
errors= Folded [Error () l]
es} -> Folded [Error () l]
es,
               $sel:designatorName:SynTCDes :: Maybe (Maybe Text, Text)
designatorName= forall a. Maybe a
Nothing,
               $sel:designatorType:SynTCDes :: Type l
designatorType= case forall l. SynTCDes l -> Type l
designatorType (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto TypeCheck) (Designator l l sem sem)
pointer)
                               of NominalType QualIdent l
_ (Just (PointerType Type l
t)) -> Type l
t
                                  ProcedureType Bool
True [(Bool, Type l)]
params Maybe (Type l)
result -> forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool, Type l)]
params Maybe (Type l)
result
                                  PointerType Type l
t -> Type l
t
                                  Type l
_ -> forall l. Type l
UnknownType}

binaryNumericOrSetSynthesis :: LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryNumericOrSetSynthesis LexicalPosition
pos Synthesized t a
left Synthesized t a
right =
   SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]
binarySetOrNumericOperatorErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
left) (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
right),
            $sel:inferredType:SynTCExp :: Type l
inferredType= forall l.
(Nameable l, Eq (QualIdent l)) =>
SynTCExp l -> SynTCExp l -> Type l
binaryNumericOperatorType (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
left) (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
right)}

binaryIntegerSynthesis :: LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryIntegerSynthesis LexicalPosition
pos Synthesized t a
left Synthesized t a
right =
   SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= forall l.
Nameable l =>
LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]
binaryIntegerOperatorErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
left) (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
right),
            $sel:inferredType:SynTCExp :: Type l
inferredType= forall l.
(Nameable l, Eq (QualIdent l)) =>
SynTCExp l -> SynTCExp l -> Type l
binaryNumericOperatorType (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
left) (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
right)}

binaryBooleanSynthesis :: LexicalPosition -> Synthesized t a -> Synthesized t a -> SynTCExp l
binaryBooleanSynthesis LexicalPosition
pos Synthesized t a
left Synthesized t a
right =
   SynTCExp{$sel:errors:SynTCExp :: Folded [Error () l]
errors= forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]
binaryBooleanOperatorErrors LexicalPosition
pos (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
left) (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized t a
right),
            $sel:inferredType:SynTCExp :: Type l
inferredType= forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"}

unaryNumericOrSetOperatorErrors :: forall l. Abstract.Nameable l => LexicalPosition -> SynTCExp l -> Folded [Error () l]
unaryNumericOrSetOperatorErrors :: forall l.
Nameable l =>
LexicalPosition -> SynTCExp l -> Folded [Error () l]
unaryNumericOrSetOperatorErrors LexicalPosition
pos SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t}
   | IntegerType{} <- Type l
t = forall a. Monoid a => a
mempty
   | BuiltinType Text
name <- Type l
t, Text -> Bool
isNumerical Text
name Bool -> Bool -> Bool
|| Text
name forall a. Eq a => a -> a -> Bool
== Text
"SET" = forall a. Monoid a => a
mempty
   | Bool
otherwise = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonNumericType Type l
t)]
unaryNumericOrSetOperatorErrors LexicalPosition
_ SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [Error () l]
errs} = Folded [Error () l]
errs

unaryNumericOrSetOperatorType :: (Int -> Int) -> SynTCExp l -> Type l
unaryNumericOrSetOperatorType :: forall l. (Int -> Int) -> SynTCExp l -> Type l
unaryNumericOrSetOperatorType Int -> Int
f SynTCExp{$sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= IntegerType Int
x} = forall l. Int -> Type l
IntegerType (Int -> Int
f Int
x)
unaryNumericOrSetOperatorType Int -> Int
_ SynTCExp{$sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t} = Type l
t

binarySetOrNumericOperatorErrors :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l))
                                 => LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]
binarySetOrNumericOperatorErrors :: forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]
binarySetOrNumericOperatorErrors LexicalPosition
_
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= BuiltinType Text
name1}
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= BuiltinType Text
name2}
  | Text -> Bool
isNumerical Text
name1 Bool -> Bool -> Bool
&& Text -> Bool
isNumerical Text
name2 Bool -> Bool -> Bool
|| Text
name1 forall a. Eq a => a -> a -> Bool
== Text
"SET" Bool -> Bool -> Bool
&& Text
name2 forall a. Eq a => a -> a -> Bool
== Text
"SET" = forall a. Monoid a => a
mempty
binarySetOrNumericOperatorErrors LexicalPosition
_
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= IntegerType{}}
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= BuiltinType Text
name}
  | Text -> Bool
isNumerical Text
name = forall a. Monoid a => a
mempty
binarySetOrNumericOperatorErrors LexicalPosition
_
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= BuiltinType Text
name}
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= IntegerType{}}
  | Text -> Bool
isNumerical Text
name = forall a. Monoid a => a
mempty
binarySetOrNumericOperatorErrors LexicalPosition
_
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= IntegerType{}}
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= IntegerType{}} = forall a. Monoid a => a
mempty
binarySetOrNumericOperatorErrors LexicalPosition
pos SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t1}
                                     SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t2}
  | Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2 = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonNumericType Type l
t1)]
  | Bool
otherwise = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> Type l -> ErrorType l
TypeMismatch Type l
t1 Type l
t2)]
binarySetOrNumericOperatorErrors LexicalPosition
_ SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [Error () l]
errs1} SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [Error () l]
errs2} = Folded [Error () l]
errs1 forall a. Semigroup a => a -> a -> a
<> Folded [Error () l]
errs2

binaryNumericOperatorType :: (Abstract.Nameable l, Eq (Abstract.QualIdent l)) => SynTCExp l -> SynTCExp l -> Type l
binaryNumericOperatorType :: forall l.
(Nameable l, Eq (QualIdent l)) =>
SynTCExp l -> SynTCExp l -> Type l
binaryNumericOperatorType SynTCExp{$sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t1} SynTCExp{$sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t2}
  | Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2 = Type l
t1
  | IntegerType{} <- Type l
t1 = Type l
t2
  | IntegerType{} <- Type l
t2 = Type l
t1
  | BuiltinType Text
name1 <- Type l
t1, BuiltinType Text
name2 <- Type l
t2,
    Just Int
index1 <- forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Text
name1 [Text]
numericTypeNames,
    Just Int
index2 <- forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Text
name2 [Text]
numericTypeNames = forall l. Text -> Type l
BuiltinType ([Text]
numericTypeNames forall a. [a] -> Int -> a
!! forall a. Ord a => a -> a -> a
max Int
index1 Int
index2)
  | Bool
otherwise = Type l
t1

binaryIntegerOperatorErrors :: Abstract.Nameable l =>
                               LexicalPosition ->  SynTCExp l -> SynTCExp l -> Folded [Error () l]
binaryIntegerOperatorErrors :: forall l.
Nameable l =>
LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]
binaryIntegerOperatorErrors LexicalPosition
pos SynTCExp l
syn1 SynTCExp l
syn2 = forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors LexicalPosition
pos SynTCExp l
syn1 forall a. Semigroup a => a -> a -> a
<> forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors LexicalPosition
pos SynTCExp l
syn2

integerExpressionErrors :: forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors :: forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
integerExpressionErrors LexicalPosition
pos SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t}
  | forall {l}. Type l -> Bool
isIntegerType Type l
t = forall a. Monoid a => a
mempty
  | Bool
otherwise = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonIntegerType Type l
t)]
integerExpressionErrors LexicalPosition
_ SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [Error () l]
errs} = Folded [Error () l]
errs

isIntegerType :: Type l -> Bool
isIntegerType IntegerType{} = Bool
True
isIntegerType (BuiltinType Text
"SHORTINT") = Bool
True
isIntegerType (BuiltinType Text
"INTEGER") = Bool
True
isIntegerType (BuiltinType Text
"LONGINT") = Bool
True
isIntegerType Type l
t = Bool
False

booleanExpressionErrors :: forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
booleanExpressionErrors :: forall l. LexicalPosition -> SynTCExp l -> Folded [Error () l]
booleanExpressionErrors LexicalPosition
_ SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [],
                                     $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= BuiltinType Text
"BOOLEAN"} = forall a. Monoid a => a
mempty
booleanExpressionErrors LexicalPosition
pos SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t} = 
   forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonBooleanType Type l
t)]
booleanExpressionErrors LexicalPosition
_ SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [Error () l]
errs} = Folded [Error () l]
errs

binaryBooleanOperatorErrors :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l))
                            => LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]
binaryBooleanOperatorErrors :: forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> SynTCExp l -> SynTCExp l -> Folded [Error () l]
binaryBooleanOperatorErrors LexicalPosition
_pos
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= BuiltinType Text
"BOOLEAN"}
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= BuiltinType Text
"BOOLEAN"} = forall a. Monoid a => a
mempty
binaryBooleanOperatorErrors LexicalPosition
pos
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t1}
  SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [], $sel:inferredType:SynTCExp :: forall l. SynTCExp l -> Type l
inferredType= Type l
t2}
  | Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2 = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> ErrorType l
NonBooleanType Type l
t1)]
  | Bool
otherwise = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> Type l -> ErrorType l
TypeMismatch Type l
t1 Type l
t2)]
binaryBooleanOperatorErrors LexicalPosition
_ SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [Error () l]
errs1} SynTCExp{$sel:errors:SynTCExp :: forall l. SynTCExp l -> Folded [Error () l]
errors= Folded [Error () l]
errs2} = Folded [Error () l]
errs1 forall a. Semigroup a => a -> a -> a
<> Folded [Error () l]
errs2

parameterCompatible :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l))
                    => LexicalPosition -> (Bool, Type l) -> Type l -> Folded [Error () l]
parameterCompatible :: forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> (Bool, Type l) -> Type l -> Folded [Error () l]
parameterCompatible LexicalPosition
_ (Bool
_, expected :: Type l
expected@(ArrayType [] Type l
_)) Type l
actual
  | forall l. Eq (QualIdent l) => Type l -> Type l -> Bool
arrayCompatible Type l
expected Type l
actual = forall a. Monoid a => a
mempty
parameterCompatible LexicalPosition
pos (Bool
True, Type l
expected) Type l
actual
  | Type l
expected forall a. Eq a => a -> a -> Bool
== Type l
actual = forall a. Monoid a => a
mempty
  | Bool
otherwise = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> Type l -> ErrorType l
UnequalTypes Type l
expected Type l
actual)]
parameterCompatible LexicalPosition
pos (Bool
False, Type l
expected) Type l
actual
  | BuiltinType Text
"ARRAY" <- Type l
expected, ArrayType{} <- Type l
actual = forall a. Monoid a => a
mempty
  | Bool
otherwise = forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
expected Type l
actual

assignmentCompatibleIn :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l))
                       => InhTCExp l -> LexicalPosition -> Type l -> Folded [Error () l]
assignmentCompatibleIn :: forall l.
(Nameable l, Eq (QualIdent l)) =>
InhTCExp l -> LexicalPosition -> Type l -> Folded [Error () l]
assignmentCompatibleIn InhTCExp{Type l
expectedType :: Type l
$sel:expectedType:InhTCExp :: forall l. InhTCExp l -> Type l
expectedType} LexicalPosition
pos = forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
expectedType

assignmentCompatible :: forall l. (Abstract.Nameable l, Eq (Abstract.QualIdent l))
                     => LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible :: forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
expected Type l
actual
   | Type l
expected forall a. Eq a => a -> a -> Bool
== Type l
actual = forall a. Monoid a => a
mempty
   | BuiltinType Text
name1 <- Type l
expected, BuiltinType Text
name2 <- Type l
actual,
     Just Int
index1 <- forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Text
name1 [Text]
numericTypeNames,
     Just Int
index2 <- forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Text
name2 [Text]
numericTypeNames, 
     Int
index1 forall a. Ord a => a -> a -> Bool
>= Int
index2 = forall a. Monoid a => a
mempty
   | BuiltinType Text
name <- Type l
expected, IntegerType{} <- Type l
actual, Text -> Bool
isNumerical Text
name = forall a. Monoid a => a
mempty
   | BuiltinType Text
"BASIC TYPE" <- Type l
expected, BuiltinType Text
name <- Type l
actual,
     Text
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"BOOLEAN", Text
"CHAR", Text
"SHORTINT", Text
"INTEGER", Text
"LONGINT", Text
"REAL", Text
"LONGREAL", Text
"SET"] = forall a. Monoid a => a
mempty
   | BuiltinType Text
"POINTER" <- Type l
expected, PointerType{} <- Type l
actual = forall a. Monoid a => a
mempty
   | BuiltinType Text
"POINTER" <- Type l
expected, NominalType QualIdent l
_ (Just Type l
t) <- Type l
actual =
       forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
expected Type l
t
   | BuiltinType Text
"CHAR" <- Type l
expected, Type l
actual forall a. Eq a => a -> a -> Bool
== forall l. Int -> Type l
StringType Int
1 = forall a. Monoid a => a
mempty
   | ReceiverType Type l
t <- Type l
actual = forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
expected Type l
t
   | ReceiverType Type l
t <- Type l
expected = forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
t Type l
actual
   | Type l
NilType <- Type l
actual, PointerType{} <- Type l
expected = forall a. Monoid a => a
mempty
   | Type l
NilType <- Type l
actual, ProcedureType{} <- Type l
expected = forall a. Monoid a => a
mempty
   | Type l
NilType <- Type l
actual, NominalType QualIdent l
_ (Just Type l
t) <- Type l
expected = forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
t Type l
actual
--   | ArrayType [] (BuiltinType "CHAR") <- expected, StringType{} <- actual = mempty
   | ArrayType [Int
m] (BuiltinType Text
"CHAR") <- Type l
expected, StringType Int
n <- Type l
actual =
       forall a. a -> Folded a
Folded (if Int
m forall a. Ord a => a -> a -> Bool
< Int
n then [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Int -> Int -> ErrorType l
TooSmallArrayType Int
m Int
n)] else [])
   | forall l. Eq (QualIdent l) => Type l -> Type l -> Bool
targetExtends Type l
actual Type l
expected = forall a. Monoid a => a
mempty
   | NominalType QualIdent l
_ (Just Type l
t) <- Type l
expected, ProcedureType{} <- Type l
actual = forall l.
(Nameable l, Eq (QualIdent l)) =>
LexicalPosition -> Type l -> Type l -> Folded [Error () l]
assignmentCompatible LexicalPosition
pos Type l
t Type l
actual
   | Bool
otherwise = forall a. a -> Folded a
Folded [forall m l. m -> LexicalPosition -> ErrorType l -> Error m l
Error () LexicalPosition
pos (forall l. Type l -> Type l -> ErrorType l
IncompatibleTypes Type l
expected Type l
actual)]

arrayCompatible :: Type l -> Type l -> Bool
arrayCompatible (ArrayType [] Type l
t1) (ArrayType [Int]
_ Type l
t2) = Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2 Bool -> Bool -> Bool
|| Type l -> Type l -> Bool
arrayCompatible Type l
t1 Type l
t2
arrayCompatible (ArrayType [] (BuiltinType Text
"CHAR")) StringType{} = Bool
True
arrayCompatible (NominalType QualIdent l
_ (Just Type l
t1)) Type l
t2 = Type l -> Type l -> Bool
arrayCompatible Type l
t1 Type l
t2
arrayCompatible Type l
t1 (NominalType QualIdent l
_ (Just Type l
t2)) = Type l -> Type l -> Bool
arrayCompatible Type l
t1 Type l
t2
arrayCompatible Type l
_ Type l
_ = Bool
False

extends, targetExtends :: Eq (Abstract.QualIdent l) => Type l -> Type l -> Bool
Type l
t1 extends :: forall l. Eq (QualIdent l) => Type l -> Type l -> Bool
`extends` Type l
t2 | Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2 = Bool
True
RecordType [QualIdent l]
ancestry Map Text (Type l)
_ `extends` NominalType QualIdent l
q Maybe (Type l)
_ = QualIdent l
q forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [QualIdent l]
ancestry
NominalType QualIdent l
_ (Just Type l
t1) `extends` Type l
t2 = Type l
t1 forall l. Eq (QualIdent l) => Type l -> Type l -> Bool
`extends` Type l
t2
Type l
t1 `extends` Type l
t2 = Bool
False -- error (show (t1, t2))

ultimate :: Type l -> Type l
ultimate :: forall l. Type l -> Type l
ultimate (NominalType QualIdent l
_ (Just Type l
t)) = forall l. Type l -> Type l
ultimate Type l
t
ultimate Type l
t = Type l
t

isNumerical :: Text -> Bool
isNumerical Text
t = Text
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
numericTypeNames
numericTypeNames :: [Text]
numericTypeNames = [Text
"SHORTINT", Text
"INTEGER", Text
"LONGINT", Text
"REAL", Text
"LONGREAL"]

PointerType Type l
t1 targetExtends :: forall l. Eq (QualIdent l) => Type l -> Type l -> Bool
`targetExtends` PointerType Type l
t2 = Type l
t1 forall l. Eq (QualIdent l) => Type l -> Type l -> Bool
`extends` Type l
t2
NominalType QualIdent l
_ (Just Type l
t1) `targetExtends` Type l
t2 = Type l
t1 forall l. Eq (QualIdent l) => Type l -> Type l -> Bool
`targetExtends` Type l
t2
Type l
t1 `targetExtends` NominalType QualIdent l
_ (Just Type l
t2) = Type l
t1 forall l. Eq (QualIdent l) => Type l -> Type l -> Bool
`targetExtends` Type l
t2
Type l
t1 `targetExtends` Type l
t2 | Type l
t1 forall a. Eq a => a -> a -> Bool
== Type l
t2 = Bool
True
Type l
t1 `targetExtends` Type l
t2 = Bool
False

instance Transformation.Transformation (Auto TypeCheck) where
   type Domain (Auto TypeCheck) = Placed
   type Codomain (Auto TypeCheck) = Semantics (Auto TypeCheck)

instance AG.Revelation (Auto TypeCheck) where
   reveal :: forall x. Auto TypeCheck -> Domain (Auto TypeCheck) x -> x
reveal (Auto TypeCheck
TypeCheck) = forall a b. (a, b) -> b
snd

instance Ord (Abstract.QualIdent l) => Transformation.At (Auto TypeCheck) (Modules l Sem Sem) where
   $ :: Auto TypeCheck
-> Domain
     (Auto TypeCheck)
     (Modules
        l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
-> Codomain
     (Auto TypeCheck)
     (Modules
        l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
($) = forall (q :: * -> *) t x (g :: (* -> *) -> (* -> *) -> *)
       (p :: * -> *).
(q ~ Semantics t, x ~ g q q, Apply (g q), Attribution t g q p) =>
(forall a. p a -> a) -> t -> p x -> q x
AG.applyDefault forall a b. (a, b) -> b
snd

-- * Unsafe Rank2 AST instances

instance Rank2.Apply (AST.Module l l f') where
   AST.Module Text
name1 [(Maybe Text, Text)]
imports1 (~>) p q (Block l l f' f')
body1 <*> :: forall (p :: * -> *) (q :: * -> *).
Module l l f' (p ~> q) -> Module l l f' p -> Module l l f' q
<*> ~(AST.Module Text
name2 [(Maybe Text, Text)]
imports2 p (Block l l f' f')
body2) =
      forall λ l (f' :: * -> *) (f :: * -> *).
Text
-> [(Maybe Text, Text)] -> f (Block l l f' f') -> Module λ l f' f
AST.Module Text
name1 [(Maybe Text, Text)]
imports1 (forall {k} (p :: k -> *) (q :: k -> *) (a :: k).
Arrow p q a -> p a -> q a
Rank2.apply (~>) p q (Block l l f' f')
body1 p (Block l l f' f')
body2)

-- | Check if the given collection of modules is well typed and return all type errors found. The collection is a
-- 'Map' keyed by module name. The first argument's value is typically 'predefined' or 'predefined2'.
checkModules :: forall l. (Abstract.Oberon l, Abstract.Nameable l,
                           Ord (Abstract.QualIdent l), Show (Abstract.QualIdent l),
                           Atts (Inherited (Auto TypeCheck)) (Abstract.Block l l Sem Sem) ~ InhTC l,
                           Atts (Synthesized (Auto TypeCheck)) (Abstract.Block l l Sem Sem) ~ SynTCMod l,
                           Full.Functor (Auto TypeCheck) (Abstract.Block l l))
             => Environment l -> Map AST.Ident (Placed (AST.Module l l Placed Placed)) -> [Error AST.Ident l]
checkModules :: forall l.
(Oberon l, Nameable l, Ord (QualIdent l), Show (QualIdent l),
 Atts
   (Inherited (Auto TypeCheck))
   (Block
      l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
 ~ InhTC l,
 Atts
   (Synthesized (Auto TypeCheck))
   (Block
      l l (Semantics (Auto TypeCheck)) (Semantics (Auto TypeCheck)))
 ~ SynTCMod l,
 Functor (Auto TypeCheck) (Block l l)) =>
Environment l
-> Map Text (Placed (Module l l Placed Placed)) -> [Error Text l]
checkModules Map (QualIdent l) (Type l)
predef Map Text (Placed (Module l l Placed Placed))
modules =
   forall a. Folded a -> a
getFolded ((forall t a. Synthesized t a -> Atts (Synthesized t) a
syn (forall t x. At t x => t -> Domain t x -> Codomain t x
Transformation.apply (forall t. t -> Auto t
Auto TypeCheck
TypeCheck) (forall {b}. b -> (LexicalPosition, b)
wrap forall a b. (a -> b) -> a -> b
$ forall t. t -> Auto t
Auto TypeCheck
TypeCheck forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
Deep.<$> forall l (f' :: * -> *) (f :: * -> *).
Map Text (f (Module l l f' f')) -> Modules l f' f
Modules Map Text (Placed (Module l l Placed Placed))
modules)
                           forall {k} (p :: k -> *) (q :: k -> *) (a :: k).
Arrow p q a -> p a -> q a
`Rank2.apply`
                           forall t a. Atts (Inherited t) a -> Inherited t a
Inherited (forall l. Environment l -> InhTCRoot l
InhTCRoot Map (QualIdent l) (Type l)
predef))).errors)
   where wrap :: b -> (LexicalPosition, b)
wrap = (,) (Int
0, [Lexeme] -> ParsedLexemes
Trailing [], Int
0)

predefined, predefined2 :: (Abstract.Wirthy l, Ord (Abstract.QualIdent l)) => Environment l
-- | The set of 'Predefined' types and procedures defined in the Oberon Language Report.
predefined :: forall l. (Wirthy l, Ord (QualIdent l)) => Environment l
predefined = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent) forall a b. (a -> b) -> a -> b
$
   [(Text
"BOOLEAN", forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"),
    (Text
"CHAR", forall l. Text -> Type l
BuiltinType Text
"CHAR"),
    (Text
"SHORTINT", forall l. Text -> Type l
BuiltinType Text
"SHORTINT"),
    (Text
"INTEGER", forall l. Text -> Type l
BuiltinType Text
"INTEGER"),
    (Text
"LONGINT", forall l. Text -> Type l
BuiltinType Text
"LONGINT"),
    (Text
"REAL", forall l. Text -> Type l
BuiltinType Text
"REAL"),
    (Text
"LONGREAL", forall l. Text -> Type l
BuiltinType Text
"LONGREAL"),
    (Text
"SET", forall l. Text -> Type l
BuiltinType Text
"SET"),
    (Text
"TRUE", forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"),
    (Text
"FALSE", forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"),
    (Text
"ABS", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"INTEGER")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"INTEGER"),
    (Text
"ASH", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"INTEGER")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"INTEGER"),
    (Text
"CAP", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"CHAR")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"CHAR"),
    (Text
"LEN", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"ARRAY")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"LONGINT"),
    (Text
"MAX", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"BASIC TYPE")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall l. Type l
UnknownType),
    (Text
"MIN", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"BASIC TYPE")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall l. Type l
UnknownType),
    (Text
"ODD", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"CHAR")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"),
    (Text
"SIZE", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"CHAR")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"INTEGER"),
    (Text
"ORD", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"CHAR")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"INTEGER"),
    (Text
"CHR", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"LONGINT")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"CHAR"),
    (Text
"SHORT", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"LONGINT")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"SHORTINT"),
    (Text
"LONG", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"INTEGER")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"INTEGER"),
    (Text
"ENTIER", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"REAL")] forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Text -> Type l
BuiltinType Text
"INTEGER"),
    (Text
"INC", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"LONGINT")] forall a. Maybe a
Nothing),
    (Text
"DEC", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"LONGINT")] forall a. Maybe a
Nothing),
    (Text
"INCL", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"SET"), (Bool
False, forall l. Text -> Type l
BuiltinType Text
"INTEGER")] forall a. Maybe a
Nothing),
    (Text
"EXCL", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"SET"), (Bool
False, forall l. Text -> Type l
BuiltinType Text
"INTEGER")] forall a. Maybe a
Nothing),
    (Text
"COPY", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"ARRAY"), (Bool
False, forall l. Text -> Type l
BuiltinType Text
"ARRAY")] forall a. Maybe a
Nothing),
    (Text
"NEW", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"POINTER")] forall a. Maybe a
Nothing),
    (Text
"HALT", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"INTEGER")] forall a. Maybe a
Nothing)]

-- | The set of 'Predefined' types and procedures defined in the Oberon-2 Language Report.
predefined2 :: forall l. (Wirthy l, Ord (QualIdent l)) => Environment l
predefined2 = forall l. (Wirthy l, Ord (QualIdent l)) => Environment l
predefined forall a. Semigroup a => a -> a -> a
<>
   forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                 [(Text
"ASSERT", forall l. Bool -> [(Bool, Type l)] -> Maybe (Type l) -> Type l
ProcedureType Bool
False [(Bool
False, forall l. Text -> Type l
BuiltinType Text
"BOOLEAN"),
                                                  (Bool
False, forall l. Text -> Type l
BuiltinType Text
"INTEGER")] forall a. Maybe a
Nothing)])