git.iko.soy/elk
on master help sign in
Add an occurs check to finally resolve #294
f73a6ffEvan Czaplicki
compiler/SourceSyntax/PrettyPrint.hs+11
compare with master
unifiedsplit
@@ -21,3 +21,14 @@ variable x =
21
21
22reprime :: String -> String
22reprime :: String -> String
23reprime = map (\c -> if c == '$' then '\'' else c)
23reprime = map (\c -> if c == '$' then '\'' else c)
24+
25+eightyCharLines :: Int -> String -> String
26+eightyCharLines indent message = answer
27+ where
28+ (answer,_,_) = foldl step (replicate (indent-1) ' ', indent-1, "") chunks
29+
30+ chunks = map (\w -> (w, length w)) (words message)
31+ spaces = replicate indent ' '
32+ step (sentence, slen, space) (word, wlen)
33+ | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
34+ | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
compiler/Type/ExtraChecks.hs+41−41
@@ -1,27 +1,25 @@
1-- This module contains checks to be run *after* type inference has
1-- This module contains checks to be run *after* type inference has
2-- completed successfully. At that point we still need to do occurs
2-- completed successfully. At that point we still need to do occurs
3-- checks and ensure that `main` has an acceptable type.
3-- checks and ensure that `main` has an acceptable type.
4−module Type.ExtraChecks (extraChecks) where
4+module Type.ExtraChecks (extraChecks, occursCheck) where
5
5
6import Control.Applicative ((<$>),(<*>))
6import Control.Applicative ((<$>),(<*>))
7+import Control.Monad.State
7import qualified Data.Map as Map
8import qualified Data.Map as Map
8import qualified Data.UnionFind.IO as UF
9import qualified Data.UnionFind.IO as UF
9import Type.Type ( Variable, structure, Term1(..), toSrcType )
10import Type.Type ( Variable, structure, Term1(..), toSrcType )
10−import Type.State (Env)
11+import qualified Type.State as TS
11import qualified Type.Alias as Alias
12import qualified Type.Alias as Alias
12import Text.PrettyPrint as P
13import Text.PrettyPrint as P
13import SourceSyntax.PrettyPrint (pretty)
14import SourceSyntax.PrettyPrint (pretty)
14import SourceSyntax.Type (Type)
15import SourceSyntax.Type (Type)
16+import qualified SourceSyntax.Location as Location
17+import qualified SourceSyntax.Expression as Expr
15import qualified Data.Traversable as Traverse
18import qualified Data.Traversable as Traverse
16
19
17−extraChecks :: Alias.Rules -> Env -> IO (Either [P.Doc] (Map.Map String Type))
20+extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))
18−extraChecks rules env = do
21+extraChecks rules env =
19− eitherEnv <- occursCheck env
20− case eitherEnv of
21− Left errs -> return $ Left errs
22− Right env' ->
23− mainCheck rules <$> Traverse.traverse toSrcType env'
22+ mainCheck rules <$> Traverse.traverse toSrcType env
24−
25
23
26mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
24mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
27mainCheck rules env =
25mainCheck rules env =
@@ -39,35 +37,37 @@ mainCheck rules env =
39 , P.text " " ]
37 , P.text " " ]
40 ]
38 ]
41
39
42−occursCheck :: Env -> IO (Either [P.Doc] Env)
43−occursCheck env = do
44− errors <- concat <$> mapM isFinite (Map.toList env)
45− return $ if null errors then Right env else Left errors
46−
47−isFinite :: (String, Variable) -> IO [P.Doc]
40+occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()
48−isFinite (name, var) =
41+occursCheck (name, variable) =
49− do varIsFinite <- go [] var
42+ do vars <- liftIO $ infiniteVars [] variable
50− return $
51− case varIsFinite of
43+ case vars of
52− True -> []
44+ [] -> return ()
53− False -> [ P.vcat [ P.text "Type Error:"
45+ var:_ -> do
54− , P.text $ "Cannot construct infinite type for '" ++ name ++ "'\n"
46+ desc <- liftIO $ UF.descriptor var
55− ]
47+ case structure desc of
56− ]
48+ Nothing ->
49+ modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
50+ Just struct ->
51+ do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
52+ var' <- liftIO $ UF.fresh desc
53+ TS.addError (Location.NoSpan name) (Just msg) var var'
57 where
54 where
55+ msg = "Infinite types are not allowed"
56+ fallback _ = return $ P.text msg
57+
58− go :: [Variable] -> Variable -> IO Bool
58+ infiniteVars :: [Variable] -> Variable -> IO [Variable]
59− go seen var =
59+ infiniteVars seen var =
60− let check = go (var:seen) in
60+ let go = infiniteVars (var:seen) in
61− case var `elem` seen of
61+ if var `elem` seen
62− True -> return False
62+ then return [var]
63− False -> do
63+ else do
64− desc <- UF.descriptor var
64+ desc <- UF.descriptor var
65− case structure desc of
65+ case structure desc of
66− Nothing -> return True
66+ Nothing -> return []
67− Just struct ->
67+ Just struct ->
68− case struct of
68+ case struct of
69− App1 a b -> (&&) <$> check a <*> check b
69+ App1 a b -> (++) <$> go a <*> go b
70− Fun1 a b -> (&&) <$> check a <*> check b
70+ Fun1 a b -> (++) <$> go a <*> go b
71− Var1 a -> check a
71+ Var1 a -> go a
72− EmptyRecord1 -> return True
72+ EmptyRecord1 -> return []
73− Record1 fields ext -> and <$> mapM check (ext : concat (Map.elems fields))
73+ Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
compiler/Type/Solve.hs+11−6
@@ -9,6 +9,7 @@ import qualified Data.Maybe as Maybe
9import qualified Data.List as List
9import qualified Data.List as List
10import Type.Type
10import Type.Type
11import Type.Unify
11import Type.Unify
12+import qualified Type.ExtraChecks as EC
12import qualified Type.Environment as Env
13import qualified Type.Environment as Env
13import qualified Type.State as TS
14import qualified Type.State as TS
14import qualified Text.PrettyPrint as P
15import qualified Text.PrettyPrint as P
@@ -118,9 +119,10 @@ solve (L span constraint) =
118
119
119 CLet schemes constraint' -> do
120 CLet schemes constraint' -> do
120 oldEnv <- TS.getEnv
121 oldEnv <- TS.getEnv
121− headers <- mapM (solveScheme span) schemes
122+ headers <- Map.unions `fmap` mapM (solveScheme span) schemes
122− TS.modifyEnv $ \env -> Map.unions (headers ++ [env])
123+ TS.modifyEnv $ \env -> Map.union headers env
123 solve constraint'
124 solve constraint'
125+ mapM EC.occursCheck $ Map.toList headers
124 TS.modifyEnv (\_ -> oldEnv)
126 TS.modifyEnv (\_ -> oldEnv)
125
127
126 CInstance name term -> do
128 CInstance name term -> do
@@ -171,11 +173,13 @@ allDistinct span vars = do
171 let check var = do
173 let check var = do
172 desc <- liftIO $ UF.descriptor var
174 desc <- liftIO $ UF.descriptor var
173 case structure desc of
175 case structure desc of
174− Just _ ->
176+ Just _ -> TS.addError span (Just msg) var var
175− TS.addError span "Cannot generalize something that is not a type variable" var var
177+ where msg = "Cannot generalize something that is not a type variable"
178+
176 Nothing -> do
179 Nothing -> do
177 if mark desc == seen
180 if mark desc == seen
178− then TS.addError span "Duplicate variable during generalization" var var
181+ then let msg = "Duplicate variable during generalization"
182+ in TS.addError span (Just msg) var var
179 else return ()
183 else return ()
180 liftIO $ UF.setDescriptor var (desc { mark = seen })
184 liftIO $ UF.setDescriptor var (desc { mark = seen })
181 mapM_ check vars
185 mapM_ check vars
@@ -186,4 +190,5 @@ isGeneric span var = do
186 desc <- liftIO $ UF.descriptor var
190 desc <- liftIO $ UF.descriptor var
187 if rank desc == noRank
191 if rank desc == noRank
188 then return ()
192 then return ()
193+ else let msg = "Unable to generalize a type variable. It is not unranked"
189− else TS.addError span "Cannot generalize. Variable must have not have a rank." var var
194+ in TS.addError span (Just msg) var var
compiler/Type/State.hs+14−14
@@ -48,7 +48,7 @@ initialState = SS {
48modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
48modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
49modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
49modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
50
50
51−addError span message t1 t2 =
51+addError span hint t1 t2 =
52 modify $ \state -> state { sErrors = makeError : sErrors state }
52 modify $ \state -> state { sErrors = makeError : sErrors state }
53 where
53 where
54 makeError rules = do
54 makeError rules = do
@@ -56,11 +56,13 @@ addError span message t1 t2 =
56 t1' <- prettiest <$> toSrcType t1
56 t1' <- prettiest <$> toSrcType t1
57 t2' <- prettiest <$> toSrcType t2
57 t2' <- prettiest <$> toSrcType t2
58 return . P.vcat $
58 return . P.vcat $
59− [ P.text $ "Type error" ++ location ++ ":"
59+ [ display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
60− , P.vcat . map P.text . lines $ if null message then defaultMessage else message
60+ , case hint of
61− , P.text src
61+ Nothing -> P.text " Could not match the following types:"
62+ Just msg -> P.text $ eightyCharLines 2 $
63+ msg ++ ", so I could not match the following types:"
62− , P.text " Expected Type:" <+> t1'
64+ , P.text " " <> t1'
63− , P.text " Actual Type:" <+> t2' <> P.text "\n"
65+ , P.text " " <> t2'
64 ]
66 ]
65
67
66 location = case span of
68 location = case span of
@@ -69,14 +71,12 @@ addError span message t1 t2 =
69 if line p1 == line p2 then " on line " ++ show (line p1)
71 if line p1 == line p2 then " on line " ++ show (line p1)
70 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
72 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
71
73
72− display msg = if null msg then "\n"
74+ display msg =
73− else "\n" ++ unlines (map (" "++) $ lines msg)
74−
75− src = case span of
75+ case lines msg of
76− NoSpan msg -> display msg
76+ [] -> P.text $ "Type error" ++ location ++ ":"
77− Span _ _ msg -> display msg
77+ lines' ->
78−
78+ P.vcat [ P.text $ "Type error" ++ location ++ ", in or near this expression:"
79− defaultMessage = "Something weird is happening with this value:"
79+ , P.text $ " " ++ List.intercalate "\n " lines' ]
80
80
81
81
82switchToPool pool = modifyPool (\_ -> pool)
82switchToPool pool = modifyPool (\_ -> pool)
compiler/Type/Unify.hs+16−15
@@ -3,6 +3,7 @@ module Type.Unify (unify) where
3import Type.Type
3import Type.Type
4import qualified Data.UnionFind.IO as UF
4import qualified Data.UnionFind.IO as UF
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6+import qualified Data.Maybe as Maybe
6import qualified Type.State as TS
7import qualified Type.State as TS
7import Control.Arrow (first,second)
8import Control.Arrow (first,second)
8import Control.Monad.State
9import Control.Monad.State
@@ -78,25 +79,26 @@ actuallyUnify span variable1 variable2 = do
78
79
79 unifyNumber svar name
80 unifyNumber svar name
80 | name `elem` ["Int","Float","number"] = flexAndUnify svar
81 | name `elem` ["Int","Float","number"] = flexAndUnify svar
81− | otherwise = TS.addError span "Expecting a number (Int or Float)" variable1 variable2
82+ | otherwise = TS.addError span (Just hint) variable1 variable2
83+ where hint = "A number must be an Int or Float"
82
84
85+ comparableError maybe =
83− comparableError str = TS.addError span (str ++ msg) variable1 variable2
86+ TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
84− where msg = "Expecting something comparable such as an\n" ++
85− "Int, Float, Char, String, or a list or tuple of comparables."
87+ where msg = "A comparable must be an Int, Float, Char, String, list, or tuple"
86
88
87 unifyComparable var name
89 unifyComparable var name
88 | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var
90 | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var
89− | otherwise = comparableError ""
91+ | otherwise = comparableError Nothing
90
92
91 unifyComparableStructure varSuper varFlex =
93 unifyComparableStructure varSuper varFlex =
92 do struct <- liftIO $ collectApps varFlex
94 do struct <- liftIO $ collectApps varFlex
93 case struct of
95 case struct of
94− Other -> comparableError ""
96+ Other -> comparableError Nothing
95 List v -> do flexAndUnify varSuper
97 List v -> do flexAndUnify varSuper
96 unify' v =<< liftIO (var $ Is Comparable)
98 unify' v =<< liftIO (var $ Is Comparable)
97 Tuple vs
99 Tuple vs
98 | length vs > 6 ->
100 | length vs > 6 ->
99− comparableError "Cannot compare a tuple with more than 6 elements.\n"
101+ comparableError $ Just "Cannot compare a tuple with more than 6 elements"
100 | otherwise ->
102 | otherwise ->
101 do flexAndUnify varSuper
103 do flexAndUnify varSuper
102 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)
104 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)
@@ -106,13 +108,12 @@ actuallyUnify span variable1 variable2 = do
106 do struct <- liftIO $ collectApps varFlex
108 do struct <- liftIO $ collectApps varFlex
107 case struct of
109 case struct of
108 List _ -> flexAndUnify varSuper
110 List _ -> flexAndUnify varSuper
109− _ -> comparableError ""
111+ _ -> comparableError Nothing
110
112
111− rigidError variable = TS.addError span msg variable1 variable2
113+ rigidError variable = TS.addError span (Just hint) variable1 variable2
112− where
114+ where hint = "There is a problem with the '" ++
113− msg = concat
114− [ "Cannot unify rigid type variable '", render (pretty Never variable), "'.\n"
115+ render (pretty Never variable) ++
115− , "It is likely that a type annotation is not general enough." ]
116+ "' in the type signature. It currently is not possible to unify type variables that appear in top-level declarations and again in subexpressions"
116
117
117 superUnify =
118 superUnify =
118 case (flex desc1, flex desc2, name desc1, name desc2) of
119 case (flex desc1, flex desc2, name desc1, name desc2) of
@@ -138,7 +139,7 @@ actuallyUnify span variable1 variable2 = do
138
139
139 (Rigid, _, _, _) -> rigidError variable1
140 (Rigid, _, _, _) -> rigidError variable1
140 (_, Rigid, _, _) -> rigidError variable2
141 (_, Rigid, _, _) -> rigidError variable2
141− _ -> TS.addError span "" variable1 variable2
142+ _ -> TS.addError span Nothing variable1 variable2
142
143
143 case (structure desc1, structure desc2) of
144 case (structure desc1, structure desc2) of
144 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
145 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
@@ -193,5 +194,5 @@ actuallyUnify span variable1 variable2 = do
193 eat (x:xs) (y:ys) = eat xs ys
194 eat (x:xs) (y:ys) = eat xs ys
194 eat xs ys = xs
195 eat xs ys = xs
195
196
196− _ -> TS.addError span "" variable1 variable2
197+ _ -> TS.addError span Nothing variable1 variable2
197
198