2f0a2ae · rowtype-yoga/purescript-native

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

Merge branch 'singleargs'

commit2f0a2ae07d4d954dafe6e86172451f6c9a107780 authorPhil Freeman <paf31@cantab.net> dateSun 2 Feb 2014, 16:13 (13 years ago) parent2842080 063ef3c

33 files changed+358−320

compare with golang

unifiedsplit

examples/failing/NullaryAbs.pursnew file+3

@@ -0,0 +1,3 @@

1+module NullaryAbs where

3+ func = \ -> "no"

examples/passing/Arrays.purs+2−2

@@ -10,9 +10,9 @@ test2 = \arr -> case arr of

1010

1111data Tree = One Number | Some [Tree]

1212

13−test3 = \(tree, sum) -> case tree of

13+test3 = \tree sum -> case tree of

1414 One n -> n

15− Some (n1 : n2 : rest) -> test3(n1, sum) * 10 + test3(n2, sum) * 5 + sum(rest)

15+ Some (n1 : n2 : rest) -> test3 n1 sum * 10 + test3 n2 sum * 5 + sum rest

1616

1717test4 = \arr -> case arr of

1818 [] -> 0

examples/passing/Category.pursnew file+15

@@ -0,0 +1,15 @@

1+module Category where

3+class Category c where

4+ id :: forall x. c x x

5+ (<|) :: forall x y z. c y z -> c x y -> c x z

7+instance Category (->) where

8+ id = Prelude.id

9+ (<|) = Prelude.(<|)

10+

11+module Main where

12+

13+import Category

14+

15+main = Trace.trace (id "Done")

examples/passing/Do.purs+6−6

@@ -9,15 +9,15 @@ instance Prelude.Monad Maybe where

99 (>>=) Nothing _ = Nothing

1010 (>>=) (Just a) f = f a

1111

12−test1 = \ -> do

12+test1 = \_ -> do

1313 Just "abc"

1414

15−test2 = \ -> do

15+test2 = \_ -> do

1616 (x : _) <- Just [1, 2, 3]

1717 (y : _) <- Just [4, 5, 6]

1818 Just (x + y)

1919

20−test3 = \ -> do

20+test3 = \_ -> do

2121 Just 1

2222 Nothing :: Maybe Number

2323 Just 2

@@ -34,11 +34,11 @@ test5 mx my mz = do

3434 z <- mz

3535 Just (z + sum)

3636

37−test6 mx = \ -> do

37+test6 mx = \_ -> do

3838 let Just x = mx

3939 Just x

4040

41−test8 = \ -> do

41+test8 = \_ -> do

4242 Just (do

4343 Just 1)

4444

@@ -60,7 +60,7 @@ forever a = do

6060 a

6161 forever a

6262

63−test9 = \ -> foo <$> Just 1 <*> Just 2 <*> Just 3

63+test9 = \_ -> foo <$> Just 1 <*> Just 2 <*> Just 3

6464

6565module Main where

6666

examples/passing/ExternData.purs+1−1

@@ -12,7 +12,7 @@ module ExternData where

1212

1313 foreign import prompt :: IO String

1414

15− main = \ -> prompt `bind` \s -> showMessage s

15+ main = \_ -> prompt `bind` \s -> showMessage s

1616

1717module Main where

1818

examples/passing/ExternRaw.purs−2

@@ -2,8 +2,6 @@ module ExternRaw where

33foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a

5−foreign import cond "function cond(b, t, f) { return b ? t : f; }" :: forall a. (Boolean, a, a) -> a

6−

75foreign import loop "function loop() { while (true) {} }" :: forall a. a

97foreign import concat "function concat(xs) { \

examples/passing/FFI.purs+1−1

@@ -9,7 +9,7 @@ module FFIModuleTest where

1010import FFI

1111

12−baz = \ -> foo "test"

12+baz = \_ -> foo "test"

1313

1414module Main where

1515

examples/passing/Functions.purs+5−7

@@ -1,16 +1,14 @@

11module Functions where

3− test1 = \ -> 0

3+ test1 = \_ -> 0

5− test2 = \() -> 0

5+ test2 = \a b c d -> a + b + c + d

7− test3 = \a (b, c) d -> a + b + c + d

7+ test3 = \a -> a

9− test4 = \(a) -> a

9+ test4 = \(%%) -> 1 %% 2

1010

11− test5 = \(%%) -> 1 %% 2

12−

13− test6 = \((+++), (***)) -> 1 +++ 2 *** 3

11+ test5 = \(+++) (***) -> 1 +++ 2 *** 3

1412

1513module Main where

1614

examples/passing/Import.purs+1−1

@@ -9,7 +9,7 @@ module M2 where

1010 import M1

1111

12− main = \() -> foo 42

12+ main = \_ -> foo 42

1313

1414module Main where

1515

examples/passing/Operators.purs+4−4

@@ -12,11 +12,11 @@ module Operators1 where

1212

1313module Operators2 where

1414

15− test1 = \(x, y, z) -> x * y + z(x)(y)

15+ test1 = \x y z -> x * y + z(x)(y)

1616

1717 test2 = (\x -> x.foo false) { foo : \_ -> 1 }

1818

19− test3 = (\(x, y) -> x)(1 + 2 * (1 + 2), true && (false || false))

19+ test3 = (\x y -> x)(1 + 2 * (1 + 2)) (true && (false || false))

2020

2121 k = \x -> \y -> x

2222

@@ -30,7 +30,7 @@ module Operators2 where

3030

3131 test6 = ((\x -> x) `k` 2) 3

3232

33− (<>) = \s1 -> \s2 -> s1 ++ s2

33+ (<>) = \s1 s2 -> s1 ++ s2

3434

