git.iko.soy/elk
on master help sign in
Move the occurs check into its own module
368cdbcEvan Czaplicki
elm-compiler.cabal+1
compare with master
unifiedsplit
@@ -139,6 +139,7 @@ Library
139 Type.Constrain.Pattern,
139 Type.Constrain.Pattern,
140 Type.Environment,
140 Type.Environment,
141 Type.Inference,
141 Type.Inference,
142+ Type.Occurs,
142 Type.Solve,
143 Type.Solve,
143 Type.State,
144 Type.State,
144 Type.Type,
145 Type.Type,
src/Type/Occurs.hsnew file+58
@@ -0,0 +1,58 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Type.Occurs (occurs) where
4+
5+import qualified Data.Map as Map
6+
7+import Type.Type as Type
8+import qualified Type.UnionFind as UF
9+
10+
11+
12+-- OCCURS
13+
14+
15+occurs :: Type.Variable -> IO Bool
16+occurs var =
17+ occursHelp [] var
18+
19+
20+occursHelp :: [Type.Variable] -> Type.Variable -> IO Bool
21+occursHelp seen var =
22+ if elem var seen then
23+ do infiniteDescriptor <- UF.descriptor var
24+ UF.setDescriptor var (infiniteDescriptor { _content = Error })
25+ return True
26+
27+ else
28+ do desc <- UF.descriptor var
29+ case _content desc of
30+ Atom _ ->
31+ return False
32+
33+ Var _ _ _ ->
34+ return False
35+
36+ Error ->
37+ return False
38+
39+ Alias _ args _ ->
40+ -- TODO is it okay to only check args?
41+ or <$> traverse (occursHelp (var:seen) . snd) args
42+
43+ Structure term ->
44+ let
45+ go = occursHelp (var:seen)
46+ in
47+ case term of
48+ App1 a b ->
49+ (||) <$> go a <*> go b
50+
51+ Fun1 a b ->
52+ (||) <$> go a <*> go b
53+
54+ EmptyRecord1 ->
55+ return False
56+
57+ Record1 fields ext ->
58+ or <$> traverse go (ext : Map.elems fields)
src/Type/Solve.hs+2−42
@@ -11,6 +11,7 @@ import qualified Data.Text as Text
11import qualified AST.Module.Name as ModuleName
11import qualified AST.Module.Name as ModuleName
12import qualified Reporting.Annotation as A
12import qualified Reporting.Annotation as A
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 Type.Unify
17import Type.Unify
@@ -268,7 +269,7 @@ crash msg =
268occurs :: (Text.Text, A.Located Variable) -> TS.Solver ()
269occurs :: (Text.Text, A.Located Variable) -> TS.Solver ()
269occurs (name, A.A region variable) =
270occurs (name, A.A region variable) =
270 {-# SCC elm_compiler_type_occurs #-}
271 {-# SCC elm_compiler_type_occurs #-}
271− do hasOccurred <- liftIO $ occursHelp [] variable
272+ do hasOccurred <- liftIO $ Occurs.occurs variable
272 case hasOccurred of
273 case hasOccurred of
273 False ->
274 False ->
274 return ()
275 return ()
@@ -276,44 +277,3 @@ occurs (name, A.A region variable) =
276 True ->
277 True ->
277 do overallType <- liftIO (Type.toSrcType variable)
278 do overallType <- liftIO (Type.toSrcType variable)
278 TS.addError region (Error.InfiniteType name overallType)
279 TS.addError region (Error.InfiniteType name overallType)
279−
280−
281−occursHelp :: [Variable] -> Variable -> IO Bool
282−occursHelp seen var =
283− if elem var seen then
284− do infiniteDescriptor <- UF.descriptor var
285− UF.setDescriptor var (infiniteDescriptor { _content = Error })
286− return True
287−
288− else
289− do desc <- UF.descriptor var
290− case _content desc of
291− Atom _ ->
292− return False
293−
294− Var _ _ _ ->
295− return False
296−
297− Error ->
298− return False
299−
300− Alias _ args _ ->
301− -- TODO is it okay to only check args?
302− or <$> mapM (occursHelp (var:seen) . snd) args
303−
304− Structure term ->
305− let
306− go = occursHelp (var:seen)
307− in
308− case term of
309− App1 a b ->
310− (||) <$> go a <*> go b
311−
312− Fun1 a b ->
313− (||) <$> go a <*> go b
314−
315− EmptyRecord1 ->
316− return False
317−
318− Record1 fields ext ->
319− or <$> mapM go (ext : Map.elems fields)