git.iko.soy/elk
on master help sign in
Fix #937, problem with empty lists
4a2cdd8Evan Czaplicki
src/Type/Constrain/Expression.hs+63−58
compare with master
unifiedsplit
@@ -237,34 +237,17 @@ constrainList env region exprs tipe =
237 do (exprInfo, exprCons) <-
237 do (exprInfo, exprCons) <-
238 unzip <$> mapM elementConstraint exprs
238 unzip <$> mapM elementConstraint exprs
239
239
240− let pairwiseCons = pairwiseConstraints 2 exprInfo
240+ (vars, cons) <- pairCons region Error.ListElement varToCon exprInfo
241
241
242− return $
243− ex (map fst exprInfo)
244− (CAnd (exprCons ++ pairwiseCons))
242+ return $ ex vars (CAnd (exprCons ++ cons))
245 where
243 where
246− list t =
247− Env.get env Env.types "List" <| t
248−
249 elementConstraint expr@(A.A region' _) =
244 elementConstraint expr@(A.A region' _) =
250 do var <- variable Flexible
245 do var <- variable Flexible
251 con <- constrain env expr (varN var)
246 con <- constrain env expr (varN var)
252 return ( (var, region'), con )
247 return ( (var, region'), con )
253
248
254− pairwiseConstraints n exprInfo =
249+ varToCon var =
255− case exprInfo of
256− [] ->
257− []
258−
259− (var,_) : [] ->
260− [ CEqual Error.List region tipe (list (varN var)) ]
250+ CEqual Error.List region tipe (Env.get env Env.types "List" <| varN var)
261−
262− (var,_) : (var',region') : rest ->
263− let
264− hint = Error.ListElement n region'
265− con = CEqual hint region (varN var) (varN var')
266− in
267− con : pairwiseConstraints (n+1) ((var', region') : rest)
268
251
269
252
270-- CONSTRAIN IF EXPRESSIONS
253-- CONSTRAIN IF EXPRESSIONS
@@ -279,9 +262,9 @@ constrainIf env region branches tipe =
279 do (branchInfo, branchExprCons) <-
262 do (branchInfo, branchExprCons) <-
280 unzip <$> mapM constrainBranch branches
263 unzip <$> mapM constrainBranch branches
281
264
282− return $
265+ (vars,cons) <- branchCons branchInfo
283− ex (map fst branchInfo)
266+
284− (CAnd (branchExprCons ++ branchCons branchInfo))
267+ return $ ex vars (CAnd (branchExprCons ++ cons))
285 where
268 where
286 bool = Env.get env Env.types "Bool"
269 bool = Env.get env Env.types "Bool"
287
270
@@ -297,27 +280,18 @@ constrainIf env region branches tipe =
297 branchCons branchInfo =
280 branchCons branchInfo =
298 case branchInfo of
281 case branchInfo of
299 [(thenVar, _), (elseVar, _)] ->
282 [(thenVar, _), (elseVar, _)] ->
283+ return
284+ ( [thenVar,elseVar]
300− [ CEqual Error.IfBranches region (varN thenVar) (varN elseVar)
285+ , [ CEqual Error.IfBranches region (varN thenVar) (varN elseVar)
301− , CEqual Error.If region tipe (varN thenVar)
286+ , varToCon thenVar
302− ]
287+ ]
288+ )
303
289
304 _ ->
290 _ ->
305− buildBranchCons 2 branchInfo
291+ pairCons region Error.MultiIfBranch varToCon branchInfo
306−
307− buildBranchCons n branchInfo =
308− case branchInfo of
309− [] ->
310− []
311
292
312− (var,_) : [] ->
293+ varToCon var =
313− [ CEqual Error.If region tipe (varN var) ]
294+ CEqual Error.If region tipe (varN var)
314−
315− (var,_) : (var',region') : rest ->
316− let
317− hint = Error.MultiIfBranch n region'
318− con = CEqual hint region (varN var) (varN var')
319− in
320− con : buildBranchCons (n+1) ((var', region') : rest)
321
295
322
296
323-- CONSTRAIN CASE EXPRESSIONS
297-- CONSTRAIN CASE EXPRESSIONS
@@ -331,15 +305,14 @@ constrainCase
331 -> IO TypeConstraint
305 -> IO TypeConstraint
332constrainCase env region expr branches tipe =
306constrainCase env region expr branches tipe =
333 do exprVar <- variable Flexible
307 do exprVar <- variable Flexible
334−
335 exprCon <- constrain env expr (varN exprVar)
308 exprCon <- constrain env expr (varN exprVar)
336
309
337 (branchInfo, branchExprCons) <-
310 (branchInfo, branchExprCons) <-
338 unzip <$> mapM (branch (varN exprVar)) branches
311 unzip <$> mapM (branch (varN exprVar)) branches
339
312
340− return $
313+ (vars, cons) <- pairCons region Error.CaseBranch varToCon branchInfo
341− ex (exprVar : map fst branchInfo)
314+
342− (CAnd (exprCon : branchExprCons ++ branchCons 2 branchInfo))
315+ return $ ex (exprVar : vars) (CAnd (exprCon : branchExprCons ++ cons))
343 where
316 where
344 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =
317 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =
345 do branchVar <- variable Flexible
318 do branchVar <- variable Flexible
@@ -350,20 +323,52 @@ constrainCase env region expr branches tipe =
350 , CLet [Fragment.toScheme fragment] branchCon
323 , CLet [Fragment.toScheme fragment] branchCon
351 )
324 )
352
325
353− branchCons n branchInfo =
326+ varToCon var =
354− case branchInfo of
327+ CEqual Error.Case region tipe (varN var)
355− [] ->
356− []
357
328
358− (var,_) : [] ->
359− [ CEqual Error.Case region tipe (varN var) ]
360
329
361− (var,_) : (var',region') : rest ->
330+-- COLLECT PAIRS
331+
332+data Pair = Pair
333+ { _index :: Int
334+ , _var1 :: Variable
335+ , _var2 :: Variable
336+ , _region :: R.Region
337+ }
338+
339+
340+pairCons
341+ :: R.Region
342+ -> (Int -> R.Region -> Error.Hint)
343+ -> (Variable -> TypeConstraint)
344+ -> [(Variable, R.Region)]
345+ -> IO ([Variable], [TypeConstraint])
346+pairCons region pairHint varToCon items =
362− let
347+ let
363− hint = Error.CaseBranch n region'
348+ pairToCon (Pair index var1 var2 subregion) =
364− con = CEqual hint region (varN var) (varN var')
349+ CEqual (pairHint index subregion) region (varN var1) (varN var2)
365− in
350+ in
366− con : branchCons (n+1) ((var', region') : rest)
351+ case collectPairs 2 items of
352+ Nothing ->
353+ do var <- variable Flexible
354+ return ([var], [varToCon var])
355+
356+ Just (pairs, var) ->
357+ return (map fst items, map pairToCon pairs ++ [varToCon var])
358+
359+
360+collectPairs :: Int -> [(Variable, R.Region)] -> Maybe ([Pair], Variable)
361+collectPairs index items =
362+ case items of
363+ [] ->
364+ Nothing
365+
366+ (var,_) : [] ->
367+ Just ([], var)
368+
369+ (var,_) : rest@((var',region) : _) ->
370+ do (pairs, summaryVar) <- collectPairs (index+1) rest
371+ return (Pair index var var' region : pairs, summaryVar)
367
372
368
373
369-- EXPAND PATTERNS
374-- EXPAND PATTERNS