98d1989 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #160 from garyb/singleargs

98d1989Phil Freeman13 years ago

libraries/prelude/prelude.purs+6

compare with golang

unifiedsplit

@@ -1,5 +1,11 @@

1module Prelude where

3+ foreign import data String :: *

4+ foreign import data Number :: *

5+ foreign import data Boolean :: *

6+ foreign import data [] :: * -> *

7+ foreign import data (->) :: * -> * -> *

3 id :: forall a. a -> a

9 id :: forall a. a -> a

4 id = \x -> x

10 id = \x -> x

src/Language/PureScript/CodeGen/JS.hs+7−7

@@ -128,20 +128,20 @@ runtimeTypeChecks arg ty =

128 maybe [] (argumentCheck (JSVar arg)) argTy

129 where

130 getFunctionArgumentType :: Type -> Maybe Type

131− getFunctionArgumentType (TypeApp (TypeApp Function funArg) _) = Just funArg

131+ getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg

132 getFunctionArgumentType (ForAll _ ty') = getFunctionArgumentType ty'

133 getFunctionArgumentType _ = Nothing

134 argumentCheck :: JS -> Type -> [JS]

135− argumentCheck val Number = [typeCheck val "number"]

135+ argumentCheck val t | t == tyNumber = [typeCheck val "number"]

136− argumentCheck val String = [typeCheck val "string"]

136+ argumentCheck val t | t == tyString = [typeCheck val "string"]

137− argumentCheck val Boolean = [typeCheck val "boolean"]

137+ argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]

138− argumentCheck val (TypeApp Array _) = [arrayCheck val]

138+ argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]

139 argumentCheck val (Object row) =

140 let

141 (pairs, _) = rowToList row

142 in

143 typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs

144− argumentCheck val (TypeApp (TypeApp Function _) _) = [typeCheck val "function"]

144+ argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]

145 argumentCheck val (ForAll _ ty') = argumentCheck val ty'

146 argumentCheck _ _ = []

147 typeCheck :: JS -> String -> JS

@@ -253,7 +253,7 @@ isOnlyConstructor m e ctor =

253 numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e

254 typeConstructor (TypeConstructor qual) = qualify m qual

255 typeConstructor (ForAll _ ty) = typeConstructor ty

256− typeConstructor (TypeApp (TypeApp Function _) ty) = typeConstructor ty

256+ typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty

257 typeConstructor (TypeApp ty _) = typeConstructor ty

258 typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn

259

src/Language/PureScript/Parser/Common.hs+3

@@ -239,6 +239,9 @@ natural = PT.natural tokenParser

239properName :: P.Parsec String u ProperName

240properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")

241

242+properNameOrExternalType :: P.Parsec String u ProperName

243+properNameOrExternalType = P.try properName <|> (ProperName <$> (P.try (lexeme $ P.string "[]") <|> (lexeme $ P.string "(->)")))

244+

242-- |

245-- |

243-- Parse a qualified name, i.e. M.name or just name

246-- Parse a qualified name, i.e. M.name or just name

244--

247--

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

@@ -64,7 +64,7 @@ parseValueDeclaration =

65parseExternDeclaration :: P.Parsec String ParseState Declaration

66parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>

67− (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

67+ (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properNameOrExternalType)

68 <*> (lexeme (indented *> P.string "::") *> parseKind)

69 <|> do ident <- parseNonReservedIdent

70 js <- P.optionMaybe (parseJSLiteral <$> stringLiteral)

src/Language/PureScript/Parser/Types.hs+6−6

@@ -27,22 +27,22 @@ import qualified Text.Parsec.Expr as P

27import Control.Monad (when, unless)

29parseNumber :: P.Parsec String ParseState Type

30−parseNumber = const Number <$> reserved "Number"

30+parseNumber = const tyNumber <$> reserved "Number"

32parseString :: P.Parsec String ParseState Type

33−parseString = const String <$> reserved "String"

33+parseString = const tyString <$> reserved "String"

35parseBoolean :: P.Parsec String ParseState Type

36−parseBoolean = const Boolean <$> reserved "Boolean"

36+parseBoolean = const tyBoolean <$> reserved "Boolean"

38parseArray :: P.Parsec String ParseState Type

39−parseArray = squares $ return Array

39+parseArray = squares $ return tyArray

41parseArrayOf :: P.Parsec String ParseState Type

42−parseArrayOf = squares $ TypeApp Array <$> parseType

42+parseArrayOf = squares $ TypeApp tyArray <$> parseType

44parseFunction :: P.Parsec String ParseState Type

45−parseFunction = parens $ P.try (lexeme (P.string "->")) >> return Function

45+parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction

47parseObject :: P.Parsec String ParseState Type

48parseObject = braces $ Object <$> parseRow False

src/Language/PureScript/Pretty/Types.hs+1−6

@@ -31,11 +31,6 @@ import Language.PureScript.Pretty.Common

31typeLiterals :: Pattern () Type String

32typeLiterals = mkPattern match

33 where

34− match Number = Just "Number"

35− match String = Just "String"

36− match Boolean = Just "Boolean"

37− match Array = Just $ "[]"

38− match Function = Just $ "(->)"

39 match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }"

34 match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }"

