d9e64f0 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

More tests for RankNTypes, adding polytypes to type synonyms and data declaration

d9e64f0Phil Freeman13 years ago

examples/passing/Church.psnew file+12

compare with golang

unifiedsplit

@@ -0,0 +1,12 @@

1+type List a = forall r. r -> (a -> r -> r) -> r

3+empty :: forall a. List a

4+empty = \r f -> r

6+cons :: forall a. a -> List a -> List a

7+cons = \a l r f -> f a (l r f)

9+append :: forall a. List a -> List a -> List a

10+append = \l1 l2 r f -> l2 (l1 r f) f

11+

12+test = append (cons 1 empty) (cons 2 empty)

src/Language/PureScript/Declarations.hs+2−2

@@ -30,8 +30,8 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)

30data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

32data Declaration

33− = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]

33+ = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]

34− | TypeSynonymDeclaration ProperName [String] Type

34+ | TypeSynonymDeclaration ProperName [String] PolyType

35 | TypeDeclaration Ident PolyType

36 | ValueDeclaration Ident Value

37 | ExternDeclaration Ident PolyType

src/Language/PureScript/Parser/Declarations.hs+2−2

@@ -44,7 +44,7 @@ parseDataDeclaration = do

44 name <- indented *> properName

45 tyArgs <- many (indented *> identifier)

46 lexeme $ indented *> P.char '='

47− ctors <- sepBy1 ((,) <$> properName <*> P.optionMaybe (indented *> parseType)) pipe

47+ ctors <- sepBy1 ((,) <$> properName <*> P.optionMaybe (indented *> parsePolyType)) pipe

48 return $ DataDeclaration name tyArgs ctors

50parseTypeDeclaration :: P.Parsec String ParseState Declaration

@@ -56,7 +56,7 @@ parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration

56parseTypeSynonymDeclaration =

57 TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)

58 <*> many (indented *> identifier)

59− <*> (lexeme (indented *> P.char '=') *> parseType)

59+ <*> (lexeme (indented *> P.char '=') *> parsePolyType)

61parseValueDeclaration :: P.Parsec String ParseState Declaration

62parseValueDeclaration =

src/Language/PureScript/TypeChecker/Types.hs+18−16

@@ -110,14 +110,8 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

110 unifyTypes' (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2)

111 | name1 == name2 = zipWithM_ unifyTypes args1 args2

112 unifyTypes' (SaturatedTypeSynonym name args) ty = do

113− env <- lift getEnv

113+ ty1 <- expandTypeSynonym name args

114− modulePath <- checkModulePath `fmap` lift get

115− case M.lookup (qualify modulePath name) (typeSynonyms env) of

116− Just (synArgs, body) -> do

117− let m = M.fromList $ zip synArgs args

118− let replaced = replaceTypeVars m body

119− replaced `unifyTypes` ty

114+ ty1 `unifyTypes` ty

120− Nothing -> error "Type synonym was not defined"

121 unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty

115 unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty

122 unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do

116 unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do

123 sk <- skolemize ident1 ty1

117 sk <- skolemize ident1 ty1

@@ -247,6 +241,16 @@ desaturateAllTypeSynonyms = everywhere (mkT replace)

247 replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args

241 replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args

248 replace t = t

242 replace t = t

249

243

244+expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Check Type

245+expandTypeSynonym name args = do

246+ env <- lift getEnv

247+ modulePath <- checkModulePath `fmap` lift get

248+ case M.lookup (qualify modulePath name) (typeSynonyms env) of

249+ Just (synArgs, body) -> do

250+ let m = M.fromList $ zip synArgs args

251+ return $ replaceTypeVars m body

252+ Nothing -> error "Type synonym was not defined"

253+

250ensureNoDuplicateProperties :: [(String, Value)] -> Check ()

254ensureNoDuplicateProperties :: [(String, Value)] -> Check ()

251ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

255ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

252

256

@@ -573,14 +577,6 @@ check' :: M.Map Ident Type -> Value -> Type -> Subst Check ()

573check' m val (ForAll idents ty) = do

577check' m val (ForAll idents ty) = do

574 sk <- skolemize idents ty

578 sk <- skolemize idents ty

575 check m val sk

579 check m val sk

576−check' m val (SaturatedTypeSynonym name args) = do

577− env <- lift getEnv

578− modulePath <- checkModulePath `fmap` lift get

579− case M.lookup (qualify modulePath name) (typeSynonyms env) of

580− Just (synArgs, body) -> do

581− let replaced = replaceTypeVars (M.fromList (zip synArgs args)) body

582− check m val replaced

583− Nothing -> error "Type synonym was not defined"

584check' m val u@(TUnknown _) = do

580check' m val u@(TUnknown _) = do

585 ty <- infer m val

581 ty <- infer m val

586 -- Don't unify an unknown with an inferred polytype

582 -- Don't unify an unknown with an inferred polytype

@@ -652,6 +648,9 @@ check' m (Constructor c) ty = do

652 Just ty1 -> do

648 Just ty1 -> do

653 repl <- lift $ replaceAllTypeSynonyms ty1

649 repl <- lift $ replaceAllTypeSynonyms ty1

654 repl `subsumes` ty

650 repl `subsumes` ty

651+check' m val (SaturatedTypeSynonym name args) = do

652+ ty <- expandTypeSynonym name args

653+ check m val ty

655check' _ val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

654check' _ val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

656

655

657checkProperties :: M.Map Ident Type -> [(String, Value)] -> Row -> Bool -> Subst Check ()

656checkProperties :: M.Map Ident Type -> [(String, Value)] -> Row -> Bool -> Subst Check ()

@@ -713,6 +712,9 @@ checkFunctionApplication' m (ForAll ident ty) args ret = do

713checkFunctionApplication' m u@(TUnknown _) args ret = do

712checkFunctionApplication' m u@(TUnknown _) args ret = do

714 tyArgs <- mapM (\arg -> infer m arg >>= replaceAllVarsWithUnknowns) args

713 tyArgs <- mapM (\arg -> infer m arg >>= replaceAllVarsWithUnknowns) args

715 u ~~ Function tyArgs ret

714 u ~~ Function tyArgs ret

715+checkFunctionApplication' m (SaturatedTypeSynonym name tyArgs) args ret = do

716+ ty <- expandTypeSynonym name tyArgs

717+ checkFunctionApplication' m ty args ret

716checkFunctionApplication' _ fnTy args ret = throwError $ "Cannot apply function of type "

718checkFunctionApplication' _ fnTy args ret = throwError $ "Cannot apply function of type "

717 ++ prettyPrintType fnTy

719 ++ prettyPrintType fnTy

718 ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)

720 ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)