b37c730 · rowtype-yoga/purescript-native

examples/passing/Arrays.purs+2−2

compare with golang

unifiedsplit

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

10

11data Tree = One Number | Some [Tree]

12

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

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

14 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

16

17test4 = \arr -> case arr of

18 [] -> 0

examples/passing/ExternRaw.purs−2

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

2

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

4

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

6−

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

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

8

6

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

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

examples/passing/Functions.purs+4−4

@@ -2,15 +2,15 @@ module Functions where

2

3 test1 = \ -> 0

4

5− test2 = \() -> 0

5+ test2 = \_ -> 0

6

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

7+ test3 = \a b c d -> a + b + c + d

8

9− test4 = \(a) -> a

9+ test4 = \a -> a

10

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

12

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

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

14

15module Main where

16

examples/passing/Import.purs+1−1

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

9

10 import M1

11

12− main = \() -> foo 42

12+ main = \_ -> foo 42

13

14module Main where

15

examples/passing/Operators.purs+4−4

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

12

13module Operators2 where

14

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

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

16

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

18

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

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

20

21 k = \x -> \y -> x

22

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

30

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

32

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

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

34

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

36

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

57import Arrays

58

59main = do

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

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

61 print test2

62 print test3

63 print test4

examples/passing/TopLevelCase.purs+5−5

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

1module TopLevelCase where

2

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

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

4− gcd (0, x) = x

4+ gcd 0 x = x

5− gcd (x, 0) = x

5+ gcd x 0 = x

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

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

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

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

8

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

10 guardsTest xs = xs

examples/passing/TypeClasses.purs+12−8

@@ -8,24 +8,24 @@ class Show a where

8instance Show String where

9 show s = s

10

11−test1 = \ -> show "testing"

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

12

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

14f x = show x

15

16−test2 = \ -> f "testing"

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

17

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

19test7 = show

20

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

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

22

23data Data a = Data a

24

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

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

27

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

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

29

30class Monad m where

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

@@ -42,10 +42,10 @@ instance TypeClasses.Monad Maybe where

42 (>>=) Nothing _ = Nothing

43 (>>=) (Just a) f = f a

44

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

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

46−test4 = \ -> ret 1

46+test4 = \_ -> ret 1

47

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

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

49

50module TypeClasses2 where

51

@@ -55,7 +55,11 @@ instance (TypeClasses.Show a) => TypeClasses.Show [a] where

55 show [] = "[]"

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

57

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

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

59+

60+instance TypeClasses.Monad (->) r where

61+ ret a r = a

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

59

63

60module Main where

64module Main where

61

65

libraries/prelude/prelude.purs+4−4

@@ -406,15 +406,15 @@ module Math where

406 , acos :: Number -> Number

407 , asin :: Number -> Number

408 , atan :: Number -> Number

409− , atan2 :: (Number, 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

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

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

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

417− , random :: () -> Number

417+ --, random :: () -> Number

418 , round :: Number -> Number

419 , sin :: Number -> Number

420 , sqrt :: Number -> Number

psci/Main.hs+1−1

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

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

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

66 (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"))) )

68 ])

69 in

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

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

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

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

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

112valueToJs 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)

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 args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs opts m e val)])

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 args val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing args (JSBlock $ runtimeTypeChecks args ty ++ [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)])

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

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

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

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

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

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

122

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

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

124−runtimeTypeChecks args ty =

124+runtimeTypeChecks arg ty =

125 let

126− argTys = getFunctionArgumentTypes ty

126+ argTy = getFunctionArgumentType ty

127 in

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

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

129 where

130− getFunctionArgumentTypes :: Type -> [Type]

130+ getFunctionArgumentType :: Type -> Maybe Type

131− getFunctionArgumentTypes (Function funArgs _) = funArgs

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

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

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

133− getFunctionArgumentTypes _ = []

133+ getFunctionArgumentType _ = Nothing

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

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

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

@@ -141,7 +141,7 @@ runtimeTypeChecks args ty =

141 (pairs, _) = rowToList row

142 in

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

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