40 match (TypeVar var) = Just var

35 match (TypeVar var) = Just var

41 match (TypeConstructor ctor) = Just $ show ctor

36 match (TypeConstructor ctor) = Just $ show ctor

@@ -75,7 +70,7 @@ typeApp = mkPattern match

75singleArgumentFunction :: Pattern () Type (Type, Type)

70singleArgumentFunction :: Pattern () Type (Type, Type)

76singleArgumentFunction = mkPattern match

71singleArgumentFunction = mkPattern match

77 where

72 where

78− match (TypeApp (TypeApp Function arg) ret) = Just (arg, ret)

73+ match (TypeApp (TypeApp t arg) ret) | t == tyFunction = Just (arg, ret)

79 match _ = Nothing

74 match _ = Nothing

81-- |

76-- |

src/Language/PureScript/Sugar/TypeClasses.hs+1−6

@@ -88,7 +88,7 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do

88 return $ ValueDeclaration entryName [] Nothing

89 (TypedValue True

90 (foldr Abs (ObjectLiteral memberNames) (map (\n -> Ident ('_' : show n)) [1..length deps]))

91− (quantify (foldr (\t1 t2 -> TypeApp (TypeApp Function t1) t2) (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))

91+ (quantify (foldr function (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))

92 )

93 where

94 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)

@@ -133,11 +133,6 @@ mkDictionaryValueName mn cl ty = do

133 return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr

134

135typeToString :: ModuleName -> Type -> Either String String

136−typeToString _ String = return "string"

137−typeToString _ Number = return "number"

138−typeToString _ Boolean = return "boolean"

139−typeToString _ Array = return "array"

140−typeToString _ Function = return "function"

141typeToString _ (TypeVar _) = return "var"

136typeToString _ (TypeVar _) = return "var"

142typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'

137typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'

143typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'

138typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'

src/Language/PureScript/TypeChecker.hs+1−1

@@ -231,7 +231,7 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

231 constructs (TypeConstructor (Qualified (Just mn) pn')) pn

232 = mn == moduleName && pn' == pn

233 constructs (ForAll _ ty) pn = ty `constructs` pn

234− constructs (TypeApp (TypeApp Function _) ty) pn = ty `constructs` pn

234+ constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn

235 constructs (TypeApp ty _) pn = ty `constructs` pn

236 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn

237typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

src/Language/PureScript/TypeChecker/Kinds.hs−5

@@ -117,15 +117,10 @@ starIfUnknown k = k

117-- Infer a kind for a type

118--

119infer :: Type -> UnifyT Check Kind

120−infer Number = return Star

121−infer String = return Star

122−infer Boolean = return Star

123−infer Array = return $ FunKind Star Star

124infer (Object row) = do

120infer (Object row) = do

125 k <- infer row

121 k <- infer row

126 k ?= Row Star

122 k ?= Row Star

127 return Star

123 return Star

128−infer Function = return $ FunKind Star $ FunKind Star Star

129infer (TypeVar v) = do

124infer (TypeVar v) = do

130 Just moduleName <- checkCurrentModule <$> get

125 Just moduleName <- checkCurrentModule <$> get

131 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

126 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

src/Language/PureScript/TypeChecker/Types.hs+54−64

@@ -95,11 +95,6 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

95 sk <- skolemize ident ty1

96 sk `unifyTypes` ty2

97 unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty

98− unifyTypes' Number Number = return ()

99− unifyTypes' String String = return ()

100− unifyTypes' Boolean Boolean = return ()

101− unifyTypes' Array Array = return ()

102− unifyTypes' Function Function = return ()

103 unifyTypes' (Object row1) (Object row2) = row1 ?= row2

98 unifyTypes' (Object row1) (Object row2) = row1 ?= row2

104 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

99 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

105 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

100 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

@@ -253,12 +248,7 @@ entails moduleName context goal@(className, ty) = do

253-- and return a substitution from type variables to types which makes the type heads unify.

248-- and return a substitution from type variables to types which makes the type heads unify.

254--

249--

255typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

250typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

256−typeHeadsAreEqual _ _ String String = Just []

257−typeHeadsAreEqual _ _ Number Number = Just []

258−typeHeadsAreEqual _ _ Boolean Boolean = Just []

259typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []

251typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []

260−typeHeadsAreEqual _ _ Array Array = Just []

261−typeHeadsAreEqual _ _ Function Function = Just []

262typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []

252typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []

263typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

253typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

264typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

254typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

@@ -390,13 +380,13 @@ infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue v

390-- Infer a type for a value

380-- Infer a type for a value

391--

381--

392infer' :: Value -> UnifyT Check Value

382infer' :: Value -> UnifyT Check Value

393−infer' v@(NumericLiteral _) = return $ TypedValue True v Number

383+infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber

394−infer' v@(StringLiteral _) = return $ TypedValue True v String

384+infer' v@(StringLiteral _) = return $ TypedValue True v tyString

395−infer' v@(BooleanLiteral _) = return $ TypedValue True v Boolean

385+infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean

396infer' (ArrayLiteral vals) = do

386infer' (ArrayLiteral vals) = do

397 ts <- mapM infer vals

387 ts <- mapM infer vals

398 els <- fresh

388 els <- fresh

399− forM_ ts $ \(TypedValue _ _ t) -> els ?= TypeApp Array t

389+ forM_ ts $ \(TypedValue _ _ t) -> els ?= TypeApp tyArray t

400 return $ TypedValue True (ArrayLiteral ts) els

390 return $ TypedValue True (ArrayLiteral ts) els

401infer' (Unary op val) = do

391infer' (Unary op val) = do

402 v <- infer val

392 v <- infer val

@@ -421,9 +411,9 @@ infer' (ObjectUpdate o ps) = do

421 return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)

411 return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)

422infer' (Indexer index val) = do

412infer' (Indexer index val) = do

423 el <- fresh

413 el <- fresh

424− index' <- check index Number

414+ index' <- check index tyNumber

425− val' <- check val (TypeApp Array el)

415+ val' <- check val (TypeApp tyArray el)

426− return $ TypedValue True (Indexer (TypedValue True index' Number) (TypedValue True val' (TypeApp Array el))) el

416+ return $ TypedValue True (Indexer (TypedValue True index' tyNumber) (TypedValue True val' (TypeApp tyArray el))) el

427infer' (Accessor prop val) = do

417infer' (Accessor prop val) = do

428 typed@(TypedValue _ _ objTy) <- infer val

418 typed@(TypedValue _ _ objTy) <- infer val

429 propTy <- inferProperty objTy prop

419 propTy <- inferProperty objTy prop

@@ -473,7 +463,7 @@ infer' (Case vals binders) = do

473 binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders

463 binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders

474 return $ TypedValue True (Case ts binders') ret

464 return $ TypedValue True (Case ts binders') ret

475infer' (IfThenElse cond th el) = do

465infer' (IfThenElse cond th el) = do

476− cond' <- check cond Boolean

466+ cond' <- check cond tyBoolean

477 v2@(TypedValue _ _ t2) <- infer th

467 v2@(TypedValue _ _ t2) <- infer th

478 v3@(TypedValue _ _ t3) <- infer el

468 v3@(TypedValue _ _ t3) <- infer el

479 t2 ?= t3

469 t2 ?= t3

@@ -528,9 +518,9 @@ checkUnary op val res =

528-- Built-in unary operators

518-- Built-in unary operators

529--

519--

530unaryOps :: [(UnaryOperator, (Type, Type))]

520unaryOps :: [(UnaryOperator, (Type, Type))]

531−unaryOps = [ (Negate, (Number, Number))

521+unaryOps = [ (Negate, (tyNumber, tyNumber))

532− , (Not, (Boolean, Boolean))

522+ , (Not, (tyBoolean, tyBoolean))

533− , (BitwiseNot, (Number, Number))

523+ , (BitwiseNot, (tyNumber, tyNumber))

534 ]

524 ]

535

525

536-- |

526-- |

@@ -539,7 +529,7 @@ unaryOps = [ (Negate, (Number, Number))

539inferBinary :: BinaryOperator -> Value -> Value -> UnifyT Check Value

529inferBinary :: BinaryOperator -> Value -> Value -> UnifyT Check Value

540inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do

530inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do

541 leftTy ?= rightTy

531 leftTy ?= rightTy

542− return $ TypedValue True (Binary op left right) Boolean

532+ return $ TypedValue True (Binary op left right) tyBoolean

543inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =

533inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =

544 case fromMaybe (error "Invalid operator") $ lookup op binaryOps of

534 case fromMaybe (error "Invalid operator") $ lookup op binaryOps of

545 (valTy, resTy) -> do

535 (valTy, resTy) -> do

@@ -553,7 +543,7 @@ inferBinary _ _ _ = error "Invalid arguments to inferBinary"

553--

543--

554checkBinary :: BinaryOperator -> Value -> Value -> Type -> UnifyT Check Value

544checkBinary :: BinaryOperator -> Value -> Value -> Type -> UnifyT Check Value

555checkBinary op left right res | isEqualityTest op = do

545checkBinary op left right res | isEqualityTest op = do

556− res ?= Boolean

546+ res ?= tyBoolean

557 left'@(TypedValue _ _ t1) <- infer left

547 left'@(TypedValue _ _ t1) <- infer left

558 right'@(TypedValue _ _ t2) <- infer right

548 right'@(TypedValue _ _ t2) <- infer right

559 t1 ?= t2

549 t1 ?= t2

@@ -578,24 +568,24 @@ isEqualityTest _ = False

578-- Built-in binary operators

568-- Built-in binary operators

579--

569--

580binaryOps :: [(BinaryOperator, (Type, Type))]

570binaryOps :: [(BinaryOperator, (Type, Type))]

581−binaryOps = [ (Add, (Number, Number))

571+binaryOps = [ (Add, (tyNumber, tyNumber))

582− , (Subtract, (Number, Number))

572+ , (Subtract, (tyNumber, tyNumber))

583− , (Multiply, (Number, Number))

573+ , (Multiply, (tyNumber, tyNumber))

584− , (Divide, (Number, Number))

574+ , (Divide, (tyNumber, tyNumber))

585− , (Modulus, (Number, Number))

575+ , (Modulus, (tyNumber, tyNumber))

586− , (BitwiseAnd, (Number, Number))

576+ , (BitwiseAnd, (tyNumber, tyNumber))

587− , (BitwiseOr, (Number, Number))

577+ , (BitwiseOr, (tyNumber, tyNumber))

588− , (BitwiseXor, (Number, Number))

578+ , (BitwiseXor, (tyNumber, tyNumber))

589− , (ShiftRight, (Number, Number))

579+ , (ShiftRight, (tyNumber, tyNumber))

590− , (ZeroFillShiftRight, (Number, Number))

580+ , (ZeroFillShiftRight, (tyNumber, tyNumber))

591− , (And, (Boolean, Boolean))

581+ , (And, (tyBoolean, tyBoolean))

592− , (Or, (Boolean, Boolean))

582+ , (Or, (tyBoolean, tyBoolean))

593− , (Concat, (String, String))

583+ , (Concat, (tyString, tyString))

594− , (Modulus, (Number, Number))

584+ , (Modulus, (tyNumber, tyNumber))

595− , (LessThan, (Number, Boolean))

585+ , (LessThan, (tyNumber, tyBoolean))

596− , (LessThanOrEqualTo, (Number, Boolean))

586+ , (LessThanOrEqualTo, (tyNumber, tyBoolean))

597− , (GreaterThan, (Number, Boolean))

587+ , (GreaterThan, (tyNumber, tyBoolean))

598− , (GreaterThanOrEqualTo, (Number, Boolean))

588+ , (GreaterThanOrEqualTo, (tyNumber, tyBoolean))

599 ]

589 ]

600

590

601-- |

591-- |

@@ -603,9 +593,9 @@ binaryOps = [ (Add, (Number, Number))

603--

593--

604inferBinder :: Type -> Binder -> UnifyT Check (M.Map Ident Type)

594inferBinder :: Type -> Binder -> UnifyT Check (M.Map Ident Type)

605inferBinder _ NullBinder = return M.empty

595inferBinder _ NullBinder = return M.empty

606−inferBinder val (StringBinder _) = val ?= String >> return M.empty

596+inferBinder val (StringBinder _) = val ?= tyString >> return M.empty

607−inferBinder val (NumberBinder _) = val ?= Number >> return M.empty

597+inferBinder val (NumberBinder _) = val ?= tyNumber >> return M.empty

608−inferBinder val (BooleanBinder _) = val ?= Boolean >> return M.empty

598+inferBinder val (BooleanBinder _) = val ?= tyBoolean >> return M.empty

609inferBinder val (VarBinder name) = return $ M.singleton name val

599inferBinder val (VarBinder name) = return $ M.singleton name val

610inferBinder val (NullaryBinder ctor) = do

600inferBinder val (NullaryBinder ctor) = do

611 env <- getEnv

601 env <- getEnv

@@ -622,7 +612,7 @@ inferBinder val (UnaryBinder ctor binder) = do

622 Just (ty, _) -> do

612 Just (ty, _) -> do

623 fn <- replaceAllVarsWithUnknowns ty

613 fn <- replaceAllVarsWithUnknowns ty

624 case fn of

614 case fn of

625− TypeApp (TypeApp Function obj) ret -> do

615+ TypeApp (TypeApp t obj) ret | t == tyFunction -> do

626 _ <- subsumes Nothing val ret

616 _ <- subsumes Nothing val ret

627 inferBinder obj binder

617 inferBinder obj binder

628 _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"

618 _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"

@@ -644,13 +634,13 @@ inferBinder val (ObjectBinder props) = do

644inferBinder val (ArrayBinder binders) = do

634inferBinder val (ArrayBinder binders) = do

645 el <- fresh

635 el <- fresh

646 m1 <- M.unions <$> mapM (inferBinder el) binders

636 m1 <- M.unions <$> mapM (inferBinder el) binders

647− val ?= TypeApp Array el

637+ val ?= TypeApp tyArray el

648 return m1

638 return m1

649inferBinder val (ConsBinder headBinder tailBinder) = do

639inferBinder val (ConsBinder headBinder tailBinder) = do

650 el <- fresh

640 el <- fresh

651 m1 <- inferBinder el headBinder

641 m1 <- inferBinder el headBinder

652 m2 <- inferBinder val tailBinder

642 m2 <- inferBinder val tailBinder

653− val ?= TypeApp Array el

643+ val ?= TypeApp tyArray el

654 return $ m1 `M.union` m2

644 return $ m1 `M.union` m2

655inferBinder val (NamedBinder name binder) = do

645inferBinder val (NamedBinder name binder) = do

656 m <- inferBinder val binder

646 m <- inferBinder val binder

@@ -669,7 +659,7 @@ checkBinders nvals ret ((binders, grd, val):bs) = do

669 case grd of

659 case grd of

670 Nothing -> return (binders, Nothing, val')

660 Nothing -> return (binders, Nothing, val')

671 Just g -> do

661 Just g -> do

672− g' <- check g Boolean

662+ g' <- check g tyBoolean

673 return (binders, Just g', val')

663 return (binders, Just g', val')

674 rs <- checkBinders nvals ret bs

664 rs <- checkBinders nvals ret bs

675 return $ r : rs

665 return $ r : rs

@@ -701,7 +691,7 @@ checkStatement mass _ (Assignment ident val) = do

701 Just ty -> do t ?= ty

691 Just ty -> do t ?= ty

702 return (False, mass, Assignment ident val')

692 return (False, mass, Assignment ident val')

703checkStatement mass ret (While val inner) = do

693checkStatement mass ret (While val inner) = do

704− val' <- check val Boolean

694+ val' <- check val tyBoolean

705 (allCodePathsReturn, _, inner') <- checkBlock mass ret inner

695 (allCodePathsReturn, _, inner') <- checkBlock mass ret inner

706 return (allCodePathsReturn, mass, While val' inner')

696 return (allCodePathsReturn, mass, While val' inner')

707checkStatement mass ret (If ifst) = do

697checkStatement mass ret (If ifst) = do

@@ -710,9 +700,9 @@ checkStatement mass ret (If ifst) = do

710checkStatement mass ret (For ident start end inner) = do

700checkStatement mass ret (For ident start end inner) = do

711 Just moduleName <- checkCurrentModule <$> get

701 Just moduleName <- checkCurrentModule <$> get

712 assignVariable ident

702 assignVariable ident

713− start' <- check start Number

703+ start' <- check start tyNumber

714− end' <- check end Number

704+ end' <- check end tyNumber

715− (allCodePathsReturn, _, inner') <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner

705+ (allCodePathsReturn, _, inner') <- bindLocalVariables moduleName [(ident, tyNumber)] $ checkBlock mass ret inner

716 return (allCodePathsReturn, mass, For ident start' end' inner')

706 return (allCodePathsReturn, mass, For ident start' end' inner')

717checkStatement mass ret (Return val) = do

707checkStatement mass ret (Return val) = do

718 val' <- check val ret

708 val' <- check val ret

@@ -723,11 +713,11 @@ checkStatement mass ret (Return val) = do

723--

713--

724checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> UnifyT Check (Bool, IfStatement)

714checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> UnifyT Check (Bool, IfStatement)

725checkIfStatement mass ret (IfStatement val thens Nothing) = do

715checkIfStatement mass ret (IfStatement val thens Nothing) = do

726− val' <- check val Boolean

716+ val' <- check val tyBoolean

727 (_, _, thens') <- checkBlock mass ret thens

717 (_, _, thens') <- checkBlock mass ret thens

728 return (False, IfStatement val' thens' Nothing)

718 return (False, IfStatement val' thens' Nothing)

729checkIfStatement mass ret (IfStatement val thens (Just elses)) = do

719checkIfStatement mass ret (IfStatement val thens (Just elses)) = do

730− val' <- check val Boolean

720+ val' <- check val tyBoolean

731 (allCodePathsReturn1, _, thens') <- checkBlock mass ret thens

721 (allCodePathsReturn1, _, thens') <- checkBlock mass ret thens

732 (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses

722 (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses

733 return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))

723 return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))

@@ -802,17 +792,17 @@ check' val u@(TUnknown _) = do

802 ty' <- replaceAllVarsWithUnknowns ty

792 ty' <- replaceAllVarsWithUnknowns ty

803 ty' ?= u

793 ty' ?= u

804 return val'

794 return val'

805−check' v@(NumericLiteral _) Number = return v

795+check' v@(NumericLiteral _) t | t == tyNumber = return v

806−check' v@(StringLiteral _) String = return v

796+check' v@(StringLiteral _) t | t == tyString = return v

807−check' v@(BooleanLiteral _) Boolean = return v

797+check' v@(BooleanLiteral _) t | t == tyBoolean = return v

808check' (Unary op val) ty = checkUnary op val ty

798check' (Unary op val) ty = checkUnary op val ty

809check' (Binary op left right) ty = checkBinary op left right ty

799check' (Binary op left right) ty = checkBinary op left right ty

810−check' (ArrayLiteral vals) (TypeApp Array ty) = ArrayLiteral <$> forM vals (\val -> check val ty)

800+check' (ArrayLiteral vals) (TypeApp a ty) | a == tyArray = ArrayLiteral <$> forM vals (\val -> check val ty)

811check' (Indexer index vals) ty = do

801check' (Indexer index vals) ty = do

812− index' <- check index Number

802+ index' <- check index tyNumber

813− vals' <- check vals (TypeApp Array ty)

803+ vals' <- check vals (TypeApp tyArray ty)

814 return $ Indexer index' vals'

804 return $ Indexer index' vals'

815−check' (Abs arg ret) (TypeApp (TypeApp Function argTy) retTy) = do

805+check' (Abs arg ret) (TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do

816 Just moduleName <- checkCurrentModule <$> get

806 Just moduleName <- checkCurrentModule <$> get

817 ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy

807 ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy

818 return $ Abs arg ret'

808 return $ Abs arg ret'

@@ -844,7 +834,7 @@ check' (Case vals binders) ret = do

844 binders' <- checkBinders ts ret binders

834 binders' <- checkBinders ts ret binders

845 return $ Case vals' binders'

835 return $ Case vals' binders'

846check' (IfThenElse cond th el) ty = do

836check' (IfThenElse cond th el) ty = do

847− cond' <- check cond Boolean

837+ cond' <- check cond tyBoolean

848 th' <- check th ty

838 th' <- check th ty

849 el' <- check el ty

839 el' <- check el ty

850 return $ IfThenElse cond' th' el'

840 return $ IfThenElse cond' th' el'

@@ -932,7 +922,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionA

932-- Check the type of a function application

922-- Check the type of a function application

933--

923--

934checkFunctionApplication' :: Value -> Type -> Value -> Type -> UnifyT Check Value

924checkFunctionApplication' :: Value -> Type -> Value -> Type -> UnifyT Check Value

935−checkFunctionApplication' fn (TypeApp (TypeApp Function argTy) retTy) arg ret = do

925+checkFunctionApplication' fn (TypeApp (TypeApp t argTy) retTy) arg ret | t == tyFunction = do

936 arg' <- check arg argTy

926 arg' <- check arg argTy

937 _ <- subsumes Nothing retTy ret

927 _ <- subsumes Nothing retTy ret

938 return $ App fn arg'

928 return $ App fn arg'

@@ -978,7 +968,7 @@ subsumes' :: Maybe Value -> Type -> Type -> UnifyT Check (Maybe Value)

978subsumes' val (ForAll ident ty1) ty2 = do

968subsumes' val (ForAll ident ty1) ty2 = do

979 replaced <- replaceVarWithUnknown ident ty1

969 replaced <- replaceVarWithUnknown ident ty1

980 subsumes val replaced ty2

970 subsumes val replaced ty2

981−subsumes' val (TypeApp (TypeApp Function arg1) ret1) (TypeApp (TypeApp Function arg2) ret2) = do

971+subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

982 subsumes Nothing arg2 arg1

972 subsumes Nothing arg2 arg1

983 subsumes Nothing ret1 ret2

973 subsumes Nothing ret1 ret2

984 return val

974 return val

src/Language/PureScript/Types.hs+31−21

@@ -35,28 +35,8 @@ data Type

35 -- |

36 -- Javascript numbers

37 --

38− | Number

39− -- |

40− -- Javascript strings

41− --

42− | String

43− -- |

44− -- Javascript booleans

45− --

46− | Boolean

47− -- |

48− -- Javascript array type constructor

49− --

50− | Array

51− -- |

52− -- Records, parameterized by a row of types

53− --

54 | Object Type

38 | Object Type

55 -- |

39 -- |

56− -- A function, with zero or more arguments

57− --

58− | Function

59− -- |

60 -- A named type variable

40 -- A named type variable

61 --

41 --

62 | TypeVar String

42 | TypeVar String

@@ -93,11 +73,41 @@ data Type

93 --

73 --

94 | RCons String Type Type deriving (Show, Eq, Data, Typeable)

74 | RCons String Type Type deriving (Show, Eq, Data, Typeable)

76+-- |

77+-- Type constructor for functions

78+--

79+tyFunction :: Type

80+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "(->)")

81+

82+-- |

83+-- Type constructor for strings

84+--

85+tyString :: Type

86+tyString = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "String")

87+

88+-- |

89+-- Type constructor for numbers

90+--

91+tyNumber :: Type

92+tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "Number")

93+

94+-- |

95+-- Type constructor for booleans

96+--

97+tyBoolean :: Type

98+tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "Boolean")

99+

100+-- |

101+-- Type constructor for arrays

102+--

103+tyArray :: Type

104+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "[]")

105+

96-- |

106-- |

97-- Smart constructor for function types

107-- Smart constructor for function types

98--

108--

99function :: Type -> Type -> Type

109function :: Type -> Type -> Type

100−function t1 t2 = TypeApp (TypeApp Function t1) t2

110+function t1 t2 = TypeApp (TypeApp tyFunction t1) t2

101

111

102-- |

112-- |

103-- Convert a row to a list of pairs of labels and types

113-- Convert a row to a list of pairs of labels and types