3535 test7 = "Hello" <> "World!"

3636

@@ -57,7 +57,7 @@ import Global

5757import Arrays

5858

5959main = do

60− print (test1 (1, 2, \x y -> x + y))

60+ print $ test1 1 2 $ \x y -> x + y

6161 print test2

6262 print test3

6363 print test4

examples/passing/Rank2Types.purs+1−1

@@ -9,7 +9,7 @@ module Rank2Types where

1010 foreign import exampleST :: forall s. ST s Number

1111

12− testST = \ -> runST exampleST

12+ testST = \_ -> runST exampleST

1313

1414 foreign import push :: forall el. el -> [el] -> [el]

1515

examples/passing/TopLevelCase.purs+5−5

@@ -1,10 +1,10 @@

11module TopLevelCase where

3− gcd :: (Number, Number) -> Number

4− gcd (0, x) = x

5− gcd (x, 0) = x

6− gcd (x, y) | x > y = gcd (x % y, y)

7− gcd (x, y) = gcd (y % x, x)

3+ gcd :: Number -> Number -> Number

4+ gcd 0 x = x

5+ gcd x 0 = x

6+ gcd x y | x > y = gcd (x % y) y

7+ gcd x y = gcd (y % x) x

99 guardsTest (x:xs) | x > 0 = guardsTest xs

1010 guardsTest xs = xs

examples/passing/TypeClasses.purs+30−26

@@ -1,64 +1,68 @@

11module TypeClasses where

3−import Prelude (($))

3+import Prelude

5−class Show a where

6− show :: a -> String

5+test1 = \_ -> show "testing"

8−instance Show String where

9− show s = s

10−

11−test1 = \ -> show "testing"

12−

13−f :: forall a. (TypeClasses.Show a) => a -> String

7+f :: forall a. (Prelude.Show a) => a -> String

148f x = show x

159

16−test2 = \ -> f "testing"

10+test2 = \_ -> f "testing"

1711

18−test7 :: forall a. (Show a) => a -> String

12+test7 :: forall a. (Prelude.Show a) => a -> String

1913test7 = show

2014

21−test8 = \ -> show $ "testing"

15+test8 = \_ -> show $ "testing"

2216

2317data Data a = Data a

2418

25−instance (TypeClasses.Show a) => TypeClasses.Show (Data a) where

19+instance (Prelude.Show a) => Prelude.Show (Data a) where

2620 show (Data a) = "Data (" ++ show a ++ ")"

2721

28−test3 = \ -> show (Data "testing")

22+test3 = \_ -> show (Data "testing")

2923

30−class Monad m where

31− ret :: forall a. a -> m a

32− (>>=) :: forall a b. m a -> (a -> m b) -> m b

33−

34−instance TypeClasses.Monad Data where

24+instance Prelude.Monad Data where

3525 ret = Data

3626 (>>=) (Data a) f = f a

3727

3828data Maybe a = Nothing | Just a

3929

40−instance TypeClasses.Monad Maybe where

30+instance Prelude.Monad Maybe where

4131 ret = Just

4232 (>>=) Nothing _ = Nothing

4333 (>>=) (Just a) f = f a

4434

45−test4 :: forall m. (Monad m) => () -> m Number

46−test4 = \ -> ret 1

35+test4 :: forall a m. (Monad m) => a -> m Number

36+test4 = \_ -> ret 1

4737

48−test5 = \ -> Just 1 >>= \n -> ret (n + 1)

38+test5 = \_ -> Just 1 >>= \n -> ret (n + 1)

4939

5040module TypeClasses2 where

5141

42+import Prelude

5243import TypeClasses

5344

54−instance (TypeClasses.Show a) => TypeClasses.Show [a] where

45+instance (Prelude.Show a) => Prelude.Show [a] where

5546 show [] = "[]"

56− show (x:xs) = TypeClasses.show x ++ ", " ++ TypeClasses.show xs

47+ show (x:xs) = show x ++ ", " ++ show xs

48+

49+test6 = \_ -> show ["testing"]

50+

51+instance Prelude.Monad (->) r where

52+ ret a r = a

53+ (>>=) f g r = g (f r) r

54+

55+ask r = r

56+

57+runReader r f = f r

5758

58−test6 = \ -> show ["testing"]

59+test9 _ = runReader 0 $ do

60+ n <- ask

61+ ret $ n + 1

5962

6063module Main where

6164

65+import Prelude

6266import TypeClasses

6367

6468main = Trace.trace (test7 "Done")

libraries/prelude/prelude.purs+87−21

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

11module Prelude where

3+ foreign import data String :: *

4+ foreign import data Number :: *

5+ foreign import data Boolean :: *

6+ foreign import data Array :: * -> *

7+ foreign import data Function :: * -> * -> *

39 id :: forall a. a -> a

410 id = \x -> x

511

@@ -401,28 +407,76 @@ module Global where

401407

402408module Math where

403409

404− type Math =

405− { abs :: Number -> Number

406− , acos :: Number -> Number

407− , asin :: Number -> Number

408− , atan :: Number -> Number

409− , atan2 :: (Number, Number) -> Number

410− , aceil :: Number -> Number

411− , cos :: Number -> Number

412− , exp :: Number -> Number

413− , floor :: Number -> Number

414− , log :: Number -> Number

415− , max :: (Number, Number) -> Number

416− , pow :: (Number, Number) -> Number

417− , random :: () -> Number

418− , round :: Number -> Number

419− , sin :: Number -> Number

420− , sqrt :: Number -> Number

421− , tan :: Number -> Number

422− }

410+ foreign import abs "function abs(n){\

411+ \ return Math.abs(n);\

412+ \}" :: Number -> Number

413+

