----------------------------------------------------------------------------- -- |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