bcc7e77 · rowtype-yoga/purescript-native

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

Merge branch 'bindinggroups'

Conflicts: src/Main.hs

commitbcc7e771890a922e8eb19fbb519361ac1f37e76e authorPhil Freeman <paf31@cantab.net> dateFri 3 Jan 2014, 22:20 (13 years ago) parent8011439 2992586

74 files changed+1303−922

compare with golang

unifiedsplit

examples/failing/Arrays.purs+3−1

@@ -1 +1,3 @@

1−test = \arr -> arr !! (0 !! 0)

1+module Arrays where

3+ test = \arr -> arr !! (0 !! 0)

examples/failing/Import.purs+3−1

@@ -1 +1,3 @@

1−import UndefinedModule

1+module Module where

3+ import UndefinedModule

examples/failing/KindError.purs+3−1

@@ -1 +1,3 @@

1−data KindError f a = One f | Two f a

1+module KindError where

3+ data KindError f a = One f | Two f a

examples/failing/LocalVars.purs+6−3

@@ -1,3 +1,6 @@

1−bad = \x -> do

2− x = x + 1

3− return x

1+module LocalVars where

3+ bad = \x -> {

4+ x = x + 1;

5+ return x;

6+ }

examples/failing/PatternScope.purs+9−6

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

1−-- Pattern scope doesn't leak

2−foobar = \x -> do

3− var y = case x of

4− z | z % 2 == 0 -> 1

5− _ -> 2

6− return z

1+module PatternScope where

3+ -- Pattern scope doesn't leak

4+ foobar = \x -> {

5+ var y = case x of

6+ z | z % 2 == 0 -> 1

7+ _ -> 2;

8+ return z;

9+ }

710

examples/failing/Rank2Types.purs+4−2

@@ -1,3 +1,5 @@

1−foreign import test :: (forall a. a -> a) -> Number

1+module Rank2Types where

3−test1 = test (\n -> n + 1)

3+ foreign import test :: (forall a. a -> a) -> Number

5+ test1 = test (\n -> n + 1)

examples/failing/ReadShow.purs+5−3

@@ -1,5 +1,7 @@

1−foreign import read :: forall a. String -> a

1+module ReadShow where

3−foreign import show :: forall a. a -> String

3+ foreign import read :: forall a. String -> a

5−test = \x -> show (read x)

5+ foreign import show :: forall a. a -> String

7+ test = \x -> show (read x)

examples/failing/SkolemEscape.purs+4−2

@@ -1,3 +1,5 @@

1−foreign import foo :: (forall a. a -> a) -> Number

1+module SkolemEscape where

3−test = \x -> foo x

3+ foreign import foo :: (forall a. a -> a) -> Number

5+ test = \x -> foo x

examples/failing/TypeError.purs+3−3

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

1−test = do

2− var x = 0

3− return x ++ "A"

1+module TypeError where

3+ test = x ++ "A"

examples/passing/Arrays.purs+3−1

@@ -1,3 +1,5 @@

1+module Arrays where

13test1 = \arr -> arr !! 0 + arr !! 1

35test2 = \arr -> case arr of

@@ -16,5 +18,5 @@ test4 = \arr -> case arr of

1618 [] -> 0

1719 [_] -> 0

1820 x : y : xs -> x * y + test4 xs

19−

21+

2022

examples/passing/Assign.purs+8−6

@@ -1,7 +1,9 @@

1−sum = \n -> {

2− var x = 0;

3− for (i <- 0 until n) {

4− x = x + i;

1+module Assign where

3+ sum = \n -> {

4+ var x = 0;

5+ for (i <- 0 until n) {

6+ x = x + i;

7+ }

8+ return x;

59 }

6− return x;

7− }

examples/passing/Auto.purs+8−6

@@ -1,9 +1,11 @@

1−data Auto s i o = Auto { state :: s, step :: s -> i -> o }

1+module Auto where

3−type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r

3+ data Auto s i o = Auto { state :: s, step :: s -> i -> o }

5−exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o

6−exists = \state step f -> f (Auto { state: state, step: step })

5+ type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r

8−run :: forall i o. SomeAuto i o -> i -> o

9−run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)

7+ exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o

8+ exists = \state step f -> f (Auto { state: state, step: step })

10+ run :: forall i o. SomeAuto i o -> i -> o

11+ run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)

examples/passing/Church.purs+10−8

@@ -1,12 +1,14 @@

1−type List a = forall r. r -> (a -> r -> r) -> r

1+module Church where

3−empty :: forall a. List a

4−empty = \r f -> r

3+ type List a = forall r. r -> (a -> r -> r) -> r

6−cons :: forall a. a -> List a -> List a

7−cons = \a l r f -> f a (l r f)

5+ empty :: forall a. List a

6+ empty = \r f -> r

9−append :: forall a. List a -> List a -> List a

10−append = \l1 l2 r f -> l2 (l1 r f) f

8+ cons :: forall a. a -> List a -> List a

9+ cons = \a l r f -> f a (l r f)

1110

12−test = append (cons 1 empty) (cons 2 empty)

11+ append :: forall a. List a -> List a -> List a

12+ append = \l1 l2 r f -> l2 (l1 r f) f

13+

14+ test = append (cons 1 empty) (cons 2 empty)

examples/passing/Conditional.purs+5−3

@@ -1,5 +1,7 @@

1−fns = \f -> if f true then f else \x -> x

1+module Conditional where

3−bin = \x -> if x && !x then x else x

3+ fns = \f -> if f true then f else \x -> x

5−not = \x -> if x then false else true

5+ bin = \x -> if x && !x then x else x

7+ not = \x -> if x then false else true

examples/passing/Cons.purs+6−4

@@ -1,7 +1,9 @@

1−infixr 6 :

1+module Cons where

3−foreign import (:) :: forall a. a -> [a] -> [a]

3+ infixr 6 :

5−test1 = \xs -> 1 : xs

5+ foreign import (:) :: forall a. a -> [a] -> [a]

7−test2 = 1 : 2 : 3 : []

7+ test1 = \xs -> 1 : xs

9+ test2 = 1 : 2 : 3 : []

examples/passing/Console.purs+17−15

@@ -1,23 +1,25 @@

1−foreign import data IO :: * -> *

1+module Console where

3−foreign import ret :: forall a. a -> IO a

3+ foreign import data IO :: * -> *

5−foreign import (>>=) :: forall a b. IO a -> (a -> IO b) -> IO b

5+ foreign import ret :: forall a. a -> IO a

7−(*>) = \a -> \b -> a >>= \x -> b

7+ foreign import (>>=) :: forall a b. IO a -> (a -> IO b) -> IO b

9−foreign import putStrLn :: String -> IO {}

9+ (*>) = \a -> \b -> a >>= \x -> b

1010

11−replicateM_ :: forall a. Number -> IO a -> IO {}

12−replicateM_ = \n -> \x ->

13− {

14− var io = ret {};

15− for (i <- 0 until n)

16− {

17− io = x *> io;

11+ foreign import putStrLn :: String -> IO {}

12+

13+ replicateM_ :: forall a. Number -> IO a -> IO {}

14+ replicateM_ = \n -> \x ->

15+ {

16+ var io = ret {};

17+ for (i <- 0 until n)

18+ {

19+ io = x *> io;

20+ }

21+ return io;

1822 }

19− return io;

20− }

2123

22−main = replicateM_ 10 (putStrLn "Hello World!")

24+ main = replicateM_ 10 (putStrLn "Hello World!")

2325

examples/passing/DataImport.pursnew file+10

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

1+module M1 where

3+data Test = Test

5+module M2 where

7+import M1

9+test :: Test -> M1.Test

10+test t = t

examples/passing/ExternData.purs+9−7

@@ -1,13 +1,15 @@

1−foreign import data IO :: * -> *

1+module ExternData where

3−foreign import fmap :: forall a b. IO a -> (a -> b) -> IO b

3+ foreign import data IO :: * -> *

5−foreign import ret :: forall a. a -> IO a

5+ foreign import fmap :: forall a b. IO a -> (a -> b) -> IO b

7−foreign import bind :: forall a b. IO a -> (a -> IO b) -> IO b

7+ foreign import ret :: forall a. a -> IO a

9−foreign import showMessage :: String -> IO { }

9+ foreign import bind :: forall a b. IO a -> (a -> IO b) -> IO b

1010

11−foreign import prompt :: IO String

11+ foreign import showMessage :: String -> IO { }

1212

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

13+ foreign import prompt :: IO String

14+

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

examples/passing/FFI.purs+8−1

@@ -1,5 +1,12 @@

1+module FFI where

13foreign import foo :: String -> String

35bar :: String -> String

4−

56bar = \x -> foo (x ++ "bar")

8+module FFIModuleTest where

10+import FFI

11+

12+baz = foo "test"

examples/passing/Foreach.purs+8−6

@@ -1,7 +1,9 @@

1−sum = \ns -> {

2− var total = 0;

3− foreach (n in ns) {

4− total = total + n;

1+module Foreach where

3+ sum = \ns -> {

4+ var total = 0;

5+ foreach (n in ns) {

6+ total = total + n;

7+ }

8+ return total;

59 }

6− return total;

7− }

examples/passing/Functions.purs+8−6

@@ -1,11 +1,13 @@

1−test1 = \ -> 0

1+module Functions where

3−test2 = \() -> 0

3+ test1 = \ -> 0

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

5+ test2 = \() -> 0

7−test4 = \(a) -> a

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

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

9+ test4 = \(a) -> a

1010

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

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

12+

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

examples/passing/Guards.purs+9−7

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

1−collatz = \x -> case x of

2− y | y % 2 == 0 -> y / 2

3− y -> y * 3 + 1

1+module Guards where

5−-- Guards have access to current scope

6−collatz2 = \x y -> case x of

7− z | y > 0 -> z / 2

8− z -> z * 3 + 1

3+ collatz = \x -> case x of

4+ y | y % 2 == 0 -> y / 2

5+ y -> y * 3 + 1

7+ -- Guards have access to current scope

8+ collatz2 = \x y -> case x of

9+ z | y > 0 -> z / 2

10+ z -> z * 3 + 1

examples/passing/IfThenElse.purs+30−28

@@ -1,34 +1,36 @@

1−testIf =

2− {

3− var x = 0;

4− if (x == 0) {

5− x = x + 1;

6− }

7− return x;

8− }

1+module IfThenElse where

10−testIfElse =

11− {

12− var x = 0;

13− if (x == 0) {

14− x = x + 1;

15− } else {

16− x = x - 1;

3+ testIf =

4+ {

5+ var x = 0;

6+ if (x == 0) {

7+ x = x + 1;

8+ }

9+ return x;

1710 }

18− return x;

19− }

2011

21−testIfElseIf = \x ->

22− {

23− var y = x;

24− while (y > 1) {

25− if (y % 3 == 0) {

26− y = y / 3;

27− } else if (y % 3 == 1) {

28− y = (y - 1) % 3;

12+ testIfElse =

13+ {

14+ var x = 0;

15+ if (x == 0) {

16+ x = x + 1;

2917 } else {

30− y = y * 4 + 1;

18+ x = x - 1;

19+ }

20+ return x;

21+ }

22+

23+ testIfElseIf = \x ->

24+ {

25+ var y = x;

26+ while (y > 1) {

27+ if (y % 3 == 0) {

28+ y = y / 3;

29+ } else if (y % 3 == 1) {

30+ y = (y - 1) % 3;

31+ } else {

32+ y = y * 4 + 1;

33+ }

3134 }

35+ return y;

3236 }

33− return y;

34− }

examples/passing/Import.purs+6−6

@@ -1,12 +1,12 @@

1−module Hello where

1+module M1 where

23 id :: forall a. a -> a

34 id = \x -> x

5− module Nested where

6− import Hello (id)

6+ foo = id

8− foo = id

8+module M2 where

10−import Hello.Nested

10+ import M1

1111

12−main = \() -> foo 42

12+ main = \() -> foo 42

examples/passing/List.purs+17−15

@@ -1,19 +1,21 @@

1−data List a

2− = Nil

3− | Cons

4− { head :: a

5− , tail :: List a

6− }

1+module List where

3+ data List a

4+ = Nil

5+ | Cons

6+ { head :: a

7+ , tail :: List a

8+ }

8−isNull Nil = true

9−isNull _ = false

10+ isNull Nil = true

11+ isNull _ = false

1012

11−concat Nil l2 = l2

12−concat (Cons x) l2 = Cons

13− { head: x.head

14− , tail: concat x.tail l2

15− }

13+ concat Nil l2 = l2

14+ concat (Cons x) l2 = Cons

15+ { head: x.head

16+ , tail: concat x.tail l2

17+ }

1618

17−flatten Nil = Nil

18−flatten (Cons cons) = concat cons.head (flatten cons.tail)

19+ flatten Nil = Nil

20+ flatten (Cons cons) = concat cons.head (flatten cons.tail)

1921

examples/passing/Match.purs+4−2

@@ -1,3 +1,5 @@

1−data Foo a = Foo

1+module Match where

3−foo = \f -> case f of Foo -> "foo"

3+ data Foo a = Foo

5+ foo = \f -> case f of Foo -> "foo"

examples/passing/Maybe.purs+8−6

@@ -1,9 +1,11 @@

1−data Maybe a = Nothing | Just a

1+module Maybe where

3−maybe :: forall a b. b -> (a -> b) -> Maybe a -> b

4−maybe b _ Nothing = b

5−maybe _ f (Just a) = f a

3+ data Maybe a = Nothing | Just a

7−fmap m f = maybe Nothing (\a -> Just (f a)) m

5+ maybe :: forall a b. b -> (a -> b) -> Maybe a -> b

6+ maybe b _ Nothing = b

7+ maybe _ f (Just a) = f a

9−bind m f = maybe Nothing f m

9+ fmap m f = maybe Nothing (\a -> Just (f a)) m

10+

11+ bind m f = maybe Nothing f m

examples/passing/MethodCall.purs+7−5

@@ -1,6 +1,8 @@

1−foreign import foo :: () -> {}

1+module MethodCall where

3−test = {

4− foo();

5− return 0;

6− }

3+ foreign import foo :: () -> {}

5+ test = {

6+ foo();

7+ return 0;

8+ }

examples/passing/Module.purs+7−12

@@ -1,8 +1,8 @@

1−module Test where

1+module M1 where

33 data Foo = Foo String

5− foo :: Test.Foo -> String

5+ foo :: M1.Foo -> String

66 foo = \f -> case f of Foo s -> s ++ "foo"

88 bar :: Foo -> String

@@ -11,15 +11,10 @@ module Test where

1111 incr :: Number -> Number

1212 incr x = x + 1

1313

14− module Inner where

14+module M2 where

1515

16− inner = "Inner"

16+ baz :: M1.Foo -> String

17+ baz = M1.foo

1718

18−baz :: Test.Foo -> String

19−baz = Test.foo

20−

21−innerCopy :: String

22−innerCopy = Test.Inner.inner

23−

24−match :: Test.Foo -> String

25−match = \f -> case f of Test.Foo s -> s ++ "foo"

19+ match :: M1.Foo -> String

20+ match = \f -> case f of M1.Foo s -> s ++ "foo"

examples/passing/Monad.purs+21−19

@@ -1,26 +1,28 @@

1−type Monad m = { ret :: forall a. a -> m a

2− , bind :: forall a b. m a -> (a -> m b) -> m b }

1+module Monad where

4−data Id a = Id a

3+ type Monad m = { ret :: forall a. a -> m a

4+ , bind :: forall a b. m a -> (a -> m b) -> m b }

6−id :: Monad Id

7−id = { ret : Id

8− , bind : \ma f -> case ma of Id a -> f a }

6+ data Id a = Id a

10−data Maybe a = Nothing | Just a

8+ id :: Monad Id

9+ id = { ret : Id

10+ , bind : \ma f -> case ma of Id a -> f a }

1111

12−maybe :: Monad Maybe

13−maybe = { ret : Just

14− , bind : \ma f -> case ma of

15− Nothing -> Nothing

16− Just a -> f a

17− }

12+ data Maybe a = Nothing | Just a

1813

19−test :: forall m. Monad m -> m Number

20−test = \m -> m.bind (m.ret 1) (\n1 ->

21− m.bind (m.ret "Test") (\n2 ->

22− m.ret n1))

14+ maybe :: Monad Maybe

15+ maybe = { ret : Just

16+ , bind : \ma f -> case ma of

17+ Nothing -> Nothing

18+ Just a -> f a

19+ }

2320

24−test1 = test id

21+ test :: forall m. Monad m -> m Number

22+ test = \m -> m.bind (m.ret 1) (\n1 ->

23+ m.bind (m.ret "Test") (\n2 ->

24+ m.ret n1))

2525

26−test2 = test maybe

26+ test1 = test id

27+

28+ test2 = test maybe

examples/passing/MutRec.pursnew file+15

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

1+module MutRec where

3+ f 0 = 0

4+ f x = g x + 1

6+ g x = f (x / 2)

8+ data Even = Zero | Even Odd

10+ data Odd = Odd Even

11+

12+ evenToNumber Zero = 0

13+ evenToNumber (Even n) = oddToNumber n + 1

14+

15+ oddToNumber (Odd n) = evenToNumber n + 1

examples/passing/NameResolution.pursdeleted−15

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

1−foo = \x -> x

2−

3−module A where

4− bar = foo

5−

6− module B where

7−

8− abc = foo

9− xyz = bar

10−

11− foo = \x y -> x

12−

13− baz = foo

14−

15− abc = A.B.abc

examples/passing/NamedPatterns.purs+5−3

@@ -1,3 +1,5 @@

1−foo = \x -> case x of

2− y@{ foo = "Foo" } -> y

3− y -> y

1+module NamedPatterns where

3+ foo = \x -> case x of

4+ y@{ foo = "Foo" } -> y

5+ y -> y

examples/passing/Nested.purs+4−2

@@ -1,3 +1,5 @@

1−data Extend r a = Extend { prev :: r a, next :: a }

1+module Nested where

3−data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)

3+ data Extend r a = Extend { prev :: r a, next :: a }

5+ data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)

examples/passing/ObjectUpdate.purs+12−10

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

1−update1 = \o -> o { foo = "Foo" }

1+module ObjectUpdate where

3−update2 :: forall r. { foo :: String | r } -> { foo :: String | r }

4−update2 = \o -> o { foo = "Foo" }

3+ update1 = \o -> o { foo = "Foo" }

6−replace = \o -> case o of

7− { foo = "Foo" } -> o { foo = "Bar" }

8− { foo = "Bar" } -> o { bar = "Baz" }

9− o -> o

5+ update2 :: forall r. { foo :: String | r } -> { foo :: String | r }

6+ update2 = \o -> o { foo = "Foo" }

107

11−polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }

12−polyUpdate = \o -> o { foo = "Foo" }

8+ replace = \o -> case o of

9+ { foo = "Foo" } -> o { foo = "Bar" }

10+ { foo = "Bar" } -> o { bar = "Baz" }

11+ o -> o

1312

14−inferPolyUpdate = \o -> o { foo = "Foo" }

13+ polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }

14+ polyUpdate = \o -> o { foo = "Foo" }

15+

16+ inferPolyUpdate = \o -> o { foo = "Foo" }

examples/passing/Objects.purs+9−7

@@ -1,12 +1,14 @@

1−test = \x -> x.foo + x.bar

1+module Objects where

3−append = \o -> { foo: o.foo, bar: 1 }

3+ test = \x -> x.foo + x.bar

5−apTest = append({foo : "Foo", baz: "Baz"})

5+ append = \o -> { foo: o.foo, bar: 1 }

7−f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }

