----------------------------------------------------------------------------- -- |The Helium Compiler : Static Analysis -- -- Maintainer : bastiaan@cs.uu.nl -- Stability : experimental -- Portability : unknown -- -- Contains all the typing rules for the an UHA abstract syntax tree. -- ----------------------------------------------------------------------------- ---------------------------------------------------------------------------------------- -- Type Inferencing : Module SEM Module | Module loc -- Solve the type constraints. . (SolveResult betaUniqueAtTheEnd substitution typeschemeMap _ solveErrors) = @solveResult . (solveResult, logEntries) = (selectConstraintSolver @lhs.options @lhs.importEnvironment) @classEnv @orderedTypeSynonyms @body.betaUnique @body.constraints . orderedTypeSynonyms = getOrderedTypeSynonyms @lhs.importEnvironment . classEnv = -- extend the set of imported instance declarations with the -- derived instances foldr (\(n, i) -> insertInstance (show n) i) (createClassEnvironment @lhs.importEnvironment) @body.collectInstances . typeErrors = case makeTypeErrors @lhs.options @classEnv @orderedTypeSynonyms @substitution @solveErrors of [] -> if NoOverloadingTypeCheck `elem` @lhs.options then filter (\(TypeError _ ms _ _) -> not $ isInfixOf "Illegal overloaded type" $ show ms) @body.collectErrors else @body.collectErrors errs -> reverse errs . warnings = @body.collectWarnings -- ++ @tooSpecificWarnings . assumptions = let f xs = [ (n, @substitution |-> tp) | (n, tp) <- xs ] in M.map f @body.assumptions . initialScope = M.keys (typeEnvironment @lhs.importEnvironment) . monos = map TVar @monomorphics . monomorphics = ftv ( (M.elems $ valueConstructors @lhs.importEnvironment) ++ (M.elems $ typeEnvironment @lhs.importEnvironment) ) body . typeschemeMap = M.fromList (M.assocs @typeschemeMap) -- was a copy rule. . betaUnique = if null @monomorphics then 0 else maximum @monomorphics + 1 --------------------------------------------------------------------------------------- -- Type Inferencing : Body ATTR Body [ monos : Monos | betaUnique : Int | assumptions : Assumptions constraints : ConstraintSet ] SEM Body | Hole lhs . assumptions = noAssumptions . constraints = emptyTree | Body declarations . bindingGroups = [] (loc.csetBinds,lhs.assumptions) = (typeEnvironment @lhs.importEnvironment .:::. @aset) @cinfo loc . constraints = @csetBinds .>>. @cset (loc.aset, loc.cset, loc.inheritedBDG, loc.chunkNr, lhs.betaUnique, loc.implicitsFM) = let inputBDG = (True, @lhs.currentChunk, @declarations.uniqueChunk, @lhs.monos, @declarations.typeSignatures, Nothing, @declarations.betaUnique) in performBindingGroup inputBDG @declarations.bindingGroups --------------------------------------------------------------------------------------- -- Type Inferencing : Declaration, Declarations, MaybeDeclarations ATTR Declaration Declarations MaybeDeclarations [ monos:Monos | betaUnique:Int | ] ATTR Declaration Declarations [ inheritedBDG:InheritedBDG | bindingGroups:BindingGroups | ] ATTR MaybeDeclarations [ | assumptions:Assumptions constraints:ConstraintSet | ] SEM Declaration | FunctionBindings lhs . bindingGroups = @mybdggrp : @lhs.bindingGroups bindings . betaUnique = @lhs.betaUnique + 2 + @bindings.numberOfPatterns . monos = findMono @bindings.name @lhs.inheritedBDG ++ @lhs.monos loc . beta = TVar @lhs.betaUnique . betaRight = TVar (@lhs.betaUnique + 1) . betasLeft = take @bindings.numberOfPatterns (map TVar [@lhs.betaUnique + 2..]) . newcon = (@beta .==. foldr (.->.) @betaRight @betasLeft) @cinfo . mybdggrp = ( M.singleton @bindings.name @beta , @bindings.assumptions , [ Node [ Phase (-1) [@newcon] , Receive @lhs.betaUnique , Node @bindings.constraintslist ] ] ) | PatternBinding lhs . bindingGroups = @mybdggrp : @lhs.bindingGroups pattern . betaUnique = @lhs.betaUnique + 1 righthandside . monos = findMono (head (M.keys @pattern.environment)) @lhs.inheritedBDG ++ @lhs.monos loc . betaRight = TVar @lhs.betaUnique . newcon = [ (@betaRight .==. @pattern.beta) @cinfo ] . mybdggrp = ( @pattern.environment , @righthandside.assumptions , [ @newcon .>. Node [ @pattern.constraints , @righthandside.constraints ] ] ) SEM MaybeDeclarations | Just declarations . bindingGroups = [] (lhs.assumptions, lhs.constraints, loc.inheritedBDG, loc.chunkNr, lhs.betaUnique, loc.implicitsFM) = let inputBDG = (False, @lhs.currentChunk, @declarations.uniqueChunk, @lhs.monos, @declarations.typeSignatures, mybdggroup, @declarations.betaUnique) mybdggroup = Just (@lhs.assumptions, [@lhs.constraints]) in performBindingGroup inputBDG @declarations.bindingGroups --------------------------------------------------------------------------------------- -- Type Inferencing : FunctionBinding, FunctionBindings ATTR FunctionBinding FunctionBindings [ betasLeft:Tps betaRight:Tp monos:Monos | betaUnique:Int | assumptions:Assumptions numberOfPatterns:Int name:Name ] ATTR FunctionBinding [ | | constraints:ConstraintSet] ATTR FunctionBindings [ | | constraintslist:ConstraintSets] SEM FunctionBinding | Hole loc . assumptions = noAssumptions . constraints = emptyTree . numberOfPatterns = 0 . name = internalError "TypeInferencing.ag" "n/a" "FunctionBindings(2)" | FunctionBinding righthandside . monos = M.elems @lefthandside.environment ++ getMonos @csetBinds ++ @lhs.monos loc . constraints = @csetBinds .>>. Node [ @conLeft .<. @lefthandside.constraints , @righthandside.constraints ] . conLeft = zipWith3 (\t1 t2 nr -> (t1 .==. t2) (@cinfoLeft nr)) @lefthandside.betas @lhs.betasLeft [0..] (loc.csetBinds,lhs.assumptions) = (@lefthandside.environment .===. @righthandside.assumptions) @cinfoBind SEM FunctionBindings | Cons lhs . assumptions = @hd.assumptions `combine` @tl.assumptions . numberOfPatterns = @hd.numberOfPatterns . name = @hd.name . constraintslist = @hd.constraints : @tl.constraintslist | Nil lhs . assumptions = noAssumptions . numberOfPatterns = internalError "TypeInferencing.ag" "n/a" "FunctionBindings(1)" . name = internalError "TypeInferencing.ag" "n/a" "FunctionBindings(2)" . constraintslist = [] --------------------------------------------------------------------------------------- -- Type Inferencing : LeftHandSide, RightHandSide ATTR LeftHandSide RightHandSide [ monos:Monos | betaUnique:Int | constraints:ConstraintSet ] ATTR LeftHandSide [ | | betas:Tps environment:PatternAssumptions numberOfPatterns:Int name:Name ] ATTR RightHandSide [ betaRight:Tp | | assumptions:Assumptions ] SEM LeftHandSide | Function lhs . name = @name.self loc . constraints = Node @patterns.constraintslist | Infix lhs . numberOfPatterns = 2 . environment = @leftPattern.environment `M.union` @rightPattern.environment . betas = [@leftPattern.beta,@rightPattern.beta] . name = @operator.self loc . constraints = Node [ @leftPattern.constraints , @rightPattern.constraints ] | Parenthesized lhs . numberOfPatterns = @lefthandside.numberOfPatterns + @patterns.numberOfPatterns . environment = @lefthandside.environment `M.union` @patterns.environment . betas = @lefthandside.betas ++ @patterns.betas loc . constraints = Node ( @lefthandside.constraints : @patterns.constraintslist ) SEM RightHandSide | Expression lhs . assumptions = @where.assumptions . constraints = @where.constraints where . assumptions = @expression.assumptions . constraints = @newcon .>. @expression.constraints loc . newcon = [ (@expression.beta .==. @lhs.betaRight) @cinfo ] | Guarded lhs . assumptions = @where.assumptions . constraints = @where.constraints guardedexpressions . numberOfGuards = length @guardedexpressions.constraintslist where . assumptions = @guardedexpressions.assumptions . constraints = Node @guardedexpressions.constraintslist --------------------------------------------------------------------------------------- -- Type Inferencing : Expression, Expressions, MaybeExpression ATTR Expression Expressions MaybeExpression [ monos:Monos | betaUnique:Int | assumptions:Assumptions ] ATTR Expression [ | | beta:Tp constraints:ConstraintSet ] ATTR Expressions [ | | betas:Tps constraintslist:ConstraintSets ] ATTR MaybeExpression [ | | beta:Tp constraints:ConstraintSet section:Bool ] SEM Expression | Literal lhs . betaUnique = @lhs.betaUnique + 1 loc . assumptions = noAssumptions . constraints = unitTree ((@literal.literalType .==. @beta) @cinfo) . beta = TVar @lhs.betaUnique | Constructor lhs . betaUnique = @lhs.betaUnique + 1 loc . assumptions = noAssumptions . constraints = listTree @newcon . beta = TVar @lhs.betaUnique . newcon = case M.lookup @name.self (valueConstructors @lhs.importEnvironment) of Nothing -> [] Just ctp -> [ (@beta .::. ctp) @cinfo ] | Variable lhs . betaUnique = @lhs.betaUnique + 1 loc . assumptions = @name.self `single` @beta . constraints = Node [ Receive @lhs.betaUnique ] . beta = TVar @lhs.betaUnique | Hole lhs . betaUnique = @lhs.betaUnique + 1 loc . assumptions = noAssumptions . constraints = emptyTree . beta = TVar @lhs.betaUnique | NormalApplication function . betaUnique = @lhs.betaUnique + 1 loc . assumptions = @function.assumptions `combine` @arguments.assumptions . constraints = @newcon .>. Node [ @function.constraints , Node @arguments.constraintslist ] . beta = TVar @lhs.betaUnique . newcon = [ (@function.beta .==. foldr (.->.) @beta @arguments.betas) @cinfo ] | InfixApplication leftExpression . betaUnique = @lhs.betaUnique + 2 loc . assumptions = @leftExpression.assumptions `combine` @operator.assumptions `combine` @rightExpression.assumptions . constraints = @conTotal .>. Node [ @operator.constraints , @leftExpression.constraints , @rightExpression.constraints ] . beta = TVar @lhs.betaUnique . betaResOp = TVar (@lhs.betaUnique + 1) . conOperator = (@operator.beta .==. @leftExpression.beta .->. @rightExpression.beta .->. @betaResOp) @cinfoOperator . conTotal = case (@leftExpression.section,@rightExpression.section) of (False,False) -> [ @conOperator, (@betaResOp .==. @beta) @cinfoComplete ] (True ,True ) -> [ (@operator.beta .==. @beta) @cinfoEmpty ] (False,True ) -> [ @conOperator, (@rightExpression.beta .->. @betaResOp .==. @beta) @cinfoRightSection ] (True ,False) -> [ @conOperator, (@leftExpression.beta .->. @betaResOp .==. @beta) @cinfoLeftSection ] | If guardExpression . betaUnique = @lhs.betaUnique + 1 loc . assumptions = @guardExpression.assumptions `combine` @thenExpression.assumptions `combine` @elseExpression.assumptions . constraints = Node [ @conGuard .<. @guardExpression.constraints , @conThen .<. @thenExpression.constraints , @conElse .<. @elseExpression.constraints ] . beta = TVar @lhs.betaUnique . conGuard = [ (@guardExpression.beta .==. boolType) @cinfoGuard ] . conThen = [ (@thenExpression.beta .==. @beta ) @cinfoThen ] . conElse = [ (@elseExpression.beta .==. @beta ) @cinfoElse ] | Lambda patterns . betaUnique = @lhs.betaUnique + 1 expression . monos = M.elems @patterns.environment ++ getMonos @csetBinds ++ @lhs.monos loc . constraints = @newcon .>. @csetBinds .>>. Node [ Node @patterns.constraintslist , @expression.constraints ] . beta = TVar @lhs.betaUnique . newcon = [ (foldr (.->.) @expression.beta @patterns.betas .==. @beta) @cinfoType ] (loc.csetBinds, loc.assumptions) = (@patterns.environment .===. @expression.assumptions) @cinfoBind | Case expression . betaUnique = @lhs.betaUnique + 2 alternatives . betaLeft = @beta' . betaRight = @beta loc . assumptions = @expression.assumptions `combine` @alternatives.assumptions . constraints = Node [ @newcon .<. @expression.constraints , Node @alternatives.constraintslist ] . beta = TVar @lhs.betaUnique . beta' = TVar (@lhs.betaUnique + 1) . newcon = [ (@expression.beta .==. @beta') @cinfo ] | Let declarations . betaUnique = @lhs.betaUnique + 1 . bindingGroups = [] loc . constraints = [ (@expression.beta .==. @beta) @cinfoType ] .>. @cset . beta = TVar @lhs.betaUnique (loc.assumptions, loc.cset, loc.inheritedBDG, loc.chunkNr, lhs.betaUnique, loc.implicitsFM) = let inputBDG = (False, @lhs.currentChunk, @expression.uniqueChunk, @lhs.monos, @declarations.typeSignatures, mybdggroup, @expression.betaUnique) mybdggroup = Just (@expression.assumptions, [@expression.constraints]) in performBindingGroup inputBDG @declarations.bindingGroups | Do lhs . constraints = Node [ @newcon .<. @statements.constraints ] statements . betaUnique = @lhs.betaUnique + 1 . generatorBeta = Nothing . assumptions = noAssumptions loc . assumptions = @statements.assumptions . constraints = emptyTree . beta = TVar @lhs.betaUnique . newcon = case @statements.generatorBeta of Nothing -> [] Just b -> [ (ioType b .==. @beta) @cinfo ] | List expressions . betaUnique = @lhs.betaUnique + 2 loc . constraints = @newcon .>. Node (zipWith3 @zipf @expressions.betas [0..] @expressions.constraintslist) . beta = TVar @lhs.betaUnique . beta' = TVar (@lhs.betaUnique + 1) . newcon = [ (listType @beta' .==. @beta) @cinfoResult ] . zipf = \tp childNr ctree -> [ (tp .==. @beta') (@cinfoElem childNr) ] .<. ctree | Tuple expressions . betaUnique = @lhs.betaUnique + 1 loc . constraints = @newcon .>. Node @expressions.constraintslist . beta = TVar @lhs.betaUnique . newcon = [ (tupleType @expressions.betas .==. @beta) @cinfo ] | Typed expression . betaUnique = @lhs.betaUnique + 1 loc . assumptions = @expression.assumptions . constraints = @conResult .>. Node [ @conExpr .<. @expression.constraints ] . beta = TVar @lhs.betaUnique . typeScheme = makeTpSchemeFromType @type.self . conResult = [ (@beta .::. @typeScheme) @cinfoResult ] . conExpr = [ (@expression.beta !::! @typeScheme) @lhs.monos @cinfoExpr ] | Comprehension expression . betaUnique = @lhs.betaUnique + 1 . monos = @qualifiers.monos qualifiers . assumptions = @expression.assumptions . constraints = @expression.constraints . monos = @lhs.monos loc . assumptions = @qualifiers.assumptions . constraints = @newcon .>. Node [ @qualifiers.constraints ] . beta = TVar @lhs.betaUnique . newcon = [ (listType @expression.beta .==. @beta) @cinfo ] | Enum from . betaUnique = @lhs.betaUnique + (if @overloaded then 2 else 1) loc . assumptions = @from.assumptions `combine` @then.assumptions `combine` @to.assumptions . constraints = (@conList ++ @conPredicate) .>. Node [ @conFrom .<. @from.constraints , @conThen .<. @then.constraints , @conTo .<. @to.constraints ] . beta = TVar @lhs.betaUnique . overloaded = case M.lookup enumFromName (typeEnvironment @lhs.importEnvironment) of Just scheme -> isOverloaded scheme Nothing -> False . elementType = if @overloaded then TVar (@lhs.betaUnique + 1) else intType . conPredicate = if @overloaded then [predicate (Predicate "Enum" @elementType) @cinfoPred] else [] . conList = [ (listType @elementType .==. @beta) @cinfoResult ] . conFrom = [ (@from.beta .==. @elementType) @cinfoFrom ] . conThen = [ (@then.beta .==. @elementType) @cinfoThen ] . conTo = [ (@to.beta .==. @elementType) @cinfoTo ] | Negate expression . betaUnique = @lhs.betaUnique + 1 loc . constraints = @newcon .>. Node [ @expression.constraints ] . beta = TVar @lhs.betaUnique . newcon = -- search for the type of 'negate' in the import envionment: otherwise use the default type. let standard = makeScheme [] [Predicate "Num" (TVar 0)] (TVar 0 .->. TVar 0) tpscheme = M.findWithDefault standard (nameFromString "negate") (typeEnvironment @lhs.importEnvironment) in [ (@expression.beta .->. @beta .::. tpscheme) @cinfo] {- only for type inference without overloading -} | NegateFloat expression . betaUnique = @lhs.betaUnique + 1 loc . constraints = @newcon .>. Node [ @expression.constraints ] . beta = TVar @lhs.betaUnique . newcon = [ (floatType .->. floatType .==. @expression.beta .->. @beta) @cinfo] SEM Expressions | Cons lhs . betas = @hd.beta : @tl.betas . assumptions = @hd.assumptions `combine` @tl.assumptions . constraintslist = @hd.constraints : @tl.constraintslist | Nil lhs . betas = [] . assumptions = noAssumptions . constraintslist = [] SEM MaybeExpression | Just lhs . section = False | Nothing lhs . section = True . betaUnique = @lhs.betaUnique + 1 . assumptions = noAssumptions . constraints = emptyTree loc . beta = TVar @lhs.betaUnique --------------------------------------------------------------------------------------- -- Type Inferencing : GuardedExpression, GuardedExpressions ATTR GuardedExpressions GuardedExpression [ numberOfGuards:Int monos:Monos betaRight:Tp | betaUnique:Int | assumptions:Assumptions ] ATTR GuardedExpressions [ | | constraintslist:ConstraintSets ] ATTR GuardedExpression [ | | constraints:ConstraintSet ] SEM GuardedExpression | GuardedExpression lhs . constraints = Node [ @newconGuard .<. @guard.constraints , @newconExpr .<. @expression.constraints ] . assumptions = @guard.assumptions `combine` @expression.assumptions loc . newconGuard = [ (@guard.beta .==. boolType) @cinfoGuard ] . newconExpr = [ (@expression.beta .==. @lhs.betaRight) @cinfoExpr ] SEM GuardedExpressions | Cons lhs . assumptions = @hd.assumptions `combine` @tl.assumptions . constraintslist = @hd.constraints : @tl.constraintslist | Nil lhs . assumptions = noAssumptions . constraintslist = [] --------------------------------------------------------------------------------------- -- Type Inferencing : Pattern ATTR Pattern Patterns [ monos:Monos | betaUnique:Int | environment:PatternAssumptions ] ATTR Pattern [ | | beta:Tp constraints:ConstraintSet ] ATTR Patterns [ | | betas:Tps constraintslist:ConstraintSets numberOfPatterns:Int ] SEM Pattern | Hole lhs . betaUnique = @lhs.betaUnique + 1 . environment = noAssumptions loc . constraints = emptyTree . beta = TVar @lhs.betaUnique | Literal lhs . betaUnique = @lhs.betaUnique + 1 . environment = noAssumptions loc . constraints = unitTree ((@literal.literalType .==. @beta) @cinfo) . beta = TVar @lhs.betaUnique | Variable lhs . betaUnique = @lhs.betaUnique + 1 . environment = M.singleton @name.self @beta loc . constraints = Receive @lhs.betaUnique . beta = TVar @lhs.betaUnique | InfixConstructor lhs . environment = @leftPattern.environment `M.union` @rightPattern.environment leftPattern . betaUnique = @lhs.betaUnique + 2 loc . constraints = @conApply .>. Node [ listTree @conConstructor , @leftPattern.constraints , @rightPattern.constraints ] . beta = TVar @lhs.betaUnique . betaCon = TVar (@lhs.betaUnique + 1) . conApply = [ (@betaCon .==. @leftPattern.beta .->. @rightPattern.beta .->. @beta) @cinfoApply ] . conConstructor = case M.lookup @constructorOperator.self (valueConstructors @lhs.importEnvironment) of Nothing -> [] Just ctp -> [ (@betaCon .::. ctp) @cinfoConstructor ] | Constructor patterns . betaUnique = @lhs.betaUnique + 2 loc . constraints = @conApply .>. Node [ listTree @conConstructor , Node @patterns.constraintslist ] . beta = TVar (@lhs.betaUnique) . betaCon = TVar (@lhs.betaUnique + 1) . conApply = [ (@betaCon .==. foldr (.->.) @beta @patterns.betas) (if @patterns.numberOfPatterns == 0 then @cinfoEmpty else @cinfoApply) ] . conConstructor = case M.lookup @name.self (valueConstructors @lhs.importEnvironment) of Nothing -> [] Just ctp -> [ (@betaCon .::. ctp) @cinfoConstructor ] | As lhs . environment = M.insert @name.self @beta @pattern.environment pattern . betaUnique = @lhs.betaUnique + 1 loc . constraints = @newcon .>. Node [ Receive @lhs.betaUnique , @pattern.constraints ] . beta = TVar @lhs.betaUnique . newcon = [ (@beta .==. @pattern.beta) @cinfo ] | Wildcard lhs . betaUnique = @lhs.betaUnique + 1 . environment = noAssumptions loc . constraints = emptyTree . beta = TVar @lhs.betaUnique | List patterns . betaUnique = @lhs.betaUnique + 2 loc . constraints = @newcon .>. Node (zipWith3 @zipf @patterns.betas [0..] @patterns.constraintslist) . beta = TVar @lhs.betaUnique . beta' = TVar (@lhs.betaUnique + 1) . newcon = [ (listType @beta' .==. @beta) @cinfoResult ] . zipf = \tp elemNr ctree -> [ (tp .==. @beta') (@cinfoElem elemNr) ] .<. ctree | Tuple patterns . betaUnique = @lhs.betaUnique + 1 loc . constraints = @newcon .>. Node @patterns.constraintslist . beta = TVar @lhs.betaUnique . newcon = [ (tupleType @patterns.betas .==. @beta) @cinfo ] | Negate lhs . betaUnique = @lhs.betaUnique + 1 . environment = noAssumptions loc . constraints = listTree @newcon . beta = TVar @lhs.betaUnique . newcon = -- The parser only accepts a literal after '-' in a Pattern -- search for the type of 'negate' in the import envionment: otherwise use the default type. let standard = makeScheme [] [Predicate "Num" (TVar 0)] (TVar 0 .->. TVar 0) tpscheme = M.findWithDefault standard (nameFromString "negate") (typeEnvironment @lhs.importEnvironment) in [ (@literal.literalType .->. @beta .::. tpscheme) @cinfo] {- only if type inferencing without overloading -} | NegateFloat lhs . betaUnique = @lhs.betaUnique + 1 . environment = noAssumptions loc . constraints = listTree @newcon . beta = TVar @lhs.betaUnique . newcon = -- The parser only accepts a literal after '-.' in a Pattern [ (floatType .==. @beta) @cinfo ] SEM Patterns | Cons lhs . betas = @hd.beta : @tl.betas . environment = @hd.environment `M.union` @tl.environment . numberOfPatterns = 1 + @tl.numberOfPatterns . constraintslist = @hd.constraints : @tl.constraintslist | Nil lhs . betas = [] . environment = noAssumptions . numberOfPatterns = 0 . constraintslist = [] --------------------------------------------------------------------------------------- -- Type Inferencing : Alternative, Alternatives ATTR Alternative Alternatives [ betaLeft:Tp betaRight:Tp monos:Monos | betaUnique:Int | assumptions:Assumptions ] ATTR Alternative [ | | constraints:ConstraintSet ] ATTR Alternatives [ | | constraintslist:ConstraintSets ] SEM Alternative | Hole lhs . assumptions = noAssumptions loc . constraints = emptyTree | Alternative righthandside . monos = M.elems @pattern.environment ++ getMonos @csetBinds ++ @lhs.monos loc . constraints = @csetBinds .>>. Node [ @conLeft .<. @pattern.constraints , @righthandside.constraints ] . conLeft = [ (@pattern.beta .==. @lhs.betaLeft) @cinfoLeft ] (loc.csetBinds,lhs.assumptions) = (@pattern.environment .===. @righthandside.assumptions) @cinfoBind | Empty lhs . assumptions = noAssumptions loc . constraints = emptyTree SEM Alternatives | Cons lhs . assumptions = @hd.assumptions `combine` @tl.assumptions . constraintslist = @hd.constraints : @tl.constraintslist | Nil lhs . assumptions = noAssumptions . constraintslist = [] --------------------------------------------------------------------------------------- -- Type Inferencing : Statement, Statements, Qualifier, Qualifiers ATTR Statement Statements Qualifier Qualifiers [ | assumptions:Assumptions betaUnique:Int constraints:ConstraintSet | ] ATTR Statement Statements [ | generatorBeta:{Maybe Tp} | ] ATTR Statement Qualifier Qualifiers [ | monos:Monos | ] ATTR Statements [ monos:Monos | | ] SEM Statement | Expression lhs . generatorBeta = Just @beta . assumptions = @lhs.assumptions `combine` @expression.assumptions . constraints = @locConstraints expression . betaUnique = @lhs.betaUnique + 1 loc . locConstraints = Node [ @newcon .<. @expression.constraints , @lhs.constraints ] . beta = TVar @lhs.betaUnique . newcon = [ (@expression.beta .==. ioType @beta) @cinfo ] | Let lhs . generatorBeta = Nothing declarations . bindingGroups = [] (lhs.assumptions, lhs.constraints, loc.inheritedBDG, loc.chunkNr, lhs.betaUnique, loc.implicitsFM) = let inputBDG = (False, @lhs.currentChunk, @declarations.uniqueChunk, @lhs.monos, @declarations.typeSignatures, mybdggroup, @declarations.betaUnique) mybdggroup = Just (@lhs.assumptions, [@lhs.constraints]) in performBindingGroup inputBDG @declarations.bindingGroups | Generator lhs . generatorBeta = Nothing . constraints = @locConstraints . assumptions = @assumptions' `combine` @expression.assumptions . monos = M.elems @pattern.environment ++ getMonos @csetBinds ++ @lhs.monos loc . locConstraints = @newcon .>. @csetBinds .>>. Node [ @pattern.constraints , @expression.constraints , @lhs.constraints ] . newcon = [ (@expression.beta .==. ioType @pattern.beta) @cinfoResult ] . (csetBinds,assumptions') = (@pattern.environment .===. @lhs.assumptions) @cinfoBind SEM Statements | Cons lhs . assumptions = @hd.assumptions . constraints = @hd.constraints hd . assumptions = @tl.assumptions . constraints = @tl.constraints tl . assumptions = @lhs.assumptions . constraints = @lhs.constraints SEM Qualifier | Guard lhs . assumptions = @lhs.assumptions `combine` @guard.assumptions . constraints = @locConstraints loc . locConstraints = Node [ @newcon .<. @guard.constraints , @lhs.constraints ] . newcon = [ (@guard.beta .==. boolType) @cinfo ] | Let declarations . bindingGroups = [] (lhs.assumptions, lhs.constraints, loc.inheritedBDG, loc.chunkNr, lhs.betaUnique, loc.implicitsFM) = let inputBDG = (False, @lhs.currentChunk, @declarations.uniqueChunk, @lhs.monos, @declarations.typeSignatures, mybdggroup, @declarations.betaUnique) mybdggroup = Just (@lhs.assumptions, [@lhs.constraints]) in performBindingGroup inputBDG @declarations.bindingGroups | Generator lhs . assumptions = @assumptions' `combine` @expression.assumptions . constraints = @locConstraints . monos = M.elems @pattern.environment ++ getMonos @csetBinds ++ @lhs.monos loc . locConstraints = @newcon .>. @csetBinds .>>. Node [ @pattern.constraints , @expression.constraints , @lhs.constraints ] . (csetBinds,assumptions') = (@pattern.environment .===. @lhs.assumptions) @cinfoBind . newcon = [ (@expression.beta .==. listType @pattern.beta) @cinfoResult ] SEM Qualifiers | Cons lhs . assumptions = @hd.assumptions . constraints = @hd.constraints hd . assumptions = @tl.assumptions . constraints = @tl.constraints tl . assumptions = @lhs.assumptions . constraints = @lhs.constraints --------------------------------------------------------------------------------------- -- Type Inferencing : Literal ATTR Literal [ | | literalType:Tp ] SEM Literal | Int lhs . literalType = intType | Char lhs . literalType = charType | String lhs . literalType = stringType | Float lhs . literalType = floatType