git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #643 from purescript/457
ee67aecPhil Freeman
examples/failing/DuplicateProperties1.pursnew file+9
compare with golang
unifiedsplit
@@ -0,0 +1,9 @@
1+module DuplicateProperties where
2+
3+foreign import data Test :: # * -> *
4+
5+foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
6+
7+foreign import hasX "" :: Test (x :: Unit, y :: Unit)
8+
9+baz = subtractX (subtractX hasX)
examples/failing/DuplicateProperties2.pursnew file+9
@@ -0,0 +1,9 @@
1+module DuplicateProperties where
2+
3+foreign import data Test :: # * -> *
4+
5+foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
6+
7+foreign import hasX "" :: forall r. Test (x :: Unit, y :: Unit | r)
8+
9+baz = subtractX (subtractX hasX)
src/Language/PureScript/TypeChecker/Types.hs+43−6
@@ -154,12 +154,12 @@ unifyRows r1 r2 =
154 unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check ()
154 unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check ()
155 unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r)
155 unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r)
156 unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r)
156 unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r)
157− unifyRows' ((name, ty):row) r others u@(TUnknown un) = do
157+ unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do
158− occursCheck un ty
158+ forM_ sd1 $ \(_, t) -> occursCheck u2 t
159− forM_ row $ \(_, t) -> occursCheck un t
159+ forM_ sd2 $ \(_, t) -> occursCheck u1 t
160− u' <- fresh
160+ rest <- fresh
161− u =?= RCons name ty u'
161+ u1 =:= rowFromList (sd2, rest)
162− unifyRows' row r others u'
162+ u2 =:= rowFromList (sd1, rest)
163 unifyRows' [] REmpty [] REmpty = return ()
163 unifyRows' [] REmpty [] REmpty = return ()
164 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
164 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
165 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
165 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
@@ -188,6 +188,8 @@ typesOf mainModuleName moduleName vals = do
188 val' <- replaceTypeClassDictionaries moduleName val
188 val' <- replaceTypeClassDictionaries moduleName val
189 -- Check skolem variables did not escape their scope
189 -- Check skolem variables did not escape their scope
190 skolemEscapeCheck val'
190 skolemEscapeCheck val'
191+ -- Check rows do not contain duplicate labels
192+ checkDuplicateLabels val'
191 -- Remove type synonyms placeholders, remove duplicate row fields, and replace
193 -- Remove type synonyms placeholders, remove duplicate row fields, and replace
192 -- top-level unification variables with named type variables.
194 -- top-level unification variables with named type variables.
193 let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'
195 let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'
@@ -511,6 +513,41 @@ skolemEscapeCheck root@TypedValue{} =
511 go' _ = mempty
513 go' _ = mempty
512skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
514skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
513
515
516+-- |
517+-- Ensure rows do not contain duplicate labels
518+--
519+checkDuplicateLabels :: Expr -> Check ()
520+checkDuplicateLabels =
521+ let (_, f, _) = everywhereOnValuesM def go def
522+ in void . f
523+ where
524+ def :: a -> Check a
525+ def = return
526+
527+ go :: Expr -> Check Expr
528+ go e@(TypedValue _ _ ty) = checkDups ty >> return e
529+ go other = return other
530+
531+ checkDups :: Type -> Check ()
532+ checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
533+ checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts
534+ checkDups (ForAll _ t _) = checkDups t
535+ checkDups (ConstrainedType args t) = do
536+ mapM_ (checkDups) $ concatMap snd args
537+ checkDups t
538+ checkDups r@(RCons _ _ _) =
539+ let (ls, _) = rowToList r in
540+ case firstDup . sort . map fst $ ls of
541+ Just l -> throwError . strMsg $ "Duplicate label " ++ show l ++ " in row"
542+ Nothing -> return ()
543+ checkDups _ = return ()
544+
545+ firstDup :: (Eq a) => [a] -> Maybe a
546+ firstDup (x : xs@(x' : _))
547+ | x == x' = Just x
548+ | otherwise = firstDup xs
549+ firstDup _ = Nothing
550+
514-- |
551-- |
515-- Ensure a row contains no duplicate labels
552-- Ensure a row contains no duplicate labels
516--
553--