144+ argumentCheck val (TypeApp (TypeApp Function _) _) = [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 (Function _ ty) = typeConstructor ty

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

257 typeConstructor (TypeApp ty _) = typeConstructor ty

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

259

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

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

88 -- |

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

90 --

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

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

92 -- |

93 -- A minimal mutually recursive set of value declarations

94 --

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

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

58parseValueDeclaration :: P.Parsec String ParseState Declaration

59parseValueDeclaration =

60 ValueDeclaration <$> parseNonReservedIdent

61− <*> P.many parseTopLevelBinder

61+ <*> P.many parseBinderNoParens

62 <*> P.optionMaybe parseGuard

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

64

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

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

67−

68parseExternDeclaration :: P.Parsec String ParseState Declaration

65parseExternDeclaration :: P.Parsec String ParseState Declaration

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

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

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

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

src/Language/PureScript/Parser/Types.hs+7−11

@@ -41,16 +41,12 @@ parseArray = squares $ return Array

41parseArrayOf :: P.Parsec String ParseState Type

42parseArrayOf = squares $ TypeApp Array <$> parseType

43

44+parseFunction :: P.Parsec String ParseState Type

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

46+

44parseObject :: P.Parsec String ParseState Type

47parseObject :: P.Parsec String ParseState Type

45parseObject = braces $ Object <$> parseRow False

48parseObject = braces $ Object <$> parseRow False

46

49

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−

54parseTypeVariable :: P.Parsec String ParseState Type

50parseTypeVariable :: P.Parsec String ParseState Type

55parseTypeVariable = TypeVar <$> identifier

51parseTypeVariable = TypeVar <$> identifier

56

52

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

68 , parseBoolean

64 , parseBoolean

69 , parseArray

65 , parseArray

70 , parseArrayOf

66 , parseArrayOf

67+ , parseFunction

71 , parseObject

68 , parseObject

72 , parseTypeVariable

69 , parseTypeVariable

73 , parseTypeConstructor

70 , parseTypeConstructor

74 , parseForAll

71 , parseForAll

75 , parens (parseRow True)

72 , parens (parseRow True)

76− , parens parseType ])

73+ , parens parsePolyType ])

77

74

78parseConstrainedType :: P.Parsec String ParseState Type

75parseConstrainedType :: P.Parsec String ParseState Type

79parseConstrainedType = do

76parseConstrainedType = do

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

90 return $ maybe ty (flip ConstrainedType ty) constraints

87 return $ maybe ty (flip ConstrainedType ty) constraints

91

88

92parseAnyType :: P.Parsec String ParseState Type

89parseAnyType :: P.Parsec String ParseState Type

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

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

94 where

91 where

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

92 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 ] ]

97

94

98-- |

95-- |

99-- Parse a monotype

96-- Parse a monotype

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

110parsePolyType :: P.Parsec String ParseState Type

107parsePolyType :: P.Parsec String ParseState Type

111parsePolyType = do

108parsePolyType = do

112 ty <- parseAnyType

109 ty <- parseAnyType

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

114 return ty

110 return ty

115

111

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

112parseNameAndType :: 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

54parseAbs :: P.Parsec String ParseState Value

55parseAbs = do

56 C.reservedOp "\\"

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

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

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

59 value <- parseValue

60 return $ toFunction args value

61 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

68 toFunction :: [Value -> Value] -> Value -> Value

62 toFunction :: [Value -> Value] -> Value -> Value

69− toFunction [] value = Abs [] value

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

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

71

64

72parseVar :: P.Parsec String ParseState Value

65parseVar :: P.Parsec String ParseState Value

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

159 indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

152 indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

160 postfixTable1 = [ parseAccessor

153 postfixTable1 = [ parseAccessor

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

154 , \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

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

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

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

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

165 ]

157 ]

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

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

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

@@ -35,6 +35,7 @@ typeLiterals = mkPattern match

35 match String = Just "String"

36 match Boolean = Just "Boolean"

37 match Array = Just $ "[]"

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

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

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

39 match (TypeVar var) = Just var

40 match (TypeVar var) = Just var