7+ apTest = append({foo : "Foo", baz: "Baz"})

9−g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }

9+ f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }

1010

11−typed :: { foo :: Number }

12−typed = { foo: 0 }

11+ g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }

12+

13+ typed :: { foo :: Number }

14+ typed = { foo: 0 }

examples/passing/Operators.purs+27−25

@@ -1,42 +1,44 @@

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

1+module Operators1 where

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

3+ (@@) :: forall a b. (a -> b) -> a -> b

4+ (@@) = \f x -> f x

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

6+ foo :: String -> String

7+ foo = \s -> s

9+ test8 = foo @@ "Hello World"

610

7−k = \x -> \y -> x

11+ bar = \s1 s2 -> s1 ++ s2

812

9−test4 = 1 `k` 2

13+module Operators2 where

1014

11−infixl 5 %%

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

1216

13−(%%) = \x -> \y -> x * y + y

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

1418

15−test5 = 1 %% 2 %% 3

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

1620

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

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

1822

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

23+ test4 = 1 `k` 2

2024

21−test7 = "Hello" <> "World!"

25+ infixl 5 %%

2226

23−module Ops where

24−

25− (@@) :: forall a b. (a -> b) -> a -> b

26− (@@) = \f x -> f x

27+ (%%) = \x -> \y -> x * y + y

2728

28− foo :: String -> String

29− foo = \s -> s

30−

31− test8 = foo @@ "Hello World"

29+ test5 = 1 %% 2 %% 3

3230

33− bar = \s1 s2 -> s1 ++ s2

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

32+

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

34+

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

3436

35−test9 = Ops.foo Ops.@@ "Hello World"

37+ test9 = Operators1.foo Operators1.@@ "Hello World"

3638

37−test10 = "Hello" `Ops.bar` "World"

39+ test10 = "Hello" `Operators1.bar` "World"

3840

39−(...) :: forall a. [a] -> [a] -> [a]

40−(...) = \as -> \bs -> as

41+ (...) :: forall a. [a] -> [a] -> [a]

42+ (...) = \as -> \bs -> as

4143

42−test11 = [1, 2, 3] ... [4, 5, 6]

44+ test11 = [1, 2, 3] ... [4, 5, 6]

examples/passing/Patterns.purs+20−18

@@ -1,23 +1,25 @@

1−test = \x -> case x of

2− { str = "Foo", bool = true } -> true

3− { str = "Bar", bool = b } -> b

4− _ -> false

1+module Patterns where

6−f = \o -> case o of

7− { foo = "Foo" } -> o.bar

8− _ -> 0

3+ test = \x -> case x of

4+ { str = "Foo", bool = true } -> true

5+ { str = "Bar", bool = b } -> b

6+ _ -> false

10−g = \o -> case o of

11− { arr = [x : xs], take = "car" } -> x

12− { arr = [_, x : xs], take = "cadr" } -> x

13− _ -> 0

8+ f = \o -> case o of

9+ { foo = "Foo" } -> o.bar

10+ _ -> 0

1411

12+ g = \o -> case o of

13+ { arr = [x : xs], take = "car" } -> x

14+ { arr = [_, x : xs], take = "cadr" } -> x

15+ _ -> 0

1516

16−h = \o -> case o of

17− a@[_,_,_] -> a

18− _ -> []

1917

20−isDesc = \o -> case o of

21− [x, y] | x > y -> true

22− _ -> false

23−

18+ h = \o -> case o of

19+ a@[_,_,_] -> a

20+ _ -> []

21+

22+ isDesc = \o -> case o of

23+ [x, y] | x > y -> true

24+ _ -> false

25+

examples/passing/Person.purs+8−6

@@ -1,7 +1,9 @@

1−data Person = Person { name :: String, age :: Number }

1+module Person where

3−foreign import itoa :: Number -> String

4−

5−showPerson :: Person -> String

6−showPerson = \p -> case p of

7− Person o -> o.name ++ ", aged " ++ itoa(o.age)

3+ data Person = Person { name :: String, age :: Number }

5+ foreign import itoa :: Number -> String

7+ showPerson :: Person -> String

8+ showPerson = \p -> case p of

9+ Person o -> o.name ++ ", aged " ++ itoa(o.age)

examples/passing/Rank2Data.purs+18−16

@@ -1,23 +1,25 @@

1−data Id = Id forall a. a -> a

1+module Rank2Data where

3−runId = \id a -> case id of

4− Id f -> f a

3+ data Id = Id forall a. a -> a

6−data Nat = Nat forall r. r -> (r -> r) -> r

5+ runId = \id a -> case id of

6+ Id f -> f a

8−runNat = \nat -> case nat of

9− Nat f -> f 0 (\n -> n + 1)

8+ data Nat = Nat forall r. r -> (r -> r) -> r

109

11−zero = Nat (\zero _ -> zero)

10+ runNat = \nat -> case nat of

11+ Nat f -> f 0 (\n -> n + 1)

1212

13−succ = \n -> case n of

14− Nat f -> Nat (\zero succ -> succ (f zero succ))

13+ zero = Nat (\zero _ -> zero)

1514

16−add = \n m -> case n of

17− Nat f -> case m of

18− Nat g -> Nat (\zero succ -> g (f zero succ) succ)

15+ succ = \n -> case n of

16+ Nat f -> Nat (\zero succ -> succ (f zero succ))

1917

20−one = succ zero

21−two = succ zero

22−four = add two two

23−fourNumber = runNat four

18+ add = \n m -> case n of

19+ Nat f -> case m of

20+ Nat g -> Nat (\zero succ -> g (f zero succ) succ)

21+

22+ one = succ zero

23+ two = succ zero

24+ four = add two two

25+ fourNumber = runNat four

examples/passing/Rank2Types.purs+13−11

@@ -1,17 +1,19 @@

1−test1 :: (forall a. (a -> a)) -> Number

2−test1 = \f -> f 0

1+module Rank2Types where

4−foreign import data ST :: * -> * -> *

3+ test1 :: (forall a. (a -> a)) -> Number

4+ test1 = \f -> f 0

6−foreign import runST :: forall a. (forall s. ST s a) -> a

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

8−foreign import exampleST :: forall s. ST s Number

8+ foreign import runST :: forall a. (forall s. ST s a) -> a

10−testST = runST exampleST

10+ foreign import exampleST :: forall s. ST s Number

1111

12−foreign import push :: forall el. el -> [el] -> [el]

12+ testST = runST exampleST

1313

14−replicateM :: forall m a. (forall a. a -> m a) -> (forall a b. m a -> (a -> m b) -> m b) -> Number -> m a -> m [a]

15−replicateM = \ret bind n m -> case n of

16− 0 -> ret []

17− n -> bind m (\x -> bind (replicateM ret bind (n - 1) m) (\xs -> ret (push x xs)))

14+ foreign import push :: forall el. el -> [el] -> [el]

15+

16+ replicateM :: forall m a. (forall a. a -> m a) -> (forall a b. m a -> (a -> m b) -> m b) -> Number -> m a -> m [a]

17+ replicateM = \ret bind n m -> case n of

18+ 0 -> ret []

19+ n -> bind m (\x -> bind (replicateM ret bind (n - 1) m) (\xs -> ret (push x xs)))

examples/passing/Recursion.purs+6−4

@@ -1,4 +1,6 @@

1−fib = \n -> case n of

2− 0 -> 1

3− 1 -> 1

4− n -> fib (n - 1) + fib (n - 2)

1+module Recursion where

3+ fib = \n -> case n of

4+ 0 -> 1

5+ 1 -> 1

6+ n -> fib (n - 1) + fib (n - 2)

examples/passing/TopLevelCase.purs+11−9

@@ -1,12 +1,14 @@

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

2−gcd (0, x) = x

3−gcd (x, 0) = x

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

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

1+module TopLevelCase where

7−guardsTest (x:xs) | x > 0 = guardsTest xs

8−guardsTest xs = xs

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

4+ gcd (0, x) = x

5+ gcd (x, 0) = x

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

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

10−data A = A

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

10+ guardsTest xs = xs

1111

12−parseTest A 0 = 0

12+ data A = A

13+

14+ parseTest A 0 = 0

examples/passing/TypeDecl.purs+13−11

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

