@@ -1,7 +1,12 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Type.Occurs (occurs) where
3+module Type.Occurs
4+ ( occurs
5+ )
6+ where
47
8+
9+import Data.Foldable (foldrM)
510import qualified Data.Map.Strict as Map
611
712import Type.Type as Type
@@ -14,11 +19,11 @@ import qualified Type.UnionFind as UF
1419
1520occurs :: Type.Variable -> IO Bool
1621occurs var =
17− occursHelp [] var
22+ occursHelp [] var False
1823
1924
20−occursHelp :: [Type.Variable] -> Type.Variable -> IO Bool
21−occursHelp seen var =
25+occursHelp :: [Type.Variable] -> Type.Variable -> Bool -> IO Bool
26+occursHelp seen var foundCycle =
2227 if elem var seen then
2328 return True
2429
@@ -26,41 +31,50 @@ occursHelp seen var =
2631 do (Descriptor content _ _ _) <- UF.descriptor var
2732 case content of
2833 FlexVar _ ->
29− return False
34+ return foundCycle
3035
3136 FlexSuper _ _ ->
32− return False
37+ return foundCycle
3338
3439 RigidVar _ ->
35− return False
40+ return foundCycle
3641
3742 RigidSuper _ _ ->
38− return False
43+ return foundCycle
3944
4045 Structure term ->
41− let go = occursHelp (var:seen) in
46+ let newSeen = var : seen in
4247 case term of
4348 App1 _ _ args ->
44− or <$> traverse go args
49+ foldrM (occursHelp newSeen) foundCycle args
4550
4651 Fun1 a b ->
47− (||) <$> go a <*> go b
52+ occursHelp newSeen a =<<
53+ occursHelp newSeen b foundCycle
4854
4955 EmptyRecord1 ->
50− return False
56+ return foundCycle
5157
5258 Record1 fields ext ->
53− or <$> traverse go (ext : Map.elems fields)
59+ occursHelp newSeen ext =<<
60+ foldrM (occursHelp newSeen) foundCycle (Map.elems fields)
5461
5562 Unit1 ->
56− return False
63+ return foundCycle
64+
65+ Tuple1 a b maybeC ->
66+ case maybeC of
67+ Nothing ->
68+ occursHelp newSeen a =<<
69+ occursHelp newSeen b foundCycle
5770
58− Tuple1 a b cs ->
59− or <$> traverse go (a:b:cs)
71+ Just c ->
72+ occursHelp newSeen a =<<
73+ occursHelp newSeen b =<<
74+ occursHelp newSeen c foundCycle
6075
6176 Alias _ _ args _ ->
62− -- TODO is it okay to only check args?
63− or <$> traverse (occursHelp (var:seen) . snd) args
77+ foldrM (occursHelp (var:seen)) foundCycle (map snd args)
6478
6579 Error _ ->
66− return False
80+ return foundCycle