40 match (TypeConstructor ctor) = Just $ show ctor

41 match (TypeConstructor ctor) = Just $ show ctor

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

74singleArgumentFunction :: Pattern () Type (Type, Type)

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

75singleArgumentFunction = mkPattern match

76singleArgumentFunction = mkPattern match

76 where

77 where

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

78+ match (TypeApp (TypeApp 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)

84 match _ = Nothing

79 match _ = Nothing

85

80

86-- |

81-- |

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

95 operators =

90 operators =

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

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

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

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

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

99 ]

93 ]

100 ]

94 ]

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

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

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

78app = mkPattern match

79 where

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

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

81 match _ = Nothing

82

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

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

84lam = mkPattern match

85 where

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

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

87 match _ = Nothing

88

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

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

127 operators =

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

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

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

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

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

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

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

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

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

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

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

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

34 where

35 namesV :: Value -> [Ident]

36− namesV (Abs args _) = args

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

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

38 namesV _ = []

39 namesS :: Statement -> [Ident]

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

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

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

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

50 let tuples = map toTuple ds

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

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

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

53 return [makeCaseDeclaration ident tuples]

54toDecls ds = return ds

55

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

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

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

58toTuple _ = error "Not a value declaration"

59

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

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

61makeCaseDeclaration ident alternatives =

62 let

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

63+ argPattern = length . fst . head $ alternatives

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

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

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

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

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

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

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

68 in

69 ValueDeclaration ident [] Nothing value

70

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)

46 go [DoNotationValue val] = return val

47 go (DoNotationValue val : rest) = do

48 rest' <- go rest

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

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

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

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

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

53 rest' <- go rest

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

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

55 go (DoNotationBind binder val : rest) = do

56 rest' <- go rest

57 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')]))

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

60 go (DoNotationLet binder val : rest) = do

61 rest' <- go rest

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

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

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

59customOperatorTable fixities =

60 let

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

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

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

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

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

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

79 bracketChain :: Chain -> Either String Value

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

81 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]]

83

84toAssoc :: Associativity -> P.Assoc

85toAssoc Infixl = P.AssocLeft

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

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

87 memberNames <- mapM (memberToNameAndValue memberTypes) decls

88 return $ ValueDeclaration entryName [] Nothing

89 (TypedValue True

90− (Abs

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

90+ (foldr Abs (ObjectLiteral memberNames) (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)))

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

94 )

92 )

95 where

93 where

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

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

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

99 memberName <- mkDictionaryEntryName mn name ty ident

97 memberName <- mkDictionaryEntryName mn name ty ident

100 return (identToJs ident, TypedValue False

98 return (identToJs ident, TypedValue False

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

99 (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 foldr App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

103 (quantify memberType))

101 (quantify memberType))

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

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

105

103

@@ -139,10 +137,11 @@ typeToString _ String = return "string"

139typeToString _ Number = return "number"

137typeToString _ Number = return "number"

140typeToString _ Boolean = return "boolean"

138typeToString _ Boolean = return "boolean"

141typeToString _ Array = return "array"

139typeToString _ Array = return "array"

140+typeToString _ Function = return "function"

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

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

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

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

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

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

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

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

146

145

147-- |

146-- |

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

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

51 env <- getEnv

52 dataConstructorIsNotDefined moduleName dctor

53 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

55 let polyType = mkForAll args dctorTy

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

57

@@ -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 (Function _ ty) pn = ty `constructs` pn

234+ constructs (TypeApp (TypeApp Function _) ty) pn = 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+1−6

@@ -125,12 +125,7 @@ infer (Object row) = do

125 k <- infer row

126 k ?= Row Star

127 return Star

128−infer (Function args ret) = do

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

129− ks <- mapM infer args

130− k <- infer ret

131− k ?= Star

132− forM_ ks (?= Star)

133− return Star

134infer (TypeVar v) = do

129infer (TypeVar v) = do

135 Just moduleName <- checkCurrentModule <$> get

130 Just moduleName <- checkCurrentModule <$> get

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

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

src/Language/PureScript/TypeChecker/Types.hs+46−44

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

99 unifyTypes' String String = return ()

100 unifyTypes' Boolean Boolean = return ()

101 unifyTypes' Array Array = return ()

102+ unifyTypes' Function Function = return ()

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

103 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

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

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

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

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

109 env <- getEnv

106 env <- getEnv

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

235 , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)

