git.iko.soy/elk
on master help sign in
Revamp type constraint generation
6709d6fEvan Czaplicki
src/Type/Constrain/Expression.hs+214−218
compare with master
unifiedsplit
@@ -6,19 +6,14 @@ module Type.Constrain.Expression
6 where
6 where
7
7
8
8
9−import Control.Arrow (second)
10−import qualified Control.Monad as Monad
11import qualified Data.Map.Strict as Map
9import qualified Data.Map.Strict as Map
12−import Data.Text (Text)
13
10
14import qualified AST.Canonical as Can
11import qualified AST.Canonical as Can
15import qualified AST.Module.Name as ModuleName
12import qualified AST.Module.Name as ModuleName
16import qualified AST.Utils.Shader as Shader
13import qualified AST.Utils.Shader as Shader
17−import qualified Data.Bag as Bag
18import qualified Data.Index as Index
14import qualified Data.Index as Index
19import qualified Elm.Name as N
15import qualified Elm.Name as N
20import qualified Reporting.Annotation as A
16import qualified Reporting.Annotation as A
21−import qualified Reporting.Error.Type as Error
22import qualified Reporting.Region as R
17import qualified Reporting.Region as R
23import Type.Constraint
18import Type.Constraint
24import qualified Type.Constrain.Pattern as Pattern
19import qualified Type.Constrain.Pattern as Pattern
@@ -29,73 +24,78 @@ import Type.Type as Type hiding (Descriptor(..))
29-- CONSTRAIN
24-- CONSTRAIN
30
25
31
26
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.
33--
30--
34−-- So if you have a top-level type annotation like (func : a -> b) then
31+-- So if you have a top-level type annotation like (func : a -> b) the RTV
35−-- the environment will hold variables for `a` and `b`
32+-- dictionary will hold variables for `a` and `b`
36--
33--
34+type RTV =
37−type Env = Map.Map N.Name Variable
35+ Map.Map N.Name Type
38
36
39
37
40−constrain :: Env -> R.Region -> Error.Context -> Can.Expr -> Type -> IO Constraint
38+constrain :: RTV -> Can.Expr -> Expectation -> IO Constraint
41−constrain env parentRegion context (A.A region expression) tipe =
39+constrain rtv (A.A region expression) expectation =
42 case expression of
40 case expression of
43 Can.VarLocal name ->
41 Can.VarLocal name ->
44− return (CLookup parentRegion context region name tipe)
42+ return (CLookup region name expectation)
45
43
46 Can.VarTopLevel _ name ->
44 Can.VarTopLevel _ name ->
47− return (CLookup parentRegion context region name tipe)
45+ return (CLookup region name expectation)
48
46
49 Can.VarKernel _ _ ->
47 Can.VarKernel _ _ ->
50 return CTrue
48 return CTrue
51
49
52 Can.VarForeign _ name annotation ->
50 Can.VarForeign _ name annotation ->
53− error "TODO figure out foreign types"
51+ return $ CInstance region (FuncName name) annotation expectation
54
52
55 Can.VarOperator op _ _ annotation ->
53 Can.VarOperator op _ _ annotation ->
56− error "TODO figure out foreign types"
54+ return $ CInstance region (OpName op) annotation expectation
57
55
58 Can.Str _ ->
56 Can.Str _ ->
59− return $ CEqual parentRegion context Error.String region Type.string tipe
57+ return $ CEqual region String Type.string expectation
60
58
61 Can.Chr _ ->
59 Can.Chr _ ->
62− return $ CEqual parentRegion context Error.Char region Type.char tipe
60+ return $ CEqual region Char Type.char expectation
63
61
64 Can.Int _ ->
62 Can.Int _ ->
65 do var <- mkFlexNumber
63 do var <- mkFlexNumber
66− return $ ex [var] $
64+ return $ ex [var] $ CEqual region Number (VarN var) expectation
67− CEqual parentRegion context Error.Number region (VarN var) tipe
68
65
69 Can.Float _ ->
66 Can.Float _ ->
70− return $ CEqual parentRegion context Error.Float region Type.float tipe
67+ return $ CEqual region Float Type.float expectation
71
68
72 Can.List elements ->
69 Can.List elements ->
73− constrainList env parentRegion context region elements tipe
70+ constrainList rtv region elements expectation
74
71
75 Can.Negate expr ->
72 Can.Negate expr ->
76 do numberVar <- mkFlexNumber
73 do numberVar <- mkFlexNumber
77 let numberType = VarN numberVar
74 let numberType = VarN numberVar
78− numberCon <- constrain env region Error.Negate expr numberType
75+ numberCon <- constrain rtv expr (FromContext region Negate numberType)
79− let negateCon = CEqual parentRegion context Error.Number region numberType tipe
76+ let negateCon = CEqual region Number numberType expectation
80 return $ ex [numberVar] $ CAnd [ numberCon, negateCon ]
77 return $ ex [numberVar] $ CAnd [ numberCon, negateCon ]
81
78
82− Can.Binop op home name annotation leftExpr rightExpr ->
79+ Can.Binop op _ _ annotation leftExpr rightExpr ->
83− constrainBinop env parentRegion context region op annotation leftExpr rightExpr tipe
80+ constrainBinop rtv region op annotation leftExpr rightExpr expectation
84
81
85− Can.Lambda args body ->
82+ Can.Lambda args _ body ->
86− constrainLambda parentRegion context env region args body tipe
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 ]
87
87
88 Can.Call func args ->
88 Can.Call func args ->
89− constrainCall env parentRegion context region func args tipe
89+ constrainCall rtv region func args expectation
90
90
91 Can.If branches finally ->
91 Can.If branches finally ->
92− constrainIf env parentRegion context region branches finally tipe
92+ constrainIf rtv region branches finally expectation
93
93
94 Can.Case expr branches ->
94 Can.Case expr branches ->
95− constrainCase env parentRegion context region expr branches tipe
95+ constrainCase rtv region expr branches expectation
96
96
97 Can.Let def body ->
97 Can.Let def body ->
98− constrainLet env parentRegion context region def body tipe
98+ constrainDef rtv def =<< constrain rtv body expectation
99
99
100 Can.LetRec defs body ->
100 Can.LetRec defs body ->
101 error "TODO let rec" defs body
101 error "TODO let rec" defs body
@@ -110,7 +110,7 @@ constrain env parentRegion context (A.A region expression) tipe =
110 let fieldType = VarN fieldVar
110 let fieldType = VarN fieldVar
111 let recordType = RecordN (Map.singleton field fieldType) extType
111 let recordType = RecordN (Map.singleton field fieldType) extType
112 return $ ex [ fieldVar, extVar ] $
112 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
114
114
115 Can.Access expr field ->
115 Can.Access expr field ->
116 do extVar <- mkFlexVar
116 do extVar <- mkFlexVar
@@ -118,179 +118,134 @@ constrain env parentRegion context (A.A region expression) tipe =
118 let extType = VarN extVar
118 let extType = VarN extVar
119 let fieldType = VarN fieldVar
119 let fieldType = VarN fieldVar
120 let recordType = RecordN (Map.singleton field fieldType) extType
120 let recordType = RecordN (Map.singleton field fieldType) extType
121+
122+ recordCon <-
121− recordCon <- constrain env region (Error.RecordAccess field) expr recordType
123+ constrain rtv expr (FromContext region (RecordAccess field) recordType)
124+
122 return $ ex [ fieldVar, extVar ] $
125 return $ ex [ fieldVar, extVar ] $
123 CAnd
126 CAnd
124 [ recordCon
127 [ recordCon
125− , CEqual parentRegion context (Error.Access field) region recordType tipe
128+ , CEqual region (Access field) recordType expectation
126 ]
129 ]
127
130
128 Can.Update expr fields ->
131 Can.Update expr fields ->
129− constrainUpdate env parentRegion context region expr fields tipe
132+ constrainUpdate rtv region expr fields expectation
130
133
131 Can.Record fields ->
134 Can.Record fields ->
132− constrainRecord env parentRegion context region fields tipe
135+ constrainRecord rtv region fields expectation
133
136
134 Can.Unit ->
137 Can.Unit ->
135− return $ CEqual parentRegion context Error.Unit region UnitN tipe
138+ return $ CEqual region Unit UnitN expectation
136
139
137 Can.Tuple a b maybeC ->
140 Can.Tuple a b maybeC ->
138− constrainTuple env parentRegion context region a b maybeC tipe
141+ constrainTuple rtv region a b maybeC expectation
139
142
140 Can.Shader _uid _src glType ->
143 Can.Shader _uid _src glType ->
141− constrainShader env parentRegion context region glType tipe
144+ constrainShader region glType expectation
142
145
143
146
144
147
145−-- CONSTRAIN LAMBDA
148+-- CONSTRAIN CALL
146
149
147
150
148−constrainLambda :: R.Region -> Error.Context -> Env -> R.Region -> Can.Args -> Can.Expr -> Type -> IO Constraint
151+constrainCall :: RTV -> R.Region -> Can.Expr -> [Can.Expr] -> Expectation -> IO Constraint
149−constrainLambda parentRegion context env lambdaRegion (Can.Args args _) body tipe =
152+constrainCall rtv region func args expectation =
150− constrainLambdaHelp parentRegion context env lambdaRegion args body [] Pattern.emptyState tipe
153+ do let maybeFuncName = getFuncName func
151
154
155+ funcVar <- mkFlexVar
156+ resultVar <- mkFlexVar
157+ let funcType = VarN funcVar
158+ let resultType = VarN resultVar
152
159
153−constrainLambdaHelp :: R.Region -> Error.Context -> Env -> R.Region -> [Can.Arg] -> Can.Expr -> [Type] -> Pattern.State -> Type -> IO Constraint
160+ funcCon <- constrain rtv func (NoExpectation funcType)
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
163
161
164− [] ->
162+ (argVars, argTypes, argCons) <-
165− do resultVar <- mkFlexVar
163+ unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeFuncName) args
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
170
164
171− let (Pattern.State headers vars revCons) = state
165+ let arityType = foldr FunN resultType argTypes
172− let scheme = Scheme [] (resultVar : Bag.toList vars) headers (CAnd (reverse revCons))
166+ let resultCon = CEqual region (CallResult maybeFuncName) resultType expectation
173
167
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+ ]
175
178
176
179
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)
177
186
178−-- CONSTRAIN CALL
179
187
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
180
192
181−constrainCall :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> [Can.Expr] -> Type -> IO Constraint
193+ resultVar <- mkFlexVar
182−constrainCall env parentRegion context callRegion func args tipe =
194+ let resultType = VarN resultVar
183− do let callName = toCallName func
195+ let arityType = foldr FunN resultType argTypes
184− let (A.A lastArgRegion _) = last args
185
196
186− funcVar <- mkFlexVar
197+ funcCon <- constrain rtv func (FromContext region BadArity arityType)
187− let funcType = VarN funcVar
198+
188− funcCon <- constrain env callRegion Error.Whatever func funcType
199+ return $ ex (resultVar:argVars) $ CAnd [ CAnd argCons, funcCon ]
189−
200+
190− (vars, revCons, resultType) <-
201+
191− constrainCallHelp env callRegion callName lastArgRegion args Index.first [funcVar] funcType [funcCon]
202+getFuncName :: Can.Expr -> Maybe FuncName
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) =
203+getFuncName (A.A _ expr) =
237 case expr of
204 case expr of
238 Can.VarLocal name ->
205 Can.VarLocal name ->
239− Error.FuncCall name
206+ Just (FuncName name)
240
207
241 Can.VarTopLevel _ name ->
208 Can.VarTopLevel _ name ->
242− Error.FuncCall name
209+ Just (FuncName name)
243
210
244 Can.VarKernel _ name ->
211 Can.VarKernel _ name ->
245− Error.FuncCall name
212+ Just (FuncName name)
246
213
247 Can.VarForeign _ name _ ->
214 Can.VarForeign _ name _ ->
248− Error.FuncCall name
215+ Just (FuncName name)
249
216
250 Can.VarOperator op _ _ _ ->
217 Can.VarOperator op _ _ _ ->
251− Error.OpCall op
218+ Just (OpName op)
252−
253− Can.Accessor field ->
254− Error.AccessCall field
255
219
256 _ ->
220 _ ->
257− Error.UnknownCall
221+ Nothing
258
222
259
223
260
224
261-- CONSTRAIN BINOP
225-- CONSTRAIN BINOP
262
226
263
227
264−constrainBinop
228+constrainBinop :: RTV -> R.Region -> N.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> Expectation -> IO Constraint
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 =
229+constrainBinop rtv region op annotation leftExpr rightExpr expectation =
276 do leftVar <- mkFlexVar
230 do leftVar <- mkFlexVar
277 rightVar <- mkFlexVar
231 rightVar <- mkFlexVar
278 answerVar <- mkFlexVar
232 answerVar <- mkFlexVar
279 let leftType = VarN leftVar
233 let leftType = VarN leftVar
280 let rightType = VarN rightVar
234 let rightType = VarN rightVar
281 let answerType = VarN answerVar
235 let answerType = VarN answerVar
236+ let binopType = leftType ==> rightType ==> answerType
282
237
283− let opCon = error "TODO CInstance" srcType (leftType ==> rightType ==> answerType)
238+ let opCon = CInstance region (OpName op) annotation (NoExpectation binopType)
284
239
285− leftCon <- constrain env opRegion (Error.OpLeft op) leftExpr leftType
240+ leftCon <- constrain rtv leftExpr (FromContext region (OpLeft op) leftType)
286− rightCon <- constrain env opRegion (Error.OpRight op) rightExpr rightType
241+ rightCon <- constrain rtv rightExpr (FromContext region (OpRight op) rightType)
287
242
288 return $ ex [ leftVar, rightVar, answerVar ] $
243 return $ ex [ leftVar, rightVar, answerVar ] $
289 CAnd
244 CAnd
290 [ opCon
245 [ opCon
291 , leftCon
246 , leftCon
292 , rightCon
247 , rightCon
293− , CEqual parentRegion context (Error.Call (Error.OpCall op)) opRegion answerType tipe
248+ , CEqual region (CallResult (Just (OpName op))) answerType expectation
294 ]
249 ]
295
250
296
251
@@ -298,96 +253,118 @@ constrainBinop env parentRegion context opRegion op srcType leftExpr rightExpr t
298-- CONSTRAIN LISTS
253-- CONSTRAIN LISTS
299
254
300
255
301−constrainList :: Env -> R.Region -> Error.Context -> R.Region -> [Can.Expr] -> Type -> IO Constraint
256+constrainList :: RTV -> R.Region -> [Can.Expr] -> Expectation -> IO Constraint
302−constrainList env parentRegion context listRegion entries tipe =
257+constrainList rtv region entries expectation =
303 do entryVar <- mkFlexVar
258 do entryVar <- mkFlexVar
304 let entryType = VarN entryVar
259 let entryType = VarN entryVar
305− entryCons <- Index.indexedTraverse (constrainListEntry env listRegion entryType) entries
306 let listType = AppN ModuleName.list N.list [entryType]
260 let listType = AppN ModuleName.list N.list [entryType]
261+
262+ entryCons <-
263+ Index.indexedTraverse (constrainListEntry rtv region entryType) entries
264+
307 return $ ex [entryVar] $
265 return $ ex [entryVar] $
308 CAnd
266 CAnd
309 [ CAnd entryCons
267 [ CAnd entryCons
310− , CEqual parentRegion context Error.List listRegion listType tipe
268+ , CEqual region List listType expectation
311 ]
269 ]
312
270
313
271
314−constrainListEntry :: Env -> R.Region -> Type -> Index.ZeroBased -> Can.Expr -> IO Constraint
272+constrainListEntry :: RTV -> R.Region -> Type -> Index.ZeroBased -> Can.Expr -> IO Constraint
315−constrainListEntry env listRegion tipe index expr =
273+constrainListEntry rtv region tipe index expr =
316− constrain env listRegion (Error.ListEntry index) expr tipe
274+ constrain rtv expr (FromContext region (ListEntry index) tipe)
317−
318
275
319
276
320
277
321-- CONSTRAIN IF EXPRESSIONS
278-- CONSTRAIN IF EXPRESSIONS
322
279
323
280
324−constrainIf :: Env -> R.Region -> Error.Context -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Type -> IO Constraint
281+constrainIf :: RTV -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Expectation -> IO Constraint
325−constrainIf env parentRegion context ifRegion branches final tipe =
282+constrainIf rtv region branches final expectation =
326− do branchVar <- mkFlexVar
283+ do let boolExpect = FromContext region IfCondition Type.bool
327− let branchType = VarN branchVar
284+ let (conditions, exprs) = foldr (\(c,e) (cs,es) -> (c:cs,e:es)) ([],[final]) branches
328
285
329− branchCons <- Index.indexedTraverse (constrainIfBranch env ifRegion branchType) branches
286+ condCons <-
330− finalCon <- constrain env ifRegion (Error.IfBranchFinal (length branches)) final branchType
287+ traverse (\c -> constrain rtv c boolExpect) conditions
331
288
332− return $ ex [branchVar] $
289+ case expectation of
333− CAnd
290+ FromAnnotation name arity _ tipe ->
334− [ CAnd branchCons
291+ do branchCons <- Index.indexedForA exprs $ \index expr ->
335− , finalCon
292+ constrain rtv expr (FromAnnotation name arity (TypedIfBranch index) tipe)
336− , CEqual parentRegion context Error.If ifRegion branchType tipe
293+ return $
294+ CAnd
295+ [ CAnd condCons
296+ , CAnd branchCons
337− ]
297+ ]
338
298
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+ ]
339
312
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 ]
345
313
346
314
347-- CONSTRAIN CASE EXPRESSIONS
315-- CONSTRAIN CASE EXPRESSIONS
348
316
349
317
350−constrainCase :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Type -> IO Constraint
318+constrainCase :: RTV -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Expectation -> IO Constraint
351−constrainCase env parentRegion context caseRegion expr branches tipe =
319+constrainCase rtv region expr branches expectation =
352− do exprVar <- mkFlexVar
353− branchVar <- mkFlexVar
320+ do ptrnVar <- mkFlexVar
354− let exprType = VarN exprVar
321+ let ptrnType = VarN ptrnVar
355− let branchType = VarN branchVar
322+ exprCon <- constrain rtv expr (NoExpectation ptrnType)
356
323
357− exprCon <- constrain env caseRegion Error.CaseExpr expr exprType
324+ case expectation of
358− revCons <- constrainCaseHelp env caseRegion branches exprType branchType [exprCon]
325+ FromAnnotation name arity _ tipe ->
359− let caseCon = CEqual parentRegion context Error.Case caseRegion branchType 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)
360
330
361− return $ ex [ exprVar, branchVar ] $ CAnd (reverse (caseCon:revCons))
331+ return $ ex [ptrnVar] $ CAnd (exprCon:branchCons)
362
332
333+ _ ->
334+ do branchVar <- mkFlexVar
335+ let branchType = VarN branchVar
363
336
337+ branchCons <- Index.indexedForA branches $ \index branch ->
338+ constrainCaseBranch rtv branch
339+ (PatternExpectation region (PCaseMatch index) ptrnType)
340+ (FromContext region (CaseBranch index) branchType)
364
341
365−constrainCaseHelp :: Env -> R.Region -> [Can.CaseBranch] -> Type -> Type -> [Constraint] -> IO [Constraint]
342+ return $ ex [ptrnVar,branchVar] $
366−constrainCaseHelp env caseRegion branches patternType exprType revCons =
343+ CAnd
367− case branches of
344+ [ exprCon
368− [] ->
345+ , CAnd branchCons
369− return revCons
346+ , CEqual region Case branchType expectation
347+ ]
370
348
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
374
349
375− exprCon <- constrain env caseRegion (Error.CaseBranch index) expr exprType
350+constrainCaseBranch :: RTV -> Can.CaseBranch -> PatternExpectation -> Expectation -> IO Constraint
376− let branchCon = CLet [ Scheme [] (Bag.toList vars) headers (CAnd (reverse revCons)) ] exprCon
351+constrainCaseBranch rtv (Can.CaseBranch pattern _ expr) pExpect bExpect =
377− constrainCaseHelp env caseRegion otherBranches patternType exprType (branchCon:revCons)
352+ do scheme <- Pattern.constrain pattern pExpect
353+ constraint <- constrain rtv expr bExpect
354+ return $ CLet [scheme] constraint
378
355
379
356
380
357
381-- CONSTRAIN RECORD
358-- CONSTRAIN RECORD
382
359
383
360
384−constrainRecord :: Env -> R.Region -> Error.Context -> R.Region -> Map.Map N.Name Can.Expr -> Type -> IO Constraint
361+constrainRecord :: RTV -> R.Region -> Map.Map N.Name Can.Expr -> Expectation -> IO Constraint
385−constrainRecord env parentRegion context recordRegion fields tipe =
362+constrainRecord rtv region fields expectation =
386− do dict <- Map.traverseWithKey (constrainField env recordRegion) fields
363+ do dict <- traverse (constrainField rtv) fields
387
364
388 let getType (_, t, _) = t
365 let getType (_, t, _) = t
389 let recordType = RecordN (Map.map getType dict) EmptyRecordN
366 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
391
368
392 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict
369 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict
393 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict
370 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict
@@ -395,11 +372,11 @@ constrainRecord env parentRegion context recordRegion fields tipe =
395 return $ ex vars (CAnd cons)
372 return $ ex vars (CAnd cons)
396
373
397
374
398−constrainField :: Env -> R.Region -> N.Name -> Can.Expr -> IO (Variable, Type, Constraint)
375+constrainField :: RTV -> Can.Expr -> IO (Variable, Type, Constraint)
399−constrainField env recordRegion name expr =
376+constrainField rtv expr =
400 do var <- mkFlexVar
377 do var <- mkFlexVar
401 let tipe = VarN var
378 let tipe = VarN var
402− con <- constrain env recordRegion (Error.RecordField name) expr tipe
379+ con <- constrain rtv expr (NoExpectation tipe)
403 return (var, tipe, con)
380 return (var, tipe, con)
404
381
405
382
@@ -407,21 +384,21 @@ constrainField env recordRegion name expr =
407-- CONSTRAIN RECORD UPDATE
384-- CONSTRAIN RECORD UPDATE
408
385
409
386
410−constrainUpdate :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Type -> IO Constraint
387+constrainUpdate :: RTV -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Expectation -> IO Constraint
411−constrainUpdate env parentRegion context recordRegion expr fields tipe =
388+constrainUpdate rtv region expr fields expectation =
412 do sharedVar <- mkFlexVar
389 do sharedVar <- mkFlexVar
413 let sharedType = VarN sharedVar
390 let sharedType = VarN sharedVar
414
391
415 oldVars <- traverse (\_ -> mkFlexVar) fields
392 oldVars <- traverse (\_ -> mkFlexVar) fields
416 let oldTypes = Map.map VarN oldVars
393 let oldTypes = Map.map VarN oldVars
417 let oldRecordType = RecordN oldTypes sharedType
394 let oldRecordType = RecordN oldTypes sharedType
418− oldCon <- constrain env recordRegion Error.RecordUpdate expr oldRecordType
395+ oldCon <- constrain rtv expr (FromContext region RecordUpdate oldRecordType)
419
396
420− newDict <- Map.traverseWithKey (constrainField env recordRegion) fields
397+ newDict <- traverse (constrainField rtv) fields
421
398
422 let getType (_, t, _) = t
399 let getType (_, t, _) = t
423 let newRecordType = RecordN (Map.map getType newDict) sharedType
400 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
425
402
426 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict
403 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict
427 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict
404 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict
@@ -433,30 +410,30 @@ constrainUpdate env parentRegion context recordRegion expr fields tipe =
433-- CONSTRAIN TUPLE
410-- CONSTRAIN TUPLE
434
411
435
412
436−constrainTuple :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Type -> IO Constraint
413+constrainTuple :: RTV -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Expectation -> IO Constraint
437−constrainTuple env parentRegion context tupleRegion a b maybeC tipe =
414+constrainTuple rtv region a b maybeC expectation =
438 do aVar <- mkFlexVar
415 do aVar <- mkFlexVar
439 bVar <- mkFlexVar
416 bVar <- mkFlexVar
440 let aType = VarN aVar
417 let aType = VarN aVar
441 let bType = VarN bVar
418 let bType = VarN bVar
442
419
443− aCon <- constrain env tupleRegion Error.Whatever a aType
420+ aCon <- constrain rtv a (NoExpectation aType)
444− bCon <- constrain env tupleRegion Error.Whatever b bType
421+ bCon <- constrain rtv b (NoExpectation bType)
445
422
446 case maybeC of
423 case maybeC of
447 Nothing ->
424 Nothing ->
448 do let tupleType = TupleN aType bType Nothing
425 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
450 return $ ex [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]
427 return $ ex [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]
451
428
452 Just c ->
429 Just c ->
453 do cVar <- mkFlexVar
430 do cVar <- mkFlexVar
454 let cType = VarN cVar
431 let cType = VarN cVar
455
432
456− cCon <- constrain env tupleRegion Error.Whatever c cType
433+ cCon <- constrain rtv c (NoExpectation cType)
457
434
458 let tupleType = TupleN aType bType (Just cType)
435 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
460
437
461 return $ ex [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]
438 return $ ex [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]
462
439
@@ -465,8 +442,8 @@ constrainTuple env parentRegion context tupleRegion a b maybeC tipe =
465-- CONSTRAIN SHADER
442-- CONSTRAIN SHADER
466
443
467
444
468−constrainShader :: Env -> R.Region -> Error.Context -> R.Region -> Shader.Shader -> Type -> IO Constraint
445+constrainShader :: R.Region -> Shader.Shader -> Expectation -> IO Constraint
469−constrainShader env parentRegion context shaderRegion (Shader.Shader attributes uniforms varyings) tipe =
446+constrainShader region (Shader.Shader attributes uniforms varyings) expectation =
470 do attrVar <- mkFlexVar
447 do attrVar <- mkFlexVar
471 unifVar <- mkFlexVar
448 unifVar <- mkFlexVar
472 let attrType = VarN attrVar
449 let attrType = VarN attrVar
@@ -480,7 +457,7 @@ constrainShader env parentRegion context shaderRegion (Shader.Shader attributes
480 ]
457 ]
481
458
482 return $ ex [ attrVar, unifVar ] $
459 return $ ex [ attrVar, unifVar ] $
483− CEqual parentRegion context Error.Shader shaderRegion shaderType tipe
460+ CEqual region Shader shaderType expectation
484
461
485
462
486toShaderRecord :: Map.Map N.Name Shader.Type -> Type -> Type
463toShaderRecord :: Map.Map N.Name Shader.Type -> Type -> Type
@@ -507,11 +484,30 @@ glToType glType =
507-- CONSTRAIN LET
484-- CONSTRAIN LET
508
485
509
486
510−constrainLet :: Env -> R.Region -> Error.Context -> R.Region -> Can.Def -> Can.Expr -> Type -> IO Constraint
487+constrainDef :: RTV -> Can.Def -> Constraint -> IO Constraint
511−constrainLet env parentRegion context letRegion (Can.Def (A.A _ name) (Can.Args args _) expr maybeType) body tipe =
488+constrainDef rtv def bodyCon =
512− case maybeType of
489+ case def of
513− Nothing ->
490+ Can.Def (A.A region name) args _ expr ->
514− error "TODO"
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
515
511
516− Just srcType ->
512+ let headers = Map.singleton name (A.A region lambdaType)
517− error "TODO"
513+ return $ CLet [ Scheme (Map.elems newRigids) [] headers defCon ] bodyCon
src/Type/Constrain/Pattern.hs+163−76
@@ -1,8 +1,8 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Pattern
2module Type.Constrain.Pattern
3− ( State(..)
3+ ( constrain
4− , emptyState
4+ , constrainArgs
5− , addConstraints
5+ , constrainTypedArgs
6 )
6 )
7 where
7 where
8
8
@@ -17,7 +17,6 @@ import qualified Data.Bag as Bag
17import qualified Data.Index as Index
17import qualified Data.Index as Index
18import qualified Elm.Name as N
18import qualified Elm.Name as N
19import qualified Reporting.Annotation as A
19import qualified Reporting.Annotation as A
20−import qualified Reporting.Error.Type as Error
21import qualified Reporting.Region as R
20import qualified Reporting.Region as R
22import Type.Constraint
21import Type.Constraint
23import qualified Type.Instantiate as Instantiate
22import qualified Type.Instantiate as Instantiate
@@ -25,7 +24,78 @@ import Type.Type as T
25
24
26
25
27
26
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+
28−-- ADD CONSTRAINTS
98+-- ACTUALLY ADD CONSTRAINTS
29
99
30
100
31-- The constraints are stored in reverse order so that adding a new
101-- The constraints are stored in reverse order so that adding a new
@@ -33,53 +103,48 @@ import Type.Type as T
33--
103--
34data State =
104data State =
35 State
105 State
36− { _headers :: Map.Map N.Name (A.Located Type)
106+ { _headers :: Header
37 , _vars :: Bag.Bag Variable
107 , _vars :: Bag.Bag Variable
38 , _revCons :: [Constraint]
108 , _revCons :: [Constraint]
39 }
109 }
40
110
41
111
42−emptyState :: State
112+type Header = Map.Map N.Name (A.Located Type)
43−emptyState =
44− State Map.empty Bag.empty []
45
113
46
114
47−addConstraints :: R.Region -> Error.PatternContext -> Can.Pattern -> Type -> State -> IO State
115+add :: Can.Pattern -> PatternExpectation -> State -> IO State
48−addConstraints outerRegion context (A.A region pattern) tipe state =
116+add (A.A region pattern) expectation state =
49 case pattern of
117 case pattern of
50 Can.PAnything ->
118 Can.PAnything ->
51 return state
119 return state
52
120
53 Can.PVar name ->
121 Can.PVar name ->
54− do let (State headers vars revCons) = state
122+ return $ addToHeaders region name expectation state
55− let newHeaders = Map.insert name (A.A region tipe) headers
56− return $ State newHeaders vars revCons
57
123
58 Can.PAlias realPattern name ->
124 Can.PAlias realPattern name ->
59− do let (State headers vars revCons) = state
125+ add realPattern expectation $
60− addConstraints outerRegion context realPattern tipe $
126+ addToHeaders region name expectation state
61− State (Map.insert name (A.A region tipe) headers) vars revCons
62
127
63 Can.PUnit ->
128 Can.PUnit ->
64 do let (State headers vars revCons) = state
129 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
66 return $ State headers vars (unitCon:revCons)
131 return $ State headers vars (unitCon:revCons)
67
132
68 Can.PTuple a b maybeC ->
133 Can.PTuple a b maybeC ->
69− addTupleConstraint outerRegion context region a b maybeC tipe state
134+ addTuple region a b maybeC expectation state
70
135
71 Can.PCtor home typeName typeVars ctorName args ->
136 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
73
138
74 Can.PList patterns ->
139 Can.PList patterns ->
75 do entryVar <- mkFlexVar
140 do entryVar <- mkFlexVar
76− let entryVarN = VarN entryVar
141+ let entryType = VarN entryVar
77− let listType = AppN ModuleName.list N.list [entryVarN]
142+ let listType = AppN ModuleName.list N.list [entryType]
78
143
79 (State headers vars revCons) <-
144 (State headers vars revCons) <-
80− foldM (addListConstraint region entryVarN) state (Index.indexedMap (,) patterns)
145+ foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)
81
146
82− let listCon = CPattern outerRegion context Error.PList region listType tipe
147+ let listCon = CPattern region PList listType expectation
83 return $ State headers (Bag.insert entryVar vars) (listCon:revCons)
148 return $ State headers (Bag.insert entryVar vars) (listCon:revCons)
84
149
85 Can.PCons headPattern tailPattern ->
150 Can.PCons headPattern tailPattern ->
@@ -87,11 +152,14 @@ addConstraints outerRegion context (A.A region pattern) tipe state =
87 let entryType = VarN entryVar
152 let entryType = VarN entryVar
88 let listType = AppN ModuleName.list N.list [entryType]
153 let listType = AppN ModuleName.list N.list [entryType]
89
154
155+ let headExpectation = NoPatternExpectation entryType
156+ let tailExpectation = PatternExpectation region PTail listType
157+
90 (State headers vars revCons) <-
158 (State headers vars revCons) <-
91− addConstraints region Error.PatternHead headPattern entryType =<<
159+ add headPattern headExpectation =<<
92− addConstraints region Error.PatternTail tailPattern listType state
160+ add tailPattern tailExpectation state
93
161
94− let listCon = CPattern outerRegion context Error.PList region listType tipe
162+ let listCon = CPattern region PList listType expectation
95 return $ State headers (Bag.insert entryVar vars) (listCon : revCons)
163 return $ State headers (Bag.insert entryVar vars) (listCon : revCons)
96
164
97 Can.PRecord fields ->
165 Can.PRecord fields ->
@@ -103,7 +171,7 @@ addConstraints outerRegion context (A.A region pattern) tipe state =
103 let recordType = RecordN fieldTypes extType
171 let recordType = RecordN fieldTypes extType
104
172
105 let (State headers vars revCons) = state
173 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
107 return $
175 return $
108 State
176 State
109 { _headers = Map.union headers (Map.map (A.A region) fieldTypes)
177 { _headers = Map.union headers (Map.map (A.A region) fieldTypes)
@@ -113,97 +181,115 @@ addConstraints outerRegion context (A.A region pattern) tipe state =
113
181
114 Can.PInt _ ->
182 Can.PInt _ ->
115 do let (State headers vars revCons) = state
183 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
117 return $ State headers vars (intCon:revCons)
185 return $ State headers vars (intCon:revCons)
118
186
119 Can.PStr _ ->
187 Can.PStr _ ->
120 do let (State headers vars revCons) = state
188 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
122 return $ State headers vars (strCon:revCons)
190 return $ State headers vars (strCon:revCons)
123
191
124 Can.PChr _ ->
192 Can.PChr _ ->
125 do let (State headers vars revCons) = state
193 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
127 return $ State headers vars (chrCon:revCons)
195 return $ State headers vars (chrCon:revCons)
128
196
129
197
130
198
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+
131
222
132
223
133-- CONSTRAIN LIST
224-- CONSTRAIN LIST
134
225
135
226
136−addListConstraint :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
227+addEntry :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
137−addListConstraint listRegion tipe state (index, pattern) =
228+addEntry listRegion tipe state (index, pattern) =
138− addConstraints listRegion (Error.PatternList index) pattern tipe state
229+ let
230+ expectation =
231+ PatternExpectation listRegion (PListEntry index) tipe
232+ in
233+ add pattern expectation state
139
234
140
235
141
236
142-- CONSTRAIN TUPLE
237-- CONSTRAIN TUPLE
143
238
144
239
145−addTupleConstraint
240+addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> PatternExpectation -> State -> IO State
146− :: R.Region
241+addTuple region a b maybeC expectation state =
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) =
156 do aVar <- mkFlexVar
242 do aVar <- mkFlexVar
157 bVar <- mkFlexVar
243 bVar <- mkFlexVar
158− let aVarN = VarN aVar
244+ let aType = VarN aVar
159− let bVarN = VarN bVar
245+ let bType = VarN bVar
160−
161− let equal = CPattern parentRegion context Error.PTuple tupleRegion
162− let addCon = addConstraints tupleRegion Error.PatternUnknown
163
246
164 case maybeC of
247 case maybeC of
165 Nothing ->
248 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+
167 let newVars = Bag.insert aVar (Bag.insert bVar vars)
253 let newVars = Bag.insert aVar (Bag.insert bVar vars)
168− addCon b bVarN =<<
254+ let tupleCon = CPattern region PTuple (TupleN aType bType Nothing) expectation
255+
169− addCon a aVarN (State headers newVars (tupleCon:revCons))
256+ return $ State headers newVars (tupleCon:revCons)
170
257
171 Just c ->
258 Just c ->
172 do cVar <- mkFlexVar
259 do cVar <- mkFlexVar
173− let cVarN = VarN cVar
260+ let cType = VarN cVar
174− let tupleCon = equal (TupleN aVarN bVarN (Just cVarN)) tipe
261+
262+ (State headers vars revCons) <-
263+ simpleAdd c cType =<<
264+ simpleAdd b bType =<<
265+ simpleAdd a aType state
266+
175 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
267 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
176− addCon c cVarN =<<
268+ let tupleCon = CPattern region PTuple (TupleN aType bType (Just cType)) expectation
177− addCon b bVarN =<<
269+
178− addCon a aVarN (State headers newVars (tupleCon:revCons))
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
179
276
180
277
181
278
182-- CONSTRAIN CONSTRUCTORS
279-- CONSTRAIN CONSTRUCTORS
183
280
184
281
185−addCtorConstraint
282+addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> PatternExpectation -> State -> IO State
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 =
283+addCtor region home typeName typeVarNames ctorName args expectation state =
198 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
284 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
199 let typePairs = map (second VarN) varPairs
285 let typePairs = map (second VarN) varPairs
200 let freeVarDict = Map.fromList typePairs
286 let freeVarDict = Map.fromList typePairs
201
287
202 (State headers vars revCons) <-
288 (State headers vars revCons) <-
203− foldM (addCtorArgConstraint ctorRegion ctorName freeVarDict) state args
289+ foldM (addCtorArg region ctorName freeVarDict) state args
204
290
205 let ctorType = AppN home typeName (map snd typePairs)
291 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
207
293
208 return $
294 return $
209 State
295 State
@@ -213,7 +299,8 @@ addCtorConstraint outerRegion context ctorRegion home typeName typeVarNames ctor
213 }
299 }
214
300
215
301
216−addCtorArgConstraint :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
302+addCtorArg :: 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) =
303+addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
218 do tipe <- Instantiate.fromSrcType freeVarDict srcType
304 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 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Constraint
3module Type.Constraint
4 ( Constraint(..)
4 ( Constraint(..)
5− , ex
5+ , Expectation(..)
6+ , Context(..)
7+ , SubContext(..)
8+ , FuncName(..)
9+ , Category(..)
10+ , PatternExpectation(..)
11+ , PatternContext(..)
12+ , PatternCategory(..)
6 , Scheme(..)
13 , Scheme(..)
7 , monoscheme
14 , monoscheme
15+ , ex
8 )
16 )
9 where
17 where
10
18
@@ -12,9 +20,9 @@ module Type.Constraint
12import qualified Data.Map.Strict as Map
20import qualified Data.Map.Strict as Map
13
21
14import qualified AST.Canonical as Can
22import qualified AST.Canonical as Can
23+import qualified Data.Index as Index
15import qualified Elm.Name as N
24import qualified Elm.Name as N
16import qualified Reporting.Annotation as A
25import qualified Reporting.Annotation as A
17−import qualified Reporting.Error.Type as Error
18import qualified Reporting.Region as R
26import qualified Reporting.Region as R
19import Type.Type (Type, Variable)
27import Type.Type (Type, Variable)
20
28
@@ -24,14 +32,103 @@ import Type.Type (Type, Variable)
24
32
25
33
26data Constraint
34data Constraint
27− = CTrue
35+ = CTrue
28− | CSaveHeaders
36+ | CSaveHeaders
29− | CEqual R.Region Error.Context Error.Category R.Region Type Type
37+ | CEqual R.Region Category Type Expectation
30− | CLookup R.Region Error.Context R.Region N.Name Type
38+ | CLookup R.Region N.Name Expectation
31− | CInstance R.Region Error.Context R.Region Can.Type Type
39+ | CInstance R.Region FuncName Can.Annotation Expectation
32− | CPattern R.Region Error.PatternContext Error.PatternCategory R.Region Type Type
40+ | CPattern R.Region PatternCategory Type PatternExpectation
33− | CAnd [Constraint]
41+ | CAnd [Constraint]
34− | CLet [Scheme] 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
35
132
36
133
37
134
@@ -47,23 +144,15 @@ data Scheme =
47 }
144 }
48
145
49
146
50−
51−-- SCHEME HELPERS
52−
53−
54monoscheme :: Map.Map N.Name (A.Located Type) -> Scheme
147monoscheme :: Map.Map N.Name (A.Located Type) -> Scheme
55monoscheme headers =
148monoscheme headers =
56 Scheme [] [] headers CTrue
149 Scheme [] [] headers CTrue
57
150
58
151
59−
60−-- CONSTRAINT HELPERS
61−
62−
63-- ex qs constraint == exists qs. constraint
152-- ex qs constraint == exists qs. constraint
64ex :: [Variable] -> Constraint -> Constraint
153ex :: [Variable] -> Constraint -> Constraint
65ex flexVars constraint =
154ex flexVars constraint =
66− CLet
155+ CLet
67− [ Scheme [] flexVars Map.empty constraint
156+ [ Scheme [] flexVars Map.empty constraint
68− ]
157+ ]
69− CTrue
158+ CTrue
src/Type/Instantiate.hs+4−59
@@ -1,8 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Instantiate
3module Type.Instantiate
4− ( flexible
4+ ( FreeVars
5− , rigid
6 , fromSrcType
5 , fromSrcType
7 )
6 )
8 where
7 where
@@ -17,65 +16,11 @@ import Type.Type
17
16
18
17
19
18
20−-- FROM SOURCE TYPES
19+-- FREE VARS
21
20
22
21
23−-- TODO should the freeFlexVars be ranked a certain way?
22+type FreeVars =
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 )
23+ Map.Map N.Name Type
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
79
24
80
25
81
26