Fix typechecking of constrained type values

garyb · garyb · commit d0a2fc2ddf65 · 2015-03-08T18:17:03.000Z
diff --git a/examples/passing/SequenceDesugared.purs b/examples/passing/SequenceDesugared.purs
@@ -0,0 +1,34 @@
+module Main where
+
+import Control.Monad.Eff
+
+data Sequence t = Sequence (forall m a. (Monad m) => t (m a) -> m (t a))
+
+sequence :: forall t. Sequence t -> (forall m a. (Monad m) => t (m a) -> m (t a))
+sequence (Sequence s) = s
+
+sequenceArraySeq :: forall m a. (Monad m) => Array (m a) -> m (Array a)
+sequenceArraySeq [] = pure []
+sequenceArraySeq (x:xs) = (:) <$> x <*> sequenceArraySeq xs
+
+sequenceArray :: Sequence []
+sequenceArray = Sequence (sequenceArraySeq)
+
+sequenceArray' :: Sequence []
+sequenceArray' = Sequence ((\val -> case val of
+  [] -> pure []
+  (x:xs) -> (:) <$> x <*> sequence sequenceArray' xs))
+
+sequenceArray'' :: Sequence []
+sequenceArray'' = Sequence (sequenceArraySeq :: forall m a. (Monad m) => Array (m a) -> m (Array a))
+
+sequenceArray''' :: Sequence []
+sequenceArray''' = Sequence ((\val -> case val of
+  [] -> pure []
+  (x:xs) -> (:) <$> x <*> sequence sequenceArray''' xs) :: forall m a. (Monad m) => Array (m a) -> m (Array a))
+
+main = do
+  sequence sequenceArray $ [Debug.Trace.trace "Done"]
+  sequence sequenceArray' $ [Debug.Trace.trace "Done"]
+  sequence sequenceArray'' $ [Debug.Trace.trace "Done"]
+  sequence sequenceArray''' $ [Debug.Trace.trace "Done"]
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -506,9 +506,9 @@ check' (TypedValue checkType val ty1) ty2 = do
   val' <- subsumes (Just val) ty1' ty2'
   case val' of
     Nothing -> throwError . errorMessage $ SubsumptionCheckFailed
-    Just val'' -> do
-      val''' <- if checkType then withScopedTypeVars moduleName args (check val'' ty2') else return val''
-      return $ TypedValue checkType (TypedValue True val''' ty1') ty2'
+    Just _ -> do
+      val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val
+      return $ TypedValue checkType val''' ty2'
 check' (Case vals binders) ret = do
   vals' <- mapM infer vals
   let ts = map (\(TypedValue _ _ t) -> t) vals'
@@ -660,8 +660,8 @@ meet e1 e2 t1 t2 = do
 -- Ensure a set of property names and value does not contain duplicate labels
 --
 ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(String, Expr)] -> m ()
-ensureNoDuplicateProperties ps = 
+ensureNoDuplicateProperties ps =
   let ls = map fst ps in
   case ls \\ nub ls of
     l : _ -> throwError . errorMessage $ DuplicateLabel l Nothing
-    _ -> return ()
+    _ -> return ()
