git.iko.soy/elk
on master help sign in
Detect infinite comparable types
65aa02aEvan Czaplicki
src/Type/Unify.hs+32−12
compare with master
unifiedsplit
@@ -11,6 +11,7 @@ import Data.Text (Text)
11import qualified AST.Variable as Var
11import qualified AST.Variable as Var
12import qualified Reporting.Region as R
12import qualified Reporting.Region as R
13import qualified Reporting.Error.Type as Error
13import qualified Reporting.Error.Type as Error
14+import qualified Type.Occurs as Occurs
14import qualified Type.State as TS
15import qualified Type.State as TS
15import Type.Type as Type
16import Type.Type as Type
16import qualified Type.UnionFind as UF
17import qualified Type.UnionFind as UF
@@ -48,7 +49,8 @@ type Unify =
48 ExceptT Mismatch TS.Solver
49 ExceptT Mismatch TS.Solver
49
50
50
51
51−data Context = Context
52+data Context =
53+ Context
52 { _orientation :: Orientation
54 { _orientation :: Orientation
53 , _first :: Variable
55 , _first :: Variable
54 , _firstDesc :: Descriptor
56 , _firstDesc :: Descriptor
@@ -152,8 +154,8 @@ merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) co
152
154
153
155
154mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
156mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
155−mergeHelp var1 second newContent newRank =
157+mergeHelp var1 var2 newContent newRank =
156− UF.union var1 second $
158+ UF.union var1 var2 $
157 Descriptor
159 Descriptor
158 { _content = newContent
160 { _content = newContent
159 , _rank = newRank
161 , _rank = newRank
@@ -384,7 +386,7 @@ atomMatchesSuper super name =
384
386
385unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
387unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
386unifyFlexSuperStructure context super term =
388unifyFlexSuperStructure context super term =
387− do appStructure <- liftIO (collectApps (Structure term))
389+ do appStructure <- liftIO (collectApps term)
388 case appStructure of
390 case appStructure of
389 Other ->
391 Other ->
390 mismatch context (Just (badSuper super))
392 mismatch context (Just (badSuper super))
@@ -398,11 +400,13 @@ unifyFlexSuperStructure context super term =
398 merge context (Structure term)
400 merge context (Structure term)
399
401
400 Comparable ->
402 Comparable ->
403+ do comparableOccursCheck context
401− do merge context (Structure term)
404+ merge context (Structure term)
402 unifyComparableRecursive (_orientation context) variable
405 unifyComparableRecursive (_orientation context) variable
403
406
404 CompAppend ->
407 CompAppend ->
408+ do comparableOccursCheck context
405− do merge context (Structure term)
409+ merge context (Structure term)
406 unifyComparableRecursive (_orientation context) variable
410 unifyComparableRecursive (_orientation context) variable
407
411
408 Tuple entries ->
412 Tuple entries ->
@@ -418,13 +422,24 @@ unifyFlexSuperStructure context super term =
418 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
422 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
419
423
420 else
424 else
425+ do comparableOccursCheck context
421− do merge context (Structure term)
426+ merge context (Structure term)
422 mapM_ (unifyComparableRecursive (_orientation context)) entries
427 mapM_ (unifyComparableRecursive (_orientation context)) entries
423
428
424 CompAppend ->
429 CompAppend ->
425 mismatch context (Just (badSuper super))
430 mismatch context (Just (badSuper super))
426
431
427
432
433+-- TODO: is there some way to avoid doing this?
434+-- Do type classes require occurs checks?
435+comparableOccursCheck :: Context -> Unify ()
436+comparableOccursCheck (Context _ _ _ var _) =
437+ do hasOccurred <- liftIO $ Occurs.occurs var
438+ if hasOccurred
439+ then throwError (Mismatch Nothing)
440+ else return ()
441+
442+
428unifyComparableRecursive :: Orientation -> Variable -> Unify ()
443unifyComparableRecursive :: Orientation -> Variable -> Unify ()
429unifyComparableRecursive orientation var =
444unifyComparableRecursive orientation var =
430 do compVar <-
445 do compVar <-
@@ -447,22 +462,27 @@ data AppStructure
447 | Other
462 | Other
448
463
449
464
450−collectApps :: Content -> IO AppStructure
465+collectApps :: FlatType -> IO AppStructure
451−collectApps content =
466+collectApps term =
467+ case term of
468+ App1 func arg ->
452− collectAppsHelp [] content
469+ collectAppsHelp [arg] =<< getContent func
470+
471+ _ ->
472+ return Other
453
473
454
474
455collectAppsHelp :: [Variable] -> Content -> IO AppStructure
475collectAppsHelp :: [Variable] -> Content -> IO AppStructure
456collectAppsHelp args content =
476collectAppsHelp args content =
457 case (content, args) of
477 case (content, args) of
458 (Structure (App1 func arg), _) ->
478 (Structure (App1 func arg), _) ->
459− collectAppsHelp (args ++ [arg]) =<< getContent func
479+ collectAppsHelp (arg : args) =<< getContent func
460
480
461 (Atom name, [arg]) | Var.isList name ->
481 (Atom name, [arg]) | Var.isList name ->
462 return (List arg)
482 return (List arg)
463
483
464 (Atom name, _) | Var.isTuple name ->
484 (Atom name, _) | Var.isTuple name ->
465− return (Tuple args)
485+ return (Tuple (reverse args))
466
486
467 _ ->
487 _ ->
468 return Other
488 return Other