414+ foreign import acos "function acos(n){\

415+ \ return Math.acos(n);\

416+ \}" :: Number -> Number

417+

418+ foreign import asin "function asin(n){\

419+ \ return Math.asin(n);\

420+ \}" :: Number -> Number

421+

422+ foreign import atan "function atan(n){\

423+ \ return Math.atan(n);\

424+ \}" :: Number -> Number

425+

426+ foreign import atan2 "function atan2(y){\

427+ \ return function (x) {\

428+ \ return Math.atan2(y, x);\

429+ \ };\

430+ \}" :: Number -> Number -> Number

431+

432+ foreign import aceil "function aceil(n){\

433+ \ return Math.aceil(n);\

434+ \}" :: Number -> Number

435+

436+ foreign import cos "function cos(n){\

437+ \ return Math.cos(n);\

438+ \}" :: Number -> Number

439+

440+ foreign import exp "function exp(n){\

441+ \ return Math.exp(n);\

442+ \}" :: Number -> Number

443+

444+ foreign import floor "function floor(n){\

445+ \ return Math.floor(n);\

446+ \}" :: Number -> Number

447+

448+ foreign import log "function log(n){\

449+ \ return Math.log(n);\

450+ \}" :: Number -> Number

451+

452+ foreign import max "function max(n){\

453+ \ return Math.max(n);\

454+ \}" :: Number -> Number

455+

456+ foreign import min "function min(n){\

457+ \ return Math.min(n);\

458+ \}" :: Number -> Number

459+

460+ foreign import pow "function pow(n){\

461+ \ return Math.pow(n);\

462+ \}" :: Number -> Number

463+

464+ foreign import round "function round(n){\

465+ \ return Math.round(n);\

466+ \}" :: Number -> Number

467+

468+ foreign import sin "function sin(n){\

469+ \ return Math.sin(n);\

470+ \}" :: Number -> Number

471+

472+ foreign import sqrt "function sqrt(n){\

473+ \ return Math.sqrt(n);\

474+ \}" :: Number -> Number

475+

476+ foreign import tan "function tan(n){\

477+ \ return Math.tan(n);\

478+ \}" :: Number -> Number

423479

424− foreign import math "var math = Math;" :: Math

425−

426480module Eff where

427481

428482 foreign import data Eff :: # ! -> * -> *

@@ -451,6 +505,18 @@ module Eff where

451505 ret = retEff

452506 (>>=) = bindEff

453507

508+module Random where

509+

510+ import Eff

511+

512+ foreign import data Random :: !

513+

514+ foreign import random "function random() {\

515+ \ return function() {\

516+ \ return Math.random();\

517+ \ };\

518+ \}" :: forall e. Eff (random :: Random | e) Number

519+

454520module Errors where

455521

456522 import Eff

libraries/prelude/tests/Eff.purs+2−2

@@ -37,7 +37,7 @@ test6 s = do

3737

3838import ST

3939

40−test7 = \ -> do

40+test7 _ = do

4141 n <- runST $ do

4242 r <- newSTRef 0

4343 modifySTRef r $ \n -> n + 1

@@ -48,4 +48,4 @@ module Main where

4848

4949import Tests

5050

51−main = test7 ()

51+main = test7 {}

psci/Main.hs+1−1

@@ -64,7 +64,7 @@ createTemporaryModule imports value =

6464 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

6565 mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing

6666 (P.Do [ P.DoNotationBind (P.VarBinder (P.Ident "it")) value

67− , P.DoNotationValue (P.App trace [ P.Var (P.Qualified Nothing (P.Ident "it")) ] )

67+ , P.DoNotationValue (P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) )

6868 ])

6969 in

7070 P.Module moduleName $ map (importDecl . P.ModuleName) imports ++ [mainDecl]

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

@@ -110,9 +110,9 @@ valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (va

110110valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)

111111valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

112112valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)

113−valueToJs opts m e (App val args) = JSApp (valueToJs opts m e val) (map (valueToJs opts m e) args)

114−valueToJs opts m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs opts m e val)])