1−id :: forall a. (a) -> a

2−id = \x -> x

1+module TypeDecl where

4−k :: String -> Number -> String

5−k = \x -> \y -> x

3+ id :: forall a. (a) -> a

4+ id = \x -> x

7−iterate :: forall a. Number -> (a -> a) -> a -> a

8−iterate = \n -> \f -> \a -> {

9− var result = a;

10− for (i <- 0 until n) {

11− result = f result;

6+ k :: String -> Number -> String

7+ k = \x -> \y -> x

9+ iterate :: forall a. Number -> (a -> a) -> a -> a

10+ iterate = \n -> \f -> \a -> {

11+ var result = a;

12+ for (i <- 0 until n) {

13+ result = f result;

14+ }

15+ return result;

1216 }

13− return result;

14− }

examples/passing/TypeSynonyms.purs+26−24

@@ -1,31 +1,33 @@

1−type Lens a b =

2− { get :: a -> b

3− , set :: a -> b -> a

4− }

1+module TypeSynonyms where

6−composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c

7−composeLenses = \l1 -> \l2 ->

8− { get: \a -> l2.get (l1.get a)

9− , set: \a -> \c ->

10− {

11− var b = l1.get a;

12− var b1 = l2.set b c;

13− return l1.set a b1;

3+ type Lens a b =

4+ { get :: a -> b

5+ , set :: a -> b -> a

146 }

15− }

167

17−type Pair a b = { fst :: a, snd :: b }

8+ composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c

9+ composeLenses = \l1 -> \l2 ->

10+ { get: \a -> l2.get (l1.get a)

11+ , set: \a -> \c ->

12+ {

13+ var b = l1.get a;

14+ var b1 = l2.set b c;

15+ return l1.set a b1;

16+ }

17+ }

18+

19+ type Pair a b = { fst :: a, snd :: b }

1820

19−fst :: forall a b. Lens (Pair a b) a

20−fst =

21− { get: \p -> p.fst

22− , set: \p -> \a -> { fst: a, snd: p.snd }

23− }

21+ fst :: forall a b. Lens (Pair a b) a

22+ fst =

23+ { get: \p -> p.fst

24+ , set: \p -> \a -> { fst: a, snd: p.snd }

25+ }

2426

25−test1 :: forall a b c. Lens (Pair (Pair a b) c) a

26−test1 = composeLenses fst fst

27+ test1 :: forall a b c. Lens (Pair (Pair a b) c) a

28+ test1 = composeLenses fst fst

2729

28−foreign import head :: forall a. Lens [a] a

30+ foreign import head :: forall a. Lens [a] a

2931

30−test2 :: forall a b c. Lens (Pair [Pair a b] c) a

31−test2 = composeLenses fst (composeLenses head fst)

32+ test2 :: forall a b c. Lens (Pair [Pair a b] c) a

33+ test2 = composeLenses fst (composeLenses head fst)

examples/passing/iota.purs+5−3

@@ -1,5 +1,7 @@

1−s = \x -> \y -> \z -> x z (y z)

1+module Iota where

3−k = \x -> \y -> x

3+ s = \x -> \y -> \z -> x z (y z)

5−iota = \x -> x s k

5+ k = \x -> \y -> x

7+ iota = \x -> x s k

examples/passing/s.purs+3−1

@@ -1 +1,3 @@

1−s = \x y z -> x z (y z)

1+module S where

3+ s = \x y z -> x z (y z)

examples/shelltest/Foreach.js+1−1

@@ -1 +1 @@

1−console.log(sum([1,2,3,4,5]));

1+console.log(Foreach.sum([1,2,3,4,5]));

examples/shelltest/List.js+4−4

@@ -1,7 +1,7 @@

1−var l1 = Cons({ head: 1, tail: Nil });

2−var l2 = Cons({ head: 2, tail: Nil });

3−var l3 = Cons({ head: l1, tail: Cons({ head: l2, tail: Nil }) });

4−var flat = flatten(l3);

1+var l1 = List.Cons({ head: 1, tail: List.Nil });

2+var l2 = List.Cons({ head: 2, tail: List.Nil });

3+var l3 = List.Cons({ head: l1, tail: List.Cons({ head: l2, tail: List.Nil }) });

4+var flat = List.flatten(l3);

55var f1 = flat.value.head;

66var f2 = flat.value.tail.value.head

77console.log([f1, f2]);

examples/shelltest/Maybe.js+3−3

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

1−console.log(bind(Just("a"))(function(a) {

2− return bind(Just("b"))(function(b) {

3− return Just(a + b);

1+console.log(Maybe.bind(Maybe.Just("a"))(function(a) {

2+ return Maybe.bind(Maybe.Just("b"))(function(b) {

3+ return Maybe.Just(a + b);

44 });

55}));

examples/shelltest/runAll.test+1−1

@@ -2,7 +2,7 @@

22mkdir -p tests && ../../dist/build/psc/psc ../passing/Maybe.purs -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | nodejs

33<<<

44>>>

5−{ ctor: 'Just', value: 'ab' }

5+{ ctor: 'Maybe.Just', value: 'ab' }

66>>>2

77>>>= 0

libraries/jquery/example.purs+10−6

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

1−main = {

2− var div = create "<div>";

3− div = div `appendText` "Hello World!" `css` { color: "#FF0000" };

4− div = div `appendTo` select "body";

5− return { };

6− }

1+module Example where

3+ import JQuery

5+ main = {

6+ var div = create "<div>";

7+ div = div `appendText` "Hello World!" `css` { color: "#FF0000" };

8+ div = div `appendTo` select "body";

9+ return { };

10+ }

libraries/jquery/jquery.purs+18−16

@@ -1,23 +1,25 @@

1−-- The jQuery wrapper type

2−foreign import data JQuery :: *

1+module JQuery where

4−-- Wrapper function for jQuery selection $('..')

5−foreign import select :: String -> JQuery

3+ -- The jQuery wrapper type

4+ foreign import data JQuery :: *

7−-- Wrapper function for jQuery creation e.g. $('<div>')

8−foreign import create :: String -> JQuery

6+ -- Wrapper function for jQuery selection $('..')

7+ foreign import select :: String -> JQuery

10−-- .attr({ ... })

11−foreign import attr :: forall attr. JQuery -> { | attr } -> JQuery

9+ -- Wrapper function for jQuery creation e.g. $('<div>')

10+ foreign import create :: String -> JQuery

1211

13−-- .css({ ... })

14−foreign import css :: forall css. JQuery -> { | css } -> JQuery

12+ -- .attr({ ... })

13+ foreign import attr :: forall attr. JQuery -> { | attr } -> JQuery

1514

16−-- .append(...)

17−foreign import append :: JQuery -> JQuery -> JQuery

15+ -- .css({ ... })

16+ foreign import css :: forall css. JQuery -> { | css } -> JQuery

1817

19−-- .appendTo(...)

20−foreign import appendTo :: JQuery -> JQuery -> JQuery

18+ -- .append(...)

19+ foreign import append :: JQuery -> JQuery -> JQuery

2120

22−-- .append(...)

23−foreign import appendText :: JQuery -> String -> JQuery

21+ -- .appendTo(...)

22+ foreign import appendTo :: JQuery -> JQuery -> JQuery

23+

24+ -- .append(...)

25+ foreign import appendText :: JQuery -> String -> JQuery

libraries/prelude/prelude.purs+177−171

@@ -1,263 +1,269 @@

1−id :: forall a. a -> a

2−id = \x -> x

1+module Prelude where

4−flip :: forall a b c. (a -> b -> c) -> b -> a -> c

5−flip = \f -> \b -> \a -> f a b

3+ id :: forall a. a -> a

4+ id = \x -> x

7−konst :: forall a b. a -> b -> a

8−konst = \a -> \b -> a

6+ flip :: forall a b c. (a -> b -> c) -> b -> a -> c

7+ flip = \f -> \b -> \a -> f a b

10−(|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c

11−(|>) = \f -> \g -> \a -> g (f a)

9+ konst :: forall a b. a -> b -> a

10+ konst = \a -> \b -> a

1211

13−(<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c

14−(<|) = flip (|>)

12+ (|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c

13+ (|>) = \f -> \g -> \a -> g (f a)

1514

16−-- Maybe

15+ (<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c

16+ (<|) = flip (|>)

1717

18−data Maybe a = Nothing | Just a

18+module Maybe where

1919

20−maybe :: forall a b. b -> (a -> b) -> Maybe a -> b

21−maybe b _ Nothing = b

22−maybe _ f (Just a) = f a

20+ data Maybe a = Nothing | Just a

2321

24−fromMaybe :: forall a. a -> Maybe a -> a

25−fromMaybe a = maybe a id

22+ maybe :: forall a b. b -> (a -> b) -> Maybe a -> b

23+ maybe b _ Nothing = b

24+ maybe _ f (Just a) = f a

2625

27−bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b

28−bindMaybe m f = maybe Nothing f m

26+ fromMaybe :: forall a. a -> Maybe a -> a

27+ fromMaybe a = maybe a Prelude.id

2928

30−-- Either

29+ bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b

30+ bindMaybe m f = maybe Nothing f m

3131

32−data Either a b = Left a | Right b

32+module Either where

3333

34−either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c

35−either f _ (Left a) = f a

36−either _ g (Right b) = g b

34+ data Either a b = Left a | Right b

3735

38−bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b

39−bindEither = either (\e _ -> Left e) (\a f -> f a)

36+ either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c

37+ either f _ (Left a) = f a

38+ either _ g (Right b) = g b

4039

41−-- Arrays

40+ bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b

41+ bindEither = either (\e _ -> Left e) (\a f -> f a)

4242

43−head :: forall a. [a] -> a

44−head (x : _) = x

43+module Arrays where

4544

46−headSafe :: forall a. [a] -> Maybe a

47−headSafe (x : _) = Just x

48−headSafe _ = Nothing

45+ import Maybe

4946

50−tail :: forall a. [a] -> [a]

51−tail (_ : xs) = xs

47+ head :: forall a. [a] -> a

48+ head (x : _) = x

5249

53−tailSafe :: forall a. [a] -> Maybe [a]

54−tailSafe (_ : xs) = Just xs

55−tailSafe _ = Nothing

50+ headSafe :: forall a. [a] -> Maybe a

51+ headSafe (x : _) = Just x

52+ headSafe _ = Nothing

5653

57−foreign import map :: forall a b. (a -> b) -> [a] -> [b]

54+ tail :: forall a. [a] -> [a]

55+ tail (_ : xs) = xs

5856

59−foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a

60−foldr f a (b : bs) = f (foldr f a bs) b

61−foldr _ a [] = a

57+ tailSafe :: forall a. [a] -> Maybe [a]

58+ tailSafe (_ : xs) = Just xs

59+ tailSafe _ = Nothing

6260

63−foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b

64−foldl f b as = {

65− var result = b;

66− foreach (a in as) {

67− result = f a result;

61+ foreign import map :: forall a b. (a -> b) -> [a] -> [b]

62+

63+ foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a

64+ foldr f a (b : bs) = f (foldr f a bs) b

65+ foldr _ a [] = a

66+

67+ foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b

68+ foldl f b as = {

69+ var result = b;

70+ foreach (a in as) {

71+ result = f a result;

72+ }

73+ return result;

6874 }

69− return result;

70− }

7175

72−foreign import member "length" length :: forall a. [a] -> Number

76+ foreign import member "length" length :: forall a. [a] -> Number

7377

74−foreign import indexOf :: forall a. [a] -> a -> Number

78+ foreign import indexOf :: forall a. [a] -> a -> Number

7579

76−foreign import lastIndexOf :: forall a. [a] -> a -> Number

80+ foreign import lastIndexOf :: forall a. [a] -> a -> Number

7781

78−foreign import concat :: forall a. [a] -> [a] -> [a]

82+ foreign import concat :: forall a. [a] -> [a] -> [a]

7983

80−foreign import join :: [String] -> String

84+ foreign import join :: [String] -> String

8185

82−foreign import joinWith :: [String] -> String -> String

86+ foreign import joinWith :: [String] -> String -> String

8387

84−foreign import push :: forall a. [a] -> a -> [a]

88+ foreign import push :: forall a. [a] -> a -> [a]

8589

86−foreign import reverse :: forall a. [a] -> [a]

90+ foreign import reverse :: forall a. [a] -> [a]

8791

88−foreign import shift :: forall a. [a] -> [a]

92+ foreign import shift :: forall a. [a] -> [a]

8993

90−foreign import slice :: forall a. Number -> Number -> [a] -> [a]

94+ foreign import slice :: forall a. Number -> Number -> [a] -> [a]

9195

92−foreign import sort :: forall a. [a] -> [a]

96+ foreign import sort :: forall a. [a] -> [a]

9397

94−foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]

98+ foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]

9599

96−cons :: forall a. a -> [a] -> [a]

97−cons = \a -> concat([a])

100+ cons :: forall a. a -> [a] -> [a]

101+ cons a = concat [a]

98102

99−concatMap :: forall a b. [a] -> (a -> [b]) -> [b]

100−concatMap as f = {

101− var result = [];

102− foreach (a in as) {

103− result = result `concat` f a;

103+ concatMap :: forall a b. [a] -> (a -> [b]) -> [b]

104+ concatMap as f = {

105+ var result = [];

106+ foreach (a in as) {

107+ result = result `concat` f a;

108+ }

109+ return result;

104110 }

105− return result;

106− }

107111

108−foreign import filter :: forall a. [a] -> (a -> Boolean) -> [a]

112+ foreign import filter :: forall a. [a] -> (a -> Boolean) -> [a]

109113

110−empty :: forall a. [a] -> Boolean

111−empty [] = true

112−empty _ = false

114+ empty :: forall a. [a] -> Boolean

115+ empty [] = true

116+ empty _ = false

113117

114−range :: Number -> Number -> [Number]

115−range lo hi = {

116− var ns = [];

117− for (n <- lo until hi) {

118− ns = push ns n;

118+ range :: Number -> Number -> [Number]

119+ range lo hi = {

120+ var ns = [];

121+ for (n <- lo until hi) {

122+ ns = push ns n;

123+ }

124+ return ns;

119125 }

120− return ns;

121− }

122−

123−zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

124−zipWith f (a:as) (b:bs) = cons (f a b) (zipWith f as bs)

125−zipWith _ _ _ = []

126−

127−any :: forall a. (a -> Boolean) -> [a] -> Boolean

128−any p as = {

129− for (i <- 0 until length as) {

130− if (p (as !! i)) {

131− return true;

126+

127+ zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

128+ zipWith f (a:as) (b:bs) = cons (f a b) (zipWith f as bs)

129+ zipWith _ _ _ = []

130+

131+ any :: forall a. (a -> Boolean) -> [a] -> Boolean

132+ any p as = {

133+ for (i <- 0 until length as) {

134+ if (p (as !! i)) {

135+ return true;

136+ }

132137 }

138+ return false;

133139 }

134− return false;

135− }

136−

137−all :: forall a. (a -> Boolean) -> [a] -> Boolean

138−all p as = {

139− for (i <- 0 until length as) {

140− if (!(p (as !! i))) {

141− return false;

140+

141+ all :: forall a. (a -> Boolean) -> [a] -> Boolean

142+ all p as = {

143+ for (i <- 0 until length as) {

144+ if (!(p (as !! i))) {

145+ return false;

146+ }

142147 }

148+ return true;

143149 }

144− return true;

145− }

146150

147−-- Pairs

151+module Tuple where

148152

149−type Tuple a b = { fst :: a, snd :: b }

153+ import Arrays

150154

151−curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c

152−curry f a b = f { fst: a, snd: b }

155+ type Tuple a b = { fst :: a, snd :: b }

153156

154−uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c

155−uncurry f t = f t.fst t.snd

157+ curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c

158+ curry f a b = f { fst: a, snd: b }

156159

157−tuple :: forall a b. a -> b -> Tuple a b

158−tuple = curry id

160+ uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c

161+ uncurry f t = f t.fst t.snd

159162

160−zip :: forall a b. [a] -> [b] -> [Tuple a b]

161−zip = zipWith tuple

163+ tuple :: forall a b. a -> b -> Tuple a b

164+ tuple = curry Prelude.id

162165

163−unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]

164−unzip (t:ts) = case unzip ts of

165− { fst = as, snd = bs } -> tuple (cons t.fst as) (cons t.snd bs)

166−unzip [] = tuple [] []

166+ zip :: forall a b. [a] -> [b] -> [Tuple a b]

167+ zip = zipWith tuple

167168

168−-- Strings

169+ unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]

170+ unzip (t:ts) = case unzip ts of

171+ { fst = as, snd = bs } -> tuple (cons t.fst as) (cons t.snd bs)

172+ unzip [] = tuple [] []

169173

170−foreign import member "length" lengthS :: String -> Number

174+module String where

171175

172−foreign import charAt :: Number -> String -> String

176+ foreign import member "length" lengthS :: String -> Number

173177

174−foreign import indexOfS :: String -> String -> Number

178+ foreign import charAt :: Number -> String -> String

175179

176−foreign import lastIndexOfS :: String -> String -> Number

180+ foreign import indexOfS :: String -> String -> Number

177181

178−foreign import localeCompare :: String -> String -> Number

182+ foreign import lastIndexOfS :: String -> String -> Number

179183

180−foreign import replace :: String -> String -> String -> String

184+ foreign import localeCompare :: String -> String -> Number

181185

182−foreign import sliceS :: Number -> Number -> String -> String

186+ foreign import replace :: String -> String -> String -> String

183187

184−foreign import split :: String -> String -> [String]

188+ foreign import sliceS :: Number -> Number -> String -> String

185189

186−foreign import substr :: Number -> Number -> String -> String

190+ foreign import split :: String -> String -> [String]

187191

188−foreign import substring :: Number -> Number -> String -> String

192+ foreign import substr :: Number -> Number -> String -> String

189193

190−foreign import toLower :: String -> String

194+ foreign import substring :: Number -> Number -> String -> String

191195

192−foreign import toUpper :: String -> String

196+ foreign import toLower :: String -> String

193197

194−foreign import trim :: String -> String

198+ foreign import toUpper :: String -> String

195199

196−-- Regex

200+ foreign import trim :: String -> String

197201

198−foreign import data Regex :: *

202+module Regex where

199203

200−foreign import regex :: String -> String -> Regex

204+ foreign import data Regex :: *

201205

202−foreign import test :: Regex -> String -> Boolean

206+ foreign import regex :: String -> String -> Regex

203207

204−foreign import match :: Regex -> String -> [String]

208+ foreign import test :: Regex -> String -> Boolean

205209

206−foreign import replaceR :: Regex -> String -> String -> String

210+ foreign import match :: Regex -> String -> [String]

207211

208−foreign import search :: Regex -> String -> Number

212+ foreign import replaceR :: Regex -> String -> String -> String

209213

210−-- Globals

214+ foreign import search :: Regex -> String -> Number

211215

212−foreign import nan :: Number

216+module Global where

213217

214−foreign import infinity :: Number

218+ foreign import nan :: Number

215219

216−foreign import toExponential :: Number -> String

220+ foreign import infinity :: Number

217221

218−foreign import toFixed :: Number -> Number -> String

222+ foreign import toExponential :: Number -> String

219223

220−foreign import toPrecision :: Number -> Number -> String

224+ foreign import toFixed :: Number -> Number -> String

221225

222−foreign import numberToString :: Number -> String

226+ foreign import toPrecision :: Number -> Number -> String

223227

224−foreign import isNaN :: Number -> Boolean

228+ foreign import numberToString :: Number -> String

225229

226−foreign import isFinite :: Number -> Boolean

230+ foreign import isNaN :: Number -> Boolean

227231

228−foreign import parseFloat :: String -> Number

232+ foreign import isFinite :: Number -> Boolean

229233

230−foreign import parseInt :: String -> Number

234+ foreign import parseFloat :: String -> Number

231235

232−foreign import encodeURIComponent :: String -> String

236+ foreign import parseInt :: String -> Number

233237

234−foreign import decodeURIComponent :: String -> String

238+ foreign import encodeURIComponent :: String -> String

235239

236−foreign import encodeURI :: String -> String

240+ foreign import decodeURIComponent :: String -> String

237241

238−foreign import decodeURI :: String -> String

242+ foreign import encodeURI :: String -> String

239243

240−-- Math

244+ foreign import decodeURI :: String -> String

241245

242−type Math =

243− { abs :: Number -> Number

244− , acos :: Number -> Number

245− , asin :: Number -> Number

246− , atan :: Number -> Number

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

248− , aceil :: Number -> Number

249− , cos :: Number -> Number

250− , exp :: Number -> Number

251− , floor :: Number -> Number

252− , log :: Number -> Number

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

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

255− , random :: () -> Number

256− , round :: Number -> Number

257− , sin :: Number -> Number

258− , sqrt :: Number -> Number

259− , tan :: Number -> Number

260− }

246+module Math where

247+

248+ type Math =

249+ { abs :: Number -> Number

250+ , acos :: Number -> Number

251+ , asin :: Number -> Number

252+ , atan :: Number -> Number

253+ , atan2 :: (Number, Number) -> Number

254+ , aceil :: Number -> Number

255+ , cos :: Number -> Number

256+ , exp :: Number -> Number

257+ , floor :: Number -> Number

258+ , log :: Number -> Number

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

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

261+ , random :: () -> Number

262+ , round :: Number -> Number

263+ , sin :: Number -> Number

264+ , sqrt :: Number -> Number

265+ , tan :: Number -> Number

266+ }

261267

262−foreign import math :: Math

268+ foreign import math :: Math

263269

purescript.cabal+5−4

@@ -17,10 +17,11 @@ library

1717 build-depends: base >=4 && <5, cmdtheline -any, containers -any,

1818 directory -any, filepath -any, mtl -any, parsec -any, syb -any,

1919 transformers -any, utf8-string -any

20− exposed-modules: Language.PureScript.Scope Data.Generics.Extras

21− Language.PureScript Language.PureScript.CodeGen

22− Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS

23− Language.PureScript.CodeGen.JS.AST

20+ exposed-modules: Language.PureScript.TypeDeclarations

21+ Language.PureScript.BindingGroups Language.PureScript.Scope

22+ Data.Generics.Extras Language.PureScript

23+ Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs

24+ Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST

2425 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations

2526 Language.PureScript.Kinds Language.PureScript.Names

2627 Language.PureScript.Operators Language.PureScript.Optimize

src/Language/PureScript.hs+10−8

@@ -26,15 +26,17 @@ import Language.PureScript.Pretty as P

2626import Language.PureScript.Optimize as P

2727import Language.PureScript.Operators as P

2828import Language.PureScript.CaseDeclarations as P

29+import Language.PureScript.TypeDeclarations as P

30+import Language.PureScript.BindingGroups as P

2931

3032import Data.List (intercalate)

31−import Data.Maybe (mapMaybe)

33+import Control.Monad (forM_, (>=>))

3234

33−compile :: [Declaration] -> Either String (String, String, Environment)

34−compile decls = do

35− bracketted <- rebracket decls

36− desugared <- desugarCases bracketted

37− (_, env) <- runCheck (typeCheckAll desugared)

38− let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared

39− let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared

35+compile :: [Module] -> Either String (String, String, Environment)

36+compile ms = do

37+ bracketted <- rebracket ms

38+ desugared <- desugarCasesModule >=> desugarTypeDeclarationsModule >=> (return . createBindingGroupsModule) $ bracketted

39+ (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls

40+ let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared

41+ let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared

4042 return (js, exts, env)

src/Language/PureScript/BindingGroups.hsnew file+98

@@ -0,0 +1,98 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.BindingGroups

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.BindingGroups (

16+ createBindingGroups,

17+ createBindingGroupsModule

18+) where

19+

20+import Data.Data

21+import Data.Graph

22+import Data.Generics

23+import Data.List (nub, intersect)

24+

25+import Language.PureScript.Declarations

26+import Language.PureScript.Names

27+import Language.PureScript.Values

28+import Language.PureScript.Types

29+

30+createBindingGroupsModule :: [Module] -> [Module]

31+createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)

32+

33+createBindingGroups :: [Declaration] -> [Declaration]

34+createBindingGroups ds =

35+ let

36+ values = filter isValueDecl ds

37+ dataDecls = filter isDataDecl ds

38+ nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds

39+ allProperNames = map getProperName dataDecls

40+ dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls

41+ dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts

42+ allIdents = map getIdent values

43+ valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values

44+ bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts

45+ in

46+ dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls

47+

48+usedIdents :: (Data d) => d -> [Ident]

49+usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)

50+ where

51+ namesV :: Value -> [Ident]

52+ namesV (Var (Qualified Nothing name)) = [name]

53+ namesV _ = []

54+ namesS :: Statement -> [Ident]

55+ namesS (VariableIntroduction name _) = [name]

56+ namesS _ = []

57+

58+usedProperNames :: (Data d) => d -> [ProperName]

59+usedProperNames = nub . everything (++) (mkQ [] names)

60+ where

61+ names :: Type -> [ProperName]

62+ names (TypeConstructor (Qualified Nothing name)) = [name]

63+ names _ = []

64+

65+isValueDecl :: Declaration -> Bool

66+isValueDecl (ValueDeclaration _ _ _ _) = True

67+isValueDecl _ = False

68+

69+isDataDecl :: Declaration -> Bool

70+isDataDecl (DataDeclaration _ _ _) = True

71+isDataDecl _ = False

72+

73+getIdent :: Declaration -> Ident

74+getIdent (ValueDeclaration ident _ _ _) = ident

75+getIdent _ = error "Expected ValueDeclaration"

76+

77+getProperName :: Declaration -> ProperName

78+getProperName (DataDeclaration pn _ _) = pn

79+getProperName _ = error "Expected DataDeclaration"

80+

81+toBindingGroup :: SCC Declaration -> Declaration

82+toBindingGroup (AcyclicSCC d) = d

83+toBindingGroup (CyclicSCC [d]) = d

84+toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'

85+

86+toDataBindingGroup :: SCC Declaration -> Declaration

87+toDataBindingGroup (AcyclicSCC d) = d

88+toDataBindingGroup (CyclicSCC [d]) = d

89+toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'

90+

91+fromValueDecl :: Declaration -> (Ident, Value)

92+fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)

93+fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"

94+fromValueDecl _ = error "Expected ValueDeclaration"

95+

96+fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe PolyType)])

97+fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)

98+fromDataDecl _ = error "Expected DataDeclaration"

src/Language/PureScript/CaseDeclarations.hs+8−6

@@ -13,11 +13,13 @@

1313-----------------------------------------------------------------------------

1414

1515module Language.PureScript.CaseDeclarations (

16− desugarCases

16+ desugarCases,

17+ desugarCasesModule

1718) where

1819

1920import Data.List (groupBy)

20−import Control.Monad (join, unless)

21+import Control.Applicative ((<$>))

22+import Control.Monad (forM, join, unless)

2123import Control.Monad.Error.Class

2224

2325import Language.PureScript.Names

@@ -25,6 +27,9 @@ import Language.PureScript.Values

2527import Language.PureScript.Declarations

2628import Language.PureScript.Scope

2729

30+desugarCasesModule :: [Module] -> Either String [Module]

31+desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds

32+

2833desugarCases :: [Declaration] -> Either String [Declaration]

2934desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

3035

@@ -39,9 +44,6 @@ toDecls ds@(ValueDeclaration ident bs _ _ : _) = do

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

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

4146 return [makeCaseDeclaration ident tuples]

42−toDecls [ModuleDeclaration name decls] = do

43− desugared <- desugarCases decls

44− return [ModuleDeclaration name desugared]

4547toDecls ds = return ds

4648

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

@@ -53,7 +55,7 @@ makeCaseDeclaration ident alternatives =

5355 let

5456 argPattern = map length . fst . head $ alternatives

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

56− vars = map (\arg -> Var (Qualified global arg)) args

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

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

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

5961 in

src/Language/PureScript/CodeGen/Externs.hs+24−16

@@ -13,29 +13,37 @@

1313-----------------------------------------------------------------------------

1414

1515module Language.PureScript.CodeGen.Externs (

16− externToPs

16+ moduleToPs

1717) where

1818

19−import Data.Maybe (mapMaybe)

19+import Data.Maybe (maybeToList, mapMaybe)

2020import qualified Data.Map as M

2121import Language.PureScript.Declarations

2222import Language.PureScript.TypeChecker.Monad

2323import Language.PureScript.Pretty

2424import Language.PureScript.Names

25+import Data.List (intercalate)

2526

26−externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String

27−externToPs indent path env (ValueDeclaration name _ _ _) = do

27+moduleToPs :: Module -> Environment -> String

28+moduleToPs (Module pname@(ProperName moduleName) decls) env =

29+ "module " ++ moduleName ++ " where\n" ++

30+ (intercalate "\n" . map (" " ++) . concatMap (declToPs (ModuleName pname) env) $ decls)

31+

32+declToPs :: ModuleName -> Environment -> Declaration -> [String]

33+declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do

2834 (ty, _) <- M.lookup (path, name) $ names env

29− return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

30−externToPs indent path env (DataDeclaration name _ _) = do

35+ return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

36+declToPs path env (BindingGroupDeclaration vals) = do

37+ flip mapMaybe vals $ \(name, _) -> do

38+ (ty, _) <- M.lookup (path, name) $ names env

39+ return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

40+declToPs path env (DataDeclaration name _ _) = maybeToList $ do

3141 (kind, _) <- M.lookup (path, name) $ types env

32− return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

33−externToPs indent _ _ (ExternMemberDeclaration member name ty) =

34− return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty

35−externToPs indent _ _ (ExternDataDeclaration name kind) =

36− return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

37−externToPs indent _ _ (TypeSynonymDeclaration name args ty) =

38− return $ replicate indent ' ' ++ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty

39−externToPs indent path env (ModuleDeclaration name decls) =

40− return $ replicate indent ' ' ++ "module " ++ show name ++ " where\n" ++ unlines (mapMaybe (externToPs (indent + 2) (subModule path name) env) decls)

41−externToPs _ _ _ _ = Nothing

42+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

43+declToPs _ _ (ExternMemberDeclaration member name ty) =

44+ return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty

45+declToPs _ _ (ExternDataDeclaration name kind) =

46+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

47+declToPs _ _ (TypeSynonymDeclaration name args ty) =

48+ return $ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty

49+declToPs _ _ _ = []

src/Language/PureScript/CodeGen/JS.hs+54−39

@@ -14,7 +14,8 @@

1414

1515module Language.PureScript.CodeGen.JS (

1616 module AST,

17− declToJs

17+ declToJs,

18+ moduleToJs

1819) where

1920

2021import Data.Maybe (mapMaybe)

@@ -32,40 +33,47 @@ import Language.PureScript.CodeGen.Monad

3233import Language.PureScript.CodeGen.JS.AST as AST

3334import Language.PureScript.TypeChecker.Monad (NameKind(..))

3435

35−declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]

36−declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =

37− Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :

38− maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

39−declToJs curMod mp (ValueDeclaration ident _ _ val) e =

40− Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :

41− maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

42−declToJs curMod _ (ExternMemberDeclaration member ident _) _ =

43− Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :

44− maybe [] (return . setProperty (show ident) (JSVar ident)) curMod

45−declToJs curMod mp (DataDeclaration _ _ ctors) _ =

36+moduleToJs :: Module -> Environment -> [JS]

37+moduleToJs (Module pname@(ProperName name) decls) env =

38+ [ JSVariableIntroduction (Ident name) Nothing

39+ , JSApp (JSFunction Nothing [Ident name]

40+ (JSBlock (concat $ mapMaybe (\decl -> declToJs (ModuleName pname) decl env) decls)))

41+ [JSAssignment (JSAssignVariable (Ident name))

42+ (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]

43+ ]

44+

45+declToJs :: ModuleName -> Declaration -> Environment -> Maybe [JS]

46+declToJs mp (ValueDeclaration ident _ _ (Abs args ret)) e =

47+ Just [ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]),

48+ setProperty (identToJs ident) (JSVar ident) mp ]

49+declToJs mp (ValueDeclaration ident _ _ val) e =

50+ Just [ JSVariableIntroduction ident (Just (valueToJs mp e val)),

51+ setProperty (identToJs ident) (JSVar ident) mp ]

52+declToJs mp (BindingGroupDeclaration vals) e =

53+ Just $ concatMap (\(ident, val) ->

54+ [ JSVariableIntroduction ident (Just (valueToJs mp e val)),

55+ setProperty (identToJs ident) (JSVar ident) mp ]

56+ ) vals

57+declToJs mp (ExternMemberDeclaration member ident _) _ =

58+ Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]),

59+ setProperty (show ident) (JSVar ident) mp ]

60+declToJs mp (DataDeclaration _ _ ctors) _ =

4661 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->

4762 let

4863 ctorJs =

4964 case maybeTy of

50− Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn))) ]))

