helium-1.8: src/Helium/StaticAnalysis/Inferencers/TypeInferenceCollect.ag
-----------------------------------------------------------------------------
-- |The Helium Compiler : Static Analysis
--
-- Maintainer : bastiaan@cs.uu.nl
-- Stability : experimental
-- Portability : unknown
--
-- Distributition of
-- * import environment
-- * substitution (result of solving the type constraints)
-- * inferred types
-- * ordered type synonyms
--
-----------------------------------------------------------------------------
ATTR Expression Expressions MaybeExpression Alternative Alternatives
Statement Statements Declaration Declarations MaybeDeclarations
RightHandSide Body Qualifier Qualifiers
GuardedExpression GuardedExpressions FunctionBinding FunctionBindings
RecordExpressionBinding RecordExpressionBindings
[ importEnvironment : ImportEnvironment
substitution : FixpointSubstitution
typeschemeMap : {M.Map Int (Scheme Predicates)}
allTypeSchemes : {M.Map NameWithRange TpScheme}
orderedTypeSynonyms : OrderedTypeSynonyms
| collectWarnings : Warnings
collectErrors : TypeErrors
|
]
ATTR LeftHandSide Pattern Patterns [ importEnvironment : ImportEnvironment | | ]
----------------------------------------------------------------------------------------
-- Collecting missing type signature warnings
SEM Module
| Module body . collectWarnings = []
. collectErrors = []
SEM Body
| Body loc . inferredTypes = findInferredTypes @lhs.typeschemeMap @implicitsFM
lhs . collectWarnings = missingTypeSignature True @declarations.simplePatNames @inferredTypes
++ @declarations.collectWarnings
. collectErrors = restrictedNameErrors @inferredTypes @declarations.restrictedNames
++ @declarations.collectErrors
SEM MaybeDeclarations
| Just loc . inferredTypes = findInferredTypes @lhs.typeschemeMap @implicitsFM
lhs . collectWarnings = missingTypeSignature False @declarations.simplePatNames @inferredTypes
++ @declarations.collectWarnings
. collectErrors = restrictedNameErrors @inferredTypes @declarations.restrictedNames
++ @declarations.collectErrors
SEM Expression
| Let loc . inferredTypes = findInferredTypes @lhs.typeschemeMap @implicitsFM
lhs . collectWarnings = missingTypeSignature False @declarations.simplePatNames @inferredTypes
++ @expression.collectWarnings
. collectErrors = restrictedNameErrors @inferredTypes @declarations.restrictedNames
++ @declarations.collectErrors
SEM Statement
| Let loc . inferredTypes = findInferredTypes @lhs.typeschemeMap @implicitsFM
lhs . collectWarnings = missingTypeSignature False @declarations.simplePatNames @inferredTypes
++ @declarations.collectWarnings
. collectErrors = restrictedNameErrors @inferredTypes @declarations.restrictedNames
++ @declarations.collectErrors
SEM Qualifier
| Let loc . inferredTypes = findInferredTypes @lhs.typeschemeMap @implicitsFM
lhs . collectWarnings = missingTypeSignature False @declarations.simplePatNames @inferredTypes
++ @declarations.collectWarnings
. collectErrors = restrictedNameErrors @inferredTypes @declarations.restrictedNames
++ @declarations.collectErrors
{
findInferredTypes :: M.Map Int (Scheme Predicates) -> M.Map Name (Sigma Predicates) -> TypeEnvironment
findInferredTypes typeschemeMap =
let err = internalError "TypeInferenceCollect.ag" "findInferredTypes" "could not find type scheme variable"
f :: Sigma Predicates -> TpScheme
f (SigmaVar i) = M.findWithDefault err i typeschemeMap
f (SigmaScheme ts) = ts
in M.map f
missingTypeSignature :: Bool -> Names -> TypeEnvironment -> Warnings
missingTypeSignature topLevel simplePats =
let -- for the moment, only missing type signature for top-level functions are reported (unless monomorphic).
makeWarning (name, scheme) =
let fromSimple = name `elem` simplePats && isOverloaded scheme
in [ NoTypeDef name scheme topLevel fromSimple | null (ftv scheme) && (topLevel || fromSimple) ]
in concatMap makeWarning . M.assocs
restrictedNameErrors :: TypeEnvironment -> Names -> TypeErrors
restrictedNameErrors env =
let f name = case M.lookup name env of
Just scheme -> [ makeRestrictedButOverloadedError name scheme | isOverloaded scheme ]
Nothing -> []
in concatMap f
}
----------------------------------------------------------------------------------------
-- Collecting inferred top level types
ATTR Body [ | | toplevelTypes : TypeEnvironment ]
SEM Body
| Hole lhs . toplevelTypes = M.empty
| Body lhs . toplevelTypes = @declarations.typeSignatures `M.union` @inferredTypes
---------------------------------------------------------
-- Collecting all the type schemes that are in scope
{- bug fix 10 september 2003: the inferred types for where-declarations are also "visible" in the expression of the
right-hand side. Therefore, MaybeDeclarations should return a (synthesized) list of localTypes, and then
RightHandSide should distribute it down -}
ATTR MaybeDeclarations [ | | localTypes : {M.Map NameWithRange TpScheme} ]
SEM Module
| Module body . allTypeSchemes = M.fromList [ (NameWithRange name, scheme) | (name, scheme) <- M.assocs (typeEnvironment @lhs.importEnvironment) ]
SEM Body
| Body loc . allTypeSchemes = @localTypes `M.union` @lhs.allTypeSchemes
. localTypes = makeLocalTypeEnv (@declarations.typeSignatures `M.union` @inferredTypes) @declarations.bindingGroups
SEM MaybeDeclarations
| Just lhs . localTypes = makeLocalTypeEnv (@declarations.typeSignatures `M.union` @inferredTypes) @declarations.bindingGroups
| Nothing lhs . localTypes = M.empty
SEM RightHandSide
| Expression loc . allTypeSchemes = @where.localTypes `M.union` @lhs.allTypeSchemes
| Guarded loc . allTypeSchemes = @where.localTypes `M.union` @lhs.allTypeSchemes
SEM Expression
| Let loc . allTypeSchemes = @localTypes `M.union` @lhs.allTypeSchemes
. localTypes = makeLocalTypeEnv (@declarations.typeSignatures `M.union` @inferredTypes) @declarations.bindingGroups
SEM Statement
| Let loc . allTypeSchemes = @localTypes `M.union` @lhs.allTypeSchemes
. localTypes = makeLocalTypeEnv (@declarations.typeSignatures `M.union` @inferredTypes) @declarations.bindingGroups
SEM Qualifier
| Let loc . allTypeSchemes = @localTypes `M.union` @lhs.allTypeSchemes
. localTypes = makeLocalTypeEnv (@declarations.typeSignatures `M.union` @inferredTypes) @declarations.bindingGroups
{
makeLocalTypeEnv :: TypeEnvironment -> BindingGroups -> M.Map NameWithRange TpScheme
makeLocalTypeEnv local groups =
let (environment, _, _) = concatBindingGroups groups
names = M.keys environment
f x = maybe err id (find (==x) names)
err = internalError "TypeInferenceCollect.ag" "makeLocalTypeEnv" "could not find name"
in M.fromList [ (NameWithRange (f name), scheme) | (name, scheme) <- M.assocs local ]
}
-- context for restricted pattern error
ATTR Declaration Declarations [ | | restrictedNames USE { ++ } { [] } : Names
simplePatNames USE { ++ } { [] } : Names ]
SEM Declaration
| PatternBinding
(lhs.restrictedNames, lhs.simplePatNames)
= if isSimplePattern @pattern.self
then ([], @pattern.patVarNames)
else (@pattern.patVarNames, [])
{
isSimplePattern :: Pattern -> Bool
isSimplePattern pattern =
case pattern of
Pattern_Variable _ _ -> True
Pattern_Parenthesized _ p -> isSimplePattern p
_ -> False
}
-------------------------------------------
-- Collecting Type Signatures
ATTR Declaration Declarations [ | typeSignatures:TypeEnvironment | ]
SEM Body | Body declarations . typeSignatures = M.empty
SEM Expression | Let declarations . typeSignatures = M.empty
SEM Statement | Let declarations . typeSignatures = M.empty
SEM Qualifier | Let declarations . typeSignatures = M.empty
SEM MaybeDeclarations | Just declarations . typeSignatures = M.empty
SEM Declaration
| TypeSignature
lhs . typeSignatures = @lhs.typeSignatures `M.union` (M.fromList [ (name, @typeScheme) | name <- @names.self ])
loc . typeScheme = makeTpSchemeFromType @type.self
--------------------------------
-- Derived instances
ATTR Module -> Declaration [ | | collectInstances USE { ++ } { [] } : {[(Name, Instance)]} ]
SEM Declaration
| Data
lhs . collectInstances = [ (cl, makeInstance (show cl) (length @simpletype.typevariables) (show @simpletype.name) )
| cl <- @derivings.self
]
ATTR SimpleType [ | | name:Name typevariables:Names ]
SEM SimpleType
| SimpleType lhs . name = @name.self
. typevariables = @typevariables.self
--------------------------------
-- Chunks
ATTR Expression Expressions MaybeExpression
Statement Statements Qualifier Qualifiers Alternative Alternatives
Declaration Declarations MaybeDeclarations Body
RightHandSide GuardedExpression GuardedExpressions
FunctionBinding FunctionBindings
RecordExpressionBinding RecordExpressionBindings
[ currentChunk:Int | uniqueChunk:Int | ]
SEM Module
| Module body . currentChunk = 0
. uniqueChunk = 1
SEM Body | Body lhs . uniqueChunk = @chunkNr -- from binding groups
SEM MaybeDeclarations | Just lhs . uniqueChunk = @chunkNr
SEM Expression | Let lhs . uniqueChunk = @chunkNr
SEM Statement | Let lhs . uniqueChunk = @chunkNr
SEM Qualifier | Let lhs . uniqueChunk = @chunkNr
SEM Declaration
| FunctionBindings bindings . currentChunk = findCurrentChunk @bindings.name @lhs.inheritedBDG -- from binding groups
| PatternBinding righthandside . currentChunk = findCurrentChunk (head (M.keys @pattern.environment)) @lhs.inheritedBDG