45f834e · elk · git.iko.soy

git.iko.soy/elk

Add context to type constraints for better error messages. Fix big with generated constraints in which some constraints could be ignored.

commit45f834e0fc59f4fb42c6e09e9c4f2a73b16a261c authorevancz <info@elm-lang.org> dateSat 28 Jul 2012, 20:45 (14 years ago) parent8c42218

2 files changed+71−47

compare with master

unifiedsplit

elm/src/Types/Constrain.hs+34−20 elm/src/Types/Unify.hs+37−27

elm/src/Types/Constrain.hs+34−20

@@ -6,7 +6,7 @@ import Types

66import Data.List (foldl')

77import qualified Data.Set as Set

88import qualified Data.Map as Map

9−import Control.Monad (liftM,mapM)

9+import Control.Monad (liftM,mapM,zipWithM)

1010import Control.Monad.State (evalState)

1111import Guid

1212

@@ -14,53 +14,64 @@ beta = VarT `liftM` guid

1414unionA = Map.unionWith (++)

1515unionsA = Map.unionsWith (++)

1616

17+data Context a b = Context a b deriving (Eq,Show)

18+ctx e = Context e

19+

20+instance (Ord a, Eq c) => Ord (Context c a) where

21+ compare (Context _ x) (Context _ y) = compare x y

22+

1723constrain hints expr = do

1824 (as,cs,t) <- inference expr

19− let cMap = Map.intersectionWith (\s -> map (\v -> VarT v:<<: s)) (Map.fromList hints) as

20− return $ Set.toList cs ++ (concat . map snd $ Map.toList cMap)

25+ let cMap = Map.intersectionWithKey combine (Map.fromList hints) as

26+ where combine k s vs = map (\v -> ctx (Var k) $ VarT v :<<: s) vs

27+ return (Set.toList cs ++ (concatMap snd $ Map.toList cMap))

2128

22−inference :: Expr -> GuidCounter (Map.Map String [X], Set.Set Constraint, Type)

29+inference :: Expr -> GuidCounter (Map.Map String [X], Set.Set (Context Expr Constraint), Type)

2330inference (Var x) =

2431 do b <- guid

2532 return (Map.singleton x [b], Set.empty, VarT b)

26−inference (App e1 e2) =

33+inference e@(App e1 e2) =

2734 do (a1,c1,t1) <- inference e1

2835 (a2,c2,t2) <- inference e2

2936 b <- beta

3037 return ( unionA a1 a2

31− , Set.unions [c1,c2,Set.singleton $ t1 :=: (LambdaT t2 b)]

38+ , Set.unions [c1,c2,Set.singleton . ctx e $ t1 :=: (LambdaT t2 b)]

3239 , b )

3340inference (Lambda x e) =

3441 do (a,c,t) <- inference e

3542 b <- beta

43+ v <- guid

3644 return ( Map.delete x a

37− , Set.union c . Set.fromList . map (\x -> VarT x :=: b) $

38− Map.findWithDefault [] x a

45+ , Set.union c . Set.fromList . map (\x -> ctx e $ VarT x :=: b) $

46+ Map.findWithDefault [v] x a

3947 , LambdaT b t )

4048inference (Let defs e) =

4149 do (as,cs,t) <- inference e

4250 (ass, schemes) <- liftM unzip (mapM defScheme defs)

4351 let assumptions = unionsA (as:ass)

4452 let names = map (\(Definition x _ _) -> x) defs

45− let genCs name s = map (\x -> VarT x :<<: s) $ Map.findWithDefault [] name assumptions

46− let cs' = Set.fromList . concat $ zipWith genCs names schemes

53+ let genCs name s = do

54+ v <- guid

55+ return . map (\x -> ctx (Var name) $ VarT x :<<: s) $ Map.findWithDefault [v] name assumptions

56+ cs' <- zipWithM genCs names schemes

4757 return ( foldr Map.delete assumptions names

48− , Set.union cs' cs

58+ , Set.union (Set.fromList . concat $ cs') cs

4959 , t )

5060

51−inference (Case e cases) =

61+inference ce@(Case e cases) =

5262 do (as,cs,t) <- inference e

5363 (ass,css,ts) <- liftM unzip3 $ mapM (caseInference t) cases

5464 return ( unionsA $ as:ass

55− , Set.unions $ Set.fromList (zipWith (:=:) ts $ tail ts) : cs : css

65+ , let combine t1 t2 = ctx ce (t1 :=: t2) in

66+ Set.unions $ Set.fromList (zipWith combine ts $ tail ts) : cs : css

5667 , head ts)

5768

58−inference (If e1 e2 e3) =

69+inference e@(If e1 e2 e3) =

5970 do (a1,c1,t1) <- inference e1

6071 (a2,c2,t2) <- inference e2

6172 (a3,c3,t3) <- inference e3

6273 return ( unionsA [a1,a2,a3]

63− , Set.unions [c1,c2,c3, Set.fromList [ t1 :=: bool, t2 :=: t3 ] ]

74+ , Set.unions [c1,c2,c3, Set.fromList [ ctx e1 (t1 :=: bool), ctx e (t2 :=: t3) ] ]

6475 , t2 )

6576

6677inference (Data name es) = inference $ foldl' App (Var name) es

@@ -71,7 +82,7 @@ inference (Range e1 e2) = inference (Var "elmRange" `App` e1 `App` e2)

7182inference other =

7283 case other of

7384 IntNum _ -> do t <- beta

74− return (Map.empty, Set.singleton (t :<: number), t)

85+ return (Map.empty, Set.singleton (ctx other $ t :<: number), t)

7586 FloatNum _ -> primitive float

7687 Chr _ -> primitive char

7788 Str _ -> primitive string

@@ -93,8 +104,11 @@ namesIn (PData name ps) = concatMap namesIn ps

93104defScheme (Definition name args e) =

94105 do argDict <- mapM (\a -> liftM ((,) a) guid) args

95106 (as,cs,t) <- inference e

96− let genCs (arg,x) = map (\y -> VarT x :=: VarT y) $ Map.findWithDefault [] arg as

97− let cs' = concatMap genCs argDict

107+ let genCs (arg,x) = do

108+ v <- guid

109+ return . map (\y -> VarT x :=: VarT y) $ Map.findWithDefault [v] arg as

110+ cs' <- concat `liftM` mapM genCs argDict

111+ let cs'' = map (\(Context _ c) -> c) (Set.toList cs)

98112 let tipe = foldr (==>) t $ map (VarT . snd) argDict

99− return (foldr Map.delete as args

100− , Forall (map snd argDict) (cs' ++ Set.toList cs) tipe)

113+ return ( foldr Map.delete as args

114+ , Forall (map snd argDict) (cs' ++ cs'') tipe)

elm/src/Types/Unify.hs+37−27

@@ -1,5 +1,5 @@

2−module Unify where

2+module Unify (unify) where

44import Constrain

55import Control.Arrow (second)

@@ -15,68 +15,78 @@ unify hints expr = run $ do

1515 cs <- constrain hints expr

1616 solver cs []

1717

18+eq ctx t1 t2 = Context ctx (t1 :=: t2)

19+

1820solver [] subs = return $ Right subs

1921

2022-------- Destruct Type-constructors --------

2123

22−solver ((t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2)) : cs) subs =

23− if n1 /= n2 then uniError t1 t2 else

24− solver (zipWith (:=:) ts1 ts2 ++ cs) subs

25−solver ((LambdaT t1 t2 :=: LambdaT t1' t2') : cs) subs =

26− solver ([ t1 :=: t1', t2 :=: t2' ] ++ cs) subs

24+solver ((Context ctx (t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2))) : cs) subs =

25+ if n1 /= n2 then uniError ctx t1 t2 else

26+ solver (zipWith (eq ctx) ts1 ts2 ++ cs) subs

27+solver ((Context ctx (LambdaT t1 t2 :=: LambdaT t1' t2')) : cs) subs =

28+ solver ([ eq ctx t1 t1', eq ctx t2 t2' ] ++ cs) subs

2729

2830-------- Type-equality --------

2931

30−solver ((VarT x :=: t) : cs) subs =

32+solver ((Context ctx (VarT x :=: t)) : cs) subs =

3133 solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs

32−solver ((t :=: VarT x) : cs) subs = solver ((VarT x :=: t) : cs) subs

33−solver ((t1 :=: t2) : cs) subs

34+solver ((Context ctx (t :=: VarT x)) : cs) subs = solver ((Context ctx (VarT x :=: t)) : cs) subs

35+solver ((Context ctx (t1 :=: t2)) : cs) subs

3436 | t1 == t2 = solver cs subs

35− | otherwise = uniError t1 t2

37+ | otherwise = uniError ctx t1 t2

3638

3739-------- subtypes --------

3840

39−solver (c@(VarT x :<: SuperType n ts) : cs) subs

40− | all isSuper cs = solver ((VarT x :=: ADT n []) : cs) subs

41+solver (c@(Context ctx (VarT x :<: SuperType n ts)) : cs) subs

42+ | all isSuper cs = solver ((Context ctx (VarT x :=: ADT n [])) : cs) subs

4143 | otherwise = solver (cs ++ [c]) subs

42− where isSuper (VarT _ :<: _) = True

44+ where isSuper (Context _ (VarT _ :<: _)) = True

4345 isSuper _ = False

44−solver ((t@(ADT n1 []) :<: st@(SuperType n2 ts)) : cs) subs

46+solver ((Context ctx (t@(ADT n1 []) :<: st@(SuperType n2 ts))) : cs) subs

4547 | n1 == n2 || Set.member t ts = solver cs subs

4648 | otherwise = return . Left $ "Type error: " ++ show t ++

47− " is not a " ++ show st

48−solver ((t@(ADT "List" [_]) :<: st@(SuperType n' ts')) : cs) subs

49− | any f (Set.toList ts') = solver cs subs

49+ " is not a " ++ show st ++

50+ " in context " ++ show ctx

51+solver ((Context ctx (t@(ADT "List" [_]) :<: st@(SuperType n' ts'))) : cs) subs

52+ | any f (Set.toList ts') || Set.member t ts' = solver cs subs

5053 | otherwise = return . Left $ "Type error: " ++ show t ++

51− " is not a " ++ show st

54+ " is not a " ++ show st ++

55+ " in context " ++ show ctx

5256 where f (ADT "List" [VarT _]) = True

5357 f _ = False

5458

55−solver ((t :<: st@(SuperType n ts)) : cs) subs

59+solver ((Context ctx (t :<: st@(SuperType n ts))) : cs) subs

5660 | Set.member t ts = solver cs subs

5761 | otherwise = return . Left $ "Type error: " ++ show t ++

5862 " is not a " ++ show st

5963

60−solver ((t1 :<<: Forall xs cs' t2) : cs) subs = do

64+solver ((Context ctx (t1 :<<: Forall xs cs' t2)) : cs) subs = do

6165 pairs <- mapM (\x -> liftM ((,) x . VarT) guid) xs

6266 let t2' = foldr (uncurry tSub) t2 pairs

63− let cs'' = foldr (\(k,v) -> map (cSub k v)) cs' pairs

64− solver ((t1 :=: t2') : cs'' ++ cs) subs

67+ let cs'' = foldr (\(k,v) -> map (cSub k v)) (map (Context ctx) cs') pairs

68+ let constrs = ((Context ctx (t1 :=: t2')) : cs'' ++ cs)

69+ solver constrs subs

6570

6671

67−cSub k v (t1 :=: t2) = force $ tSub k v t1 :=: tSub k v t2

68−cSub k v (t :<: super) = force $ tSub k v t :<: super

69−cSub k v (t :<<: poly) = force $ tSub k v t :<<: poly

72+cSub k v (Context c (t1 :=: t2) ) = force . Context c $ tSub k v t1 :=: tSub k v t2

73+cSub k v (Context c (t :<: super)) = force . Context c $ tSub k v t :<: super

74+cSub k v (Context c (t :<<: poly)) = force . Context c $ tSub k v t :<<: poly

7075

7176tSub k v t@(VarT x) = if k == x then v else t

7277tSub k v (LambdaT t1 t2) = force $ LambdaT (tSub k v t1) (tSub k v t2)

7378tSub k v (ADT name ts) = ADT name (map (force . tSub k v) ts)

7479

75−uniError t1 t2 =

76− return . Left $ "Type error: " ++ show t1 ++ " is not equal to " ++ show t2

80+uniError ctx t1 t2 =

81+ return . Left $ "Type error: " ++ show t1 ++

82+ " is not equal to " ++ show t2 ++

83+ " in context " ++ show ctx

7784

7885force x = x `deepseq` x

7986

87+instance (NFData a) => NFData (Context c a) where

88+ rnf (Context _ a) = a `deepseq` ()

89+

8090instance NFData Constraint where

8191 rnf (t1 :=: t2) = t1 `deepseq` t2 `deepseq` ()

8292 rnf (t :<: _) = t `deepseq` ()