65+ Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))

5166 Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]

5267 (JSBlock [JSReturn

53− (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))

68+ (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))

5469 , ("value", JSVar (Ident "value")) ])])

55− in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) curMod

56−declToJs curMod mp (ModuleDeclaration pn@(ProperName name) decls) env =

57− Just $ [ JSVariableIntroduction (Ident name) Nothing

58− , JSApp (JSFunction Nothing [Ident name]

59− (JSBlock (concat $ mapMaybe (\decl -> declToJs (Just (Ident name)) (subModule mp pn) decl env) decls)))

60− [JSAssignment (JSAssignVariable (Ident name))

61− (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]] ++

62− maybe [] (return . setProperty name (JSVar (Ident name))) curMod

63−declToJs _ _ _ _ = Nothing

70+ in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]

71+declToJs _ _ _ = Nothing

6472

65−setProperty :: String -> JS -> Ident -> JS

66−setProperty prop val curMod = JSAssignment (JSAssignProperty prop (JSAssignVariable curMod)) val

73+setProperty :: String -> JS -> ModuleName -> JS

74+setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val

6775

68−valueToJs :: ModulePath -> Environment -> Value -> JS

76+valueToJs :: ModuleName -> Environment -> Value -> JS

6977valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n

7078valueToJs _ _ (StringLiteral s) = JSStringLiteral s

