git.iko.soy/elk
on master help sign in
Implement occurs check with fewer operations and allocations
a8bfb99Evan Czaplicki
src/Type/Occurs.hs+33−19
compare with master
unifiedsplit
@@ -1,7 +1,12 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module Type.Occurs (occurs) where
3+module Type.Occurs
4+ ( occurs
5+ )
6+ where
4
7
8+
9+import Data.Foldable (foldrM)
5import qualified Data.Map.Strict as Map
10import qualified Data.Map.Strict as Map
6
11
7import Type.Type as Type
12import Type.Type as Type
@@ -14,11 +19,11 @@ import qualified Type.UnionFind as UF
14
19
15occurs :: Type.Variable -> IO Bool
20occurs :: Type.Variable -> IO Bool
16occurs var =
21occurs var =
17− occursHelp [] var
22+ occursHelp [] var False
18
23
19
24
20−occursHelp :: [Type.Variable] -> Type.Variable -> IO Bool
25+occursHelp :: [Type.Variable] -> Type.Variable -> Bool -> IO Bool
21−occursHelp seen var =
26+occursHelp seen var foundCycle =
22 if elem var seen then
27 if elem var seen then
23 return True
28 return True
24
29
@@ -26,41 +31,50 @@ occursHelp seen var =
26 do (Descriptor content _ _ _) <- UF.descriptor var
31 do (Descriptor content _ _ _) <- UF.descriptor var
27 case content of
32 case content of
28 FlexVar _ ->
33 FlexVar _ ->
29− return False
34+ return foundCycle
30
35
31 FlexSuper _ _ ->
36 FlexSuper _ _ ->
32− return False
37+ return foundCycle
33
38
34 RigidVar _ ->
39 RigidVar _ ->
35− return False
40+ return foundCycle
36
41
37 RigidSuper _ _ ->
42 RigidSuper _ _ ->
38− return False
43+ return foundCycle
39
44
40 Structure term ->
45 Structure term ->
41− let go = occursHelp (var:seen) in
46+ let newSeen = var : seen in
42 case term of
47 case term of
43 App1 _ _ args ->
48 App1 _ _ args ->
44− or <$> traverse go args
49+ foldrM (occursHelp newSeen) foundCycle args
45
50
46 Fun1 a b ->
51 Fun1 a b ->
47− (||) <$> go a <*> go b
52+ occursHelp newSeen a =<<
53+ occursHelp newSeen b foundCycle
48
54
49 EmptyRecord1 ->
55 EmptyRecord1 ->
50− return False
56+ return foundCycle
51
57
52 Record1 fields ext ->
58 Record1 fields ext ->
53− or <$> traverse go (ext : Map.elems fields)
59+ occursHelp newSeen ext =<<
60+ foldrM (occursHelp newSeen) foundCycle (Map.elems fields)
54
61
55 Unit1 ->
62 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
57
70
58− Tuple1 a b cs ->
71+ Just c ->
59− or <$> traverse go (a:b:cs)
72+ occursHelp newSeen a =<<
73+ occursHelp newSeen b =<<
74+ occursHelp newSeen c foundCycle
60
75
61 Alias _ _ args _ ->
76 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)
64
78
65 Error _ ->
79 Error _ ->
66− return False
80+ return foundCycle