git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Check all unknowns become quantified at the top level. Fix row unification bug./
dd540b4Phil Freeman
examples/ReadShow.psnew file+5
compare with golang
unifiedsplit
@@ -0,0 +1,5 @@
1+extern read :: forall a. (String) -> a
2+
3+extern show :: forall a. (a) -> String
4+
5+test = \x -> show(read(x))
src/PureScript/TypeChecker/Types.hs+37−4
@@ -53,14 +53,47 @@ typeOf :: Ident -> Value -> Check PolyType
53typeOf name val = do
53typeOf name val = do
54 me <- fresh
54 me <- fresh
55 (cs, n) <- typeConstraints (M.singleton name me) val
55 (cs, n) <- typeConstraints (M.singleton name me) val
56+ let allConstraints = TypeConstraint me (TUnknown n) : cs
56− solution <- solveTypeConstraints ((TypeConstraint me (TUnknown n)) : cs) emptyTypeSolution
57+ solution <- solveTypeConstraints allConstraints emptyTypeSolution
58+ let ty = fst (runTypeSolution solution) n
59+ allUnknownsBecameQuantified allConstraints solution ty
57− return $ varIfUnknown $ fst (runTypeSolution solution) n
60+ return $ varIfUnknown ty
61+
62+allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()
63+allUnknownsBecameQuantified cs solution ty = do
64+ let
65+ typesMentioned = findUnknownTypes ty
66+ unknownTypes = nub $ flip concatMap cs $ \c -> case c of
67+ TypeConstraint u t -> u : findUnknownTypes t
68+ RowConstraint _ r -> findUnknownTypes r
69+ unsolvedTypes = filter (\n -> TUnknown n == fst (runTypeSolution solution) n) unknownTypes
70+ guardWith "Unsolved type variable" $ null $ unsolvedTypes \\ typesMentioned
71+ let
72+ rowsMentioned = findUnknownRows ty
73+ unknownRows = nub $ flip concatMap cs $ \c -> case c of
74+ TypeConstraint _ t -> findUnknownRows t
75+ RowConstraint u r -> u : findUnknownRows r
76+ unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows
77+ guardWith ("Unsolved row variable" ++ show (unsolvedRows \\ rowsMentioned) ++ ", " ++ show cs) $ null $ unsolvedRows \\ rowsMentioned
78+
79+findUnknownTypes :: (Data d) => d -> [Int]
80+findUnknownTypes = everything (++) (mkQ [] f)
81+ where
82+ f :: Type -> [Int]
83+ f (TUnknown n) = [n]
84+ f _ = []
85+
86+findUnknownRows :: (Data d) => d -> [Int]
87+findUnknownRows = everything (++) (mkQ [] f)
88+ where
89+ f :: Row -> [Int]
90+ f (RUnknown n) = [n]
91+ f _ = []
58
92
59varIfUnknown :: Type -> PolyType
93varIfUnknown :: Type -> PolyType
60varIfUnknown ty =
94varIfUnknown ty =
61 let
95 let
62 (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty
96 (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty
63− -- TODO : check no nested unknowns
64 in
97 in
65 PolyType (sort $ nub $ M.elems m) ty'
98 PolyType (sort $ nub $ M.elems m) ty'
66 where
99 where
@@ -478,7 +511,7 @@ unifyRows r1 r2 =
478 unifyRows' ((name, ty):row) r others (RUnknown u) = do
511 unifyRows' ((name, ty):row) r others (RUnknown u) = do
479 u' <- fresh
512 u' <- fresh
480 cs <- unifyRows' row r others (RUnknown u')
513 cs <- unifyRows' row r others (RUnknown u')
481− return [ RowConstraint u (RCons name ty (RUnknown u')) ]
514+ return (RowConstraint u (RCons name ty (RUnknown u')) : cs)
482 unifyRows' [] REmpty [] REmpty = return []
515 unifyRows' [] REmpty [] REmpty = return []
483 unifyRows' sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ show (fromList (sd1, r1)) ++ " with " ++ show (fromList (sd2, r2)) ++ "."
516 unifyRows' sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ show (fromList (sd1, r1)) ++ " with " ++ show (fromList (sd2, r2)) ++ "."
484 toList :: Row -> ([(String, Type)], Row)
517 toList :: Row -> ([(String, Type)], Row)
src/PureScript/Types.hs+2−2
@@ -28,7 +28,7 @@ data Type
28 | Function [Type] Type
28 | Function [Type] Type
29 | TypeVar String
29 | TypeVar String
30 | TypeConstructor String
30 | TypeConstructor String
31− | TypeApp Type Type deriving (Show, Data, Typeable)
31+ | TypeApp Type Type deriving (Show, Eq, Data, Typeable)
32
32
33data PolyType = PolyType [String] Type deriving (Show, Data, Typeable)
33data PolyType = PolyType [String] Type deriving (Show, Data, Typeable)
34
34
@@ -36,7 +36,7 @@ data Row
36 = RUnknown Int
36 = RUnknown Int
37 | RowVar String
37 | RowVar String
38 | REmpty
38 | REmpty
39− | RCons String Type Row deriving (Show, Data, Typeable)
39+ | RCons String Type Row deriving (Show, Eq, Data, Typeable)
40
40
41monoType :: Type -> PolyType
41monoType :: Type -> PolyType
42monoType = PolyType []
42monoType = PolyType []