7179valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b

@@ -82,20 +90,27 @@ valueToJs m e (App val args) = JSApp (valueToJs m e val) (map (valueToJs m e) ar

8290valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m e val)])

8391valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)

8492valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)

85−valueToJs m e (Var ident) = case M.lookup (qualify m ident) (names e) of

86− Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified aliasModule aliasIdent)

87− _ -> qualifiedToJS identToJs ident

93+valueToJs m e (Var ident) = varToJs m e ident

8894valueToJs m e (TypedValue val _) = valueToJs m e val

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

9096

97+varToJs :: ModuleName -> Environment -> Qualified Ident -> JS

98+varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of

99+ Just (_, ty) | isExtern ty -> JSVar ident

100+ Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)

101+ _ -> qualifiedToJS identToJs qual

102+ where

103+ isExtern Extern = True

104+ isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of

105+ Just (_, ty') -> isExtern ty'

106+ Nothing -> error "Undefined alias in varToJs"

107+ isExtern _ = False

108+

91109qualifiedToJS :: (a -> String) -> Qualified a -> JS

92−qualifiedToJS f (Qualified (ModulePath parts) a) =

93− delimited (f a : reverse (map show parts))

94− where delimited [part] = JSVar (Ident (part))

95− delimited (part:parts') = JSAccessor part (delimited parts')

96− delimited _ = error "Invalid argument to delimited"

110+qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))

111+qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))

97112

98−bindersToJs :: ModulePath -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS

113+bindersToJs :: ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS

99114bindersToJs m e binders vals = do

100115 setNextName $ firstUnusedName (binders, vals)

101116 valNames <- replicateM (length vals) fresh

@@ -111,7 +126,7 @@ bindersToJs m e binders vals = do

111126 binderToJs m e v done'' b

112127 go _ _ _ _ = error "Invalid arguments to bindersToJs"

113128

114−binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]

129+binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]

115130binderToJs _ _ _ done NullBinder = return done

116131binderToJs _ _ varName done (StringBinder str) =

117132 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]

@@ -124,11 +139,11 @@ binderToJs _ _ varName done (BooleanBinder False) =

124139binderToJs _ _ varName done (VarBinder ident) =

125140 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)

126141binderToJs m _ varName done (NullaryBinder ctor) =

127− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock done) Nothing]

142+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]

128143binderToJs m e varName done (UnaryBinder ctor b) = do

129144 value <- fresh

130145 js <- binderToJs m e value done b

131− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]

146+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]

132147binderToJs m e varName done (ObjectBinder bs) = go done bs

133148 where

134149 go :: [JS] -> [(String, Binder)] -> Gen [JS]

@@ -163,7 +178,7 @@ binderToJs m e varName done (NamedBinder ident binder) = do

163178 js <- binderToJs m e varName done binder

164179 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)

165180

166−statementToJs :: ModulePath -> Environment -> Statement -> JS

181+statementToJs :: ModuleName -> Environment -> Statement -> JS

167182statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))

168183statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)

169184statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))

src/Language/PureScript/Declarations.hs+5−2

@@ -29,15 +29,18 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)

2929

3030data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

3131

32+data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)

33+

3234data Declaration

3335 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]

36+ | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe PolyType)])]

3437 | TypeSynonymDeclaration ProperName [String] PolyType

3538 | TypeDeclaration Ident PolyType

3639 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value

40+ | BindingGroupDeclaration [(Ident, Value)]

3741 | ExternDeclaration Ident PolyType

3842 | ExternMemberDeclaration String Ident PolyType

3943 | ExternDataDeclaration ProperName Kind

4044 | FixityDeclaration Fixity String

41− | ModuleDeclaration ProperName [Declaration]

42− | ImportDeclaration ModulePath (Maybe [Ident])

45+ | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])

4346 deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/Names.hs+9−19

@@ -17,7 +17,6 @@

1717module Language.PureScript.Names where

1818

1919import Data.Data

20−import Data.List (inits, intercalate)

2120

2221data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)

2322

@@ -30,26 +29,17 @@ newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, D

3029instance Show ProperName where

3130 show = runProperName

3231

33−data ModulePath = ModulePath [ProperName] deriving (Eq, Ord, Data, Typeable)

32+data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)

3433

35−instance Show ModulePath where

36− show (ModulePath segments) = intercalate "." $ map show segments

34+instance Show ModuleName where

35+ show (ModuleName name) = show name

3736

38−subModule :: ModulePath -> ProperName -> ModulePath

39−subModule (ModulePath mp) name = ModulePath (mp ++ [name])

40−

41−global :: ModulePath

42−global = ModulePath []

43−

44−data Qualified a = Qualified ModulePath a deriving (Eq, Ord, Data, Typeable)

37+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)

4538

4639instance (Show a) => Show (Qualified a) where

47− show (Qualified (ModulePath names) a) = intercalate "." (map show names ++ [show a])

48−

49−qualify :: ModulePath -> Qualified a -> (ModulePath, a)

50−qualify mp (Qualified (ModulePath []) a) = (mp, a)

51−qualify _ (Qualified mp a) = (mp, a)

40+ show (Qualified Nothing a) = show a

41+ show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a

5242

53−nameResolution :: ModulePath -> Qualified a -> [(ModulePath, a)]

54−nameResolution (ModulePath mp) (Qualified (ModulePath []) a) = [ (ModulePath mp', a) | mp' <- reverse $ inits mp ]

55−nameResolution _ (Qualified mp a) = [(mp, a)]

43+qualify :: ModuleName -> Qualified a -> (ModuleName, a)

44+qualify m (Qualified Nothing a) = (m, a)

45+qualify _ (Qualified (Just m) a) = (m, a)

src/Language/PureScript/Operators.hs+19−22

@@ -33,12 +33,12 @@ import qualified Text.Parsec as P

3333import qualified Text.Parsec.Pos as P

3434import qualified Text.Parsec.Expr as P

3535

36−rebracket :: [Declaration] -> Either String [Declaration]

37−rebracket ds = do

38− m <- collectFixities ds

36+rebracket :: [Module] -> Either String [Module]

37+rebracket ms = forM ms $ \(Module name ds) -> do

38+ m <- collectFixities (ModuleName name) ds

3939 let opTable = customOperatorTable m

40− ds' <- G.everywhereM' (G.mkM (matchOperators opTable)) ds

41− return $ G.everywhere (G.mkT removeParens) ds'

40+ ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds

41+ return $ Module name $ G.everywhere (G.mkT removeParens) ds'

4242

4343removeParens :: Value -> Value

4444removeParens (Parens val) = val

@@ -56,8 +56,8 @@ customOperatorTable fixities =

5656

5757type Chain = [Either Value (Qualified Ident)]

5858

59−matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value

60−matchOperators ops val = G.everywhereM' (G.mkM parseChains) val

59+matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value

60+matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val

6161 where

6262 parseChains :: Value -> Either String Value

6363 parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)

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

6767 extendChain other = [Left other]

6868 bracketChain :: Chain -> Either String Value

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

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

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

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

7272

7373toAssoc :: Associativity -> P.Assoc

@@ -80,27 +80,24 @@ parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)

8080parseOp :: P.Parsec Chain () (Qualified Ident)

8181parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator"

8282

83−matchOp :: Qualified Ident -> P.Parsec Chain () ()

84−matchOp op = do

83+matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()

84+matchOp moduleName op = do

