git.iko.soy/elk
on master help sign in
Revamp type constraint generation

Create new “Expectation” type that holds context information about why certain things should be equal. That is separate from the “Category” type that clarifies what kind of node generated the constraint. This also makes it much easier to “push type information down” into the branches of ifs and cases. This also implements constraint generation for non-recursive definitions. Because we know that they are not self-recursive, we can generate simpler constraints. Hopefully this speeds things up a bit.

commit6709d6fbd6ef1e8516222c31f96159632e401f6f authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 14 Nov 2017, 21:49 (9 years ago) parenta964796
4 files changed+492−375
compare with master
unifiedsplit
src/Type/Constrain/Expression.hs+214−218 src/Type/Constrain/Pattern.hs+163−76 src/Type/Constraint.hs+111−22 src/Type/Instantiate.hs+4−59
src/Type/Constrain/Expression.hs+214−218
@@ -6,19 +6,14 @@ module Type.Constrain.Expression
66 where
77
88
9−import Control.Arrow (second)
10−import qualified Control.Monad as Monad
119import qualified Data.Map.Strict as Map
12−import Data.Text (Text)
1310
1411import qualified AST.Canonical as Can
1512import qualified AST.Module.Name as ModuleName
1613import qualified AST.Utils.Shader as Shader
17−import qualified Data.Bag as Bag
1814import qualified Data.Index as Index
1915import qualified Elm.Name as N
2016import qualified Reporting.Annotation as A
21−import qualified Reporting.Error.Type as Error
2217import qualified Reporting.Region as R
2318import Type.Constraint
2419import qualified Type.Constrain.Pattern as Pattern
@@ -29,73 +24,78 @@ import Type.Type as Type hiding (Descriptor(..))
2924-- CONSTRAIN
3025
3126
32−-- The environment contains all known type variables.
27+-- As we step past type annotations, the free type variables are added to
28+-- the "rigid type variables" dict. Allowing sharing of rigid variables
29+-- between nested type annotations.
3330--
34−-- So if you have a top-level type annotation like (func : a -> b) then
35−-- the environment will hold variables for `a` and `b`
31+-- So if you have a top-level type annotation like (func : a -> b) the RTV
32+-- dictionary will hold variables for `a` and `b`
3633--
37−type Env = Map.Map N.Name Variable
34+type RTV =
35+ Map.Map N.Name Type
3836
3937
40−constrain :: Env -> R.Region -> Error.Context -> Can.Expr -> Type -> IO Constraint
41−constrain env parentRegion context (A.A region expression) tipe =
38+constrain :: RTV -> Can.Expr -> Expectation -> IO Constraint
39+constrain rtv (A.A region expression) expectation =
4240 case expression of
4341 Can.VarLocal name ->
44− return (CLookup parentRegion context region name tipe)
42+ return (CLookup region name expectation)
4543
4644 Can.VarTopLevel _ name ->
47− return (CLookup parentRegion context region name tipe)
45+ return (CLookup region name expectation)
4846
4947 Can.VarKernel _ _ ->
5048 return CTrue
5149
5250 Can.VarForeign _ name annotation ->
53− error "TODO figure out foreign types"
51+ return $ CInstance region (FuncName name) annotation expectation
5452
5553 Can.VarOperator op _ _ annotation ->
56− error "TODO figure out foreign types"
54+ return $ CInstance region (OpName op) annotation expectation
5755
5856 Can.Str _ ->
59− return $ CEqual parentRegion context Error.String region Type.string tipe
57+ return $ CEqual region String Type.string expectation
6058
6159 Can.Chr _ ->
62− return $ CEqual parentRegion context Error.Char region Type.char tipe
60+ return $ CEqual region Char Type.char expectation
6361
6462 Can.Int _ ->
6563 do var <- mkFlexNumber
66− return $ ex [var] $
67− CEqual parentRegion context Error.Number region (VarN var) tipe
64+ return $ ex [var] $ CEqual region Number (VarN var) expectation
6865
6966 Can.Float _ ->
70− return $ CEqual parentRegion context Error.Float region Type.float tipe
67+ return $ CEqual region Float Type.float expectation
7168
7269 Can.List elements ->
73− constrainList env parentRegion context region elements tipe
70+ constrainList rtv region elements expectation
7471
7572 Can.Negate expr ->
7673 do numberVar <- mkFlexNumber
7774 let numberType = VarN numberVar
78− numberCon <- constrain env region Error.Negate expr numberType
79− let negateCon = CEqual parentRegion context Error.Number region numberType tipe
75+ numberCon <- constrain rtv expr (FromContext region Negate numberType)
76+ let negateCon = CEqual region Number numberType expectation
8077 return $ ex [numberVar] $ CAnd [ numberCon, negateCon ]
8178
82− Can.Binop op home name annotation leftExpr rightExpr ->
83− constrainBinop env parentRegion context region op annotation leftExpr rightExpr tipe
79+ Can.Binop op _ _ annotation leftExpr rightExpr ->
80+ constrainBinop rtv region op annotation leftExpr rightExpr expectation
8481
85− Can.Lambda args body ->
86− constrainLambda parentRegion context env region args body tipe
82+ Can.Lambda args _ body ->
83+ do (lambdaType, resultType, scheme) <- Pattern.constrainArgs args
84+ bodyCon <- constrain rtv body (NoExpectation resultType)
85+ let lambdaCon = CEqual region Lambda lambdaType expectation
86+ return $ CLet [scheme] $ CAnd [ bodyCon, lambdaCon ]
8787
8888 Can.Call func args ->
89− constrainCall env parentRegion context region func args tipe
89+ constrainCall rtv region func args expectation
9090
9191 Can.If branches finally ->
92− constrainIf env parentRegion context region branches finally tipe
92+ constrainIf rtv region branches finally expectation
9393
9494 Can.Case expr branches ->
95− constrainCase env parentRegion context region expr branches tipe
95+ constrainCase rtv region expr branches expectation
9696
9797 Can.Let def body ->
98− constrainLet env parentRegion context region def body tipe
98+ constrainDef rtv def =<< constrain rtv body expectation
9999
100100 Can.LetRec defs body ->
101101 error "TODO let rec" defs body
@@ -110,7 +110,7 @@ constrain env parentRegion context (A.A region expression) tipe =
110110 let fieldType = VarN fieldVar
111111 let recordType = RecordN (Map.singleton field fieldType) extType
112112 return $ ex [ fieldVar, extVar ] $
113− CEqual parentRegion context (Error.Accessor field) region (FunN recordType fieldType) tipe
113+ CEqual region (Accessor field) (FunN recordType fieldType) expectation
114114
115115 Can.Access expr field ->
116116 do extVar <- mkFlexVar
@@ -118,179 +118,134 @@ constrain env parentRegion context (A.A region expression) tipe =
118118 let extType = VarN extVar
119119 let fieldType = VarN fieldVar
120120 let recordType = RecordN (Map.singleton field fieldType) extType
121− recordCon <- constrain env region (Error.RecordAccess field) expr recordType
121+
122+ recordCon <-
123+ constrain rtv expr (FromContext region (RecordAccess field) recordType)
124+
122125 return $ ex [ fieldVar, extVar ] $
123126 CAnd
124127 [ recordCon
125− , CEqual parentRegion context (Error.Access field) region recordType tipe
128+ , CEqual region (Access field) recordType expectation
126129 ]
127130
128131 Can.Update expr fields ->
129− constrainUpdate env parentRegion context region expr fields tipe
132+ constrainUpdate rtv region expr fields expectation
130133
131134 Can.Record fields ->
132− constrainRecord env parentRegion context region fields tipe
135+ constrainRecord rtv region fields expectation
133136
134137 Can.Unit ->
135− return $ CEqual parentRegion context Error.Unit region UnitN tipe
138+ return $ CEqual region Unit UnitN expectation
136139
137140 Can.Tuple a b maybeC ->
138− constrainTuple env parentRegion context region a b maybeC tipe
141+ constrainTuple rtv region a b maybeC expectation
139142
140143 Can.Shader _uid _src glType ->
141− constrainShader env parentRegion context region glType tipe
144+ constrainShader region glType expectation
142145
143146
144147
145−-- CONSTRAIN LAMBDA
148+-- CONSTRAIN CALL
146149
147150
148−constrainLambda :: R.Region -> Error.Context -> Env -> R.Region -> Can.Args -> Can.Expr -> Type -> IO Constraint
149−constrainLambda parentRegion context env lambdaRegion (Can.Args args _) body tipe =
150− constrainLambdaHelp parentRegion context env lambdaRegion args body [] Pattern.emptyState tipe
151+constrainCall :: RTV -> R.Region -> Can.Expr -> [Can.Expr] -> Expectation -> IO Constraint
152+constrainCall rtv region func args expectation =
153+ do let maybeFuncName = getFuncName func
151154
155+ funcVar <- mkFlexVar
156+ resultVar <- mkFlexVar
157+ let funcType = VarN funcVar
158+ let resultType = VarN resultVar
152159
153−constrainLambdaHelp :: R.Region -> Error.Context -> Env -> R.Region -> [Can.Arg] -> Can.Expr -> [Type] -> Pattern.State -> Type -> IO Constraint
154−constrainLambdaHelp parentRegion context env lambdaRegion args body revArgTypes state tipe =
155− case args of
156− (Can.Arg index pattern) : otherArgs ->
157− do argVar <- mkFlexVar
158− let argType = VarN argVar
159− let newTypes = argType : revArgTypes
160− let lambdaContext = Error.PatternArg Error.UnknownCall index
161− newState <- Pattern.addConstraints lambdaRegion lambdaContext pattern argType state
162− constrainLambdaHelp parentRegion context env lambdaRegion otherArgs body newTypes newState tipe
160+ funcCon <- constrain rtv func (NoExpectation funcType)
163161
164− [] ->
165− do resultVar <- mkFlexVar
166− let resultType = VarN resultVar
167− let lambdaType = foldr (==>) resultType revArgTypes
168− let lambdaCon = CEqual parentRegion context Error.Lambda lambdaRegion lambdaType tipe
169− bodyCon <- constrain env lambdaRegion Error.LambdaBody body resultType
162+ (argVars, argTypes, argCons) <-
163+ unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeFuncName) args
170164
171− let (Pattern.State headers vars revCons) = state
172− let scheme = Scheme [] (resultVar : Bag.toList vars) headers (CAnd (reverse revCons))
165+ let arityType = foldr FunN resultType argTypes
166+ let resultCon = CEqual region (CallResult maybeFuncName) resultType expectation
173167
174− return $ CLet [scheme] $ CAnd [ bodyCon, lambdaCon ]
168+ return $ ex (funcVar:resultVar:argVars) $
169+ CAnd
170+ [ funcCon
171+ , CBranch
172+ { _a = funcType
173+ , _b = arityType
174+ , _eq = CAnd [ CAnd argCons, resultCon ]
175+ , _neq = constrainCallBackup rtv region maybeFuncName func args
176+ }
177+ ]
175178
176179
180+constrainArg :: RTV -> R.Region -> Maybe FuncName -> Index.ZeroBased -> Can.Expr -> IO (Variable, Type, Constraint)
181+constrainArg rtv region maybeFuncName index arg =
182+ do argVar <- mkFlexVar
183+ let argType = VarN argVar
184+ argCon <- constrain rtv arg (FromContext region (CallArg maybeFuncName index) argType)
185+ return (argVar, argType, argCon)
177186
178−-- CONSTRAIN CALL
179187
188+constrainCallBackup :: RTV -> R.Region -> Maybe FuncName -> Can.Expr -> [Can.Expr] -> IO Constraint
189+constrainCallBackup rtv region maybeFuncName func args =
190+ do (argVars, argTypes, argCons) <-
191+ unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeFuncName) args
180192
181−constrainCall :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> [Can.Expr] -> Type -> IO Constraint
182−constrainCall env parentRegion context callRegion func args tipe =
183− do let callName = toCallName func
184− let (A.A lastArgRegion _) = last args
193+ resultVar <- mkFlexVar
194+ let resultType = VarN resultVar
195+ let arityType = foldr FunN resultType argTypes
185196
186− funcVar <- mkFlexVar
187− let funcType = VarN funcVar
188− funcCon <- constrain env callRegion Error.Whatever func funcType
189−
190− (vars, revCons, resultType) <-
191− constrainCallHelp env callRegion callName lastArgRegion args Index.first [funcVar] funcType [funcCon]
192−
193− let callCon = CEqual parentRegion context (Error.CallResult callName) callRegion resultType tipe
194−
195− return $ ex vars $ CAnd (reverse (callCon:revCons))
196−
197−
198−constrainCallHelp
199− :: Env
200− -> R.Region
201− -> Error.CallName
202− -> R.Region
203− -> [Can.Expr]
204− -> Index.ZeroBased
205− -> [Variable]
206− -> Type
207− -> [Constraint]
208− -> IO ([Variable], [Constraint], Type)
209−constrainCallHelp env callRegion callName lastArgRegion args index vars funcType revCons =
210− case args of
211− [] ->
212− return (vars, revCons, funcType)
213−
214− arg@(A.A argRegion _) : otherArgs ->
215− do argVar <- mkFlexVar
216− resultVar <- mkFlexVar
217− let argType = VarN argVar
218− let resultType = VarN resultVar
219−
220− -- check arity
221− let aRegion = R.merge argRegion lastArgRegion
222− let aContext = Error.CallArity callName index
223− let aCategory = Error.Call callName
224− let arityCon = CEqual callRegion aContext aCategory aRegion funcType (argType ==> resultType)
225−
226− -- check arg type
227− argCon <- constrain env callRegion (Error.CallArg callName index) arg argType
228−
229− let newIndex = Index.next index
230− let newVars = argVar : resultVar : vars
231− let newCons = argCon : arityCon : revCons
232− constrainCallHelp env callRegion callName lastArgRegion otherArgs newIndex newVars resultType newCons
233−
234−
235−toCallName :: Can.Expr -> Error.CallName
236−toCallName (A.A _ expr) =
197+ funcCon <- constrain rtv func (FromContext region BadArity arityType)
198+
199+ return $ ex (resultVar:argVars) $ CAnd [ CAnd argCons, funcCon ]
200+
201+
202+getFuncName :: Can.Expr -> Maybe FuncName
203+getFuncName (A.A _ expr) =
237204 case expr of
238205 Can.VarLocal name ->
239− Error.FuncCall name
206+ Just (FuncName name)
240207
241208 Can.VarTopLevel _ name ->
242− Error.FuncCall name
209+ Just (FuncName name)
243210
244211 Can.VarKernel _ name ->
245− Error.FuncCall name
212+ Just (FuncName name)
246213
247214 Can.VarForeign _ name _ ->
248− Error.FuncCall name
215+ Just (FuncName name)
249216
250217 Can.VarOperator op _ _ _ ->
251− Error.OpCall op
252−
253− Can.Accessor field ->
254− Error.AccessCall field
218+ Just (OpName op)
255219
256220 _ ->
257− Error.UnknownCall
221+ Nothing
258222
259223
260224
261225-- CONSTRAIN BINOP
262226
263227
264−constrainBinop
265− :: Env
266− -> R.Region
267− -> Error.Context
268− -> R.Region
269− -> N.Name
270− -> Can.Annotation
271− -> Can.Expr
272− -> Can.Expr
273− -> Type
274− -> IO Constraint
275−constrainBinop env parentRegion context opRegion op srcType leftExpr rightExpr tipe =
228+constrainBinop :: RTV -> R.Region -> N.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> Expectation -> IO Constraint
229+constrainBinop rtv region op annotation leftExpr rightExpr expectation =
276230 do leftVar <- mkFlexVar
277231 rightVar <- mkFlexVar
278232 answerVar <- mkFlexVar
279233 let leftType = VarN leftVar
280234 let rightType = VarN rightVar
281235 let answerType = VarN answerVar
236+ let binopType = leftType ==> rightType ==> answerType
282237
283− let opCon = error "TODO CInstance" srcType (leftType ==> rightType ==> answerType)
238+ let opCon = CInstance region (OpName op) annotation (NoExpectation binopType)
284239
285− leftCon <- constrain env opRegion (Error.OpLeft op) leftExpr leftType
286− rightCon <- constrain env opRegion (Error.OpRight op) rightExpr rightType
240+ leftCon <- constrain rtv leftExpr (FromContext region (OpLeft op) leftType)
241+ rightCon <- constrain rtv rightExpr (FromContext region (OpRight op) rightType)
287242
288243 return $ ex [ leftVar, rightVar, answerVar ] $
289244 CAnd
290245 [ opCon
291246 , leftCon
292247 , rightCon
293− , CEqual parentRegion context (Error.Call (Error.OpCall op)) opRegion answerType tipe
248+ , CEqual region (CallResult (Just (OpName op))) answerType expectation
294249 ]
295250
296251
@@ -298,96 +253,118 @@ constrainBinop env parentRegion context opRegion op srcType leftExpr rightExpr t
298253-- CONSTRAIN LISTS
299254
300255
301−constrainList :: Env -> R.Region -> Error.Context -> R.Region -> [Can.Expr] -> Type -> IO Constraint
302−constrainList env parentRegion context listRegion entries tipe =
256+constrainList :: RTV -> R.Region -> [Can.Expr] -> Expectation -> IO Constraint
257+constrainList rtv region entries expectation =
303258 do entryVar <- mkFlexVar
304259 let entryType = VarN entryVar
305− entryCons <- Index.indexedTraverse (constrainListEntry env listRegion entryType) entries
306260 let listType = AppN ModuleName.list N.list [entryType]
261+
262+ entryCons <-
263+ Index.indexedTraverse (constrainListEntry rtv region entryType) entries
264+
307265 return $ ex [entryVar] $
308266 CAnd
309267 [ CAnd entryCons
310− , CEqual parentRegion context Error.List listRegion listType tipe
268+ , CEqual region List listType expectation
311269 ]
312270
313271
314−constrainListEntry :: Env -> R.Region -> Type -> Index.ZeroBased -> Can.Expr -> IO Constraint
315−constrainListEntry env listRegion tipe index expr =
316− constrain env listRegion (Error.ListEntry index) expr tipe
317−
272+constrainListEntry :: RTV -> R.Region -> Type -> Index.ZeroBased -> Can.Expr -> IO Constraint
273+constrainListEntry rtv region tipe index expr =
274+ constrain rtv expr (FromContext region (ListEntry index) tipe)
318275
319276
320277
321278-- CONSTRAIN IF EXPRESSIONS
322279
323280
324−constrainIf :: Env -> R.Region -> Error.Context -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Type -> IO Constraint
325−constrainIf env parentRegion context ifRegion branches final tipe =
326− do branchVar <- mkFlexVar
327− let branchType = VarN branchVar
281+constrainIf :: RTV -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Expectation -> IO Constraint
282+constrainIf rtv region branches final expectation =
283+ do let boolExpect = FromContext region IfCondition Type.bool
284+ let (conditions, exprs) = foldr (\(c,e) (cs,es) -> (c:cs,e:es)) ([],[final]) branches
328285
329− branchCons <- Index.indexedTraverse (constrainIfBranch env ifRegion branchType) branches
330− finalCon <- constrain env ifRegion (Error.IfBranchFinal (length branches)) final branchType
286+ condCons <-
287+ traverse (\c -> constrain rtv c boolExpect) conditions
331288
332− return $ ex [branchVar] $
333− CAnd
334− [ CAnd branchCons
335− , finalCon
336− , CEqual parentRegion context Error.If ifRegion branchType tipe
337− ]
289+ case expectation of
290+ FromAnnotation name arity _ tipe ->
291+ do branchCons <- Index.indexedForA exprs $ \index expr ->
292+ constrain rtv expr (FromAnnotation name arity (TypedIfBranch index) tipe)
293+ return $
294+ CAnd
295+ [ CAnd condCons
296+ , CAnd branchCons
297+ ]
338298
299+ _ ->
300+ do branchVar <- mkFlexVar
301+ let branchType = VarN branchVar
302+
303+ branchCons <- Index.indexedForA exprs $ \index expr ->
304+ constrain rtv expr (FromContext region (IfBranch index) branchType)
305+
306+ return $ ex [branchVar] $
307+ CAnd
308+ [ CAnd condCons
309+ , CAnd branchCons
310+ , CEqual region If branchType expectation
311+ ]
339312
340−constrainIfBranch :: Env -> R.Region -> Type -> Index.ZeroBased -> (Can.Expr, Can.Expr) -> IO Constraint
341−constrainIfBranch env ifRegion branchType index (condition, branch) =
342− do condCon <- constrain env ifRegion Error.IfCondition condition Type.bool
343− branchCon <- constrain env ifRegion (Error.IfBranch index) branch branchType
344− return $ CAnd [ condCon, branchCon ]
345313
346314
347315-- CONSTRAIN CASE EXPRESSIONS
348316
349317
350−constrainCase :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Type -> IO Constraint
351−constrainCase env parentRegion context caseRegion expr branches tipe =
352− do exprVar <- mkFlexVar
353− branchVar <- mkFlexVar
354− let exprType = VarN exprVar
355− let branchType = VarN branchVar
318+constrainCase :: RTV -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Expectation -> IO Constraint
319+constrainCase rtv region expr branches expectation =
320+ do ptrnVar <- mkFlexVar
321+ let ptrnType = VarN ptrnVar
322+ exprCon <- constrain rtv expr (NoExpectation ptrnType)
356323
357− exprCon <- constrain env caseRegion Error.CaseExpr expr exprType
358− revCons <- constrainCaseHelp env caseRegion branches exprType branchType [exprCon]
359− let caseCon = CEqual parentRegion context Error.Case caseRegion branchType tipe
324+ case expectation of
325+ FromAnnotation name arity _ tipe ->
326+ do branchCons <- Index.indexedForA branches $ \index branch ->
327+ constrainCaseBranch rtv branch
328+ (PatternExpectation region (PCaseMatch index) ptrnType)
329+ (FromAnnotation name arity (TypedCaseBranch index) tipe)
360330
361− return $ ex [ exprVar, branchVar ] $ CAnd (reverse (caseCon:revCons))
331+ return $ ex [ptrnVar] $ CAnd (exprCon:branchCons)
362332
333+ _ ->
334+ do branchVar <- mkFlexVar
335+ let branchType = VarN branchVar
363336
337+ branchCons <- Index.indexedForA branches $ \index branch ->
338+ constrainCaseBranch rtv branch
339+ (PatternExpectation region (PCaseMatch index) ptrnType)
340+ (FromContext region (CaseBranch index) branchType)
364341
365−constrainCaseHelp :: Env -> R.Region -> [Can.CaseBranch] -> Type -> Type -> [Constraint] -> IO [Constraint]
366−constrainCaseHelp env caseRegion branches patternType exprType revCons =
367− case branches of
368− [] ->
369− return revCons
342+ return $ ex [ptrnVar,branchVar] $
343+ CAnd
344+ [ exprCon
345+ , CAnd branchCons
346+ , CEqual region Case branchType expectation
347+ ]
370348
371− (Can.CaseBranch index pattern destructors expr) : otherBranches ->
372− do (Pattern.State headers vars revCons) <-
373− Pattern.addConstraints caseRegion (Error.PatternCaseMatch index) pattern patternType Pattern.emptyState
374349
375− exprCon <- constrain env caseRegion (Error.CaseBranch index) expr exprType
376− let branchCon = CLet [ Scheme [] (Bag.toList vars) headers (CAnd (reverse revCons)) ] exprCon
377− constrainCaseHelp env caseRegion otherBranches patternType exprType (branchCon:revCons)
350+constrainCaseBranch :: RTV -> Can.CaseBranch -> PatternExpectation -> Expectation -> IO Constraint
351+constrainCaseBranch rtv (Can.CaseBranch pattern _ expr) pExpect bExpect =
352+ do scheme <- Pattern.constrain pattern pExpect
353+ constraint <- constrain rtv expr bExpect
354+ return $ CLet [scheme] constraint
378355
379356
380357
381358-- CONSTRAIN RECORD
382359
383360
384−constrainRecord :: Env -> R.Region -> Error.Context -> R.Region -> Map.Map N.Name Can.Expr -> Type -> IO Constraint
385−constrainRecord env parentRegion context recordRegion fields tipe =
386− do dict <- Map.traverseWithKey (constrainField env recordRegion) fields
361+constrainRecord :: RTV -> R.Region -> Map.Map N.Name Can.Expr -> Expectation -> IO Constraint
362+constrainRecord rtv region fields expectation =
363+ do dict <- traverse (constrainField rtv) fields
387364
388365 let getType (_, t, _) = t
389366 let recordType = RecordN (Map.map getType dict) EmptyRecordN
390− let recordCon = CEqual parentRegion context Error.Record recordRegion recordType tipe
367+ let recordCon = CEqual region Record recordType expectation
391368
392369 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict
393370 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict
@@ -395,11 +372,11 @@ constrainRecord env parentRegion context recordRegion fields tipe =
395372 return $ ex vars (CAnd cons)
396373
397374
398−constrainField :: Env -> R.Region -> N.Name -> Can.Expr -> IO (Variable, Type, Constraint)
399−constrainField env recordRegion name expr =
375+constrainField :: RTV -> Can.Expr -> IO (Variable, Type, Constraint)
376+constrainField rtv expr =
400377 do var <- mkFlexVar
401378 let tipe = VarN var
402− con <- constrain env recordRegion (Error.RecordField name) expr tipe
379+ con <- constrain rtv expr (NoExpectation tipe)
403380 return (var, tipe, con)
404381
405382
@@ -407,21 +384,21 @@ constrainField env recordRegion name expr =
407384-- CONSTRAIN RECORD UPDATE
408385
409386
410−constrainUpdate :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Type -> IO Constraint
411−constrainUpdate env parentRegion context recordRegion expr fields tipe =
387+constrainUpdate :: RTV -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Expectation -> IO Constraint
388+constrainUpdate rtv region expr fields expectation =
412389 do sharedVar <- mkFlexVar
413390 let sharedType = VarN sharedVar
414391
415392 oldVars <- traverse (\_ -> mkFlexVar) fields
416393 let oldTypes = Map.map VarN oldVars
417394 let oldRecordType = RecordN oldTypes sharedType
418− oldCon <- constrain env recordRegion Error.RecordUpdate expr oldRecordType
395+ oldCon <- constrain rtv expr (FromContext region RecordUpdate oldRecordType)
419396
420− newDict <- Map.traverseWithKey (constrainField env recordRegion) fields
397+ newDict <- traverse (constrainField rtv) fields
421398
422399 let getType (_, t, _) = t
423400 let newRecordType = RecordN (Map.map getType newDict) sharedType
424− let newCon = CEqual parentRegion context Error.Record recordRegion newRecordType tipe
401+ let newCon = CEqual region Record newRecordType expectation
425402
426403 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict
427404 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict
@@ -433,30 +410,30 @@ constrainUpdate env parentRegion context recordRegion expr fields tipe =
433410-- CONSTRAIN TUPLE
434411
435412
436−constrainTuple :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Type -> IO Constraint
437−constrainTuple env parentRegion context tupleRegion a b maybeC tipe =
413+constrainTuple :: RTV -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Expectation -> IO Constraint
414+constrainTuple rtv region a b maybeC expectation =
438415 do aVar <- mkFlexVar
439416 bVar <- mkFlexVar
440417 let aType = VarN aVar
441418 let bType = VarN bVar
442419
443− aCon <- constrain env tupleRegion Error.Whatever a aType
444− bCon <- constrain env tupleRegion Error.Whatever b bType
420+ aCon <- constrain rtv a (NoExpectation aType)
421+ bCon <- constrain rtv b (NoExpectation bType)
445422
446423 case maybeC of
447424 Nothing ->
448425 do let tupleType = TupleN aType bType Nothing
449− let tupleCon = CEqual parentRegion context Error.Tuple tupleRegion tupleType tipe
426+ let tupleCon = CEqual region Tuple tupleType expectation
450427 return $ ex [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]
451428
452429 Just c ->
453430 do cVar <- mkFlexVar
454431 let cType = VarN cVar
455432
456− cCon <- constrain env tupleRegion Error.Whatever c cType
433+ cCon <- constrain rtv c (NoExpectation cType)
457434
458435 let tupleType = TupleN aType bType (Just cType)
459− let tupleCon = CEqual parentRegion context Error.Tuple tupleRegion tupleType tipe
436+ let tupleCon = CEqual region Tuple tupleType expectation
460437
461438 return $ ex [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]
462439
@@ -465,8 +442,8 @@ constrainTuple env parentRegion context tupleRegion a b maybeC tipe =
465442-- CONSTRAIN SHADER
466443
467444
468−constrainShader :: Env -> R.Region -> Error.Context -> R.Region -> Shader.Shader -> Type -> IO Constraint
469−constrainShader env parentRegion context shaderRegion (Shader.Shader attributes uniforms varyings) tipe =
445+constrainShader :: R.Region -> Shader.Shader -> Expectation -> IO Constraint
446+constrainShader region (Shader.Shader attributes uniforms varyings) expectation =
470447 do attrVar <- mkFlexVar
471448 unifVar <- mkFlexVar
472449 let attrType = VarN attrVar
@@ -480,7 +457,7 @@ constrainShader env parentRegion context shaderRegion (Shader.Shader attributes
480457 ]
481458
482459 return $ ex [ attrVar, unifVar ] $
483− CEqual parentRegion context Error.Shader shaderRegion shaderType tipe
460+ CEqual region Shader shaderType expectation
484461
485462
486463toShaderRecord :: Map.Map N.Name Shader.Type -> Type -> Type
@@ -507,11 +484,30 @@ glToType glType =
507484-- CONSTRAIN LET
508485
509486
510−constrainLet :: Env -> R.Region -> Error.Context -> R.Region -> Can.Def -> Can.Expr -> Type -> IO Constraint
511−constrainLet env parentRegion context letRegion (Can.Def (A.A _ name) (Can.Args args _) expr maybeType) body tipe =
512− case maybeType of
513− Nothing ->
514− error "TODO"
487+constrainDef :: RTV -> Can.Def -> Constraint -> IO Constraint
488+constrainDef rtv def bodyCon =
489+ case def of
490+ Can.Def (A.A region name) args _ expr ->
491+ do (lambdaType, resultType, scheme) <-
492+ Pattern.constrainArgs args
493+
494+ defCon <-
495+ CLet [scheme] <$> constrain rtv expr (NoExpectation resultType)
496+
497+ let headers = Map.singleton name (A.A region lambdaType)
498+ return $ CLet [Scheme [] [] headers defCon] bodyCon
499+
500+ Can.TypedDef (A.A region name) freeVars typedArgs _ expr srcResultType ->
501+ do let newNames = Map.difference freeVars rtv
502+ newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames
503+ let newRtv = Map.union rtv (Map.map VarN newRigids)
504+
505+ (lambdaType, resultType, scheme) <-
506+ Pattern.constrainTypedArgs newRtv typedArgs srcResultType
507+
508+ let expectation = FromAnnotation name (length typedArgs) TypedBody resultType
509+ defCon <-
510+ CLet [scheme] <$> constrain newRtv expr expectation
515511
516− Just srcType ->
517− error "TODO"
512+ let headers = Map.singleton name (A.A region lambdaType)
513+ return $ CLet [ Scheme (Map.elems newRigids) [] headers defCon ] bodyCon
src/Type/Constrain/Pattern.hs+163−76
@@ -1,8 +1,8 @@
11{-# OPTIONS_GHC -Wall #-}
22module Type.Constrain.Pattern
3− ( State(..)
4− , emptyState
5− , addConstraints
3+ ( constrain
4+ , constrainArgs
5+ , constrainTypedArgs
66 )
77 where
88
@@ -17,7 +17,6 @@ import qualified Data.Bag as Bag
1717import qualified Data.Index as Index
1818import qualified Elm.Name as N
1919import qualified Reporting.Annotation as A
20−import qualified Reporting.Error.Type as Error
2120import qualified Reporting.Region as R
2221import Type.Constraint
2322import qualified Type.Instantiate as Instantiate
@@ -25,7 +24,78 @@ import Type.Type as T
2524
2625
2726
28−-- ADD CONSTRAINTS
27+-- CONSTRAIN
28+
29+
30+constrain :: Can.Pattern -> PatternExpectation -> IO Scheme
31+constrain pattern expectation =
32+ do (State headers vars revCons) <- add pattern expectation emptyState
33+ return $ Scheme [] (Bag.toList vars) headers (CAnd (reverse revCons))
34+
35+
36+{-# NOINLINE emptyState #-}
37+emptyState :: State
38+emptyState =
39+ State Map.empty Bag.empty []
40+
41+
42+
43+-- CONSTRAIN ARGS
44+
45+
46+constrainArgs :: [Can.Arg] -> IO (Type, Type, Scheme)
47+constrainArgs args =
48+ do resultVar <- mkFlexVar
49+ let resultType = VarN resultVar
50+ (toLambdaType, State headers varBag revCons) <-
51+ foldM argHelp (id, emptyState) args
52+
53+ let vars = resultVar : Bag.toList varBag
54+ let cons = CAnd (reverse revCons)
55+ return
56+ ( toLambdaType resultType
57+ , resultType
58+ , Scheme [] vars headers cons
59+ )
60+
61+
62+argHelp :: (Type -> Type, State) -> Can.Arg -> IO (Type -> Type, State)
63+argHelp (toLambdaType, state) (Can.Arg _ pattern) =
64+ do argVar <- mkFlexVar
65+ let argType = VarN argVar
66+ newState <- add pattern (NoPatternExpectation argType) state
67+ return (toLambdaType . FunN argType, addToVars argVar newState)
68+
69+
70+
71+-- CONSTRAIN TYPED ARGS
72+
73+
74+constrainTypedArgs :: Map.Map N.Name Type -> [Can.TypedArg] -> Can.Type -> IO (Type, Type, Scheme)
75+constrainTypedArgs rtv args srcResultType =
76+ do resultType <- Instantiate.fromSrcType rtv srcResultType
77+
78+ (toLambdaType, State headers varBag revCons) <-
79+ foldM (typedArgHelp rtv) (id, emptyState) args
80+
81+ let vars = Bag.toList varBag
82+ let cons = CAnd (reverse revCons)
83+ return
84+ ( toLambdaType resultType
85+ , resultType
86+ , Scheme [] vars headers cons
87+ )
88+
89+
90+typedArgHelp :: Map.Map N.Name Type -> (Type -> Type, State) -> Can.TypedArg -> IO (Type -> Type, State)
91+typedArgHelp rtv (toLambdaType, state) (Can.TypedArg _ srcType pattern) =
92+ do argType <- Instantiate.fromSrcType rtv srcType
93+ newState <- add pattern (NoPatternExpectation argType) state
94+ return (toLambdaType . FunN argType, newState)
95+
96+
97+
98+-- ACTUALLY ADD CONSTRAINTS
2999
30100
31101-- The constraints are stored in reverse order so that adding a new
@@ -33,53 +103,48 @@ import Type.Type as T
33103--
34104data State =
35105 State
36− { _headers :: Map.Map N.Name (A.Located Type)
106+ { _headers :: Header
37107 , _vars :: Bag.Bag Variable
38108 , _revCons :: [Constraint]
39109 }
40110
41111
42−emptyState :: State
43−emptyState =
44− State Map.empty Bag.empty []
112+type Header = Map.Map N.Name (A.Located Type)
45113
46114
47−addConstraints :: R.Region -> Error.PatternContext -> Can.Pattern -> Type -> State -> IO State
48−addConstraints outerRegion context (A.A region pattern) tipe state =
115+add :: Can.Pattern -> PatternExpectation -> State -> IO State
116+add (A.A region pattern) expectation state =
49117 case pattern of
50118 Can.PAnything ->
51119 return state
52120
53121 Can.PVar name ->
54− do let (State headers vars revCons) = state
55− let newHeaders = Map.insert name (A.A region tipe) headers
56− return $ State newHeaders vars revCons
122+ return $ addToHeaders region name expectation state
57123
58124 Can.PAlias realPattern name ->
59− do let (State headers vars revCons) = state
60− addConstraints outerRegion context realPattern tipe $
61− State (Map.insert name (A.A region tipe) headers) vars revCons
125+ add realPattern expectation $
126+ addToHeaders region name expectation state
62127
63128 Can.PUnit ->
64129 do let (State headers vars revCons) = state
65− let unitCon = CPattern outerRegion context Error.PUnit region UnitN tipe
130+ let unitCon = CPattern region PUnit UnitN expectation
66131 return $ State headers vars (unitCon:revCons)
67132
68133 Can.PTuple a b maybeC ->
69− addTupleConstraint outerRegion context region a b maybeC tipe state
134+ addTuple region a b maybeC expectation state
70135
71136 Can.PCtor home typeName typeVars ctorName args ->
72− addCtorConstraint outerRegion context region home typeName typeVars ctorName args tipe state
137+ addCtor region home typeName typeVars ctorName args expectation state
73138
74139 Can.PList patterns ->
75140 do entryVar <- mkFlexVar
76− let entryVarN = VarN entryVar
77− let listType = AppN ModuleName.list N.list [entryVarN]
141+ let entryType = VarN entryVar
142+ let listType = AppN ModuleName.list N.list [entryType]
78143
79144 (State headers vars revCons) <-
80− foldM (addListConstraint region entryVarN) state (Index.indexedMap (,) patterns)
145+ foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)
81146
82− let listCon = CPattern outerRegion context Error.PList region listType tipe
147+ let listCon = CPattern region PList listType expectation
83148 return $ State headers (Bag.insert entryVar vars) (listCon:revCons)
84149
85150 Can.PCons headPattern tailPattern ->
@@ -87,11 +152,14 @@ addConstraints outerRegion context (A.A region pattern) tipe state =
87152 let entryType = VarN entryVar
88153 let listType = AppN ModuleName.list N.list [entryType]
89154
155+ let headExpectation = NoPatternExpectation entryType
156+ let tailExpectation = PatternExpectation region PTail listType
157+
90158 (State headers vars revCons) <-
91− addConstraints region Error.PatternHead headPattern entryType =<<
92− addConstraints region Error.PatternTail tailPattern listType state
159+ add headPattern headExpectation =<<
160+ add tailPattern tailExpectation state
93161
94− let listCon = CPattern outerRegion context Error.PList region listType tipe
162+ let listCon = CPattern region PList listType expectation
95163 return $ State headers (Bag.insert entryVar vars) (listCon : revCons)
96164
97165 Can.PRecord fields ->
@@ -103,7 +171,7 @@ addConstraints outerRegion context (A.A region pattern) tipe state =
103171 let recordType = RecordN fieldTypes extType
104172
105173 let (State headers vars revCons) = state
106− let recordCon = CPattern outerRegion context Error.PRecord region recordType tipe
174+ let recordCon = CPattern region PRecord recordType expectation
107175 return $
108176 State
109177 { _headers = Map.union headers (Map.map (A.A region) fieldTypes)
@@ -113,97 +181,115 @@ addConstraints outerRegion context (A.A region pattern) tipe state =
113181
114182 Can.PInt _ ->
115183 do let (State headers vars revCons) = state
116− let intCon = CPattern outerRegion context Error.PInt region T.int tipe
184+ let intCon = CPattern region PInt T.int expectation
117185 return $ State headers vars (intCon:revCons)
118186
119187 Can.PStr _ ->
120188 do let (State headers vars revCons) = state
121− let strCon = CPattern outerRegion context Error.PStr region T.string tipe
189+ let strCon = CPattern region PStr T.string expectation
122190 return $ State headers vars (strCon:revCons)
123191
124192 Can.PChr _ ->
125193 do let (State headers vars revCons) = state
126− let chrCon = CPattern outerRegion context Error.PChr region T.char tipe
194+ let chrCon = CPattern region PChr T.char expectation
127195 return $ State headers vars (chrCon:revCons)
128196
129197
130198
199+-- STATE HELPERS
200+
201+
202+addToVars :: Variable -> State -> State
203+addToVars var (State headers vars revCons) =
204+ State headers (Bag.insert var vars) revCons
205+
206+
207+addToHeaders :: R.Region -> N.Name -> PatternExpectation -> State -> State
208+addToHeaders region name expectation (State headers vars revCons) =
209+ let
210+ tipe = getType expectation
211+ newHeaders = Map.insert name (A.A region tipe) headers
212+ in
213+ State newHeaders vars revCons
214+
215+
216+getType :: PatternExpectation -> Type
217+getType expectation =
218+ case expectation of
219+ NoPatternExpectation tipe -> tipe
220+ PatternExpectation _ _ tipe -> tipe
221+
131222
132223
133224-- CONSTRAIN LIST
134225
135226
136−addListConstraint :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
137−addListConstraint listRegion tipe state (index, pattern) =
138− addConstraints listRegion (Error.PatternList index) pattern tipe state
227+addEntry :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
228+addEntry listRegion tipe state (index, pattern) =
229+ let
230+ expectation =
231+ PatternExpectation listRegion (PListEntry index) tipe
232+ in
233+ add pattern expectation state
139234
140235
141236
142237-- CONSTRAIN TUPLE
143238
144239
145−addTupleConstraint
146− :: R.Region
147− -> Error.PatternContext
148− -> R.Region
149− -> Can.Pattern
150− -> Can.Pattern
151− -> Maybe Can.Pattern
152− -> Type
153− -> State
154− -> IO State
155−addTupleConstraint parentRegion context tupleRegion a b maybeC tipe (State headers vars revCons) =
240+addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> PatternExpectation -> State -> IO State
241+addTuple region a b maybeC expectation state =
156242 do aVar <- mkFlexVar
157243 bVar <- mkFlexVar
158− let aVarN = VarN aVar
159− let bVarN = VarN bVar
160−
161− let equal = CPattern parentRegion context Error.PTuple tupleRegion
162− let addCon = addConstraints tupleRegion Error.PatternUnknown
244+ let aType = VarN aVar
245+ let bType = VarN bVar
163246
164247 case maybeC of
165248 Nothing ->
166− do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
249+ do (State headers vars revCons) <-
250+ simpleAdd b bType =<<
251+ simpleAdd a aType state
252+
167253 let newVars = Bag.insert aVar (Bag.insert bVar vars)
168− addCon b bVarN =<<
169− addCon a aVarN (State headers newVars (tupleCon:revCons))
254+ let tupleCon = CPattern region PTuple (TupleN aType bType Nothing) expectation
255+
256+ return $ State headers newVars (tupleCon:revCons)
170257
171258 Just c ->
172259 do cVar <- mkFlexVar
173− let cVarN = VarN cVar
174− let tupleCon = equal (TupleN aVarN bVarN (Just cVarN)) tipe
260+ let cType = VarN cVar
261+
262+ (State headers vars revCons) <-
263+ simpleAdd c cType =<<
264+ simpleAdd b bType =<<
265+ simpleAdd a aType state
266+
175267 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
176− addCon c cVarN =<<
177− addCon b bVarN =<<
178− addCon a aVarN (State headers newVars (tupleCon:revCons))
268+ let tupleCon = CPattern region PTuple (TupleN aType bType (Just cType)) expectation
269+
270+ return $ State headers newVars (tupleCon:revCons)
271+
272+
273+simpleAdd :: Can.Pattern -> Type -> State -> IO State
274+simpleAdd pattern patternType state =
275+ add pattern (NoPatternExpectation patternType) state
179276
180277
181278
182279-- CONSTRAIN CONSTRUCTORS
183280
184281
185−addCtorConstraint
186− :: R.Region
187− -> Error.PatternContext
188− -> R.Region
189− -> ModuleName.Canonical
190− -> N.Name
191− -> [N.Name]
192− -> N.Name
193− -> [Can.PatternCtorArg]
194− -> Type
195− -> State
196− -> IO State
197−addCtorConstraint outerRegion context ctorRegion home typeName typeVarNames ctorName args tipe state =
282+addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> PatternExpectation -> State -> IO State
283+addCtor region home typeName typeVarNames ctorName args expectation state =
198284 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
199285 let typePairs = map (second VarN) varPairs
200286 let freeVarDict = Map.fromList typePairs
201287
202288 (State headers vars revCons) <-
203− foldM (addCtorArgConstraint ctorRegion ctorName freeVarDict) state args
289+ foldM (addCtorArg region ctorName freeVarDict) state args
204290
205291 let ctorType = AppN home typeName (map snd typePairs)
206− let ctorCon = CPattern outerRegion context (Error.PCtor ctorName) ctorRegion ctorType tipe
292+ let ctorCon = CPattern region (PCtor ctorName) ctorType expectation
207293
208294 return $
209295 State
@@ -213,7 +299,8 @@ addCtorConstraint outerRegion context ctorRegion home typeName typeVarNames ctor
213299 }
214300
215301
216−addCtorArgConstraint :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
217−addCtorArgConstraint ctorRegion ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
302+addCtorArg :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
303+addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
218304 do tipe <- Instantiate.fromSrcType freeVarDict srcType
219− addConstraints ctorRegion (Error.PatternCtorArg ctorName index) pattern tipe state
305+ let expectation = PatternExpectation region (PCtorArg ctorName index) tipe
306+ add pattern expectation state
src/Type/Constraint.hs+111−22
@@ -2,9 +2,17 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Type.Constraint
44 ( Constraint(..)
5− , ex
5+ , Expectation(..)
6+ , Context(..)
7+ , SubContext(..)
8+ , FuncName(..)
9+ , Category(..)
10+ , PatternExpectation(..)
11+ , PatternContext(..)
12+ , PatternCategory(..)
613 , Scheme(..)
714 , monoscheme
15+ , ex
816 )
917 where
1018
@@ -12,9 +20,9 @@ module Type.Constraint
1220import qualified Data.Map.Strict as Map
1321
1422import qualified AST.Canonical as Can
23+import qualified Data.Index as Index
1524import qualified Elm.Name as N
1625import qualified Reporting.Annotation as A
17−import qualified Reporting.Error.Type as Error
1826import qualified Reporting.Region as R
1927import Type.Type (Type, Variable)
2028
@@ -24,14 +32,103 @@ import Type.Type (Type, Variable)
2432
2533
2634data Constraint
27− = CTrue
28− | CSaveHeaders
29− | CEqual R.Region Error.Context Error.Category R.Region Type Type
30− | CLookup R.Region Error.Context R.Region N.Name Type
31− | CInstance R.Region Error.Context R.Region Can.Type Type
32− | CPattern R.Region Error.PatternContext Error.PatternCategory R.Region Type Type
33− | CAnd [Constraint]
34− | CLet [Scheme] Constraint
35+ = CTrue
36+ | CSaveHeaders
37+ | CEqual R.Region Category Type Expectation
38+ | CLookup R.Region N.Name Expectation
39+ | CInstance R.Region FuncName Can.Annotation Expectation
40+ | CPattern R.Region PatternCategory Type PatternExpectation
41+ | CAnd [Constraint]
42+ | CLet [Scheme] Constraint
43+ | CBranch
44+ { _a :: Type
45+ , _b :: Type
46+ , _eq :: Constraint
47+ , _neq :: IO Constraint
48+ }
49+
50+
51+
52+-- EXPRESSION EXPECTATIONS
53+
54+
55+data Expectation
56+ = NoExpectation Type
57+ | FromContext R.Region Context Type
58+ | FromAnnotation N.Name Int SubContext Type
59+
60+
61+data Context
62+ = ListEntry Index.ZeroBased
63+ | Negate
64+ | OpLeft N.Name
65+ | OpRight N.Name
66+ | IfCondition
67+ | IfBranch Index.ZeroBased
68+ | CaseBranch Index.ZeroBased
69+ | CallArg (Maybe FuncName) Index.ZeroBased
70+ | BadArity
71+ | RecordAccess N.Name
72+ | RecordUpdate
73+
74+
75+data SubContext
76+ = TypedIfBranch Index.ZeroBased
77+ | TypedElseBranch
78+ | TypedCaseBranch Index.ZeroBased
79+ | TypedBody
80+
81+
82+data FuncName
83+ = FuncName N.Name
84+ | OpName N.Name
85+
86+
87+data Category
88+ = List
89+ | Number
90+ | Float
91+ | String
92+ | Char
93+ | Binop
94+ | If
95+ | Case
96+ | CallResult (Maybe FuncName)
97+ | Lambda
98+ | Accessor N.Name
99+ | Access N.Name
100+ | Record
101+ | Tuple
102+ | Unit
103+ | Shader
104+
105+
106+
107+-- PATTERN EXPECTATIONS
108+
109+
110+data PatternExpectation
111+ = NoPatternExpectation Type
112+ | PatternExpectation R.Region PatternContext Type
113+
114+
115+data PatternContext
116+ = PTypedArg N.Name Index.ZeroBased
117+ | PCaseMatch Index.ZeroBased
118+ | PCtorArg N.Name Index.ZeroBased
119+ | PListEntry Index.ZeroBased
120+ | PTail
121+
122+
123+data PatternCategory
124+ = PRecord
125+ | PUnit
126+ | PTuple
127+ | PList
128+ | PCtor N.Name
129+ | PInt
130+ | PStr
131+ | PChr
35132
36133
37134
@@ -47,23 +144,15 @@ data Scheme =
47144 }
48145
49146
50−
51−-- SCHEME HELPERS
52−
53−
54147monoscheme :: Map.Map N.Name (A.Located Type) -> Scheme
55148monoscheme headers =
56149 Scheme [] [] headers CTrue
57150
58151
59−
60−-- CONSTRAINT HELPERS
61−
62−
63152-- ex qs constraint == exists qs. constraint
64153ex :: [Variable] -> Constraint -> Constraint
65154ex flexVars constraint =
66− CLet
67− [ Scheme [] flexVars Map.empty constraint
68− ]
69− CTrue
155+ CLet
156+ [ Scheme [] flexVars Map.empty constraint
157+ ]
158+ CTrue
src/Type/Instantiate.hs+4−59
@@ -1,8 +1,7 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Type.Instantiate
4− ( flexible
5− , rigid
4+ ( FreeVars
65 , fromSrcType
76 )
87 where
@@ -17,65 +16,11 @@ import Type.Type
1716
1817
1918
20−-- FROM SOURCE TYPES
19+-- FREE VARS
2120
2221
23−-- TODO should the freeFlexVars be ranked a certain way?
24−-- How does this interact with `TS.flatten` exactly?
25−flexible :: Can.Type -> IO ( Type, Map.Map N.Name Variable )
26−flexible srcType =
27− do let freeVars = gatherFreeVars srcType Map.empty
28− freeFlexVars <- Map.traverseWithKey (\name () -> nameToFlex name) freeVars
29− tipe <- fromSrcType (Map.map VarN freeFlexVars) srcType
30− return ( tipe, freeFlexVars )
31−
32−
33−rigid :: Can.Type -> IO ( Type, Map.Map N.Name Variable )
34−rigid srcType =
35− do let freeVars = gatherFreeVars srcType Map.empty
36− freeRigidVars <- Map.traverseWithKey (\name () -> nameToRigid name) freeVars
37− tipe <- fromSrcType (Map.map VarN freeRigidVars) srcType
38− return ( tipe, freeRigidVars )
39−
40−
41−
42−-- GATHER FREE VARS
43−
44−
45−gatherFreeVars :: Can.Type -> Map.Map N.Name () -> Map.Map N.Name ()
46−gatherFreeVars tipe dict =
47− case tipe of
48− Can.TLambda arg result ->
49− gatherFreeVars result (gatherFreeVars arg dict)
50−
51− Can.TVar name ->
52− Map.insert name () dict
53−
54− Can.TType _ _ args ->
55− foldr gatherFreeVars dict args
56−
57− Can.TAlias _ _ args _ ->
58− foldr gatherFreeVars dict (map snd args)
59−
60− Can.TTuple a b maybeC ->
61− gatherFreeVars a $ gatherFreeVars b $
62− case maybeC of
63− Nothing ->
64− dict
65−
66− Just c ->
67− gatherFreeVars c dict
68−
69− Can.TUnit ->
70− dict
71−
72− Can.TRecord fields maybeExt ->
73− case maybeExt of
74− Nothing ->
75− Map.foldr gatherFreeVars dict fields
76−
77− Just ext ->
78− Map.foldr gatherFreeVars (gatherFreeVars ext dict) fields
22+type FreeVars =
23+ Map.Map N.Name Type
7924
8025
8126