07d727c · rowtype-yoga/purescript-native

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

on golang help sign in

Test cases pass again

07d727cPhil Freeman13 years ago

src/Language/PureScript/TypeChecker.hs+6−2

compare with golang

unifiedsplit

@@ -94,11 +94,15 @@ typeCheckAll (ExternMemberDeclaration member name ty : rest) = do

94 case M.lookup (modulePath, name) (names env) of

95 Just _ -> throwError $ show name ++ " is already defined"

96 Nothing -> case ty of

97− (ForAll _ (Function [_] _)) -> do

97+ _ | isSingleArgumentFunction ty -> do

98 putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)

99 , members = M.insert (modulePath, name) member (members env) })

100− _ -> throwError "Foreign member declarations must have function types, with an single argument."

100+ | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."

101 typeCheckAll rest

102+ where

103+ isSingleArgumentFunction (Function [_] _) = True

104+ isSingleArgumentFunction (ForAll _ ty) = isSingleArgumentFunction ty

105+ isSingleArgumentFunction _ = False

102typeCheckAll (ExternDeclaration name ty : rest) = do

106typeCheckAll (ExternDeclaration name ty : rest) = do

103 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

107 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

104 env <- getEnv

108 env <- getEnv

src/Language/PureScript/TypeChecker/Types.hs+31−9

@@ -157,7 +157,7 @@ typeOf name val = do

157 Just ident | isFunction val ->

158 do me <- fresh

159 ty <- infer (M.singleton ident me) val

160− me ~~ ty

160+ ty `subsumes` me

161 return ty

162 _ -> infer M.empty val

163 escapeCheck checks ty sub

@@ -230,6 +230,10 @@ replaceRowVars m = everywhere (mkT replace)

230 _ -> RowVar v

231 replace t = t

232

233+replaceAllVarsWithUnknowns :: Type -> Subst Check Type

234+replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarsWithUnknowns [ident] ty >>= replaceAllVarsWithUnknowns

235+replaceAllVarsWithUnknowns ty = return ty

236+

233replaceVarsWithUnknowns :: [String] -> Type -> Subst Check Type

237replaceVarsWithUnknowns :: [String] -> Type -> Subst Check Type

234replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)

238replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)

235 where

239 where

@@ -318,10 +322,11 @@ infer' m (Abs args ret) = do

318 let m' = m `M.union` M.fromList (zip args ts)

322 let m' = m `M.union` M.fromList (zip args ts)

319 body <- infer m' ret

323 body <- infer m' ret

320 return $ Function ts body

324 return $ Function ts body

321−infer' m (App f xs) = do

325+infer' m app@(App _ _) = do

326+ let (f, argss) = unfoldApplication app

322− t1 <- infer m f

327+ ft <- infer m f

323 ret <- fresh

328 ret <- fresh

324− checkFunctionApplication m t1 xs ret

329+ checkFunctionApplications m ft argss ret

325 return ret

330 return ret

326infer' m (Var var@(Qualified mp name)) = do

331infer' m (Var var@(Qualified mp name)) = do

327 case mp of

332 case mp of

@@ -601,7 +606,9 @@ check' m val (SaturatedTypeSynonym name args) = do

601 Nothing -> error "Type synonym was not defined"

606 Nothing -> error "Type synonym was not defined"

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

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

603 ty <- infer m val

608 ty <- infer m val

604− ty ~~ u

609+ -- Don't unify an unknown with an inferred polytype

610+ ty' <- replaceAllVarsWithUnknowns ty

611+ ty' ~~ u

605check' m (NumericLiteral _) Number = return ()

612check' m (NumericLiteral _) Number = return ()

606check' m (StringLiteral _) String = return ()

613check' m (StringLiteral _) String = return ()

607check' m (BooleanLiteral _) Boolean = return ()

614check' m (BooleanLiteral _) Boolean = return ()

@@ -613,9 +620,10 @@ check' m (Abs args ret) (Function argTys retTy) = do

613 guardWith "Incorrect number of function arguments" (length args == length argTys)

620 guardWith "Incorrect number of function arguments" (length args == length argTys)

614 let bindings = M.fromList (zip args argTys)

621 let bindings = M.fromList (zip args argTys)

615 check (bindings `M.union` m) ret retTy

622 check (bindings `M.union` m) ret retTy

616−check' m (App f xs) ret = do

623+check' m app@(App _ _) ret = do

624+ let (f, argss) = unfoldApplication app

617 ft <- infer m f

625 ft <- infer m f

618− checkFunctionApplication m ft xs ret

626+ checkFunctionApplications m ft argss ret

619check' m v@(Var var@(Qualified mp name)) ty = do

627check' m v@(Var var@(Qualified mp name)) ty = do

620 case mp of

628 case mp of

621 ModulePath [] ->

629 ModulePath [] ->

@@ -694,6 +702,20 @@ checkProperties m ps row lax = let (ts, r') = rowToList row in go ps ts r' where

694 go ps (delete (p, ty) ts) r

702 go ps (delete (p, ty) ts) r

695 go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)

703 go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)

696

704

705+unfoldApplication :: Value -> (Value, [[Value]])

706+unfoldApplication = go []

707+ where

708+ go argss (App f args) = go (args:argss) f

709+ go argss f = (f, argss)

710+

711+checkFunctionApplications :: M.Map Ident Type -> Type -> [[Value]] -> Type -> Subst Check ()

712+checkFunctionApplications _ _ [] _ = error "Nullary function application"

713+checkFunctionApplications m fnTy [args] ret = checkFunctionApplication m fnTy args ret

714+checkFunctionApplications m fnTy (args:argss) ret = do

715+ f <- fresh

716+ checkFunctionApplication m fnTy args f

717+ checkFunctionApplications m f argss ret

718+

697checkFunctionApplication :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()

719checkFunctionApplication :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()

698checkFunctionApplication m fnTy args ret = rethrow errorMessage $ checkFunctionApplication' m fnTy args ret

720checkFunctionApplication m fnTy args ret = rethrow errorMessage $ checkFunctionApplication' m fnTy args ret

699 where

721 where

@@ -712,8 +734,8 @@ checkFunctionApplication' m (ForAll ident ty) args ret = do

712 replaced <- replaceVarsWithUnknowns [ident] ty

734 replaced <- replaceVarsWithUnknowns [ident] ty

713 checkFunctionApplication m replaced args ret

735 checkFunctionApplication m replaced args ret

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

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

715− tyArgs <- mapM (infer m) args

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

716− u `subsumes` Function tyArgs ret

738+ u ~~ Function tyArgs ret

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

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

718 ++ prettyPrintType fnTy

740 ++ prettyPrintType fnTy

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

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