8585 ident <- parseOp

86− guard (ident == op)

86+ guard (qualify moduleName ident == qualify moduleName op)

8787

88−collectFixities :: [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

89−collectFixities = go M.empty global

88+collectFixities :: ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

89+collectFixities = go M.empty

9090 where

91− go :: M.Map (Qualified Ident) Fixity -> ModulePath -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

91+ go :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

9292 go m _ [] = return m

93− go m p (FixityDeclaration fixity name : rest) = do

94− let qual = Qualified p (Op name)

93+ go m moduleName (FixityDeclaration fixity name : rest) = do

94+ let qual = Qualified (Just moduleName) (Op name)

9595 when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)

96− go (M.insert qual fixity m) p rest

97− go m p (ModuleDeclaration name decls : rest) = do

98− m' <- go m (subModule p name) decls

99− go m' p rest

100− go m p (_:ds) = go m p ds

96+ go (M.insert qual fixity m) moduleName rest

97+ go m moduleName (_:ds) = go m moduleName ds

10198

10299globalOp :: String -> Qualified Ident

103−globalOp = Qualified global . Op

100+globalOp = Qualified Nothing . Op

104101

105102builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]

106103builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)

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

@@ -188,11 +188,10 @@ properName :: P.Parsec String u ProperName

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

189189

190190parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)

191−parseQualified parser = part global

191+parseQualified parser = qual

192192 where

193− part path = (do name <- P.try (properName <* delimiter)

194− part (subModule path name))

195− <|> (Qualified path <$> P.try parser)

193+ qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)

194+ <|> (Qualified Nothing <$> P.try parser)

196195 delimiter = indented *> dot

197196

198197integerOrFloat :: P.Parsec String u (Either Integer Double)

src/Language/PureScript/Parser/Declarations.hs+16−19

@@ -14,7 +14,8 @@

1414

1515module Language.PureScript.Parser.Declarations (

1616 parseDeclaration,

17− parseDeclarations

17+ parseModule,

18+ parseModules

1819) where

1920

2021import Control.Applicative

@@ -84,25 +85,13 @@ parseFixityDeclaration = do

8485 name <- operator

8586 return $ FixityDeclaration fixity name

8687

87−parseModuleDeclaration :: P.Parsec String ParseState Declaration

88−parseModuleDeclaration = do

89− reserved "module"

90− indented

91− name <- properName

92− lexeme $ P.string "where"

93− decls <- mark (P.many (same *> parseDeclaration))

94− return $ ModuleDeclaration name decls

95−

96−parseModulePath :: P.Parsec String ParseState ModulePath

97−parseModulePath = ModulePath <$> properName `sepBy1` dot

98−

9988parseImportDeclaration :: P.Parsec String ParseState Declaration

10089parseImportDeclaration = do

10190 reserved "import"

10291 indented

103− modulePath <- parseModulePath

104− idents <- P.optionMaybe $ parens $ commaSep1 parseIdent

105− return $ ImportDeclaration modulePath idents

92+ moduleName <- ModuleName <$> properName

93+ idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)

94+ return $ ImportDeclaration moduleName idents

10695

10796parseDeclaration :: P.Parsec String ParseState Declaration

10897parseDeclaration = P.choice

@@ -112,8 +101,16 @@ parseDeclaration = P.choice

112101 , parseValueDeclaration

113102 , parseExternDeclaration

114103 , parseFixityDeclaration

115− , parseModuleDeclaration

116104 , parseImportDeclaration ] P.<?> "declaration"

117105

118−parseDeclarations :: P.Parsec String ParseState [Declaration]

119−parseDeclarations = whiteSpace *> mark (P.many (same *> parseDeclaration)) <* P.eof

106+parseModule :: P.Parsec String ParseState Module

107+parseModule = do

108+ reserved "module"

109+ indented

110+ name <- properName

111+ lexeme $ P.string "where"

112+ decls <- mark (P.many (same *> parseDeclaration))

113+ return $ Module name decls

114+

115+parseModules :: P.Parsec String ParseState [Module]

116+parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof

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

@@ -32,7 +32,7 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB

3232 where

3333 namesV :: Value -> [Ident]

3434 namesV (Abs args _) = args

35− namesV (Var (Qualified (ModulePath []) name)) = [name]

35+ namesV (Var (Qualified Nothing name)) = [name]

3636 namesV _ = []

3737 namesS :: Statement -> [Ident]

3838 namesS (VariableIntroduction name _) = [name]

src/Language/PureScript/TypeChecker.hs+138−79

@@ -26,114 +26,173 @@ import Language.PureScript.TypeChecker.Synonyms as T

2626

2727import Data.Maybe

2828import qualified Data.Map as M

29+import Control.Monad.State

30+import Control.Monad.Error

31+import Data.Either (rights, lefts)

2932

30−import Language.PureScript.Values

3133import Language.PureScript.Types

3234import Language.PureScript.Names

3335import Language.PureScript.Kinds

3436import Language.PureScript.Declarations

3537

36−import Control.Monad.State

37−import Control.Monad.Error

38+addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, Maybe Type)] -> Kind -> Check ()

39+addDataType moduleName name args dctors ctorKind = do

40+ env <- getEnv

41+ putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }

42+ forM_ dctors $ \(dctor, maybeTy) ->

43+ rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $

44+ addDataConstructor moduleName name args dctor maybeTy

45+

46+addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> Maybe Type -> Check ()

47+addDataConstructor moduleName name args dctor maybeTy = do

48+ env <- getEnv

49+ dataConstructorIsNotDefined moduleName dctor

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

51+ let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

52+ let polyType = mkForAll args dctorTy

53+ putEnv $ env { dataConstructors = M.insert (moduleName, dctor) polyType (dataConstructors env) }

54+

55+addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()

56+addTypeSynonym moduleName name args ty kind = do

57+ env <- getEnv

58+ putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)

59+ , typeSynonyms = M.insert (moduleName, name) (args, ty) (typeSynonyms env) }

60+

61+typeIsNotDefined :: ModuleName -> ProperName -> Check ()

62+typeIsNotDefined moduleName name = do

63+ env <- getEnv

64+ guardWith (show name ++ " is already defined") $

65+ not $ M.member (moduleName, name) (types env)

66+

67+dataConstructorIsNotDefined :: ModuleName -> ProperName -> Check ()

68+dataConstructorIsNotDefined moduleName dctor = do

69+ env <- getEnv

70+ guardWith (show dctor ++ " is already defined") $

71+ not $ M.member (moduleName, dctor) (dataConstructors env)

72+

73+valueIsNotDefined :: ModuleName -> Ident -> Check ()

74+valueIsNotDefined moduleName name = do

75+ env <- getEnv

76+ case M.lookup (moduleName, name) (names env) of

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

78+ Nothing -> return ()

3879

39−typeCheckAll :: [Declaration] -> Check ()

40−typeCheckAll [] = return ()

41−typeCheckAll (DataDeclaration name args dctors : rest) = do

80+addValue :: ModuleName -> Ident -> Type -> Check ()

81+addValue moduleName name ty = do

82+ env <- getEnv

83+ putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })

84+

85+typeCheckAll :: ModuleName -> [Declaration] -> Check ()

86+typeCheckAll _ [] = return ()

87+typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do

4288 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

43− env <- getEnv

44− modulePath <- checkModulePath `fmap` get

45− guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)

46− ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)

47− putEnv $ env { types = M.insert (modulePath, name) (ctorKind, Data) (types env) }

48− forM_ dctors $ \(dctor, maybeTy) ->

49− rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $ do

50− env' <- getEnv

51− guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')

52− let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)

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

54− let polyType = mkForAll args dctorTy

55− putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }

56− typeCheckAll rest

57−typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do

89+ typeIsNotDefined moduleName name

90+ ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)

91+ addDataType moduleName name args dctors ctorKind

92+ typeCheckAll moduleName rest

93+typeCheckAll moduleName (DataBindingGroupDeclaration tys : rest) = do

94+ rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do

95+ forM_ tys $ \(name, _, _) ->

96+ typeIsNotDefined moduleName name

97+ ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)

98+ forM (zip tys ks) $ \((name, args, dctors), ctorKind) ->

99+ addDataType moduleName name args dctors ctorKind

100+ typeCheckAll moduleName rest

101+typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do

58102 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

59− env <- getEnv

60− modulePath <- checkModulePath `fmap` get

61− guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)

62− kind <- kindsOf (Just name) args [ty]

63− putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)

64− , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }

65− typeCheckAll rest

66−typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =

67− typeCheckAll (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)

68−typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

69−typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do

103+ typeIsNotDefined moduleName name

104+ kind <- kindsOf moduleName name args [ty]

105+ addTypeSynonym moduleName name args ty kind

106+ typeCheckAll moduleName rest

107+typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

108+typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do

70109 rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

71− env <- getEnv

72− modulePath <- checkModulePath `fmap` get

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

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

75− Nothing -> do

76− ty <- typeOf (Just name) val

77− putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })

78− typeCheckAll rest

79−typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

80−typeCheckAll (ExternDataDeclaration name kind : rest) = do

110+ valueIsNotDefined moduleName name

111+ [ty] <- typesOf moduleName [(name, val)]

112+ addValue moduleName name ty

113+ typeCheckAll moduleName rest

114+typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

115+typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do

116+ rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do

117+ forM_ (map fst vals) $ \name ->

118+ valueIsNotDefined moduleName name

119+ tys <- typesOf moduleName vals

120+ forM (zip (map fst vals) tys) $ \(name, ty) ->

121+ addValue moduleName name ty

122+ typeCheckAll moduleName rest

123+typeCheckAll moduleName (ExternDataDeclaration name kind : rest) = do

81124 env <- getEnv

82− modulePath <- checkModulePath `fmap` get

83− guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)

84− putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env) }

85− typeCheckAll rest

86−typeCheckAll (ExternMemberDeclaration member name ty : rest) = do

125+ guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)

126+ putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }

127+ typeCheckAll moduleName rest

128+typeCheckAll moduleName (ExternMemberDeclaration member name ty : rest) = do

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

88130 env <- getEnv

89− modulePath <- checkModulePath `fmap` get

90− kind <- kindOf ty

131+ kind <- kindOf moduleName ty

91132 guardWith "Expected kind *" $ kind == Star

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

133+ case M.lookup (moduleName, name) (names env) of

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

94135 Nothing -> case ty of

95136 _ | isSingleArgumentFunction ty -> do

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

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

137+ putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env)

138+ , members = M.insert (moduleName, name) member (members env) })

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

99− typeCheckAll rest

140+ typeCheckAll moduleName rest

100141 where

101142 isSingleArgumentFunction (Function [_] _) = True

102143 isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t

103144 isSingleArgumentFunction _ = False

104−typeCheckAll (ExternDeclaration name ty : rest) = do

145+typeCheckAll moduleName (ExternDeclaration name ty : rest) = do

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

106147 env <- getEnv

107− modulePath <- checkModulePath `fmap` get

108− kind <- kindOf ty

148+ kind <- kindOf moduleName ty

109149 guardWith "Expected kind *" $ kind == Star

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

150+ case M.lookup (moduleName, name) (names env) of

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

112− Nothing -> putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env) })

113− typeCheckAll rest

114−typeCheckAll (FixityDeclaration _ name : rest) = do

115− typeCheckAll rest

152+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) })

153+ typeCheckAll moduleName rest

154+typeCheckAll moduleName (FixityDeclaration _ name : rest) = do

155+ typeCheckAll moduleName rest

116156 env <- getEnv

117− modulePath <- checkModulePath `fmap` get

118− guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (modulePath, Op name) $ names env

119−typeCheckAll (ModuleDeclaration name decls : rest) = do

120− withModule name $ typeCheckAll decls

121− typeCheckAll rest

122−typeCheckAll (ImportDeclaration modulePath idents : rest) = do

157+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env

158+typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do

123159 env <- getEnv

124− currentModule <- checkModulePath `fmap` get

125160 rethrow errorMessage $ do

126− guardWith ("Module " ++ show modulePath ++ " does not exist") $ moduleExists env

161+ guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env

127162 case idents of

128− Nothing -> bindIdents (map snd $ filterModule env) currentModule env

129− Just idents' -> bindIdents idents' currentModule env

130− typeCheckAll rest

131− where errorMessage = (("Error in import declaration " ++ show modulePath ++ ":\n") ++)

132− filterModule = filter ((== modulePath) . fst) . M.keys . names

133− moduleExists env = not $ null $ filterModule env

134− bindIdents idents' currentModule env =

163+ Nothing -> do

164+ shadowIdents (map snd $ filterModule (names env)) env

165+ shadowTypes (map snd $ filterModule (types env)) env

166+ Just idents' -> do

167+ shadowIdents (lefts idents') env

168+ shadowTypes (rights idents') env

169+ typeCheckAll currentModule rest

170+ where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

171+ filterModule = filter ((== moduleName) . fst) . M.keys

172+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))

173+ shadowIdents idents' env =

135174 forM_ idents' $ \ident -> do

136175 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

137− case (modulePath, ident) `M.lookup` names env of

138− Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias modulePath ident) (names e) })

139− Nothing -> throwError (show modulePath ++ "." ++ show ident ++ " is undefined")

176+ case (moduleName, ident) `M.lookup` names env of

177+ Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })

178+ Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

179+ shadowTypes pns env =

180+ forM_ pns $ \pn -> do

181+ guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env

182+ case (moduleName, pn) `M.lookup` types env of

183+ Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")

184+ Just (k, _) -> do

185+ modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })

186+ let keys = map (snd . fst) . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env

187+ forM_ keys $ \dctor -> do

188+ guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env

189+ case (moduleName, dctor) `M.lookup` dataConstructors env of

190+ Just ctorTy -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) ctorTy (dataConstructors e) })

191+ Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")

