d9e64f0 · rowtype-yoga/purescript-native

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

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

commitd9e64f073efba2243ff77ca9d57bb5aef9b259f2 authorPhil Freeman <paf31@cantab.net> dateTue 26 Nov 2013, 13:14 (13 years ago) parent90503c5

4 files changed+34−20

compare with golang

unifiedsplit

examples/passing/Church.ps+12 src/Language/PureScript/Declarations.hs+2−2 src/Language/PureScript/Parser/Declarations.hs+2−2 src/Language/PureScript/TypeChecker/Types.hs+18−16

examples/passing/Church.psnew file+12

@@ -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)

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

3131

3232data Declaration

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

34− | TypeSynonymDeclaration ProperName [String] Type

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

34+ | TypeSynonymDeclaration ProperName [String] PolyType

3535 | TypeDeclaration Ident PolyType

3636 | ValueDeclaration Ident Value

3737 | ExternDeclaration Ident PolyType

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

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

4444 name <- indented *> properName

4545 tyArgs <- many (indented *> identifier)

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

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

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

4848 return $ DataDeclaration name tyArgs ctors

4949

5050parseTypeDeclaration :: P.Parsec String ParseState Declaration

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

5656parseTypeSynonymDeclaration =

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

5858 <*> many (indented *> identifier)

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

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

6060

6161parseValueDeclaration :: P.Parsec String ParseState Declaration

6262parseValueDeclaration =

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

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

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

111111 | name1 == name2 = zipWithM_ unifyTypes args1 args2

112112 unifyTypes' (SaturatedTypeSynonym name args) ty = do

113− env <- lift getEnv

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

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

113+ ty1 <- expandTypeSynonym name args

114+ ty1 `unifyTypes` ty

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

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

123117 sk <- skolemize ident1 ty1

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

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

248242 replace t = t

249243

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+

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

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

252256

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

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

574578 sk <- skolemize idents ty

575579 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"

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

585581 ty <- infer m val

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

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

652648 Just ty1 -> do

653649 repl <- lift $ replaceAllTypeSynonyms ty1

654650 repl `subsumes` ty

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

652+ ty <- expandTypeSynonym name args

653+ check m val ty

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

656655

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

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

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

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

715714 u ~~ Function tyArgs ret

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

716+ ty <- expandTypeSynonym name tyArgs

717+ checkFunctionApplication' m ty args ret

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

717719 ++ prettyPrintType fnTy

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