115−valueToJs opts m e (TypedValue _ (Abs args val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing args (JSBlock $ runtimeTypeChecks args ty ++ [JSReturn (valueToJs opts m e val)])

113+valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]

114+valueToJs opts m e (Abs arg val) = JSFunction Nothing [arg] (JSBlock [JSReturn (valueToJs opts m e val)])

115+valueToJs opts m e (TypedValue _ (Abs arg val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing [arg] (JSBlock $ runtimeTypeChecks arg ty ++ [JSReturn (valueToJs opts m e val)])

116116valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)

117117valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)

118118valueToJs _ m e (Var ident) = varToJs m e ident

@@ -120,28 +120,28 @@ valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

120120valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

121121valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

122122

123−runtimeTypeChecks :: [Ident] -> Type -> [JS]

124−runtimeTypeChecks args ty =

123+runtimeTypeChecks :: Ident -> Type -> [JS]

124+runtimeTypeChecks arg ty =

125125 let

126− argTys = getFunctionArgumentTypes ty

126+ argTy = getFunctionArgumentType ty

127127 in

128− concat $ zipWith argumentCheck (map JSVar args) argTys

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

129129 where

130− getFunctionArgumentTypes :: Type -> [Type]

131− getFunctionArgumentTypes (Function funArgs _) = funArgs

132− getFunctionArgumentTypes (ForAll _ ty') = getFunctionArgumentTypes ty'

133− getFunctionArgumentTypes _ = []

130+ getFunctionArgumentType :: Type -> Maybe Type

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

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

133+ getFunctionArgumentType _ = Nothing

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

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

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

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

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

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

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

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

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

139139 argumentCheck val (Object row) =

140140 let

141141 (pairs, _) = rowToList row

142142 in

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

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

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

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

146146 argumentCheck _ _ = []

147147 typeCheck :: JS -> String -> JS

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

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

254254 typeConstructor (TypeConstructor qual) = qualify m qual

255255 typeConstructor (ForAll _ ty) = typeConstructor ty

256− typeConstructor (Function _ ty) = typeConstructor ty

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

257257 typeConstructor (TypeApp ty _) = typeConstructor ty

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

259259

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

@@ -88,7 +88,7 @@ data Declaration

8888 -- |

8989 -- A value declaration (name, top-level binders, optional guard, value)

9090 --

91− | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value

91+ | ValueDeclaration Ident [Binder] (Maybe Guard) Value

9292 -- |

9393 -- A minimal mutually recursive set of value declarations

9494 --

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

@@ -58,13 +58,10 @@ parseTypeSynonymDeclaration =

5858parseValueDeclaration :: P.Parsec String ParseState Declaration

5959parseValueDeclaration =

6060 ValueDeclaration <$> parseNonReservedIdent

61− <*> P.many parseTopLevelBinder

61+ <*> P.many parseBinderNoParens

6262 <*> P.optionMaybe parseGuard

6363 <*> ((lexeme (indented *> P.char '=')) *> parseValue)

6464

65−parseTopLevelBinder :: P.Parsec String ParseState [Binder]

66−parseTopLevelBinder = return <$> P.try parseBinderNoParens <|> parens (commaSep parseBinder)

67−

6865parseExternDeclaration :: P.Parsec String ParseState Declaration

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

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

src/Language/PureScript/Parser/Types.hs+12−16

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

2727import Control.Monad (when, unless)

2828

2929parseNumber :: P.Parsec String ParseState Type

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

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

3131

3232parseString :: P.Parsec String ParseState Type

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

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

3434

3535parseBoolean :: P.Parsec String ParseState Type

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

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

3737

3838parseArray :: P.Parsec String ParseState Type

39−parseArray = squares $ return Array

39+parseArray = squares $ return tyArray

4040

4141parseArrayOf :: P.Parsec String ParseState Type

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

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

43+

44+parseFunction :: P.Parsec String ParseState Type

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

4346

4447parseObject :: P.Parsec String ParseState Type

4548parseObject = braces $ Object <$> parseRow False

4649

47−parseFunction :: P.Parsec String ParseState Type

48−parseFunction = do

49− args <- lexeme $ parens $ commaSep parsePolyType

50− _ <- lexeme $ P.string "->"

51− resultType <- parseType

52− return $ Function args resultType

53−

5450parseTypeVariable :: P.Parsec String ParseState Type

5551parseTypeVariable = TypeVar <$> identifier

5652

@@ -68,12 +64,13 @@ parseTypeAtom = indented *> P.choice (map P.try

6864 , parseBoolean

6965 , parseArray

7066 , parseArrayOf

67+ , parseFunction

7168 , parseObject

7269 , parseTypeVariable

7370 , parseTypeConstructor

7471 , parseForAll

7572 , parens (parseRow True)

76− , parens parseType ])

73+ , parens parsePolyType ])

7774

7875parseConstrainedType :: P.Parsec String ParseState Type

7976parseConstrainedType = do

@@ -90,10 +87,10 @@ parseConstrainedType = do

9087 return $ maybe ty (flip ConstrainedType ty) constraints

9188

9289parseAnyType :: P.Parsec String ParseState Type

93−parseAnyType = (P.buildExpressionParser operators $ parseTypeAtom) <|> parseFunction P.<?> "type"

90+parseAnyType = (P.buildExpressionParser operators $ parseTypeAtom) P.<?> "type"

9491 where

9592 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

96− , [ P.Infix (P.try (lexeme (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]

93+ , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]

9794

9895-- |

9996-- Parse a monotype

@@ -110,7 +107,6 @@ parseType = do

110107parsePolyType :: P.Parsec String ParseState Type

111108parsePolyType = do

112109 ty <- parseAnyType

113− unless (isPolyType ty) $ P.unexpected "polymorphic type"

114110 return ty

115111

116112parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)

src/Language/PureScript/Parser/Values.hs+2−10

@@ -54,19 +54,12 @@ parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C

5454parseAbs :: P.Parsec String ParseState Value

5555parseAbs = do

5656 C.reservedOp "\\"

57− args <- P.many (C.indented *> (P.try singleArg <|> manyArgs))

57+ args <- P.many1 (C.indented *> (Abs <$> C.parseIdent))

5858 C.indented *> C.reservedOp "->"

5959 value <- parseValue

6060 return $ toFunction args value

6161 where

62− manyArgs :: P.Parsec String ParseState (Value -> Value)

63− manyArgs = do

64− args <- C.parens (C.commaSep C.parseIdent)

65− return $ Abs args

66− singleArg :: P.Parsec String ParseState (Value -> Value)

67− singleArg = Abs . return <$> C.parseIdent

6862 toFunction :: [Value -> Value] -> Value -> Value

69− toFunction [] value = Abs [] value

7063 toFunction args value = foldr (($)) value args

7164

7265parseVar :: P.Parsec String ParseState Value

@@ -159,8 +152,7 @@ parseValue =

159152 indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

160153 postfixTable1 = [ parseAccessor

161154 , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

162− postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v

163− , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v

155+ postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= return . flip App) <*> pure v

164156 , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

165157 ]

166158 operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)

src/Language/PureScript/Pretty/Types.hs+2−12

@@ -31,12 +31,9 @@ import Language.PureScript.Pretty.Common

3131typeLiterals :: Pattern () Type String

3232typeLiterals = mkPattern match

3333 where