192+ constructs (TypeConstructor (Qualified (Just mn) pn')) pn

193+ = mn == moduleName && pn' == pn

194+ constructs (ForAll _ ty) pn = ty `constructs` pn

195+ constructs (Function _ ty) pn = ty `constructs` pn

196+ constructs (TypeApp ty _) pn = ty `constructs` pn

197+ constructs fn _ = error $ "Invalid arguments to construct" ++ show fn

198+

src/Language/PureScript/TypeChecker/Kinds.hs+55−41

@@ -15,8 +15,9 @@

1515{-# LANGUAGE DeriveDataTypeable #-}

1616

1717module Language.PureScript.TypeChecker.Kinds (

18+ kindOf,

1819 kindsOf,

19− kindOf

20+ kindsOfAll

2021) where

2122

2223import Language.PureScript.Types

@@ -28,6 +29,7 @@ import Language.PureScript.Unknown

2829

2930import Control.Monad.State

3031import Control.Monad.Error

32+import Control.Monad.Reader

3133

3234import Control.Applicative

3335

@@ -53,14 +55,31 @@ instance Unifiable Kind where

5355 unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2

5456 unknowns _ = []

5557

56−kindOf :: Type -> Check Kind

57−kindOf ty = fmap (\(k, _, _) -> k) . runSubst $ starIfUnknown <$> infer Nothing M.empty ty

58+kindOf :: ModuleName -> Type -> Check Kind

59+kindOf moduleName ty = fmap (\(k, _, _) -> k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty

5860

59−kindsOf :: Maybe ProperName -> [String] -> [Type] -> Check Kind

60−kindsOf name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst $ do

61+kindsOf :: ModuleName -> ProperName -> [String] -> [PolyType] -> Check Kind

62+kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst (SubstContext moduleName) $ do

6163 tyCon <- fresh

6264 kargs <- replicateM (length args) fresh

63− ks <- inferAll (fmap (\pn -> (pn, tyCon)) name) (M.fromList (zip args kargs)) ts

65+ let dict = (name, tyCon) : zip (map ProperName args) kargs

66+ bindLocalTypeVariables moduleName dict $

67+ solveTypes ts kargs tyCon

68+

69+kindsOfAll :: ModuleName -> [(ProperName, [String], [PolyType])] -> Check [Kind]

70+kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, _, _) -> ks)) . runSubst (SubstContext moduleName) $ do

71+ tyCons <- replicateM (length tys) fresh

72+ let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons

73+ bindLocalTypeVariables moduleName dict $

74+ zipWithM (\tyCon (_, args, ts) -> do

75+ kargs <- replicateM (length args) fresh

76+ let argDict = zip (map ProperName args) kargs

77+ bindLocalTypeVariables moduleName argDict $

78+ solveTypes ts kargs tyCon) tyCons tys

79+

80+solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind

81+solveTypes ts kargs tyCon = do

82+ ks <- mapM infer ts

6483 tyCon ~~ foldr FunKind Star kargs

6584 forM_ ks $ \k -> k ~~ Star

6685 return tyCon

@@ -70,56 +89,51 @@ starIfUnknown (KUnknown _) = Star

7089starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

7190starIfUnknown k = k

7291

73−inferAll :: Maybe (ProperName, Kind) -> M.Map String Kind -> [Type] -> Subst [Kind]

74−inferAll name m = mapM (infer name m)

75−

76−infer :: Maybe (ProperName, Kind) -> M.Map String Kind -> Type -> Subst Kind

77−infer name m (Array t) = do

78− k <- infer name m t

92+infer :: Type -> Subst Kind

93+infer (Array t) = do

94+ k <- infer t

7995 k ~~ Star

8096 return Star

81−infer name m (Object row) = do

82− k <- inferRow name m row

97+infer (Object row) = do

98+ k <- inferRow row

8399 k ~~ Row

84100 return Star

85−infer name m (Function args ret) = do

86− ks <- inferAll name m args

87− k <- infer name m ret

101+infer (Function args ret) = do

102+ ks <- mapM infer args

103+ k <- infer ret

88104 k ~~ Star

89105 forM ks (~~ Star)

90106 return Star

91−infer _ m (TypeVar v) =

92− case M.lookup v m of

93− Just k -> return k

94− Nothing -> throwError $ "Unbound type variable " ++ v

95−infer (Just (name, k)) _ (TypeConstructor (Qualified (ModulePath []) pn)) | name == pn = return k

96−infer _ _ (TypeConstructor v) = do

107+infer (TypeVar v) = do

108+ moduleName <- substCurrentModule <$> ask

109+ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

110+infer (TypeConstructor v) = do

97111 env <- liftCheck getEnv

98− modulePath <- checkModulePath `fmap` get

99− case M.lookup (qualify modulePath v) (types env) of

112+ moduleName <- substCurrentModule `fmap` ask

113+ case M.lookup (qualify moduleName v) (types env) of

100114 Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"

101115 Just (kind, _) -> return kind

102−infer name m (TypeApp t1 t2) = do

116+infer (TypeApp t1 t2) = do

103117 k0 <- fresh

104− k1 <- infer name m t1

105− k2 <- infer name m t2

118+ k1 <- infer t1

119+ k2 <- infer t2

106120 k1 ~~ FunKind k2 k0

107121 return k0

108−infer name m (ForAll ident ty) = do

122+infer (ForAll ident ty) = do

109123 k <- fresh

110− infer name (M.insert ident k m) ty

111−infer _ _ _ = return Star

124+ moduleName <- substCurrentModule <$> ask

125+ bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty

126+infer _ = return Star

112127

113−inferRow :: Maybe (ProperName, Kind) -> M.Map String Kind -> Row -> Subst Kind

114−inferRow _ m (RowVar v) = do

115− case M.lookup v m of

116− Just k -> return k

117− Nothing -> throwError $ "Unbound row variable " ++ v

118−inferRow _ _ REmpty = return Row

119−inferRow name m (RCons _ ty row) = do

120− k1 <- infer name m ty

121− k2 <- inferRow name m row

128+inferRow :: Row -> Subst Kind

129+inferRow (RowVar v) = do

130+ moduleName <- substCurrentModule <$> ask

131+ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

132+inferRow REmpty = return Row

133+inferRow (RCons _ ty row) = do

134+ k1 <- infer ty

135+ k2 <- inferRow row

122136 k1 ~~ Star

123137 k2 ~~ Row

124138 return Row

125−inferRow _ _ _ = error "Invalid row in inferRow"

139+inferRow _ = error "Invalid row in inferRow"

src/Language/PureScript/TypeChecker/Monad.hs+62−36

@@ -28,52 +28,77 @@ import Data.Monoid

2828import Control.Applicative

2929import Control.Monad.State

3030import Control.Monad.Error

31+import Control.Monad.Reader

3132

3233import qualified Data.Map as M

3334

34−data NameKind = Value | Extern | Alias ModulePath Ident | LocalVariable deriving Show

35+data NameKind

36+ = Value

37+ | Extern

38+ | Alias ModuleName Ident

39+ | LocalVariable deriving Show

3540

36−data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

41+data TypeDeclarationKind

42+ = Data

43+ | ExternData

44+ | TypeSynonym

45+ | DataAlias ModuleName ProperName

46+ | LocalTypeVariable deriving Show

3747

3848data Environment = Environment

39− { names :: M.Map (ModulePath, Ident) (Type, NameKind)

40− , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)

41− , dataConstructors :: M.Map (ModulePath, ProperName) Type

42− , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)

43− , members :: M.Map (ModulePath, Ident) String

49+ { names :: M.Map (ModuleName, Ident) (Type, NameKind)

50+ , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

51+ , dataConstructors :: M.Map (ModuleName, ProperName) Type

52+ , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

53+ , members :: M.Map (ModuleName, Ident) String

4454 } deriving (Show)

4555

4656emptyEnvironment :: Environment

4757emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty

4858

49−bindNames :: (MonadState CheckState m) => M.Map (ModulePath, Ident) (Type, NameKind) -> m a -> m a

59+bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a

5060bindNames newNames action = do

51− orig <- get

61+ orig <- get

5262 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

5363 a <- action

5464 modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }

5565 return a

5666

57−bindLocalVariables :: (Functor m, MonadState CheckState m) => [(Ident, Type)] -> m a -> m a

58−bindLocalVariables bindings action = do

59− modulePath <- checkModulePath `fmap` get

60− bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((modulePath, name), (ty, LocalVariable))) action

67+bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a

68+bindTypes newNames action = do

69+ orig <- get

70+ modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

71+ a <- action

72+ modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }

73+ return a

74+

75+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

76+bindLocalVariables moduleName bindings action =

77+ bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action

6178

62−lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => Qualified Ident -> m Type

63−lookupVariable var = do

79+bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

80+bindLocalTypeVariables moduleName bindings action =

81+ bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action

82+

83+lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type

84+lookupVariable currentModule (Qualified moduleName var) = do

6485 env <- getEnv

65− modulePath <- checkModulePath <$> get

66− let tries = map (First . flip M.lookup (names env)) (nameResolution modulePath var)

67− case getFirst (mconcat tries) of

86+ case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

6887 Nothing -> throwError $ show var ++ " is undefined"

6988 Just (ty, _) -> return ty

7089

90+lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind

91+lookupTypeVariable currentModule (Qualified moduleName name) = do

92+ env <- getEnv

93+ case M.lookup (fromMaybe currentModule moduleName, name) (types env) of

94+ Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

95+ Just (k, _) -> return k

96+

7197data AnyUnifiable where

7298 AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable

7399

74100data CheckState = CheckState { checkEnv :: Environment

75101 , checkNextVar :: Int

76− , checkModulePath :: ModulePath

77102 }

78103

79104newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }

@@ -90,7 +115,7 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

90115

91116runCheck :: Check a -> Either String (a, Environment)

92117runCheck c = do

93− (a, s) <- flip runStateT (CheckState emptyEnvironment 0 global) $ unCheck c

118+ (a, s) <- flip runStateT (CheckState emptyEnvironment 0) $ unCheck c

94119 return (a, checkEnv s)

95120

96121guardWith :: (MonadError e m) => e -> Bool -> m ()

@@ -100,14 +125,6 @@ guardWith e False = throwError e

100125rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

101126rethrow f = flip catchError $ \e -> throwError (f e)

102127

103−withModule :: ProperName -> Check a -> Check a

104−withModule name act = do

105− original <- checkModulePath `fmap` get

106− modify $ \s -> s { checkModulePath = subModule (checkModulePath s) name }

107− a <- act

108− modify $ \s -> s { checkModulePath = original }

109− return a

110−

111128newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }

112129

113130instance Monoid Substitution where

@@ -117,21 +134,23 @@ instance Monoid Substitution where

117134data SubstState = SubstState { substSubst :: Substitution

118135 , substFutureEscapeChecks :: [AnyUnifiable] }

119136

120−newtype Subst a = Subst { unSubst :: StateT SubstState Check a }

121− deriving (Functor, Monad, Applicative, MonadPlus)

137+newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)

138+

139+newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }

140+ deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)

122141

123142instance MonadState CheckState Subst where

124− get = Subst . lift $ get

125− put = Subst . lift . put

143+ get = Subst . lift . lift $ get

144+ put = Subst . lift . lift . put

126145

127146deriving instance MonadError String Subst

128147

129148liftCheck :: Check a -> Subst a

130−liftCheck = Subst . lift

149+liftCheck = Subst . lift . lift

131150

132−runSubst :: (Unifiable a) => Subst a -> Check (a, Substitution, [AnyUnifiable])

133−runSubst subst = do

134− (a, s) <- flip runStateT (SubstState mempty []) . unSubst $ subst

151+runSubst :: (Unifiable a) => SubstContext -> Subst a -> Check (a, Substitution, [AnyUnifiable])

152+runSubst context subst = do

153+ (a, s) <- flip runStateT (SubstState mempty []) . flip runReaderT context . unSubst $ subst

135154 return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)

136155

137156substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution

@@ -163,6 +182,13 @@ class (Typeable t, Data t, Show t) => Unifiable t where

163182 apply :: Substitution -> t -> t

164183 unknowns :: t -> [Int]

165184

185+instance (Unifiable a) => Unifiable [a] where

186+ unknown _ = error "not supported"

187+ (~~) = zipWithM_ (~~)

188+ isUnknown _ = error "not supported"

189+ apply s = map (apply s)

190+ unknowns = concatMap unknowns

191+

166192occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()

167193occursCheck (Unknown u) t =

168194 case isUnknown t of

src/Language/PureScript/TypeChecker/Synonyms.hs+8−8

@@ -27,22 +27,22 @@ import Data.Generics.Extras

2727import Control.Monad.Writer

2828import Control.Monad.Error

2929

30−buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)

31−buildTypeSubstitution name n = go n []

30+buildTypeSubstitution :: ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type)

31+buildTypeSubstitution moduleName name n = go n []

3232 where

3333 go :: Int -> [Type] -> Type -> Either String (Maybe Type)

34− go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)

34+ go 0 args (TypeConstructor ctor) | qualify moduleName name == qualify moduleName ctor = return (Just $ SaturatedTypeSynonym ctor args)

3535 go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name

3636 go m args (TypeApp f arg) = go (m - 1) (arg:args) f

3737 go _ _ _ = return Nothing

3838

39−saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d

40−saturateTypeSynonym name n = everywhereM' (mkM replace)

39+saturateTypeSynonym :: (Data d) => ModuleName -> Qualified ProperName -> Int -> d -> Either String d

40+saturateTypeSynonym moduleName name n = everywhereM' (mkM replace)

4141 where

42− replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t

42+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution moduleName name n t

4343

44−saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d

45−saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns

44+saturateAllTypeSynonyms :: (Data d) => ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d

45+saturateAllTypeSynonyms moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym moduleName name n result) d syns

4646

4747

4848

src/Language/PureScript/TypeChecker/Types.hs+84−55

@@ -15,11 +15,12 @@

1515{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}

1616

1717module Language.PureScript.TypeChecker.Types (

18− typeOf

18+ typesOf

1919) where

