git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #951 from purescript/constrained-typedval-fix

Fix typechecking of constrained type values

commit3acb2f554ac5797c4e6e29032255c7d2979c7ac2 authorGary Burgess <gary.burgess@gmail.com> dateSun 8 Mar 2015, 18:45 (12 years ago) parentedcefcbd0a2fc2
3 files changed+41−7
compare with golang
unifiedsplit
examples/passing/SequenceDesugared.purs+34 src/Language/PureScript/Pretty/Values.hs+2−2 src/Language/PureScript/TypeChecker/Types.hs+5−5
examples/passing/SequenceDesugared.pursnew file+34
@@ -0,0 +1,34 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+
5+data Sequence t = Sequence (forall m a. (Monad m) => t (m a) -> m (t a))
6+
7+sequence :: forall t. Sequence t -> (forall m a. (Monad m) => t (m a) -> m (t a))
8+sequence (Sequence s) = s
9+
10+sequenceArraySeq :: forall m a. (Monad m) => Array (m a) -> m (Array a)
11+sequenceArraySeq [] = pure []
12+sequenceArraySeq (x:xs) = (:) <$> x <*> sequenceArraySeq xs
13+
14+sequenceArray :: Sequence []
15+sequenceArray = Sequence (sequenceArraySeq)
16+
17+sequenceArray' :: Sequence []
18+sequenceArray' = Sequence ((\val -> case val of
19+ [] -> pure []
20+ (x:xs) -> (:) <$> x <*> sequence sequenceArray' xs))
21+
22+sequenceArray'' :: Sequence []
23+sequenceArray'' = Sequence (sequenceArraySeq :: forall m a. (Monad m) => Array (m a) -> m (Array a))
24+
25+sequenceArray''' :: Sequence []
26+sequenceArray''' = Sequence ((\val -> case val of
27+ [] -> pure []
28+ (x:xs) -> (:) <$> x <*> sequence sequenceArray''' xs) :: forall m a. (Monad m) => Array (m a) -> m (Array a))
29+
30+main = do
31+ sequence sequenceArray $ [Debug.Trace.trace "Done"]
32+ sequence sequenceArray' $ [Debug.Trace.trace "Done"]
33+ sequence sequenceArray'' $ [Debug.Trace.trace "Done"]
34+ sequence sequenceArray''' $ [Debug.Trace.trace "Done"]
src/Language/PureScript/Pretty/Values.hs+2−2
@@ -29,7 +29,7 @@ import Control.Applicative
2929import Language.PureScript.AST
3030import Language.PureScript.Names
3131import Language.PureScript.Pretty.Common
32−import Language.PureScript.Pretty.Types (prettyPrintType)
32+import Language.PureScript.Pretty.Types (prettyPrintType, prettyPrintTypeAtom)
3333
3434literals :: Pattern PrinterState Expr String
3535literals = mkPattern' match
@@ -76,7 +76,7 @@ literals = mkPattern' match
7676 ]
7777 match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"
7878 match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"
79− match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"
79+ match (TypeClassDictionary _ (name, tys) _) = return $ "<<dict " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"
8080 match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
8181 match (TypedValue _ val _) = prettyPrintValue' val
8282 match (PositionedValue _ _ val) = prettyPrintValue' val
src/Language/PureScript/TypeChecker/Types.hs+5−5
@@ -506,9 +506,9 @@ check' (TypedValue checkType val ty1) ty2 = do
506506 val' <- subsumes (Just val) ty1' ty2'
507507 case val' of
508508 Nothing -> throwError . errorMessage $ SubsumptionCheckFailed
509− Just val'' -> do
510− val''' <- if checkType then withScopedTypeVars moduleName args (check val'' ty2') else return val''
511− return $ TypedValue checkType (TypedValue True val''' ty1') ty2'
509+ Just _ -> do
510+ val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val
511+ return $ TypedValue checkType val''' ty2'
512512check' (Case vals binders) ret = do
513513 vals' <- mapM infer vals
514514 let ts = map (\(TypedValue _ _ t) -> t) vals'
@@ -660,8 +660,8 @@ meet e1 e2 t1 t2 = do
660660-- Ensure a set of property names and value does not contain duplicate labels
661661--
662662ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(String, Expr)] -> m ()
663−ensureNoDuplicateProperties ps =
663+ensureNoDuplicateProperties ps =
664664 let ls = map fst ps in
665665 case ls \\ nub ls of
666666 l : _ -> throwError . errorMessage $ DuplicateLabel l Nothing
667− _ -> return ()
667+ _ -> return ()