34− match Number = Just "Number"

35− match String = Just "String"

36− match Boolean = Just "Boolean"

37− match Array = Just $ "[]"

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

3935 match (TypeVar var) = Just var

36+ match (TypeApp arr ty) | arr == tyArray = Just $ "[" ++ prettyPrintType ty ++ "]"

4037 match (TypeConstructor ctor) = Just $ show ctor

4138 match (TUnknown (TypedUnknown (Unknown u))) = Just $ 'u' : show u

4239 match (Skolem s) = Just $ 's' : show s

@@ -74,13 +71,7 @@ typeApp = mkPattern match

7471singleArgumentFunction :: Pattern () Type (Type, Type)

7572singleArgumentFunction = mkPattern match

7673 where

77− match (Function [arg] ret) = Just (arg, ret)

78− match _ = Nothing

79−

80−function :: Pattern () Type ([Type], Type)

81−function = mkPattern match

82− where

83− match (Function args ret) = Just (args, ret)

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

8475 match _ = Nothing

8576

8677-- |

@@ -95,6 +86,5 @@ prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()

9586 operators =

9687 OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]

9788 , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret

98− , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret

9989 ]

10090 ]

src/Language/PureScript/Pretty/Values.hs+5−5

@@ -77,13 +77,13 @@ objectUpdate = mkPattern match

7777app :: Pattern () Value (String, Value)

7878app = mkPattern match

7979 where

80− match (App val args) = Just (intercalate "," (map prettyPrintValue args), val)

80+ match (App val arg) = Just (prettyPrintValue arg, val)

8181 match _ = Nothing

8282

83−lam :: Pattern () Value ([String], Value)

83+lam :: Pattern () Value (String, Value)

8484lam = mkPattern match

8585 where

86− match (Abs args val) = Just (map show args, val)

86+ match (Abs arg val) = Just (show arg, val)

8787 match _ = Nothing

8888

8989typed :: Pattern () Value (Type, Value)

@@ -127,8 +127,8 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (

127127 operators =

128128 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

129129 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

130− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

131− , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]

130+ , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]

131+ , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]

132132 , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]

133133 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]

134134 , [ AssocR indexer (\index val -> val ++ " !! " ++ index) ]

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

@@ -33,7 +33,7 @@ usedNames :: (Data d) => d -> [Ident]

3333usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val

3434 where

3535 namesV :: Value -> [Ident]

36− namesV (Abs args _) = args

36+ namesV (Abs arg _) = [arg]

3737 namesV (Var (Qualified Nothing name)) = [name]

3838 namesV _ = []

3939 namesS :: Statement -> [Ident]

src/Language/PureScript/Sugar/CaseDeclarations.hs+7−11

@@ -48,27 +48,23 @@ toDecls :: [Declaration] -> Either String [Declaration]

4848toDecls d@[ValueDeclaration _ [] Nothing _] = return d

4949toDecls ds@(ValueDeclaration ident bs _ _ : _) = do

5050 let tuples = map toTuple ds

51− unless (all ((== map length bs) . map length . fst) tuples) $

51+ unless (all ((== length bs) . length . fst) tuples) $

5252 throwError $ "Argument list lengths differ in declaration " ++ show ident

5353 return [makeCaseDeclaration ident tuples]

5454toDecls ds = return ds

5555

56−toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))

56+toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))

5757toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))

5858toTuple _ = error "Not a value declaration"

5959

60−makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration

60+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration

6161makeCaseDeclaration ident alternatives =

6262 let

63− argPattern = map length . fst . head $ alternatives

64− args = take (sum argPattern) $ unusedNames (ident, alternatives)

63+ argPattern = length . fst . head $ alternatives

64+ args = take argPattern $ unusedNames (ident, alternatives)

6565 vars = map (\arg -> Var (Qualified Nothing arg)) args

66− binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]

67− value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)

66+ binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ]

67+ value = foldr (\args' ret -> Abs args' ret) (Case vars binders) args

6868 in

6969 ValueDeclaration ident [] Nothing value

7070

71−rearrange :: [Int] -> [a] -> [[a]]

72−rearrange [] _ = []

73−rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)

74−

src/Language/PureScript/Sugar/DoNotation.hs+3−3

@@ -46,16 +46,16 @@ desugarDo = everywhereM (mkM replace)

4646 go [DoNotationValue val] = return val

4747 go (DoNotationValue val : rest) = do

4848 rest' <- go rest