232 , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)

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

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

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

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

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

238 solveSubgoals _ _ Nothing = return Nothing

236 solveSubgoals _ _ Nothing = return Nothing

239 solveSubgoals env subst (Just subgoals) = do

237 solveSubgoals env subst (Just subgoals) = do

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

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

241 return $ Just dict

239 return $ Just dict

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

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

241+ mkDictionary fnName Nothing = Var fnName

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

243+ filterModule :: TypeClassDictionaryInScope -> Bool

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

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

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

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

245 filterModule _ = False

246 filterModule _ = False

247+ canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

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

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

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

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

248

250

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

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

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

432 return $ TypedValue True (Accessor prop typed) field

434 return $ TypedValue True (Accessor prop typed) field

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

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

434−infer' (Abs args ret) = do

436+infer' (Abs arg ret) = do

435− ts <- replicateM (length args) fresh

437+ ty <- fresh

436 Just moduleName <- checkCurrentModule <$> get

438 Just moduleName <- checkCurrentModule <$> get

437− bindLocalVariables moduleName (zip args ts) $ do

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

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

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

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

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

440−infer' (App f args) = do

442+infer' (App f arg) = do

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

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

442 ret <- fresh

444 ret <- fresh

443− app <- checkFunctionApplication f' ft args ret

445+ app <- checkFunctionApplication f' ft arg ret

444 return $ TypedValue True app ret

446 return $ TypedValue True app ret

445infer' (Var var) = do

447infer' (Var var) = do

446 Just moduleName <- checkCurrentModule <$> get

448 Just moduleName <- checkCurrentModule <$> get

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

450 ConstrainedType constraints _ -> do

452 ConstrainedType constraints _ -> do

451 env <- getEnv

453 env <- getEnv

452 dicts <- getTypeClassDictionaries

454 dicts <- getTypeClassDictionaries

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

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

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

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

455infer' (Block ss) = do

457infer' (Block ss) = do

456 ret <- fresh

458 ret <- fresh

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

619 Just (ty, _) -> do

621 Just (ty, _) -> do

620 fn <- replaceAllVarsWithUnknowns ty

622 fn <- replaceAllVarsWithUnknowns ty

621 case fn of

623 case fn of

622− Function [obj] ret -> do

624+ TypeApp (TypeApp Function obj) ret -> do

623 _ <- subsumes Nothing val ret

625 _ <- subsumes Nothing val ret

624 inferBinder obj binder

626 inferBinder obj binder

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

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

@@ -792,7 +794,7 @@ check' val (ConstrainedType constraints ty) = do

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

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

793 (qualifyAllUnqualifiedNames moduleName env constraints)) $

795 (qualifyAllUnqualifiedNames moduleName env constraints)) $

794 check val ty

796 check val ty

795− return $ Abs dictNames val'

797+ return $ foldr Abs val' dictNames

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

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

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

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

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

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

@@ -809,14 +811,13 @@ check' (Indexer index vals) ty = do

809 index' <- check index Number

811 index' <- check index Number

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

812 vals' <- check vals (TypeApp Array ty)

811 return $ Indexer index' vals'

813 return $ Indexer index' vals'

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

814+check' (Abs arg ret) (TypeApp (TypeApp Function argTy) retTy) = do

813 Just moduleName <- checkCurrentModule <$> get

815 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+ ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy

816− return $ Abs args ret'

817+ return $ Abs arg ret'

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

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

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

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

819− app <- checkFunctionApplication f' ft args ret

820+ app <- checkFunctionApplication f' ft arg ret

820 return $ app

821 return $ app

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

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

822 Just moduleName <- checkCurrentModule <$> get

823 Just moduleName <- checkCurrentModule <$> get

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

918-- |

919-- |

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

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

920--

921--

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

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

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

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

923 where

924 where

