git.iko.soy/elk
on master help sign in
Rename to CLocal and CForeign / track variable names a bit different
1966810Evan Czaplicki
src/Type/Constrain/Expression.hs+34−28
compare with master
unifiedsplit
@@ -41,22 +41,25 @@ constrain :: RTV -> Can.Expr -> Expected Type -> IO Constraint
41constrain rtv (A.At region expression) expected =
41constrain rtv (A.At region expression) expected =
42 case expression of
42 case expression of
43 Can.VarLocal name ->
43 Can.VarLocal name ->
44− return (CLookup region name expected)
44+ return (CLocal region name expected)
45
45
46 Can.VarTopLevel _ name ->
46 Can.VarTopLevel _ name ->
47− return (CLookup region name expected)
47+ return (CLocal region name expected)
48
48
49 Can.VarKernel _ _ ->
49 Can.VarKernel _ _ ->
50 return CTrue
50 return CTrue
51
51
52 Can.VarForeign _ name annotation ->
52 Can.VarForeign _ name annotation ->
53− return $ CInstance region (FuncName name) annotation expected
53+ return $ CForeign region name annotation expected
54+
55+ Can.VarCtor _ _ name _ annotation ->
56+ return $ CForeign region name annotation expected
54
57
55 Can.VarDebug _ name annotation ->
58 Can.VarDebug _ name annotation ->
56− return $ CInstance region (FuncName name) annotation expected
59+ return $ CForeign region name annotation expected
57
60
58 Can.VarOperator op _ _ annotation ->
61 Can.VarOperator op _ _ annotation ->
59− return $ CInstance region (OpName op) annotation expected
62+ return $ CForeign region op annotation expected
60
63
61 Can.Str _ ->
64 Can.Str _ ->
62 return $ CEqual region String Type.string expected
65 return $ CEqual region String Type.string expected
@@ -180,7 +183,7 @@ constrainLambda rtv region args body expected =
180
183
181constrainCall :: RTV -> R.Region -> Can.Expr -> [Can.Expr] -> Expected Type -> IO Constraint
184constrainCall :: RTV -> R.Region -> Can.Expr -> [Can.Expr] -> Expected Type -> IO Constraint
182constrainCall rtv region func args expected =
185constrainCall rtv region func args expected =
183− do let maybeFuncName = getFuncName func
186+ do let maybeName = getName func
184
187
185 funcVar <- mkFlexVar
188 funcVar <- mkFlexVar
186 resultVar <- mkFlexVar
189 resultVar <- mkFlexVar
@@ -190,10 +193,10 @@ constrainCall rtv region func args expected =
190 funcCon <- constrain rtv func (NoExpectation funcType)
193 funcCon <- constrain rtv func (NoExpectation funcType)
191
194
192 (argVars, argTypes, argCons) <-
195 (argVars, argTypes, argCons) <-
193− unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeFuncName) args
196+ unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeName) args
194
197
195 let arityType = foldr FunN resultType argTypes
198 let arityType = foldr FunN resultType argTypes
196− let resultCon = CEqual region (CallResult maybeFuncName) resultType expected
199+ let resultCon = CEqual region (CallResult maybeName) resultType expected
197
200
198 return $ exists (funcVar:resultVar:argVars) $
201 return $ exists (funcVar:resultVar:argVars) $
199 CAnd
202 CAnd
@@ -202,53 +205,56 @@ constrainCall rtv region func args expected =
202 { _a = funcType
205 { _a = funcType
203 , _b = arityType
206 , _b = arityType
204 , _eq = CAnd [ CAnd argCons, resultCon ]
207 , _eq = CAnd [ CAnd argCons, resultCon ]
205− , _neq = constrainCallBackup rtv region maybeFuncName func args
208+ , _neq = constrainCallBackup rtv region maybeName func args
206 }
209 }
207 ]
210 ]
208
211
209
212
210−constrainArg :: RTV -> R.Region -> Maybe FuncName -> Index.ZeroBased -> Can.Expr -> IO (Variable, Type, Constraint)
213+constrainArg :: RTV -> R.Region -> MaybeName -> Index.ZeroBased -> Can.Expr -> IO (Variable, Type, Constraint)
211−constrainArg rtv region maybeFuncName index arg =
214+constrainArg rtv region maybeName index arg =
212 do argVar <- mkFlexVar
215 do argVar <- mkFlexVar
213 let argType = VarN argVar
216 let argType = VarN argVar
214− argCon <- constrain rtv arg (FromContext region (CallArg maybeFuncName index) argType)
217+ argCon <- constrain rtv arg (FromContext region (CallArg maybeName index) argType)
215 return (argVar, argType, argCon)
218 return (argVar, argType, argCon)
216
219
217
220
218−constrainCallBackup :: RTV -> R.Region -> Maybe FuncName -> Can.Expr -> [Can.Expr] -> IO Constraint
221+constrainCallBackup :: RTV -> R.Region -> MaybeName -> Can.Expr -> [Can.Expr] -> IO Constraint
219−constrainCallBackup rtv region maybeFuncName func args =
222+constrainCallBackup rtv region maybeName func args =
220 do (argVars, argTypes, argCons) <-
223 do (argVars, argTypes, argCons) <-
221− unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeFuncName) args
224+ unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeName) args
222
225
223 resultVar <- mkFlexVar
226 resultVar <- mkFlexVar
224 let resultType = VarN resultVar
227 let resultType = VarN resultVar
225 let arityType = foldr FunN resultType argTypes
228 let arityType = foldr FunN resultType argTypes
226
229
227− funcCon <- constrain rtv func (FromContext region (TooManyArgs maybeFuncName (length args)) arityType)
230+ funcCon <- constrain rtv func (FromContext region (TooManyArgs maybeName (length args)) arityType)
228
231
229 return $ exists (resultVar:argVars) $ CAnd [ CAnd argCons, funcCon ]
232 return $ exists (resultVar:argVars) $ CAnd [ CAnd argCons, funcCon ]
230
233
231
234
232−getFuncName :: Can.Expr -> Maybe FuncName
235+getName :: Can.Expr -> MaybeName
233−getFuncName (A.At _ expr) =
236+getName (A.At _ expr) =
234 case expr of
237 case expr of
235 Can.VarLocal name ->
238 Can.VarLocal name ->
236− Just (FuncName name)
239+ FuncName name
237
240
238 Can.VarTopLevel _ name ->
241 Can.VarTopLevel _ name ->
239− Just (FuncName name)
242+ FuncName name
240−
241− Can.VarKernel _ name ->
242− Just (FuncName name)
243
243
244 Can.VarForeign _ name _ ->
244 Can.VarForeign _ name _ ->
245− Just (FuncName name)
245+ FuncName name
246+
247+ Can.VarCtor _ _ name _ _ ->
248+ CtorName name
246
249
247 Can.VarOperator op _ _ _ ->
250 Can.VarOperator op _ _ _ ->
248− Just (OpName op)
251+ OpName op
252+
253+ Can.VarKernel _ name ->
254+ FuncName name
249
255
250 _ ->
256 _ ->
251− Nothing
257+ NoName
252
258
253
259
254
260
@@ -265,7 +271,7 @@ constrainBinop rtv region op annotation leftExpr rightExpr expected =
265 let answerType = VarN answerVar
271 let answerType = VarN answerVar
266 let binopType = leftType ==> rightType ==> answerType
272 let binopType = leftType ==> rightType ==> answerType
267
273
268− let opCon = CInstance region (OpName op) annotation (NoExpectation binopType)
274+ let opCon = CForeign region op annotation (NoExpectation binopType)
269
275
270 leftCon <- constrain rtv leftExpr (FromContext region (OpLeft op) leftType)
276 leftCon <- constrain rtv leftExpr (FromContext region (OpLeft op) leftType)
271 rightCon <- constrain rtv rightExpr (FromContext region (OpRight op) rightType)
277 rightCon <- constrain rtv rightExpr (FromContext region (OpRight op) rightType)
@@ -275,7 +281,7 @@ constrainBinop rtv region op annotation leftExpr rightExpr expected =
275 [ opCon
281 [ opCon
276 , leftCon
282 , leftCon
277 , rightCon
283 , rightCon
278− , CEqual region (CallResult (Just (OpName op))) answerType expected
284+ , CEqual region (CallResult (OpName op)) answerType expected
279 ]
285 ]
280
286
281
287
src/Type/Constrain/Module.hs+3−3
@@ -136,11 +136,11 @@ constrainEffects r0 r1 r2 toFinalArgs =
136 return $
136 return $
137 CLet [] vars Map.empty
137 CLet [] vars Map.empty
138 (CAnd
138 (CAnd
139− [ CLookup r0 "init" $ NoExpectation $
139+ [ CLocal r0 "init" $ NoExpectation $
140 task s0
140 task s0
141− , CLookup r1 "onEffects" $ NoExpectation $
141+ , CLocal r1 "onEffects" $ NoExpectation $
142 router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)
142 router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)
143− , CLookup r2 "onSelfMsg" $ NoExpectation $
143+ , CLocal r2 "onSelfMsg" $ NoExpectation $
144 router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2
144 router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2
145 , equal r1 s0 (VarN s1)
145 , equal r1 s0 (VarN s1)
146 , equal r2 s0 (VarN s2)
146 , equal r2 s0 (VarN s2)
src/Type/Constraint.hs+9−7
@@ -6,7 +6,7 @@ module Type.Constraint
6 , Expected(..)
6 , Expected(..)
7 , Context(..)
7 , Context(..)
8 , SubContext(..)
8 , SubContext(..)
9− , FuncName(..)
9+ , MaybeName(..)
10 , Category(..)
10 , Category(..)
11 , PExpected(..)
11 , PExpected(..)
12 , PContext(..)
12 , PContext(..)
@@ -35,8 +35,8 @@ data Constraint
35 = CTrue
35 = CTrue
36 | CSaveTheEnvironment
36 | CSaveTheEnvironment
37 | CEqual R.Region Category Type (Expected Type)
37 | CEqual R.Region Category Type (Expected Type)
38− | CLookup R.Region N.Name (Expected Type)
38+ | CLocal R.Region N.Name (Expected Type)
39− | CInstance R.Region FuncName Can.Annotation (Expected Type)
39+ | CForeign R.Region N.Name Can.Annotation (Expected Type)
40 | CPattern R.Region PCategory Type (PExpected Type)
40 | CPattern R.Region PCategory Type (PExpected Type)
41 | CAnd [Constraint]
41 | CAnd [Constraint]
42 | CBranch
42 | CBranch
@@ -77,8 +77,8 @@ data Context
77 | IfCondition
77 | IfCondition
78 | IfBranch Index.ZeroBased
78 | IfBranch Index.ZeroBased
79 | CaseBranch Index.ZeroBased
79 | CaseBranch Index.ZeroBased
80− | CallArg (Maybe FuncName) Index.ZeroBased
80+ | CallArg MaybeName Index.ZeroBased
81− | TooManyArgs (Maybe FuncName) Int
81+ | TooManyArgs MaybeName Int
82 | RecordAccess N.Name
82 | RecordAccess N.Name
83 | RecordUpdate
83 | RecordUpdate
84 | Destructure
84 | Destructure
@@ -90,9 +90,11 @@ data SubContext
90 | TypedBody
90 | TypedBody
91
91
92
92
93−data FuncName
93+data MaybeName
94 = FuncName N.Name
94 = FuncName N.Name
95+ | CtorName N.Name
95 | OpName N.Name
96 | OpName N.Name
97+ | NoName
96
98
97
99
98data Category
100data Category
@@ -104,7 +106,7 @@ data Category
104 | Binop
106 | Binop
105 | If
107 | If
106 | Case
108 | Case
107− | CallResult (Maybe FuncName)
109+ | CallResult MaybeName
108 | Lambda
110 | Lambda
109 | Accessor N.Name
111 | Accessor N.Name
110 | Access N.Name
112 | Access N.Name
src/Type/Solve.hs+13−22
@@ -87,15 +87,14 @@ solve env rank pools state constraint =
87 do introduce rank pools vars
87 do introduce rank pools vars
88 return state
88 return state
89
89
90− Unify.Err vars problem actualType expectedType ->
90+ Unify.Err vars actualType expectedType ->
91 do introduce rank pools vars
91 do introduce rank pools vars
92 return $ addError state $
92 return $ addError state $
93 Error.Mismatch
93 Error.Mismatch
94 (Error.BadExpr region category actualType)
94 (Error.BadExpr region category actualType)
95 (Con.typeReplace expectation expectedType)
95 (Con.typeReplace expectation expectedType)
96− problem
97
96
98− CLookup region name expectation ->
97+ CLocal region name expectation ->
99 do actual <- makeCopy rank pools (env ! name)
98 do actual <- makeCopy rank pools (env ! name)
100 expected <- expectedToVariable rank pools expectation
99 expected <- expectedToVariable rank pools expectation
101 answer <- Unify.unify actual expected
100 answer <- Unify.unify actual expected
@@ -104,15 +103,14 @@ solve env rank pools state constraint =
104 do introduce rank pools vars
103 do introduce rank pools vars
105 return state
104 return state
106
105
107− Unify.Err vars problem actualType expectedType ->
106+ Unify.Err vars actualType expectedType ->
108 do introduce rank pools vars
107 do introduce rank pools vars
109 return $ addError state $
108 return $ addError state $
110 Error.Mismatch
109 Error.Mismatch
111 (Error.BadLocal region name actualType)
110 (Error.BadLocal region name actualType)
112 (Con.typeReplace expectation expectedType)
111 (Con.typeReplace expectation expectedType)
113− problem
114
112
115− CInstance region funcName (Can.Forall freeVars srcType) expectation ->
113+ CForeign region name (Can.Forall freeVars srcType) expectation ->
116 do actual <- srcTypeToVariable rank pools freeVars srcType
114 do actual <- srcTypeToVariable rank pools freeVars srcType
117 expected <- expectedToVariable rank pools expectation
115 expected <- expectedToVariable rank pools expectation
118 answer <- Unify.unify actual expected
116 answer <- Unify.unify actual expected
@@ -121,13 +119,12 @@ solve env rank pools state constraint =
121 do introduce rank pools vars
119 do introduce rank pools vars
122 return state
120 return state
123
121
124− Unify.Err vars problem actualType expectedType ->
122+ Unify.Err vars actualType expectedType ->
125 do introduce rank pools vars
123 do introduce rank pools vars
126 return $ addError state $
124 return $ addError state $
127 Error.Mismatch
125 Error.Mismatch
128− (Error.BadForeign region funcName actualType)
126+ (Error.BadForeign region name actualType)
129 (Con.typeReplace expectation expectedType)
127 (Con.typeReplace expectation expectedType)
130− problem
131
128
132 CPattern region category tipe expectation ->
129 CPattern region category tipe expectation ->
133 do actual <- typeToVariable rank pools tipe
130 do actual <- typeToVariable rank pools tipe
@@ -138,12 +135,11 @@ solve env rank pools state constraint =
138 do introduce rank pools vars
135 do introduce rank pools vars
139 return state
136 return state
140
137
141− Unify.Err vars problem actualType expectedType ->
138+ Unify.Err vars actualType expectedType ->
142 do introduce rank pools vars
139 do introduce rank pools vars
143 return $ addError state $
140 return $ addError state $
144 Error.BadPattern region category actualType
141 Error.BadPattern region category actualType
145 (Con.ptypeReplace expectation expectedType)
142 (Con.ptypeReplace expectation expectedType)
146− problem
147
143
148 CAnd constraints ->
144 CAnd constraints ->
149 foldM (solve env rank pools) state constraints
145 foldM (solve env rank pools) state constraints
@@ -157,7 +153,7 @@ solve env rank pools state constraint =
157 do introduce rank pools vars
153 do introduce rank pools vars
158 solve env rank pools state eqCon
154 solve env rank pools state eqCon
159
155
160− Unify.Err vars _ _ _ ->
156+ Unify.Err vars _ _ ->
161 do introduce rank pools vars
157 do introduce rank pools vars
162 solve env rank pools state =<< makeNotEqCon
158 solve env rank pools state =<< makeNotEqCon
163
159
@@ -218,16 +214,11 @@ isGeneric var =
218 do (Descriptor _ rank _ _) <- UF.get var
214 do (Descriptor _ rank _ _) <- UF.get var
219 if rank == noRank
215 if rank == noRank
220 then return ()
216 then return ()
217+ else
218+ error
219+ "You ran into a compiler bug!\n\n\
221− else crash "Unable to generalize a type variable. It is not unranked."
220+ \I was unable to generalize a type variable during type inference. It was ranked.\n\n\
222−
223−
224−crash :: String -> a
225−crash msg =
226− error $
227− "It looks like something went wrong with the type inference algorithm.\n\n"
228− ++ msg ++ "\n\n"
229− ++ "Please create a minimal example that triggers this problem and report it to\n"
230− ++ "<https://github.com/elm-lang/elm-compiler/issues>"
221+ \Please create an <http://sscce.org/> and report it at <https://github.com/elm-lang/elm-compiler/issues>\n\n"
231
222
232
223
233
224