2020

2121import Data.List

2222import Data.Maybe (fromMaybe)

23+import Data.Either (lefts, rights)

2324import qualified Data.Data as D

2425import Data.Generics

2526 (mkT, something, everywhere, everywhereBut, mkQ, extQ)

@@ -36,6 +37,7 @@ import Language.PureScript.Unknown

3637

3738import Control.Monad.State

3839import Control.Monad.Error

40+import Control.Monad.Reader

3941

4042import Control.Applicative

4143import Control.Arrow (Arrow(..))

@@ -131,41 +133,57 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

131133 ret1 `unifyTypes` ret2

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

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

134− modulePath <- checkModulePath `fmap` get

135− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)

136+ env <- getEnv

137+ moduleName <- substCurrentModule `fmap` ask

138+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)

136139 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

137140 t3 `unifyTypes` t5

138141 t4 `unifyTypes` t6

139142 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()

140143 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

141144

142−isFunction :: Value -> Bool

143−isFunction (Abs _ _) = True

144−isFunction (TypedValue untyped _) = isFunction untyped

145−isFunction _ = False

146−

147−typeOf :: Maybe Ident -> Value -> Check Type

148−typeOf name val = do

149− (ty, sub, checks) <- runSubst $ case name of

150− Just ident | isFunction val ->

151− case val of

152− TypedValue value ty -> do

153− kind <- liftCheck $ kindOf ty

154− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

155− ty' <- replaceAllTypeSynonyms ty

156− modulePath <- checkModulePath <$> get

157− bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check value ty'

158− return ty'

159− _ -> do

160− me <- fresh

161− modulePath <- checkModulePath <$> get

162− ty <- bindNames (M.singleton (modulePath, ident) (me, LocalVariable)) $ infer val

163− ty ~~ me

164− return ty

165− _ -> infer val

166− escapeCheck checks ty sub

167− skolemEscapeCheck ty

168− return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty

145+typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool

146+typeConstructorsAreEqual env moduleName c1 c2 =

147+ let

148+ c1' = qualify moduleName c1

149+ c2' = qualify moduleName c2

150+ in

151+ canonicalize env c1' == canonicalize env c2'

152+ where

153+ canonicalize :: Environment -> (ModuleName, ProperName) -> (ModuleName, ProperName)

154+ canonicalize _ key = case key `M.lookup` types env of

155+ Just (_, DataAlias mn' pn') -> (mn', pn')

156+ _ -> key

157+

158+typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]

159+typesOf moduleName vals = do

160+ (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do

161+ let es = map isTyped vals

162+ typed = lefts es

163+ untyped = rights es

164+ typedDict = map (\(ident, ty, _) -> (ident, ty)) typed

165+ untypedNames <- replicateM (length untyped) fresh

166+ let untypedDict = zip (map fst untyped) untypedNames

167+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)

168+ tys <- forM es $ \e -> case e of

169+ Left (_, ty, val) -> do

170+ kind <- liftCheck $ kindOf moduleName ty

171+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

172+ ty' <- replaceAllTypeSynonyms ty

173+ bindNames dict $ check val ty'

174+ return ty'

175+ Right (ident, val) -> do

176+ ty <- bindNames dict $ infer val

177+ ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

178+ return ty

179+ return tys

180+ forM tys $ flip (escapeCheck checks) sub

181+ forM tys $ skolemEscapeCheck

182+ return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys

183+

184+isTyped :: (Ident, Value) -> Either (Ident, Type, Value) (Ident, Value)

185+isTyped (name, TypedValue value ty) = Left (name, ty, value)

186+isTyped (name, value) = Right (name, value)

169187

170188escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()

171189escapeCheck checks ty sub =

@@ -234,11 +252,12 @@ replaceVarWithUnknown ident ty = do

234252 ru <- fresh

235253 return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty

236254

237−replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d

255+replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d

238256replaceAllTypeSynonyms d = do

239257 env <- getEnv

240− let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env

241− either throwError return $ saturateAllTypeSynonyms syns d

258+ moduleName <- substCurrentModule <$> ask

259+ let syns = map (\((path, name), (args, _)) -> (Qualified (Just path) name, length args)) . M.toList $ typeSynonyms env

260+ either throwError return $ saturateAllTypeSynonyms moduleName syns d

242261

243262desaturateAllTypeSynonyms :: (D.Data d) => d -> d

244263desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

@@ -249,8 +268,8 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

249268expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type

250269expandTypeSynonym name args = do

251270 env <- getEnv

252− modulePath <- checkModulePath `fmap` get

253− case M.lookup (qualify modulePath name) (typeSynonyms env) of

271+ moduleName <- substCurrentModule `fmap` ask

272+ case M.lookup (qualify moduleName name) (typeSynonyms env) of

254273 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body

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

256275

@@ -308,7 +327,8 @@ infer' (Accessor prop val) = do

308327 Just ty -> return ty

309328infer' (Abs args ret) = do

310329 ts <- replicateM (length args) fresh

311− bindLocalVariables (zip args ts) $ do

330+ moduleName <- substCurrentModule <$> ask

331+ bindLocalVariables moduleName (zip args ts) $ do

312332 body <- infer' ret

313333 return $ Function ts body

314334infer' app@(App _ _) = do

@@ -318,7 +338,8 @@ infer' app@(App _ _) = do

318338 checkFunctionApplications ft argss ret

319339 return ret

320340infer' (Var var) = do

321− ty <- lookupVariable var

341+ moduleName <- substCurrentModule <$> ask

342+ ty <- lookupVariable moduleName var

322343 replaceAllTypeSynonyms ty

323344infer' (Block ss) = do

324345 ret <- fresh

@@ -327,8 +348,8 @@ infer' (Block ss) = do

327348 return ret

328349infer' (Constructor c) = do

329350 env <- getEnv

330− modulePath <- checkModulePath `fmap` get

331− case M.lookup (qualify modulePath c) (dataConstructors env) of

351+ moduleName <- substCurrentModule `fmap` ask

352+ case M.lookup (qualify moduleName c) (dataConstructors env) of

332353 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

333354 Just ty -> replaceAllTypeSynonyms ty

334355infer' (Case vals binders) = do

@@ -343,7 +364,8 @@ infer' (IfThenElse cond th el) = do

343364 t2 ~~ t3

344365 return t2

345366infer' (TypedValue val ty) = do

346− kind <- liftCheck $ kindOf ty

367+ moduleName <- substCurrentModule <$> ask

368+ kind <- liftCheck $ kindOf moduleName ty

347369 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

348370 ty' <- replaceAllTypeSynonyms ty

349371 check val ty'

@@ -440,16 +462,16 @@ inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty

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

441463inferBinder val (NullaryBinder ctor) = do

442464 env <- getEnv

443− modulePath <- checkModulePath <$> get

444− case M.lookup (qualify modulePath ctor) (dataConstructors env) of

465+ moduleName <- substCurrentModule <$> ask

466+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of

445467 Just ty -> do

446468 ty `subsumes` val

447469 return M.empty

448470 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"

449471inferBinder val (UnaryBinder ctor binder) = do

450472 env <- getEnv

451− modulePath <- checkModulePath <$> get

452− case M.lookup (qualify modulePath ctor) (dataConstructors env) of

473+ moduleName <- substCurrentModule <$> ask

474+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of

453475 Just ty -> do

454476 fn <- replaceAllVarsWithUnknowns ty

455477 case fn of

@@ -490,8 +512,9 @@ inferBinder val (NamedBinder name binder) = do

490512checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()

491513checkBinders _ _ [] = return ()

492514checkBinders nvals ret ((binders, grd, val):bs) = do

515+ moduleName <- substCurrentModule <$> ask

493516 m1 <- M.unions <$> zipWithM inferBinder nvals binders

494− bindLocalVariables (M.toList m1) $ do

517+ bindLocalVariables moduleName (M.toList m1) $ do

495518 check val ret

496519 case grd of

497520 Nothing -> return ()

@@ -501,8 +524,8 @@ checkBinders nvals ret ((binders, grd, val):bs) = do

501524assignVariable :: Ident -> Subst ()

502525assignVariable name = do

503526 env <- checkEnv <$> get

504− modulePath <- checkModulePath <$> get

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

527+ moduleName <- substCurrentModule <$> ask

528+ case M.lookup (moduleName, name) (names env) of

506529 Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."

507530 _ -> return ()

508531

@@ -525,16 +548,18 @@ checkStatement mass ret (If ifst) = do

525548 allCodePathsReturn <- checkIfStatement mass ret ifst

526549 return (allCodePathsReturn, mass)

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

551+ moduleName <- substCurrentModule <$> ask

528552 assignVariable ident

529553 check start Number

530554 check end Number

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

555+ (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner

532556 return (allCodePathsReturn, mass)

533557checkStatement mass ret (ForEach ident vals inner) = do

558+ moduleName <- substCurrentModule <$> ask

534559 assignVariable ident

535560 val <- fresh

536561 check vals (Array val)

537− (allCodePathsReturn, _) <- bindLocalVariables [(ident, val)] $ checkBlock mass ret inner

562+ (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, val)] $ checkBlock mass ret inner

538563 guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn

539564 return (False, mass)

540565checkStatement mass _ (ValueStatement val) = do

@@ -562,8 +587,9 @@ checkElseStatement mass ret (ElseIf ifst) = checkIfStatement mass ret ifst

562587checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)

563588checkBlock mass _ [] = return (False, mass)

564589checkBlock mass ret (s:ss) = do

590+ moduleName <- substCurrentModule <$> ask

565591 (b1, mass1) <- checkStatement mass ret s

566− bindLocalVariables (M.toList mass1) $ case (b1, ss) of

592+ bindLocalVariables moduleName (M.toList mass1) $ case (b1, ss) of

567593 (True, []) -> return (True, mass1)

568594 (True, _) -> throwError "Unreachable code"

569595 (False, ss') -> checkBlock mass1 ret ss'

@@ -602,18 +628,21 @@ check' (Binary op left right) ty = checkBinary op left right ty

602628check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)

603629check' (Indexer index vals) ty = check index Number >> check vals (Array ty)

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

631+ moduleName <- substCurrentModule <$> ask

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

606− bindLocalVariables (zip args argTys) $ check ret retTy

633+ bindLocalVariables moduleName (zip args argTys) $ check ret retTy

607634check' app@(App _ _) ret = do

608635 let (f, argss) = unfoldApplication app

609636 ft <- infer f

610637 checkFunctionApplications ft argss ret

611638check' (Var var) ty = do

612− ty1 <- lookupVariable var

639+ moduleName <- substCurrentModule <$> ask

640+ ty1 <- lookupVariable moduleName var

613641 repl <- replaceAllTypeSynonyms ty1

614642 repl `subsumes` ty

615643check' (TypedValue val ty1) ty2 = do

616− kind <- liftCheck $ kindOf ty1

644+ moduleName <- substCurrentModule <$> ask

645+ kind <- liftCheck $ kindOf moduleName ty1

617646 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

618647 ty1 `subsumes` ty2

619648 check val ty1

@@ -643,8 +672,8 @@ check' (Block ss) ret = do

643672 guardWith "Block is missing a return statement" allCodePathsReturn

644673check' (Constructor c) ty = do

645674 env <- getEnv

646− modulePath <- checkModulePath <$> get

647− case M.lookup (qualify modulePath c) (dataConstructors env) of

675+ moduleName <- substCurrentModule <$> ask

676+ case M.lookup (qualify moduleName c) (dataConstructors env) of

648677 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

649678 Just ty1 -> do

650679 repl <- replaceAllTypeSynonyms ty1

src/Language/PureScript/TypeDeclarations.hsnew file+35

@@ -0,0 +1,35 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.TypeDeclarations

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.TypeDeclarations (

16+ desugarTypeDeclarations,

17+ desugarTypeDeclarationsModule

18+) where

19+

20+import Control.Applicative

21+import Control.Monad.Error.Class

22+import Control.Monad (forM)

23+

24+import Language.PureScript.Declarations

25+import Language.PureScript.Values

26+

27+desugarTypeDeclarationsModule :: [Module] -> Either String [Module]

28+desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds

29+

30+desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

31+desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =

32+ desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)

33+desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

34+desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

35+desugarTypeDeclarations [] = return []

src/Main.hs+7−7

@@ -22,21 +22,21 @@ import System.Exit (exitSuccess, exitFailure)

2222import qualified System.IO.UTF8 as U

2323import Text.Parsec (ParseError)

2424

25−readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Declaration])

26−readInput Nothing = getContents >>= return . P.runIndentParser P.parseDeclarations

25+readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])

26+readInput Nothing = getContents >>= return . P.runIndentParser P.parseModules

2727readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do

2828 text <- U.readFile inputFile

29− return $ P.runIndentParser P.parseDeclarations text

29+ return $ P.runIndentParser P.parseModules text

3030

3131compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

3232compile input output externs = do

33− asts <- readInput input

34− case asts of

33+ modules <- readInput input

34+ case modules of

3535 Left err -> do

3636 U.print err

3737 exitFailure

38− Right decls ->

39− case P.compile decls of

38+ Right ms ->

39+ case P.compile ms of

4040 Left err -> do

4141 U.putStrLn err

4242 exitFailure

tests/Main.hs+4−4

@@ -27,12 +27,12 @@ import qualified Data.Map as M

2727

2828compile :: FilePath -> IO (Either String P.Environment)

2929compile inputFile = do

30− ast <- P.runIndentParser P.parseDeclarations <$> U.readFile inputFile

31− case ast of

30+ modules <- P.runIndentParser P.parseModules <$> U.readFile inputFile

31+ case modules of

3232 Left parseError -> do

3333 return (Left $ show parseError)

34− Right decls -> do

35− case P.compile decls of

34+ Right ms -> do

35+ case P.compile ms of

3636 Left typeError -> do

3737 return (Left typeError)

3838 Right (_, _, env) -> do