924 errorMessage msg = "Error applying function of type "

925 errorMessage msg = "Error applying function of type "

925 ++ prettyPrintType fnTy

926 ++ prettyPrintType fnTy

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

927+ ++ " to argument " ++ prettyPrintValue arg

927 ++ ":\n" ++ msg

928 ++ ":\n" ++ msg

928

929

929-- |

930-- |

930-- Check the type of a function application

931-- Check the type of a function application

931--

932--

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

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

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

934+checkFunctionApplication' fn (TypeApp (TypeApp Function argTy) retTy) arg ret = do

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

935+ arg' <- check arg argTy

935− args' <- zipWithM check args argTys

936 _ <- subsumes Nothing retTy ret

937− return $ App fn args'

937+ return $ App fn arg'

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

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

939 replaced <- replaceVarWithUnknown ident ty

940− checkFunctionApplication fn replaced args ret

940+ checkFunctionApplication fn replaced arg ret

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

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

942+ arg' <- do

943+ TypedValue _ v t <- infer arg

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

944+ TypedValue True v <$> replaceAllVarsWithUnknowns t

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

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

944− u ?= Function tys ret

946+ u ?= function ty ret

945− return $ App fn args'

947+ return $ App fn arg'

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

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

947 ty <- expandTypeSynonym name tyArgs

949 ty <- expandTypeSynonym name tyArgs

948− checkFunctionApplication fn ty args ret

950+ checkFunctionApplication fn ty arg ret

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

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

950 env <- getEnv

952 env <- getEnv

951 dicts <- getTypeClassDictionaries

953 dicts <- getTypeClassDictionaries

952 Just moduleName <- checkCurrentModule <$> get

954 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

955 ++ prettyPrintType fnTy

957 ++ prettyPrintType fnTy

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

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

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

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

958

960

959-- |

961-- |

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

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

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

976 replaced <- replaceVarWithUnknown ident ty1

978 replaced <- replaceVarWithUnknown ident ty1

977 subsumes val replaced ty2

979 subsumes val replaced ty2

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

980+subsumes' val (TypeApp (TypeApp Function arg1) ret1) (TypeApp (TypeApp Function arg2) ret2) = do

979− zipWithM_ (subsumes Nothing) args2 args1

981+ subsumes Nothing arg2 arg1

980 subsumes Nothing ret1 ret2

982 subsumes Nothing ret1 ret2

981 return val

983 return val

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

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

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

984 dicts <- getTypeClassDictionaries

986 dicts <- getTypeClassDictionaries

985 Just moduleName <- checkCurrentModule <$> get

987 Just moduleName <- checkCurrentModule <$> get

986 _ <- subsumes' Nothing ty1 ty2

988 _ <- subsumes' Nothing ty1 ty2

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

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

988subsumes' val ty1 ty2 = do

990subsumes' val ty1 ty2 = do

989 ty1 ?= ty2

991 ty1 ?= ty2

990 return val

992 return val

src/Language/PureScript/Types.hs+8−13

@@ -55,7 +55,7 @@ data Type

55 -- |

56 -- A function, with zero or more arguments

57 --

58− | Function [Type] Type

58+ | Function

59 -- |

60 -- A named type variable

61 --

@@ -93,6 +93,12 @@ data Type

93 --

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

95

96+-- |

97+-- Smart constructor for function types

98+--

99+function :: Type -> Type -> Type

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

101+

96-- |

102-- |

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

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

98--

104--

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

113--

119--

114isMonoType :: Type -> Bool

120isMonoType :: Type -> Bool

115isMonoType (ForAll _ _) = False

121isMonoType (ForAll _ _) = False

116−isMonoType ty = isPolyType ty

122+isMonoType ty = True

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

128

123

129-- |

124-- |

130-- Universally quantify a type

125-- Universally quantify a type

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

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

190 -- |

191 -- Function introduction

192 --

193− | Abs [Ident] Value

193+ | Abs Ident Value

194 -- |

195 -- Function application

196 --

197− | App Value [Value]

197+ | App Value Value

198 -- |

199 -- Variable

200 --