49− return $ App (App bind [val]) [Abs [Ident "_"] rest']

49+ return $ App (App bind val) (Abs (Ident "_") rest')

5050 go [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"

5151 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

5252 go (DoNotationBind (VarBinder ident) val : rest) = do

5353 rest' <- go rest

54− return $ App (App bind [val]) [Abs [ident] rest']

54+ return $ App (App bind val) (Abs ident rest')

5555 go (DoNotationBind binder val : rest) = do

5656 rest' <- go rest

5757 let ident = head $ unusedNames rest'

58− return $ App (App bind [val]) [Abs [ident] (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')])]

58+ return $ App (App bind val) (Abs ident (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')]))

5959 go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"

6060 go (DoNotationLet binder val : rest) = do

6161 rest' <- go rest

src/Language/PureScript/Sugar/Operators.hs+2−2

@@ -58,7 +58,7 @@ removeParens val = val

5858customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]

5959customOperatorTable fixities =

6060 let

61− applyUserOp name t1 t2 = App (App (Var name) [t1]) [t2]

61+ applyUserOp name t1 t2 = App (App (Var name) t1) t2

6262 userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities

6363 sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns)

6464 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

@@ -79,7 +79,7 @@ matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val

7979 bracketChain :: Chain -> Either String Value

8080 bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

8181 opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops

82− ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]]

82+ ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]]

8383

8484toAssoc :: Associativity -> P.Assoc

8585toAssoc Infixl = P.AssocLeft

src/Language/PureScript/Sugar/TypeClasses.hs+4−10

@@ -87,10 +87,8 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do

8787 memberNames <- mapM (memberToNameAndValue memberTypes) decls

8888 return $ ValueDeclaration entryName [] Nothing

8989 (TypedValue True

90− (Abs

91− (map (\n -> Ident ('_' : show n)) [1..length deps])

92− (ObjectLiteral memberNames))

93− (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))

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

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

9492 )

9593 where

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

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

9997 memberName <- mkDictionaryEntryName mn name ty ident

10098 return (identToJs ident, TypedValue False

10199 (if null deps then Var (Qualified Nothing memberName)

102− else App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

100+ else foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

103101 (quantify memberType))

104102 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

105103

@@ -137,14 +135,10 @@ mkDictionaryValueName mn cl ty = do

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

138136

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

140−typeToString _ String = return "string"

141−typeToString _ Number = return "number"

142−typeToString _ Boolean = return "boolean"

143−typeToString _ Array = return "array"

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

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

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

147−typeToString a b = Left $ "Type class instance must be of the form T a1 ... an " ++ show (a, b)

141+typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"

148142

149143-- |

150144-- Generate a name for a type class dictionary member, based on the module name, class name, type name and

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

@@ -51,7 +51,7 @@ addDataConstructor moduleName name args dctor maybeTy = do

5151 env <- getEnv

5252 dataConstructorIsNotDefined moduleName dctor

5353 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

54− let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

54+ let dctorTy = maybe retTy (flip function retTy) maybeTy

5555 let polyType = mkForAll args dctorTy

5656 putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }

5757

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

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

232232 = mn == moduleName && pn' == pn

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

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

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

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

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

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

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

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

117117-- Infer a kind for a type

118118--

119119infer :: 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

124120infer (Object row) = do

125121 k <- infer row

126122 k ?= Row Star

127123 return Star

128−infer (Function args ret) = do

129− ks <- mapM infer args

130− k <- infer ret

131− k ?= Star

132− forM_ ks (?= Star)

133− return Star

134124infer (TypeVar v) = do

135125 Just moduleName <- checkCurrentModule <$> get

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

src/Language/PureScript/TypeChecker/Types.hs+96−102

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

9595 sk <- skolemize ident ty1

9696 sk `unifyTypes` ty2

9797 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 ()

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

103− unifyTypes' (Function args1 ret1) (Function args2 ret2) = do

104− guardWith "Function applied to incorrect number of args" $ length args1 == length args2

105− zipWithM_ unifyTypes args1 args2

106− ret1 `unifyTypes` ret2

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

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

109101 env <- getEnv

@@ -235,14 +227,19 @@ entails moduleName context goal@(className, ty) = do

235227 , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)

236228 , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)

237229 , args <- solveSubgoals env subst (tcdDependencies tcd) ]

230+ solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, Type)] -> [Maybe [Value]]

238231 solveSubgoals _ _ Nothing = return Nothing

239232 solveSubgoals env subst (Just subgoals) = do

240233 dict <- mapM (go env) (replaceAllTypeVars subst subgoals)

241234 return $ Just dict

242− mkDictionary fnName args = maybe id (flip App) args $ (Var fnName)

235+ mkDictionary :: Qualified Ident -> Maybe [Value] -> Value

236+ mkDictionary fnName Nothing = Var fnName

237+ mkDictionary fnName (Just dicts) = foldr (flip App) (Var fnName) dicts

238+ filterModule :: TypeClassDictionaryInScope -> Bool

243239 filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True

244240 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True

245241 filterModule _ = False

242+ canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

246243 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

247244 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

248245

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

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

252249--

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

254−typeHeadsAreEqual _ _ String String = Just []

255−typeHeadsAreEqual _ _ Number Number = Just []

256−typeHeadsAreEqual _ _ Boolean Boolean = Just []

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

258−typeHeadsAreEqual _ _ Array Array = Just []

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

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

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

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

387380-- Infer a type for a value

388381--

389382infer' :: Value -> UnifyT Check Value

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

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

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

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

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

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

393386infer' (ArrayLiteral vals) = do

394387 ts <- mapM infer vals

395388 els <- fresh

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

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

397390 return $ TypedValue True (ArrayLiteral ts) els

398391infer' (Unary op val) = do

399392 v <- infer val

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

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

419412infer' (Indexer index val) = do

420413 el <- fresh

421− index' <- check index Number

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

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

414+ index' <- check index tyNumber

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

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

424417infer' (Accessor prop val) = do

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

426419 propTy <- inferProperty objTy prop

@@ -431,16 +424,16 @@ infer' (Accessor prop val) = do

431424 _ <- subsumes Nothing objTy (Object (RCons prop field rest))

432425 return $ TypedValue True (Accessor prop typed) field

433426 Just ty -> return $ TypedValue True (Accessor prop typed) ty

434−infer' (Abs args ret) = do

435− ts <- replicateM (length args) fresh

427+infer' (Abs arg ret) = do

428+ ty <- fresh

436429 Just moduleName <- checkCurrentModule <$> get

437− bindLocalVariables moduleName (zip args ts) $ do

430+ bindLocalVariables moduleName [(arg, ty)] $ do

438431 body@(TypedValue _ _ bodyTy) <- infer' ret

439− return $ TypedValue True (Abs args body) $ Function ts bodyTy

440−infer' (App f args) = do

432+ return $ TypedValue True (Abs arg body) $ function ty bodyTy

