@@ -11,6 +11,7 @@ import Data.Text (Text)
1111import qualified AST.Variable as Var
1212import qualified Reporting.Region as R
1313import qualified Reporting.Error.Type as Error
14+import qualified Type.Occurs as Occurs
1415import qualified Type.State as TS
1516import Type.Type as Type
1617import qualified Type.UnionFind as UF
@@ -48,7 +49,8 @@ type Unify =
4849 ExceptT Mismatch TS.Solver
4950
5051
51−data Context = Context
52+data Context =
53+ Context
5254 { _orientation :: Orientation
5355 , _first :: Variable
5456 , _firstDesc :: Descriptor
@@ -152,8 +154,8 @@ merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) co
152154
153155
154156mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
155−mergeHelp var1 second newContent newRank =
156− UF.union var1 second $
157+mergeHelp var1 var2 newContent newRank =
158+ UF.union var1 var2 $
157159 Descriptor
158160 { _content = newContent
159161 , _rank = newRank
@@ -384,7 +386,7 @@ atomMatchesSuper super name =
384386
385387unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
386388unifyFlexSuperStructure context super term =
387− do appStructure <- liftIO (collectApps (Structure term))
389+ do appStructure <- liftIO (collectApps term)
388390 case appStructure of
389391 Other ->
390392 mismatch context (Just (badSuper super))
@@ -398,11 +400,13 @@ unifyFlexSuperStructure context super term =
398400 merge context (Structure term)
399401
400402 Comparable ->
401− do merge context (Structure term)
403+ do comparableOccursCheck context
404+ merge context (Structure term)
402405 unifyComparableRecursive (_orientation context) variable
403406
404407 CompAppend ->
405− do merge context (Structure term)
408+ do comparableOccursCheck context
409+ merge context (Structure term)
406410 unifyComparableRecursive (_orientation context) variable
407411
408412 Tuple entries ->
@@ -418,13 +422,24 @@ unifyFlexSuperStructure context super term =
418422 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
419423
420424 else
421− do merge context (Structure term)
425+ do comparableOccursCheck context
426+ merge context (Structure term)
422427 mapM_ (unifyComparableRecursive (_orientation context)) entries
423428
424429 CompAppend ->
425430 mismatch context (Just (badSuper super))
426431
427432
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+
428443unifyComparableRecursive :: Orientation -> Variable -> Unify ()
429444unifyComparableRecursive orientation var =
430445 do compVar <-
@@ -447,22 +462,27 @@ data AppStructure
447462 | Other
448463
449464
450−collectApps :: Content -> IO AppStructure
451−collectApps content =
452− collectAppsHelp [] content
465+collectApps :: FlatType -> IO AppStructure
466+collectApps term =
467+ case term of
468+ App1 func arg ->
469+ collectAppsHelp [arg] =<< getContent func
470+
471+ _ ->
472+ return Other
453473
454474
455475collectAppsHelp :: [Variable] -> Content -> IO AppStructure
456476collectAppsHelp args content =
457477 case (content, args) of
458478 (Structure (App1 func arg), _) ->
459− collectAppsHelp (args ++ [arg]) =<< getContent func
479+ collectAppsHelp (arg : args) =<< getContent func
460480
461481 (Atom name, [arg]) | Var.isList name ->
462482 return (List arg)
463483
464484 (Atom name, _) | Var.isTuple name ->
465− return (Tuple args)
485+ return (Tuple (reverse args))
466486
467487 _ ->
468488 return Other