git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge branch 'singleargs'
2f0a2aePhil Freeman
examples/failing/NullaryAbs.pursnew file+3
compare with golang
unifiedsplit
@@ -0,0 +1,3 @@
1+module NullaryAbs where
2+
3+ func = \ -> "no"
examples/passing/Arrays.purs+2−2
@@ -10,9 +10,9 @@ test2 = \arr -> case arr of
10
10
11data Tree = One Number | Some [Tree]
11data Tree = One Number | Some [Tree]
12
12
13−test3 = \(tree, sum) -> case tree of
13+test3 = \tree sum -> case tree of
14 One n -> n
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
16
17test4 = \arr -> case arr of
17test4 = \arr -> case arr of
18 [] -> 0
18 [] -> 0
examples/passing/Category.pursnew file+15
@@ -0,0 +1,15 @@
1+module Category where
2+
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
6+
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
9 (>>=) Nothing _ = Nothing
9 (>>=) Nothing _ = Nothing
10 (>>=) (Just a) f = f a
10 (>>=) (Just a) f = f a
11
11
12−test1 = \ -> do
12+test1 = \_ -> do
13 Just "abc"
13 Just "abc"
14
14
15−test2 = \ -> do
15+test2 = \_ -> do
16 (x : _) <- Just [1, 2, 3]
16 (x : _) <- Just [1, 2, 3]
17 (y : _) <- Just [4, 5, 6]
17 (y : _) <- Just [4, 5, 6]
18 Just (x + y)
18 Just (x + y)
19
19
20−test3 = \ -> do
20+test3 = \_ -> do
21 Just 1
21 Just 1
22 Nothing :: Maybe Number
22 Nothing :: Maybe Number
23 Just 2
23 Just 2
@@ -34,11 +34,11 @@ test5 mx my mz = do
34 z <- mz
34 z <- mz
35 Just (z + sum)
35 Just (z + sum)
36
36
37−test6 mx = \ -> do
37+test6 mx = \_ -> do
38 let Just x = mx
38 let Just x = mx
39 Just x
39 Just x
40
40
41−test8 = \ -> do
41+test8 = \_ -> do
42 Just (do
42 Just (do
43 Just 1)
43 Just 1)
44
44
@@ -60,7 +60,7 @@ forever a = do
60 a
60 a
61 forever a
61 forever a
62
62
63−test9 = \ -> foo <$> Just 1 <*> Just 2 <*> Just 3
63+test9 = \_ -> foo <$> Just 1 <*> Just 2 <*> Just 3
64
64
65module Main where
65module Main where
66
66
examples/passing/ExternData.purs+1−1
@@ -12,7 +12,7 @@ module ExternData where
12
12
13 foreign import prompt :: IO String
13 foreign import prompt :: IO String
14
14
15− main = \ -> prompt `bind` \s -> showMessage s
15+ main = \_ -> prompt `bind` \s -> showMessage s
16
16
17module Main where
17module Main where
18
18
examples/passing/ExternRaw.purs−2
@@ -2,8 +2,6 @@ module ExternRaw where
2
2
3foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a
3foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a
4
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/FFI.purs+1−1
@@ -9,7 +9,7 @@ module FFIModuleTest where
9
9
10import FFI
10import FFI
11
11
12−baz = \ -> foo "test"
12+baz = \_ -> foo "test"
13
13
14module Main where
14module Main where
15
15
examples/passing/Functions.purs+5−7
@@ -1,16 +1,14 @@
1module Functions where
1module Functions where
2
2
3− test1 = \ -> 0
3+ test1 = \_ -> 0
4
4
5− test2 = \() -> 0
5+ test2 = \a b c d -> a + b + c + d
6
6
7− test3 = \a (b, c) d -> a + b + c + d
7+ test3 = \a -> a
8
8
9− test4 = \(a) -> a
9+ test4 = \(%%) -> 1 %% 2
10
10
11− test5 = \(%%) -> 1 %% 2
11+ test5 = \(+++) (***) -> 1 +++ 2 *** 3
12−
13− test6 = \((+++), (***)) -> 1 +++ 2 *** 3
14
12
15module Main where
13module Main where
16
14
examples/passing/Import.purs+1−1
@@ -9,7 +9,7 @@ module M2 where
9
9
10 import M1
10 import M1
11
11
12− main = \() -> foo 42
12+ main = \_ -> foo 42
13
13
14module Main where
14module Main where
15
15
examples/passing/Operators.purs+4−4
@@ -12,11 +12,11 @@ module Operators1 where
12
12
13module Operators2 where
13module Operators2 where
14
14
15− test1 = \(x, y, z) -> x * y + z(x)(y)
15+ test1 = \x y z -> x * y + z(x)(y)
16
16
17 test2 = (\x -> x.foo false) { foo : \_ -> 1 }
17 test2 = (\x -> x.foo false) { foo : \_ -> 1 }
18
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
20
21 k = \x -> \y -> x
21 k = \x -> \y -> x
22
22
@@ -30,7 +30,7 @@ module Operators2 where
30
30
31 test6 = ((\x -> x) `k` 2) 3
31 test6 = ((\x -> x) `k` 2) 3
32
32
33− (<>) = \s1 -> \s2 -> s1 ++ s2
33+ (<>) = \s1 s2 -> s1 ++ s2
34
34
35 test7 = "Hello" <> "World!"
35 test7 = "Hello" <> "World!"
36
36
@@ -57,7 +57,7 @@ import Global
57import Arrays
57import Arrays
58
58
59main = do
59main = do
60− print (test1 (1, 2, \x y -> x + y))
60+ print $ test1 1 2 $ \x y -> x + y
61 print test2
61 print test2
62 print test3
62 print test3
63 print test4
63 print test4
examples/passing/Rank2Types.purs+1−1
@@ -9,7 +9,7 @@ module Rank2Types where
9
9
10 foreign import exampleST :: forall s. ST s Number
10 foreign import exampleST :: forall s. ST s Number
11
11
12− testST = \ -> runST exampleST
12+ testST = \_ -> runST exampleST
13
13
14 foreign import push :: forall el. el -> [el] -> [el]
14 foreign import push :: forall el. el -> [el] -> [el]
15
15
examples/passing/TopLevelCase.purs+5−5
@@ -1,10 +1,10 @@
1module TopLevelCase where
1module TopLevelCase where
2
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
8
9 guardsTest (x:xs) | x > 0 = guardsTest xs
9 guardsTest (x:xs) | x > 0 = guardsTest xs
10 guardsTest xs = xs
10 guardsTest xs = xs
examples/passing/TypeClasses.purs+30−26
@@ -1,64 +1,68 @@
1module TypeClasses where
1module TypeClasses where
2
2
3−import Prelude (($))
3+import Prelude
4
4
5−class Show a where
5+test1 = \_ -> show "testing"
6− show :: a -> String
7
6
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
14f x = show x
8f x = show x
15
9
16−test2 = \ -> f "testing"
10+test2 = \_ -> f "testing"
17
11
18−test7 :: forall a. (Show a) => a -> String
12+test7 :: forall a. (Prelude.Show a) => a -> String
19test7 = show
13test7 = show
20
14
21−test8 = \ -> show $ "testing"
15+test8 = \_ -> show $ "testing"
22
16
23data Data a = Data a
17data Data a = Data a
24
18
25−instance (TypeClasses.Show a) => TypeClasses.Show (Data a) where
19+instance (Prelude.Show a) => Prelude.Show (Data a) where
26 show (Data a) = "Data (" ++ show a ++ ")"
20 show (Data a) = "Data (" ++ show a ++ ")"
27
21
28−test3 = \ -> show (Data "testing")
22+test3 = \_ -> show (Data "testing")
29
23
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
35 ret = Data
25 ret = Data
36 (>>=) (Data a) f = f a
26 (>>=) (Data a) f = f a
37
27
38data Maybe a = Nothing | Just a
28data Maybe a = Nothing | Just a
39
29
40−instance TypeClasses.Monad Maybe where
30+instance Prelude.Monad Maybe where
41 ret = Just
31 ret = Just
42 (>>=) Nothing _ = Nothing
32 (>>=) Nothing _ = Nothing
43 (>>=) (Just a) f = f a
33 (>>=) (Just a) f = f a
44
34
45−test4 :: forall m. (Monad m) => () -> m Number
35+test4 :: forall a m. (Monad m) => a -> m Number
46−test4 = \ -> ret 1
36+test4 = \_ -> ret 1
47
37
48−test5 = \ -> Just 1 >>= \n -> ret (n + 1)
38+test5 = \_ -> Just 1 >>= \n -> ret (n + 1)
49
39
50module TypeClasses2 where
40module TypeClasses2 where
51
41
42+import Prelude
52import TypeClasses
43import TypeClasses
53
44
54−instance (TypeClasses.Show a) => TypeClasses.Show [a] where
45+instance (Prelude.Show a) => Prelude.Show [a] where
55 show [] = "[]"
46 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
57
58
58−test6 = \ -> show ["testing"]
59+test9 _ = runReader 0 $ do
60+ n <- ask
61+ ret $ n + 1
59
62
60module Main where
63module Main where
61
64
65+import Prelude
62import TypeClasses
66import TypeClasses
63
67
64main = Trace.trace (test7 "Done")
68main = Trace.trace (test7 "Done")
libraries/prelude/prelude.purs+87−21
@@ -1,5 +1,11 @@
1module Prelude where
1module Prelude where
2
2
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 :: * -> * -> *
8+
3 id :: forall a. a -> a
9 id :: forall a. a -> a
4 id = \x -> x
10 id = \x -> x
5
11
@@ -401,28 +407,76 @@ module Global where
401
407
402module Math where
408module Math where
403
409
404− type Math =
410+ foreign import abs "function abs(n){\
411+ \ return Math.abs(n);\
405− { abs :: Number -> Number
412+ \}" :: Number -> Number
413+
414+ foreign import acos "function acos(n){\
415+ \ return Math.acos(n);\
406− , acos :: Number -> Number
416+ \}" :: Number -> Number
417+
418+ foreign import asin "function asin(n){\
419+ \ return Math.asin(n);\
407− , asin :: Number -> Number
420+ \}" :: Number -> Number
421+
422+ foreign import atan "function atan(n){\
423+ \ return Math.atan(n);\
408− , atan :: Number -> Number
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);\
409− , atan2 :: (Number, Number) -> Number
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);\
410− , aceil :: Number -> Number
454+ \}" :: Number -> Number
411− , cos :: Number -> Number
455+
456+ foreign import min "function min(n){\
457+ \ return Math.min(n);\
412− , exp :: Number -> Number
458+ \}" :: Number -> Number
413− , floor :: Number -> Number
459+
460+ foreign import pow "function pow(n){\
461+ \ return Math.pow(n);\
414− , log :: Number -> Number
462+ \}" :: Number -> Number
415− , max :: (Number, Number) -> Number
463+
464+ foreign import round "function round(n){\
465+ \ return Math.round(n);\
416− , pow :: (Number, Number) -> Number
466+ \}" :: Number -> Number
417− , random :: () -> Number
467+
468+ foreign import sin "function sin(n){\
469+ \ return Math.sin(n);\
418− , round :: Number -> Number
470+ \}" :: Number -> Number
419− , sin :: Number -> Number
471+
472+ foreign import sqrt "function sqrt(n){\
473+ \ return Math.sqrt(n);\
420− , sqrt :: Number -> Number
474+ \}" :: Number -> Number
475+
476+ foreign import tan "function tan(n){\
477+ \ return Math.tan(n);\
421− , tan :: Number -> Number
478+ \}" :: Number -> Number
422− }
423
479
424− foreign import math "var math = Math;" :: Math
425−
426module Eff where
480module Eff where
427
481
428 foreign import data Eff :: # ! -> * -> *
482 foreign import data Eff :: # ! -> * -> *
@@ -451,6 +505,18 @@ module Eff where
451 ret = retEff
505 ret = retEff
452 (>>=) = bindEff
506 (>>=) = bindEff
453
507
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+
454module Errors where
520module Errors where
455
521
456 import Eff
522 import Eff
libraries/prelude/tests/Eff.purs+2−2
@@ -37,7 +37,7 @@ test6 s = do
37
37
38import ST
38import ST
39
39
40−test7 = \ -> do
40+test7 _ = do
41 n <- runST $ do
41 n <- runST $ do
42 r <- newSTRef 0
42 r <- newSTRef 0
43 modifySTRef r $ \n -> n + 1
43 modifySTRef r $ \n -> n + 1
@@ -48,4 +48,4 @@ module Main where
48
48
49import Tests
49import Tests
50
50
51−main = test7 ()
51+main = test7 {}
psci/Main.hs+1−1
@@ -64,7 +64,7 @@ createTemporaryModule imports value =
64 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
64 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
65 mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing
65 mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing
66 (P.Do [ P.DoNotationBind (P.VarBinder (P.Ident "it")) value
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 ])
68 ])
69 in
69 in
70 P.Module moduleName $ map (importDecl . P.ModuleName) imports ++ [mainDecl]
70 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
110valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
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)
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)
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)
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)
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
118valueToJs _ m e (Var ident) = varToJs m e ident
@@ -120,28 +120,28 @@ valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
120valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
120valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
121valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
121valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
122
122
123−runtimeTypeChecks :: [Ident] -> Type -> [JS]
123+runtimeTypeChecks :: Ident -> Type -> [JS]
124−runtimeTypeChecks args ty =
124+runtimeTypeChecks arg ty =
125 let
125 let
126− argTys = getFunctionArgumentTypes ty
126+ argTy = getFunctionArgumentType ty
127 in
127 in
128− concat $ zipWith argumentCheck (map JSVar args) argTys
128+ maybe [] (argumentCheck (JSVar arg)) argTy
129 where
129 where
130− getFunctionArgumentTypes :: Type -> [Type]
130+ getFunctionArgumentType :: Type -> Maybe Type
131− getFunctionArgumentTypes (Function funArgs _) = funArgs
131+ getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg
132− getFunctionArgumentTypes (ForAll _ ty') = getFunctionArgumentTypes ty'
132+ getFunctionArgumentType (ForAll _ ty') = getFunctionArgumentType ty'
133− getFunctionArgumentTypes _ = []
133+ getFunctionArgumentType _ = Nothing
134 argumentCheck :: JS -> Type -> [JS]
134 argumentCheck :: JS -> Type -> [JS]
135− argumentCheck val Number = [typeCheck val "number"]
135+ argumentCheck val t | t == tyNumber = [typeCheck val "number"]
136− argumentCheck val String = [typeCheck val "string"]
136+ argumentCheck val t | t == tyString = [typeCheck val "string"]
137− argumentCheck val Boolean = [typeCheck val "boolean"]
137+ argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]
138− argumentCheck val (TypeApp Array _) = [arrayCheck val]
138+ argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]
139 argumentCheck val (Object row) =
139 argumentCheck val (Object row) =
140 let
140 let
141 (pairs, _) = rowToList row
141 (pairs, _) = rowToList row
142 in
142 in
143 typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs
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 t _) _) | t == tyFunction = [typeCheck val "function"]
145 argumentCheck val (ForAll _ ty') = argumentCheck val ty'
145 argumentCheck val (ForAll _ ty') = argumentCheck val ty'
146 argumentCheck _ _ = []
146 argumentCheck _ _ = []
147 typeCheck :: JS -> String -> JS
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
253 numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e
254 typeConstructor (TypeConstructor qual) = qualify m qual
254 typeConstructor (TypeConstructor qual) = qualify m qual
255 typeConstructor (ForAll _ ty) = typeConstructor ty
255 typeConstructor (ForAll _ ty) = typeConstructor ty
256− typeConstructor (Function _ ty) = typeConstructor ty
256+ typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty
257 typeConstructor (TypeApp ty _) = typeConstructor ty
257 typeConstructor (TypeApp ty _) = typeConstructor ty
258 typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
258 typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
259
259
src/Language/PureScript/Declarations.hs+1−1
@@ -88,7 +88,7 @@ data Declaration
88 -- |
88 -- |
89 -- A value declaration (name, top-level binders, optional guard, value)
89 -- A value declaration (name, top-level binders, optional guard, value)
90 --
90 --
91− | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
91+ | ValueDeclaration Ident [Binder] (Maybe Guard) Value
92 -- |
92 -- |
93 -- A minimal mutually recursive set of value declarations
93 -- A minimal mutually recursive set of value declarations
94 --
94 --
src/Language/PureScript/Parser/Declarations.hs+1−4
@@ -58,13 +58,10 @@ parseTypeSynonymDeclaration =
58parseValueDeclaration :: P.Parsec String ParseState Declaration
58parseValueDeclaration :: P.Parsec String ParseState Declaration
59parseValueDeclaration =
59parseValueDeclaration =
60 ValueDeclaration <$> parseNonReservedIdent
60 ValueDeclaration <$> parseNonReservedIdent
61− <*> P.many parseTopLevelBinder
61+ <*> P.many parseBinderNoParens
62 <*> P.optionMaybe parseGuard
62 <*> P.optionMaybe parseGuard
63 <*> ((lexeme (indented *> P.char '=')) *> parseValue)
63 <*> ((lexeme (indented *> P.char '=')) *> parseValue)
64
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+12−16
@@ -27,30 +27,26 @@ import qualified Text.Parsec.Expr as P
27import Control.Monad (when, unless)
27import Control.Monad (when, unless)
28
28
29parseNumber :: P.Parsec String ParseState Type
29parseNumber :: P.Parsec String ParseState Type
30−parseNumber = const Number <$> reserved "Number"
30+parseNumber = const tyNumber <$> reserved "Number"
31
31
32parseString :: P.Parsec String ParseState Type
32parseString :: P.Parsec String ParseState Type
33−parseString = const String <$> reserved "String"
33+parseString = const tyString <$> reserved "String"
34
34
35parseBoolean :: P.Parsec String ParseState Type
35parseBoolean :: P.Parsec String ParseState Type
36−parseBoolean = const Boolean <$> reserved "Boolean"
36+parseBoolean = const tyBoolean <$> reserved "Boolean"
37
37
38parseArray :: P.Parsec String ParseState Type
38parseArray :: P.Parsec String ParseState Type
39−parseArray = squares $ return Array
39+parseArray = squares $ return tyArray
40
40
41parseArrayOf :: P.Parsec String ParseState Type
41parseArrayOf :: 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
43
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
54parseAbs :: P.Parsec String ParseState Value
55parseAbs = do
55parseAbs = do
56 C.reservedOp "\\"
56 C.reservedOp "\\"
57− args <- P.many (C.indented *> (P.try singleArg <|> manyArgs))
57+ args <- P.many1 (C.indented *> (Abs <$> C.parseIdent))
58 C.indented *> C.reservedOp "->"
58 C.indented *> C.reservedOp "->"
59 value <- parseValue
59 value <- parseValue
60 return $ toFunction args value
60 return $ toFunction args value
61 where
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−12
@@ -31,12 +31,9 @@ import Language.PureScript.Pretty.Common
31typeLiterals :: Pattern () Type String
31typeLiterals :: Pattern () Type String
32typeLiterals = mkPattern match
32typeLiterals = mkPattern match
33 where
33 where
34− match Number = Just "Number"
35− match String = Just "String"
36− match Boolean = Just "Boolean"
37− match Array = Just $ "[]"
38 match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }"
34 match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }"
39 match (TypeVar var) = Just var
35 match (TypeVar var) = Just var
36+ match (TypeApp arr ty) | arr == tyArray = Just $ "[" ++ prettyPrintType ty ++ "]"
40 match (TypeConstructor ctor) = Just $ show ctor
37 match (TypeConstructor ctor) = Just $ show ctor
41 match (TUnknown (TypedUnknown (Unknown u))) = Just $ 'u' : show u
38 match (TUnknown (TypedUnknown (Unknown u))) = Just $ 'u' : show u
42 match (Skolem s) = Just $ 's' : show s
39 match (Skolem s) = Just $ 's' : show s
@@ -74,13 +71,7 @@ typeApp = mkPattern match
74singleArgumentFunction :: Pattern () Type (Type, Type)
71singleArgumentFunction :: Pattern () Type (Type, Type)
75singleArgumentFunction = mkPattern match
72singleArgumentFunction = mkPattern match
76 where
73 where
77− match (Function [arg] ret) = Just (arg, ret)
74+ match (TypeApp (TypeApp t arg) ret) | t == tyFunction = 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
75 match _ = Nothing
85
76
86-- |
77-- |
@@ -95,6 +86,5 @@ prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()
95 operators =
86 operators =
96 OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
87 OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
97 , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
88 , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
98− , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret
99 ]
89 ]
100 ]
90 ]
src/Language/PureScript/Pretty/Values.hs+5−5
@@ -77,13 +77,13 @@ objectUpdate = mkPattern match
77app :: Pattern () Value (String, Value)
77app :: Pattern () Value (String, Value)
78app = mkPattern match
78app = mkPattern match
79 where
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
81 match _ = Nothing
82
82
83−lam :: Pattern () Value ([String], Value)
83+lam :: Pattern () Value (String, Value)
84lam = mkPattern match
84lam = mkPattern match
85 where
85 where
86− match (Abs args val) = Just (map show args, val)
86+ match (Abs arg val) = Just (show arg, val)
87 match _ = Nothing
87 match _ = Nothing
88
88
89typed :: Pattern () Value (Type, Value)
89typed :: Pattern () Value (Type, Value)
@@ -127,8 +127,8 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (
127 operators =
127 operators =
128 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
128 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
129 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
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 ]
132 , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]
133 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
133 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
134 , [ AssocR indexer (\index val -> val ++ " !! " ++ index) ]
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
33usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val
34 where
34 where
35 namesV :: Value -> [Ident]
35 namesV :: Value -> [Ident]
36− namesV (Abs args _) = args
36+ namesV (Abs arg _) = [arg]
37 namesV (Var (Qualified Nothing name)) = [name]
37 namesV (Var (Qualified Nothing name)) = [name]
38 namesV _ = []
38 namesV _ = []
39 namesS :: Statement -> [Ident]
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
48toDecls d@[ValueDeclaration _ [] Nothing _] = return d
49toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
49toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
50 let tuples = map toTuple ds
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
52 throwError $ "Argument list lengths differ in declaration " ++ show ident
53 return [makeCaseDeclaration ident tuples]
53 return [makeCaseDeclaration ident tuples]
54toDecls ds = return ds
54toDecls ds = return ds
55
55
56−toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
56+toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))
57toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
57toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
58toTuple _ = error "Not a value declaration"
58toTuple _ = error "Not a value declaration"
59
59
60−makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration
60+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration
61makeCaseDeclaration ident alternatives =
61makeCaseDeclaration ident alternatives =
62 let
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
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
68 in
69 ValueDeclaration ident [] Nothing value
69 ValueDeclaration ident [] Nothing value
70
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
46 go [DoNotationValue val] = return val
47 go (DoNotationValue val : rest) = do
47 go (DoNotationValue val : rest) = do
48 rest' <- go rest
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"
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)
51 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
52 go (DoNotationBind (VarBinder ident) val : rest) = do
52 go (DoNotationBind (VarBinder ident) val : rest) = do
53 rest' <- go rest
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
55 go (DoNotationBind binder val : rest) = do
56 rest' <- go rest
56 rest' <- go rest
57 let ident = head $ unusedNames 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"
59 go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"
60 go (DoNotationLet binder val : rest) = do
60 go (DoNotationLet binder val : rest) = do
61 rest' <- go rest
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)]]
58customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
59customOperatorTable fixities =
59customOperatorTable fixities =
60 let
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
62 userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
63 sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns)
63 sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns)
64 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
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
79 bracketChain :: Chain -> Either String Value
80 bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
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
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
83
84toAssoc :: Associativity -> P.Assoc
84toAssoc :: Associativity -> P.Assoc
85toAssoc Infixl = P.AssocLeft
85toAssoc Infixl = P.AssocLeft
src/Language/PureScript/Sugar/TypeClasses.hs+4−10
@@ -87,10 +87,8 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do
87 memberNames <- mapM (memberToNameAndValue memberTypes) decls
87 memberNames <- mapM (memberToNameAndValue memberTypes) decls
88 return $ ValueDeclaration entryName [] Nothing
88 return $ ValueDeclaration entryName [] Nothing
89 (TypedValue True
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 function (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 foldl 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
@@ -137,14 +135,10 @@ mkDictionaryValueName mn cl ty = do
137 return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr
135 return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr
138
136
139typeToString :: ModuleName -> Type -> Either String String
137typeToString :: 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"
144typeToString _ (TypeVar _) = return "var"
138typeToString _ (TypeVar _) = return "var"
145typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'
139typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'
146typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'
140typeToString 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"
148
142
149-- |
143-- |
150-- Generate a name for a type class dictionary member, based on the module name, class name, type name and
144-- 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
51 env <- getEnv
52 dataConstructorIsNotDefined moduleName dctor
52 dataConstructorIsNotDefined moduleName dctor
53 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
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
55 let polyType = mkForAll args dctorTy
56 putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }
56 putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }
57
57
@@ -231,7 +231,7 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
231 constructs (TypeConstructor (Qualified (Just mn) pn')) pn
231 constructs (TypeConstructor (Qualified (Just mn) pn')) pn
232 = mn == moduleName && pn' == pn
232 = mn == moduleName && pn' == pn
233 constructs (ForAll _ ty) pn = ty `constructs` pn
233 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
235 constructs (TypeApp ty _) pn = ty `constructs` pn
235 constructs (TypeApp ty _) pn = ty `constructs` pn
236 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
236 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
237typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
237typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
src/Language/PureScript/TypeChecker/Kinds.hs−10
@@ -117,20 +117,10 @@ starIfUnknown k = k
117-- Infer a kind for a type
117-- Infer a kind for a type
118--
118--
119infer :: Type -> UnifyT Check Kind
119infer :: Type -> UnifyT Check Kind
120−infer Number = return Star
121−infer String = return Star
122−infer Boolean = return Star
123−infer Array = return $ FunKind Star Star
124infer (Object row) = do
120infer (Object row) = do
125 k <- infer row
121 k <- infer row
126 k ?= Row Star
122 k ?= Row Star
127 return Star
123 return Star
128−infer (Function args ret) = do
129− ks <- mapM infer args
130− k <- infer ret
131− k ?= Star
132− forM_ ks (?= Star)
133− return Star
134infer (TypeVar v) = do
124infer (TypeVar v) = do
135 Just moduleName <- checkCurrentModule <$> get
125 Just moduleName <- checkCurrentModule <$> get
136 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
126 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 +
95 sk <- skolemize ident ty1
95 sk <- skolemize ident ty1
96 sk `unifyTypes` ty2
96 sk `unifyTypes` ty2
97 unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty
97 unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty
98− unifyTypes' Number Number = return ()
99− unifyTypes' String String = return ()
100− unifyTypes' Boolean Boolean = return ()
101− unifyTypes' Array Array = return ()
102 unifyTypes' (Object row1) (Object row2) = row1 ?= row2
98 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 ()
99 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
108 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
100 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
109 env <- getEnv
101 env <- getEnv
@@ -235,14 +227,19 @@ entails moduleName context goal@(className, ty) = do
235 , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
227 , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
236 , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
228 , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
237 , args <- solveSubgoals env subst (tcdDependencies tcd) ]
229 , args <- solveSubgoals env subst (tcdDependencies tcd) ]
230+ solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, Type)] -> [Maybe [Value]]
238 solveSubgoals _ _ Nothing = return Nothing
231 solveSubgoals _ _ Nothing = return Nothing
239 solveSubgoals env subst (Just subgoals) = do
232 solveSubgoals env subst (Just subgoals) = do
240 dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
233 dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
241 return $ Just dict
234 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
243 filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
239 filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
244 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
240 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
245 filterModule _ = False
241 filterModule _ = False
242+ canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
246 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
243 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
247 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
244 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
248
245
@@ -251,11 +248,7 @@ entails moduleName context goal@(className, ty) = do
251-- and return a substitution from type variables to types which makes the type heads unify.
248-- and return a substitution from type variables to types which makes the type heads unify.
252--
249--
253typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
250typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
254−typeHeadsAreEqual _ _ String String = Just []
255−typeHeadsAreEqual _ _ Number Number = Just []
256−typeHeadsAreEqual _ _ Boolean Boolean = Just []
257typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []
251typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []
258−typeHeadsAreEqual _ _ Array Array = Just []
259typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
252typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
260typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
253typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
261typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
254typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
@@ -387,13 +380,13 @@ infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue v
387-- Infer a type for a value
380-- Infer a type for a value
388--
381--
389infer' :: Value -> UnifyT Check Value
382infer' :: Value -> UnifyT Check Value
390−infer' v@(NumericLiteral _) = return $ TypedValue True v Number
383+infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber
391−infer' v@(StringLiteral _) = return $ TypedValue True v String
384+infer' v@(StringLiteral _) = return $ TypedValue True v tyString
392−infer' v@(BooleanLiteral _) = return $ TypedValue True v Boolean
385+infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
393infer' (ArrayLiteral vals) = do
386infer' (ArrayLiteral vals) = do
394 ts <- mapM infer vals
387 ts <- mapM infer vals
395 els <- fresh
388 els <- fresh
396− forM_ ts $ \(TypedValue _ _ t) -> els ?= TypeApp Array t
389+ forM_ ts $ \(TypedValue _ _ t) -> els ?= TypeApp tyArray t
397 return $ TypedValue True (ArrayLiteral ts) els
390 return $ TypedValue True (ArrayLiteral ts) els
398infer' (Unary op val) = do
391infer' (Unary op val) = do
399 v <- infer val
392 v <- infer val
@@ -418,9 +411,9 @@ infer' (ObjectUpdate o ps) = do
418 return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)
411 return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)
419infer' (Indexer index val) = do
412infer' (Indexer index val) = do
420 el <- fresh
413 el <- fresh
421− index' <- check index Number
414+ index' <- check index tyNumber
422− val' <- check val (TypeApp Array el)
415+ val' <- check val (TypeApp tyArray el)
423− return $ TypedValue True (Indexer (TypedValue True index' Number) (TypedValue True val' (TypeApp Array el))) el
416+ return $ TypedValue True (Indexer (TypedValue True index' tyNumber) (TypedValue True val' (TypeApp tyArray el))) el
424infer' (Accessor prop val) = do
417infer' (Accessor prop val) = do
425 typed@(TypedValue _ _ objTy) <- infer val
418 typed@(TypedValue _ _ objTy) <- infer val
426 propTy <- inferProperty objTy prop
419 propTy <- inferProperty objTy prop
@@ -431,16 +424,16 @@ infer' (Accessor prop val) = do
431 _ <- subsumes Nothing objTy (Object (RCons prop field rest))
424 _ <- subsumes Nothing objTy (Object (RCons prop field rest))
432 return $ TypedValue True (Accessor prop typed) field
425 return $ TypedValue True (Accessor prop typed) field
433 Just ty -> return $ TypedValue True (Accessor prop typed) ty
426 Just ty -> return $ TypedValue True (Accessor prop typed) ty
434−infer' (Abs args ret) = do
427+infer' (Abs arg ret) = do
435− ts <- replicateM (length args) fresh
428+ ty <- fresh
436 Just moduleName <- checkCurrentModule <$> get
429 Just moduleName <- checkCurrentModule <$> get
437− bindLocalVariables moduleName (zip args ts) $ do
430+ bindLocalVariables moduleName [(arg, ty)] $ do
438 body@(TypedValue _ _ bodyTy) <- infer' ret
431 body@(TypedValue _ _ bodyTy) <- infer' ret
439− return $ TypedValue True (Abs args body) $ Function ts bodyTy
432+ return $ TypedValue True (Abs arg body) $ function ty bodyTy
440−infer' (App f args) = do
433+infer' (App f arg) = do
441 f'@(TypedValue _ _ ft) <- infer f
434 f'@(TypedValue _ _ ft) <- infer f
442 ret <- fresh
435 ret <- fresh
443− app <- checkFunctionApplication f' ft args ret
436+ app <- checkFunctionApplication f' ft arg ret
444 return $ TypedValue True app ret
437 return $ TypedValue True app ret
445infer' (Var var) = do
438infer' (Var var) = do
446 Just moduleName <- checkCurrentModule <$> get
439 Just moduleName <- checkCurrentModule <$> get
@@ -450,7 +443,7 @@ infer' (Var var) = do
450 ConstrainedType constraints _ -> do
443 ConstrainedType constraints _ -> do
451 env <- getEnv
444 env <- getEnv
452 dicts <- getTypeClassDictionaries
445 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'
454 _ -> return $ TypedValue True (Var var) ty'
447 _ -> return $ TypedValue True (Var var) ty'
455infer' (Block ss) = do
448infer' (Block ss) = do
456 ret <- fresh
449 ret <- fresh
@@ -470,7 +463,7 @@ infer' (Case vals binders) = do
470 binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders
463 binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders
471 return $ TypedValue True (Case ts binders') ret
464 return $ TypedValue True (Case ts binders') ret
472infer' (IfThenElse cond th el) = do
465infer' (IfThenElse cond th el) = do
473− cond' <- check cond Boolean
466+ cond' <- check cond tyBoolean
474 v2@(TypedValue _ _ t2) <- infer th
467 v2@(TypedValue _ _ t2) <- infer th
475 v3@(TypedValue _ _ t3) <- infer el
468 v3@(TypedValue _ _ t3) <- infer el
476 t2 ?= t3
469 t2 ?= t3
@@ -525,9 +518,9 @@ checkUnary op val res =
525-- Built-in unary operators
518-- Built-in unary operators
526--
519--
527unaryOps :: [(UnaryOperator, (Type, Type))]
520unaryOps :: [(UnaryOperator, (Type, Type))]
528−unaryOps = [ (Negate, (Number, Number))
521+unaryOps = [ (Negate, (tyNumber, tyNumber))
529− , (Not, (Boolean, Boolean))
522+ , (Not, (tyBoolean, tyBoolean))
530− , (BitwiseNot, (Number, Number))
523+ , (BitwiseNot, (tyNumber, tyNumber))
531 ]
524 ]
532
525
533-- |
526-- |
@@ -536,7 +529,7 @@ unaryOps = [ (Negate, (Number, Number))
536inferBinary :: BinaryOperator -> Value -> Value -> UnifyT Check Value
529inferBinary :: BinaryOperator -> Value -> Value -> UnifyT Check Value
537inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do
530inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do
538 leftTy ?= rightTy
531 leftTy ?= rightTy
539− return $ TypedValue True (Binary op left right) Boolean
532+ return $ TypedValue True (Binary op left right) tyBoolean
540inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =
533inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =
541 case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
534 case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
542 (valTy, resTy) -> do
535 (valTy, resTy) -> do
@@ -550,7 +543,7 @@ inferBinary _ _ _ = error "Invalid arguments to inferBinary"
550--
543--
551checkBinary :: BinaryOperator -> Value -> Value -> Type -> UnifyT Check Value
544checkBinary :: BinaryOperator -> Value -> Value -> Type -> UnifyT Check Value
552checkBinary op left right res | isEqualityTest op = do
545checkBinary op left right res | isEqualityTest op = do
553− res ?= Boolean
546+ res ?= tyBoolean
554 left'@(TypedValue _ _ t1) <- infer left
547 left'@(TypedValue _ _ t1) <- infer left
555 right'@(TypedValue _ _ t2) <- infer right
548 right'@(TypedValue _ _ t2) <- infer right
556 t1 ?= t2
549 t1 ?= t2
@@ -575,24 +568,24 @@ isEqualityTest _ = False
575-- Built-in binary operators
568-- Built-in binary operators
576--
569--
577binaryOps :: [(BinaryOperator, (Type, Type))]
570binaryOps :: [(BinaryOperator, (Type, Type))]
578−binaryOps = [ (Add, (Number, Number))
571+binaryOps = [ (Add, (tyNumber, tyNumber))
579− , (Subtract, (Number, Number))
572+ , (Subtract, (tyNumber, tyNumber))
580− , (Multiply, (Number, Number))
573+ , (Multiply, (tyNumber, tyNumber))
581− , (Divide, (Number, Number))
574+ , (Divide, (tyNumber, tyNumber))
582− , (Modulus, (Number, Number))
575+ , (Modulus, (tyNumber, tyNumber))
583− , (BitwiseAnd, (Number, Number))
576+ , (BitwiseAnd, (tyNumber, tyNumber))
584− , (BitwiseOr, (Number, Number))
577+ , (BitwiseOr, (tyNumber, tyNumber))
585− , (BitwiseXor, (Number, Number))
578+ , (BitwiseXor, (tyNumber, tyNumber))
586− , (ShiftRight, (Number, Number))
579+ , (ShiftRight, (tyNumber, tyNumber))
587− , (ZeroFillShiftRight, (Number, Number))
580+ , (ZeroFillShiftRight, (tyNumber, tyNumber))
588− , (And, (Boolean, Boolean))
581+ , (And, (tyBoolean, tyBoolean))
589− , (Or, (Boolean, Boolean))
582+ , (Or, (tyBoolean, tyBoolean))
590− , (Concat, (String, String))
583+ , (Concat, (tyString, tyString))
591− , (Modulus, (Number, Number))
584+ , (Modulus, (tyNumber, tyNumber))
592− , (LessThan, (Number, Boolean))
585+ , (LessThan, (tyNumber, tyBoolean))
593− , (LessThanOrEqualTo, (Number, Boolean))
586+ , (LessThanOrEqualTo, (tyNumber, tyBoolean))
594− , (GreaterThan, (Number, Boolean))
587+ , (GreaterThan, (tyNumber, tyBoolean))
595− , (GreaterThanOrEqualTo, (Number, Boolean))
588+ , (GreaterThanOrEqualTo, (tyNumber, tyBoolean))
596 ]
589 ]
597
590
598-- |
591-- |
@@ -600,9 +593,9 @@ binaryOps = [ (Add, (Number, Number))
600--
593--
601inferBinder :: Type -> Binder -> UnifyT Check (M.Map Ident Type)
594inferBinder :: Type -> Binder -> UnifyT Check (M.Map Ident Type)
602inferBinder _ NullBinder = return M.empty
595inferBinder _ NullBinder = return M.empty
603−inferBinder val (StringBinder _) = val ?= String >> return M.empty
596+inferBinder val (StringBinder _) = val ?= tyString >> return M.empty
604−inferBinder val (NumberBinder _) = val ?= Number >> return M.empty
597+inferBinder val (NumberBinder _) = val ?= tyNumber >> return M.empty
605−inferBinder val (BooleanBinder _) = val ?= Boolean >> return M.empty
598+inferBinder val (BooleanBinder _) = val ?= tyBoolean >> return M.empty
606inferBinder val (VarBinder name) = return $ M.singleton name val
599inferBinder val (VarBinder name) = return $ M.singleton name val
607inferBinder val (NullaryBinder ctor) = do
600inferBinder val (NullaryBinder ctor) = do
608 env <- getEnv
601 env <- getEnv
@@ -619,7 +612,7 @@ inferBinder val (UnaryBinder ctor binder) = do
619 Just (ty, _) -> do
612 Just (ty, _) -> do
620 fn <- replaceAllVarsWithUnknowns ty
613 fn <- replaceAllVarsWithUnknowns ty
621 case fn of
614 case fn of
622− Function [obj] ret -> do
615+ TypeApp (TypeApp t obj) ret | t == tyFunction -> do
623 _ <- subsumes Nothing val ret
616 _ <- subsumes Nothing val ret
624 inferBinder obj binder
617 inferBinder obj binder
625 _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
618 _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
@@ -641,13 +634,13 @@ inferBinder val (ObjectBinder props) = do
641inferBinder val (ArrayBinder binders) = do
634inferBinder val (ArrayBinder binders) = do
642 el <- fresh
635 el <- fresh
643 m1 <- M.unions <$> mapM (inferBinder el) binders
636 m1 <- M.unions <$> mapM (inferBinder el) binders
644− val ?= TypeApp Array el
637+ val ?= TypeApp tyArray el
645 return m1
638 return m1
646inferBinder val (ConsBinder headBinder tailBinder) = do
639inferBinder val (ConsBinder headBinder tailBinder) = do
647 el <- fresh
640 el <- fresh
648 m1 <- inferBinder el headBinder
641 m1 <- inferBinder el headBinder
649 m2 <- inferBinder val tailBinder
642 m2 <- inferBinder val tailBinder
650− val ?= TypeApp Array el
643+ val ?= TypeApp tyArray el
651 return $ m1 `M.union` m2
644 return $ m1 `M.union` m2
652inferBinder val (NamedBinder name binder) = do
645inferBinder val (NamedBinder name binder) = do
653 m <- inferBinder val binder
646 m <- inferBinder val binder
@@ -666,7 +659,7 @@ checkBinders nvals ret ((binders, grd, val):bs) = do
666 case grd of
659 case grd of
667 Nothing -> return (binders, Nothing, val')
660 Nothing -> return (binders, Nothing, val')
668 Just g -> do
661 Just g -> do
669− g' <- check g Boolean
662+ g' <- check g tyBoolean
670 return (binders, Just g', val')
663 return (binders, Just g', val')
671 rs <- checkBinders nvals ret bs
664 rs <- checkBinders nvals ret bs
672 return $ r : rs
665 return $ r : rs
@@ -698,7 +691,7 @@ checkStatement mass _ (Assignment ident val) = do
698 Just ty -> do t ?= ty
691 Just ty -> do t ?= ty
699 return (False, mass, Assignment ident val')
692 return (False, mass, Assignment ident val')
700checkStatement mass ret (While val inner) = do
693checkStatement mass ret (While val inner) = do
701− val' <- check val Boolean
694+ val' <- check val tyBoolean
702 (allCodePathsReturn, _, inner') <- checkBlock mass ret inner
695 (allCodePathsReturn, _, inner') <- checkBlock mass ret inner
703 return (allCodePathsReturn, mass, While val' inner')
696 return (allCodePathsReturn, mass, While val' inner')
704checkStatement mass ret (If ifst) = do
697checkStatement mass ret (If ifst) = do
@@ -707,9 +700,9 @@ checkStatement mass ret (If ifst) = do
707checkStatement mass ret (For ident start end inner) = do
700checkStatement mass ret (For ident start end inner) = do
708 Just moduleName <- checkCurrentModule <$> get
701 Just moduleName <- checkCurrentModule <$> get
709 assignVariable ident
702 assignVariable ident
710− start' <- check start Number
703+ start' <- check start tyNumber
711− end' <- check end Number
704+ end' <- check end tyNumber
712− (allCodePathsReturn, _, inner') <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner
705+ (allCodePathsReturn, _, inner') <- bindLocalVariables moduleName [(ident, tyNumber)] $ checkBlock mass ret inner
713 return (allCodePathsReturn, mass, For ident start' end' inner')
706 return (allCodePathsReturn, mass, For ident start' end' inner')
714checkStatement mass ret (Return val) = do
707checkStatement mass ret (Return val) = do
715 val' <- check val ret
708 val' <- check val ret
@@ -720,11 +713,11 @@ checkStatement mass ret (Return val) = do
720--
713--
721checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> UnifyT Check (Bool, IfStatement)
714checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> UnifyT Check (Bool, IfStatement)
722checkIfStatement mass ret (IfStatement val thens Nothing) = do
715checkIfStatement mass ret (IfStatement val thens Nothing) = do
723− val' <- check val Boolean
716+ val' <- check val tyBoolean
724 (_, _, thens') <- checkBlock mass ret thens
717 (_, _, thens') <- checkBlock mass ret thens
725 return (False, IfStatement val' thens' Nothing)
718 return (False, IfStatement val' thens' Nothing)
726checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
719checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
727− val' <- check val Boolean
720+ val' <- check val tyBoolean
728 (allCodePathsReturn1, _, thens') <- checkBlock mass ret thens
721 (allCodePathsReturn1, _, thens') <- checkBlock mass ret thens
729 (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses
722 (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses
730 return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))
723 return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))
@@ -792,31 +785,30 @@ check' val (ConstrainedType constraints ty) = do
792 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
785 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
793 (qualifyAllUnqualifiedNames moduleName env constraints)) $
786 (qualifyAllUnqualifiedNames moduleName env constraints)) $
794 check val ty
787 check val ty
795− return $ Abs dictNames val'
788+ return $ foldr Abs val' dictNames
796check' val u@(TUnknown _) = do
789check' val u@(TUnknown _) = do
797 val'@(TypedValue _ _ ty) <- infer val
790 val'@(TypedValue _ _ ty) <- infer val
798 -- Don't unify an unknown with an inferred polytype
791 -- Don't unify an unknown with an inferred polytype
799 ty' <- replaceAllVarsWithUnknowns ty
792 ty' <- replaceAllVarsWithUnknowns ty
800 ty' ?= u
793 ty' ?= u
801 return val'
794 return val'
802−check' v@(NumericLiteral _) Number = return v
795+check' v@(NumericLiteral _) t | t == tyNumber = return v
803−check' v@(StringLiteral _) String = return v
796+check' v@(StringLiteral _) t | t == tyString = return v
804−check' v@(BooleanLiteral _) Boolean = return v
797+check' v@(BooleanLiteral _) t | t == tyBoolean = return v
805check' (Unary op val) ty = checkUnary op val ty
798check' (Unary op val) ty = checkUnary op val ty
806check' (Binary op left right) ty = checkBinary op left right ty
799check' (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)
808check' (Indexer index vals) ty = do
801check' (Indexer index vals) ty = do
809− index' <- check index Number
802+ index' <- check index tyNumber
810− vals' <- check vals (TypeApp Array ty)
803+ vals' <- check vals (TypeApp tyArray ty)
811 return $ Indexer index' vals'
804 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
813 Just moduleName <- checkCurrentModule <$> get
806 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
807+ ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy
816− return $ Abs args ret'
808+ return $ Abs arg ret'
817−check' (App f args) ret = do
809+check' (App f arg) ret = do
818 f'@(TypedValue _ _ ft) <- infer f
810 f'@(TypedValue _ _ ft) <- infer f
819− app <- checkFunctionApplication f' ft args ret
811+ app <- checkFunctionApplication f' ft arg ret
820 return $ app
812 return $ app
821check' v@(Var var) ty = do
813check' v@(Var var) ty = do
822 Just moduleName <- checkCurrentModule <$> get
814 Just moduleName <- checkCurrentModule <$> get
@@ -842,7 +834,7 @@ check' (Case vals binders) ret = do
842 binders' <- checkBinders ts ret binders
834 binders' <- checkBinders ts ret binders
843 return $ Case vals' binders'
835 return $ Case vals' binders'
844check' (IfThenElse cond th el) ty = do
836check' (IfThenElse cond th el) ty = do
845− cond' <- check cond Boolean
837+ cond' <- check cond tyBoolean
846 th' <- check th ty
838 th' <- check th ty
847 el' <- check el ty
839 el' <- check el ty
848 return $ IfThenElse cond' th' el'
840 return $ IfThenElse cond' th' el'
@@ -918,42 +910,44 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
918-- |
910-- |
919-- Check the type of a function application, rethrowing errors to provide a better error message
911-- Check the type of a function application, rethrowing errors to provide a better error message
920--
912--
921−checkFunctionApplication :: Value -> Type -> [Value] -> Type -> UnifyT Check Value
913+checkFunctionApplication :: Value -> Type -> Value -> Type -> UnifyT Check Value
922−checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret
914+checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg ret
923 where
915 where
924 errorMessage msg = "Error applying function of type "
916 errorMessage msg = "Error applying function of type "
925 ++ prettyPrintType fnTy
917 ++ prettyPrintType fnTy
926− ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
918+ ++ " to argument " ++ prettyPrintValue arg
927 ++ ":\n" ++ msg
919 ++ ":\n" ++ msg
928
920
929-- |
921-- |
930-- Check the type of a function application
922-- Check the type of a function application
931--
923--
932−checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> UnifyT Check Value
924+checkFunctionApplication' :: Value -> Type -> Value -> Type -> UnifyT Check Value
933−checkFunctionApplication' fn (Function argTys retTy) args ret = do
925+checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
934− guardWith "Incorrect number of function arguments" (length args == length argTys)
926+ tyFunction' ?= tyFunction
935− args' <- zipWithM check args argTys
927+ arg' <- check arg argTy
936 _ <- subsumes Nothing retTy ret
928 _ <- subsumes Nothing retTy ret
937− return $ App fn args'
929+ return $ App fn arg'
938−checkFunctionApplication' fn (ForAll ident ty) args ret = do
930+checkFunctionApplication' fn (ForAll ident ty) arg ret = do
939 replaced <- replaceVarWithUnknown ident ty
931 replaced <- replaceVarWithUnknown ident ty
940− checkFunctionApplication fn replaced args ret
932+ checkFunctionApplication fn replaced arg ret
941−checkFunctionApplication' fn u@(TUnknown _) args ret = do
933+checkFunctionApplication' fn u@(TUnknown _) arg ret = do
934+ arg' <- do
935+ TypedValue _ v t <- infer arg
942− args' <- mapM (\arg -> infer arg >>= \(TypedValue _ v t) -> TypedValue True v <$> replaceAllVarsWithUnknowns t) args
936+ TypedValue True v <$> replaceAllVarsWithUnknowns t
943− let tys = map (\(TypedValue _ _ t) -> t) args'
937+ let ty = (\(TypedValue _ _ t) -> t) arg'
944− u ?= Function tys ret
938+ u ?= function ty ret
945− return $ App fn args'
939+ return $ App fn arg'
946−checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do
940+checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
947 ty <- expandTypeSynonym name tyArgs
941 ty <- expandTypeSynonym name tyArgs
948− checkFunctionApplication fn ty args ret
942+ checkFunctionApplication fn ty arg ret
949−checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do
943+checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
950 env <- getEnv
944 env <- getEnv
951 dicts <- getTypeClassDictionaries
945 dicts <- getTypeClassDictionaries
952 Just moduleName <- checkCurrentModule <$> get
946 Just moduleName <- checkCurrentModule <$> get
953− checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy args ret
947+ checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy arg ret
954−checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "
948+checkFunctionApplication' _ fnTy arg ret = throwError $ "Applying a function of type "
955 ++ prettyPrintType fnTy
949 ++ prettyPrintType fnTy
956− ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
950+ ++ " to argument(s) " ++ prettyPrintValue arg
957 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
951 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
958
952
959-- |
953-- |
@@ -975,8 +969,8 @@ subsumes' :: Maybe Value -> Type -> Type -> UnifyT Check (Maybe Value)
975subsumes' val (ForAll ident ty1) ty2 = do
969subsumes' val (ForAll ident ty1) ty2 = do
976 replaced <- replaceVarWithUnknown ident ty1
970 replaced <- replaceVarWithUnknown ident ty1
977 subsumes val replaced ty2
971 subsumes val replaced ty2
978−subsumes' val (Function args1 ret1) (Function args2 ret2) = do
972+subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
979− zipWithM_ (subsumes Nothing) args2 args1
973+ subsumes Nothing arg2 arg1
980 subsumes Nothing ret1 ret2
974 subsumes Nothing ret1 ret2
981 return val
975 return val
982subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
976subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
@@ -984,7 +978,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
984 dicts <- getTypeClassDictionaries
978 dicts <- getTypeClassDictionaries
985 Just moduleName <- checkCurrentModule <$> get
979 Just moduleName <- checkCurrentModule <$> get
986 _ <- subsumes' Nothing ty1 ty2
980 _ <- 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))
988subsumes' val ty1 ty2 = do
982subsumes' val ty1 ty2 = do
989 ty1 ?= ty2
983 ty1 ?= ty2
990 return val
984 return val
src/Language/PureScript/Types.hs+37−32
@@ -35,28 +35,8 @@ data Type
35 -- |
35 -- |
36 -- Javascript numbers
36 -- Javascript numbers
37 --
37 --
38− | Number
39− -- |
40− -- Javascript strings
41− --
42− | String
43− -- |
44− -- Javascript booleans
45− --
46− | Boolean
47− -- |
48− -- Javascript array type constructor
49− --
50− | Array
51− -- |
52− -- Records, parameterized by a row of types
53− --
54 | Object Type
38 | Object Type
55 -- |
39 -- |
56− -- A function, with zero or more arguments
57− --
58− | Function [Type] Type
59− -- |
60 -- A named type variable
40 -- A named type variable
61 --
41 --
62 | TypeVar String
42 | TypeVar String
@@ -93,6 +73,42 @@ data Type
93 --
73 --
94 | RCons String Type Type deriving (Show, Eq, Data, Typeable)
74 | RCons String Type Type deriving (Show, Eq, Data, Typeable)
95
75
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+
96-- |
112-- |
97-- Convert a row to a list of pairs of labels and types
113-- Convert a row to a list of pairs of labels and types
98--
114--
@@ -113,18 +129,7 @@ rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
113--
129--
114isMonoType :: Type -> Bool
130isMonoType :: Type -> Bool
115isMonoType (ForAll _ _) = False
131isMonoType (ForAll _ _) = False
116−isMonoType ty = isPolyType ty
132+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
133
129-- |
134-- |
130-- Universally quantify a type
135-- Universally quantify a type
src/Language/PureScript/Values.hs+2−2
@@ -190,11 +190,11 @@ data Value
190 -- |
190 -- |
191 -- Function introduction
191 -- Function introduction
192 --
192 --
193− | Abs [Ident] Value
193+ | Abs Ident Value
194 -- |
194 -- |
195 -- Function application
195 -- Function application
196 --
196 --
197− | App Value [Value]
197+ | App Value Value
198 -- |
198 -- |
199 -- Variable
199 -- Variable
200 --
200 --