433+infer' (App f arg) = do

441434 f'@(TypedValue _ _ ft) <- infer f

442435 ret <- fresh

443− app <- checkFunctionApplication f' ft args ret

436+ app <- checkFunctionApplication f' ft arg ret

444437 return $ TypedValue True app ret

445438infer' (Var var) = do

446439 Just moduleName <- checkCurrentModule <$> get

@@ -450,7 +443,7 @@ infer' (Var var) = do

450443 ConstrainedType constraints _ -> do

451444 env <- getEnv

452445 dicts <- getTypeClassDictionaries

453− return $ TypedValue True (App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'

446+ return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'

454447 _ -> return $ TypedValue True (Var var) ty'

455448infer' (Block ss) = do

456449 ret <- fresh

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

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

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

472465infer' (IfThenElse cond th el) = do

473− cond' <- check cond Boolean

466+ cond' <- check cond tyBoolean

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

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

476469 t2 ?= t3

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

525518-- Built-in unary operators

526519--

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

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

529− , (Not, (Boolean, Boolean))

530− , (BitwiseNot, (Number, Number))

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

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

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

531524 ]

532525

533526-- |

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

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

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

538531 leftTy ?= rightTy

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

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

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

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

542535 (valTy, resTy) -> do

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

550543--

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

552545checkBinary op left right res | isEqualityTest op = do

553− res ?= Boolean

546+ res ?= tyBoolean

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

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

556549 t1 ?= t2

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

575568-- Built-in binary operators

576569--

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

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

579− , (Subtract, (Number, Number))

580− , (Multiply, (Number, Number))

581− , (Divide, (Number, Number))

582− , (Modulus, (Number, Number))

583− , (BitwiseAnd, (Number, Number))

584− , (BitwiseOr, (Number, Number))

585− , (BitwiseXor, (Number, Number))

586− , (ShiftRight, (Number, Number))

587− , (ZeroFillShiftRight, (Number, Number))

588− , (And, (Boolean, Boolean))

589− , (Or, (Boolean, Boolean))

590− , (Concat, (String, String))

591− , (Modulus, (Number, Number))

592− , (LessThan, (Number, Boolean))

593− , (LessThanOrEqualTo, (Number, Boolean))

594− , (GreaterThan, (Number, Boolean))

595− , (GreaterThanOrEqualTo, (Number, Boolean))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

596589 ]

597590

598591-- |

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

600593--

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

602595inferBinder _ NullBinder = return M.empty

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

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

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

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

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

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

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

607600inferBinder val (NullaryBinder ctor) = do

608601 env <- getEnv

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

619612 Just (ty, _) -> do

620613 fn <- replaceAllVarsWithUnknowns ty

621614 case fn of

622− Function [obj] ret -> do

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

623616 _ <- subsumes Nothing val ret

624617 inferBinder obj binder

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

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

641634inferBinder val (ArrayBinder binders) = do

642635 el <- fresh

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

644− val ?= TypeApp Array el

637+ val ?= TypeApp tyArray el

645638 return m1

646639inferBinder val (ConsBinder headBinder tailBinder) = do

647640 el <- fresh

648641 m1 <- inferBinder el headBinder

649642 m2 <- inferBinder val tailBinder

650− val ?= TypeApp Array el

643+ val ?= TypeApp tyArray el

651644 return $ m1 `M.union` m2

652645inferBinder val (NamedBinder name binder) = do

653646 m <- inferBinder val binder

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

666659 case grd of

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

668661 Just g -> do

669− g' <- check g Boolean

662+ g' <- check g tyBoolean

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

671664 rs <- checkBinders nvals ret bs

672665 return $ r : rs

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

698691 Just ty -> do t ?= ty

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

700693checkStatement mass ret (While val inner) = do

701− val' <- check val Boolean

694+ val' <- check val tyBoolean

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

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

704697checkStatement mass ret (If ifst) = do

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

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

708701 Just moduleName <- checkCurrentModule <$> get

709702 assignVariable ident

710− start' <- check start Number

711− end' <- check end Number

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

703+ start' <- check start tyNumber

704+ end' <- check end tyNumber

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

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

714707checkStatement mass ret (Return val) = do

715708 val' <- check val ret

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

720713--

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

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

723− val' <- check val Boolean

716+ val' <- check val tyBoolean

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

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

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

727− val' <- check val Boolean

720+ val' <- check val tyBoolean

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

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

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

@@ -792,31 +785,30 @@ check' val (ConstrainedType constraints ty) = do

792785 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

793786 (qualifyAllUnqualifiedNames moduleName env constraints)) $

794787 check val ty

795− return $ Abs dictNames val'

788+ return $ foldr Abs val' dictNames

796789check' val u@(TUnknown _) = do

797790 val'@(TypedValue _ _ ty) <- infer val

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

799792 ty' <- replaceAllVarsWithUnknowns ty

800793 ty' ?= u

801794 return val'

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

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

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

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

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

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

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

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

807−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)

808801check' (Indexer index vals) ty = do

809− index' <- check index Number

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

802+ index' <- check index tyNumber

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

811804 return $ Indexer index' vals'

812−check' (Abs args ret) (Function argTys retTy) = do

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

813806 Just moduleName <- checkCurrentModule <$> get

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

815− ret' <- bindLocalVariables moduleName (zip args argTys) $ check ret retTy

816− return $ Abs args ret'

817−check' (App f args) ret = do

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

808+ return $ Abs arg ret'

809+check' (App f arg) ret = do

818810 f'@(TypedValue _ _ ft) <- infer f

819− app <- checkFunctionApplication f' ft args ret

811+ app <- checkFunctionApplication f' ft arg ret

820812 return $ app

821813check' v@(Var var) ty = do

822814 Just moduleName <- checkCurrentModule <$> get

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

842834 binders' <- checkBinders ts ret binders

843835 return $ Case vals' binders'

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

845− cond' <- check cond Boolean

837+ cond' <- check cond tyBoolean

846838 th' <- check th ty

847839 el' <- check el ty

848840 return $ IfThenElse cond' th' el'

@@ -918,42 +910,44 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

918910-- |

919911-- Check the type of a function application, rethrowing errors to provide a better error message

920912--

921−checkFunctionApplication :: Value -> Type -> [Value] -> Type -> UnifyT Check Value

922−checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret

913+checkFunctionApplication :: Value -> Type -> Value -> Type -> UnifyT Check Value

914+checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg ret

923915 where

924916 errorMessage msg = "Error applying function of type "

925917 ++ prettyPrintType fnTy

926− ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)

918+ ++ " to argument " ++ prettyPrintValue arg

927919 ++ ":\n" ++ msg

928920

929921-- |

930922-- Check the type of a function application

931923--

932−checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> UnifyT Check Value

933−checkFunctionApplication' fn (Function argTys retTy) args ret = do

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

935− args' <- zipWithM check args argTys

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

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

926+ tyFunction' ?= tyFunction

927+ arg' <- check arg argTy

936928 _ <- subsumes Nothing retTy ret

937− return $ App fn args'

938−checkFunctionApplication' fn (ForAll ident ty) args ret = do

929+ return $ App fn arg'

930+checkFunctionApplication' fn (ForAll ident ty) arg ret = do

939931 replaced <- replaceVarWithUnknown ident ty

940− checkFunctionApplication fn replaced args ret

941−checkFunctionApplication' fn u@(TUnknown _) args ret = do

942− args' <- mapM (\arg -> infer arg >>= \(TypedValue _ v t) -> TypedValue True v <$> replaceAllVarsWithUnknowns t) args

943− let tys = map (\(TypedValue _ _ t) -> t) args'

944− u ?= Function tys ret

945− return $ App fn args'

946−checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do

932+ checkFunctionApplication fn replaced arg ret

933+checkFunctionApplication' fn u@(TUnknown _) arg ret = do

934+ arg' <- do

935+ TypedValue _ v t <- infer arg

936+ TypedValue True v <$> replaceAllVarsWithUnknowns t

937+ let ty = (\(TypedValue _ _ t) -> t) arg'

938+ u ?= function ty ret

939+ return $ App fn arg'

940+checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do

947941 ty <- expandTypeSynonym name tyArgs

948− checkFunctionApplication fn ty args ret

949−checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do

942+ checkFunctionApplication fn ty arg ret

943+checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

950944 env <- getEnv

951945 dicts <- getTypeClassDictionaries

952946 Just moduleName <- checkCurrentModule <$> get

953− checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy args ret

954−checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "

947+ checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy arg ret

948+checkFunctionApplication' _ fnTy arg ret = throwError $ "Applying a function of type "

955949 ++ prettyPrintType fnTy

956− ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)

950+ ++ " to argument(s) " ++ prettyPrintValue arg

957951 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."

958952

959953-- |

@@ -975,8 +969,8 @@ subsumes' :: Maybe Value -> Type -> Type -> UnifyT Check (Maybe Value)

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

976970 replaced <- replaceVarWithUnknown ident ty1

977971 subsumes val replaced ty2

978−subsumes' val (Function args1 ret1) (Function args2 ret2) = do

979− zipWithM_ (subsumes Nothing) args2 args1

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

973+ subsumes Nothing arg2 arg1

980974 subsumes Nothing ret1 ret2

981975 return val

982976subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

@@ -984,7 +978,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

984978 dicts <- getTypeClassDictionaries

985979 Just moduleName <- checkCurrentModule <$> get

986980 _ <- subsumes' Nothing ty1 ty2

987− return . Just $ App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))

981+ return . Just $ foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))

988982subsumes' val ty1 ty2 = do

989983 ty1 ?= ty2

990984 return val

src/Language/PureScript/Types.hs+37−32

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

3535 -- |

3636 -- Javascript numbers

3737 --

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− --

5438 | Object Type

5539 -- |

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

57− --

58− | Function [Type] Type

59− -- |

6040 -- A named type variable

6141 --

6242 | TypeVar String

@@ -93,6 +73,42 @@ data Type

9373 --

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

9575

76+-- |

77+-- Type constructor for functions

78+--

79+tyFunction :: Type

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

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 "Array")

105+

106+-- |

107+-- Smart constructor for function types

108+--

109+function :: Type -> Type -> Type

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

111+

96112-- |

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

98114--

@@ -113,18 +129,7 @@ rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))

113129--

114130isMonoType :: Type -> Bool

115131isMonoType (ForAll _ _) = False

116−isMonoType ty = isPolyType ty

117−

118−-- |

119−-- Check whather a type is a valid polytype

120−--

121−isPolyType :: Type -> Bool

122−isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)

123−isPolyType (Function args ret) = all isPolyType args && isPolyType ret

124−isPolyType (TypeApp t1 t2) = isMonoType t1 && isMonoType t2

125−isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args

126−isPolyType (ForAll _ ty) = isPolyType ty

127−isPolyType _ = True

132+isMonoType ty = True

128133

129134-- |

130135-- Universally quantify a type

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

@@ -190,11 +190,11 @@ data Value

190190 -- |

191191 -- Function introduction

192192 --

193− | Abs [Ident] Value

193+ | Abs Ident Value

194194 -- |

195195 -- Function application

196196 --

197− | App Value [Value]

197+ | App Value Value

198198 -- |

199199 -- Variable

200200 --