git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge branch 'bindinggroups'
bcc7e77Phil Freeman
examples/failing/Arrays.purs+3−1
compare with golang
unifiedsplit
@@ -1 +1,3 @@
1+module Arrays where
2+
1−test = \arr -> arr !! (0 !! 0)
3+ test = \arr -> arr !! (0 !! 0)
examples/failing/Import.purs+3−1
@@ -1 +1,3 @@
1+module Module where
2+
1−import UndefinedModule
3+ import UndefinedModule
examples/failing/KindError.purs+3−1
@@ -1 +1,3 @@
1+module KindError where
2+
1−data KindError f a = One f | Two f a
3+ data KindError f a = One f | Two f a
examples/failing/LocalVars.purs+6−3
@@ -1,3 +1,6 @@
1+module LocalVars where
2+
1−bad = \x -> do
3+ bad = \x -> {
2− x = x + 1
4+ x = x + 1;
3− return x
5+ return x;
6+ }
examples/failing/PatternScope.purs+9−6
@@ -1,7 +1,10 @@
1+module PatternScope where
2+
1−-- Pattern scope doesn't leak
3+ -- Pattern scope doesn't leak
2−foobar = \x -> do
4+ foobar = \x -> {
3− var y = case x of
5+ var y = case x of
4− z | z % 2 == 0 -> 1
6+ z | z % 2 == 0 -> 1
5− _ -> 2
7+ _ -> 2;
6− return z
8+ return z;
9+ }
7
10
examples/failing/Rank2Types.purs+4−2
@@ -1,3 +1,5 @@
1−foreign import test :: (forall a. a -> a) -> Number
1+module Rank2Types where
2
2
3+ foreign import test :: (forall a. a -> a) -> Number
4+
3−test1 = test (\n -> n + 1)
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
2
2
3−foreign import show :: forall a. a -> String
3+ foreign import read :: forall a. String -> a
4
4
5+ foreign import show :: forall a. a -> String
6+
5−test = \x -> show (read x)
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
2
2
3+ foreign import foo :: (forall a. a -> a) -> Number
4+
3−test = \x -> foo x
5+ test = \x -> foo x
examples/failing/TypeError.purs+3−3
@@ -1,3 +1,3 @@
1+module TypeError where
2+
1−test = do
3+ test = x ++ "A"
2− var x = 0
3− return x ++ "A"
examples/passing/Arrays.purs+3−1
@@ -1,3 +1,5 @@
1+module Arrays where
2+
1test1 = \arr -> arr !! 0 + arr !! 1
3test1 = \arr -> arr !! 0 + arr !! 1
2
4
3test2 = \arr -> case arr of
5test2 = \arr -> case arr of
@@ -16,5 +18,5 @@ test4 = \arr -> case arr of
16 [] -> 0
18 [] -> 0
17 [_] -> 0
19 [_] -> 0
18 x : y : xs -> x * y + test4 xs
20 x : y : xs -> x * y + test4 xs
19−
21+
20
22
examples/passing/Assign.purs+8−6
@@ -1,7 +1,9 @@
1+module Assign where
2+
1−sum = \n -> {
3+ sum = \n -> {
2− var x = 0;
4+ var x = 0;
3− for (i <- 0 until n) {
5+ for (i <- 0 until n) {
4− x = x + i;
6+ x = x + i;
7+ }
8+ return x;
5 }
9 }
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
2
2
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 }
4
4
5−exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
5+ type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
6−exists = \state step f -> f (Auto { state: state, step: step })
7
6
7+ exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
8+ exists = \state step f -> f (Auto { state: state, step: step })
9+
8−run :: forall i o. SomeAuto i o -> i -> o
10+ 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)
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
2
2
3−empty :: forall a. List a
3+ type List a = forall r. r -> (a -> r -> r) -> r
4−empty = \r f -> r
5
4
6−cons :: forall a. a -> List a -> List a
5+ empty :: forall a. List a
7−cons = \a l r f -> f a (l r f)
6+ empty = \r f -> r
8
7
9−append :: forall a. List a -> List a -> List a
8+ cons :: forall a. a -> List a -> List a
10−append = \l1 l2 r f -> l2 (l1 r f) f
9+ cons = \a l r f -> f a (l r f)
11
10
11+ append :: forall a. List a -> List a -> List a
12+ append = \l1 l2 r f -> l2 (l1 r f) f
13+
12−test = append (cons 1 empty) (cons 2 empty)
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
2
2
3−bin = \x -> if x && !x then x else x
3+ fns = \f -> if f true then f else \x -> x
4
4
5+ bin = \x -> if x && !x then x else x
6+
5−not = \x -> if x then false else true
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
2
2
3−foreign import (:) :: forall a. a -> [a] -> [a]
3+ infixr 6 :
4
4
5−test1 = \xs -> 1 : xs
5+ foreign import (:) :: forall a. a -> [a] -> [a]
6
6
7+ test1 = \xs -> 1 : xs
8+
7−test2 = 1 : 2 : 3 : []
9+ test2 = 1 : 2 : 3 : []
examples/passing/Console.purs+17−15
@@ -1,23 +1,25 @@
1−foreign import data IO :: * -> *
1+module Console where
2
2
3−foreign import ret :: forall a. a -> IO a
3+ foreign import data IO :: * -> *
4
4
5−foreign import (>>=) :: forall a b. IO a -> (a -> IO b) -> IO b
5+ foreign import ret :: forall a. a -> IO a
6
6
7−(*>) = \a -> \b -> a >>= \x -> b
7+ foreign import (>>=) :: forall a b. IO a -> (a -> IO b) -> IO b
8
8
9−foreign import putStrLn :: String -> IO {}
9+ (*>) = \a -> \b -> a >>= \x -> b
10
10
11+ foreign import putStrLn :: String -> IO {}
12+
11−replicateM_ :: forall a. Number -> IO a -> IO {}
13+ replicateM_ :: forall a. Number -> IO a -> IO {}
12−replicateM_ = \n -> \x ->
14+ replicateM_ = \n -> \x ->
13− {
15+ {
14− var io = ret {};
16+ var io = ret {};
15− for (i <- 0 until n)
17+ for (i <- 0 until n)
16− {
18+ {
17− io = x *> io;
19+ io = x *> io;
20+ }
21+ return io;
18 }
22 }
19− return io;
20− }
21
23
22−main = replicateM_ 10 (putStrLn "Hello World!")
24+ main = replicateM_ 10 (putStrLn "Hello World!")
23
25
examples/passing/DataImport.pursnew file+10
@@ -0,0 +1,10 @@
1+module M1 where
2+
3+data Test = Test
4+
5+module M2 where
6+
7+import M1
8+
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
2
2
3−foreign import fmap :: forall a b. IO a -> (a -> b) -> IO b
3+ foreign import data IO :: * -> *
4
4
5−foreign import ret :: forall a. a -> IO a
5+ foreign import fmap :: forall a b. IO a -> (a -> b) -> IO b
6
6
7−foreign import bind :: forall a b. IO a -> (a -> IO b) -> IO b
7+ foreign import ret :: forall a. a -> IO a
8
8
9−foreign import showMessage :: String -> IO { }
9+ foreign import bind :: forall a b. IO a -> (a -> IO b) -> IO b
10
10
11−foreign import prompt :: IO String
11+ foreign import showMessage :: String -> IO { }
12
12
13+ foreign import prompt :: IO String
14+
13−main = prompt `bind` \s -> showMessage s
15+ main = prompt `bind` \s -> showMessage s
examples/passing/FFI.purs+8−1
@@ -1,5 +1,12 @@
1+module FFI where
2+
1foreign import foo :: String -> String
3foreign import foo :: String -> String
2
4
3bar :: String -> String
5bar :: String -> String
4−
5bar = \x -> foo (x ++ "bar")
6bar = \x -> foo (x ++ "bar")
7+
8+module FFIModuleTest where
9+
10+import FFI
11+
12+baz = foo "test"
examples/passing/Foreach.purs+8−6
@@ -1,7 +1,9 @@
1+module Foreach where
2+
1−sum = \ns -> {
3+ sum = \ns -> {
2− var total = 0;
4+ var total = 0;
3− foreach (n in ns) {
5+ foreach (n in ns) {
4− total = total + n;
6+ total = total + n;
7+ }
8+ return total;
5 }
9 }
6− return total;
7− }
examples/passing/Functions.purs+8−6
@@ -1,11 +1,13 @@
1−test1 = \ -> 0
1+module Functions where
2
2
3−test2 = \() -> 0
3+ test1 = \ -> 0
4
4
5−test3 = \a (b, c) d -> a + b + c + d
5+ test2 = \() -> 0
6
6
7−test4 = \(a) -> a
7+ test3 = \a (b, c) d -> a + b + c + d
8
8
9−test5 = \(%%) -> 1 %% 2
9+ test4 = \(a) -> a
10
10
11+ test5 = \(%%) -> 1 %% 2
12+
11−test6 = \((+++), (***)) -> 1 +++ 2 *** 3
13+ test6 = \((+++), (***)) -> 1 +++ 2 *** 3
examples/passing/Guards.purs+9−7
@@ -1,8 +1,10 @@
1−collatz = \x -> case x of
1+module Guards where
2− y | y % 2 == 0 -> y / 2
3− y -> y * 3 + 1
4
2
3+ collatz = \x -> case x of
4+ y | y % 2 == 0 -> y / 2
5+ y -> y * 3 + 1
6+
5−-- Guards have access to current scope
7+ -- Guards have access to current scope
6−collatz2 = \x y -> case x of
8+ collatz2 = \x y -> case x of
7− z | y > 0 -> z / 2
9+ z | y > 0 -> z / 2
8− z -> z * 3 + 1
10+ z -> z * 3 + 1
examples/passing/IfThenElse.purs+30−28
@@ -1,34 +1,36 @@
1−testIf =
1+module IfThenElse where
2− {
3− var x = 0;
4− if (x == 0) {
5− x = x + 1;
6− }
7− return x;
8− }
9
2
10−testIfElse =
3+ testIf =
11− {
4+ {
12− var x = 0;
5+ var x = 0;
13− if (x == 0) {
6+ if (x == 0) {
14− x = x + 1;
7+ x = x + 1;
15− } else {
8+ }
16− x = x - 1;
9+ return x;
17 }
10 }
18− return x;
19− }
20
11
21−testIfElseIf = \x ->
12+ testIfElse =
22− {
13+ {
23− var y = x;
14+ var x = 0;
24− while (y > 1) {
25− if (y % 3 == 0) {
15+ if (x == 0) {
26− y = y / 3;
16+ x = x + 1;
27− } else if (y % 3 == 1) {
28− y = (y - 1) % 3;
29 } else {
17 } else {
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 {
30− y = y * 4 + 1;
32+ y = y * 4 + 1;
33+ }
31 }
34 }
35+ return y;
32 }
36 }
33− return y;
34− }
examples/passing/Import.purs+6−6
@@ -1,12 +1,12 @@
1−module Hello where
1+module M1 where
2+
2 id :: forall a. a -> a
3 id :: forall a. a -> a
3 id = \x -> x
4 id = \x -> x
4
5
5− module Nested where
6+ foo = id
6− import Hello (id)
7
7
8− foo = id
8+module M2 where
9
9
10−import Hello.Nested
10+ import M1
11
11
12−main = \() -> foo 42
12+ main = \() -> foo 42
examples/passing/List.purs+17−15
@@ -1,19 +1,21 @@
1+module List where
2+
1−data List a
3+ data List a
2− = Nil
4+ = Nil
3− | Cons
5+ | Cons
4− { head :: a
6+ { head :: a
5− , tail :: List a
7+ , tail :: List a
6− }
8+ }
7
9
8−isNull Nil = true
10+ isNull Nil = true
9−isNull _ = false
11+ isNull _ = false
10
12
11−concat Nil l2 = l2
13+ concat Nil l2 = l2
12−concat (Cons x) l2 = Cons
14+ concat (Cons x) l2 = Cons
13− { head: x.head
15+ { head: x.head
14− , tail: concat x.tail l2
16+ , tail: concat x.tail l2
15− }
17+ }
16
18
17−flatten Nil = Nil
19+ flatten Nil = Nil
18−flatten (Cons cons) = concat cons.head (flatten cons.tail)
20+ flatten (Cons cons) = concat cons.head (flatten cons.tail)
19
21
examples/passing/Match.purs+4−2
@@ -1,3 +1,5 @@
1−data Foo a = Foo
1+module Match where
2
2
3+ data Foo a = Foo
4+
3−foo = \f -> case f of Foo -> "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
2
2
3−maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
3+ data Maybe a = Nothing | Just a
4−maybe b _ Nothing = b
5−maybe _ f (Just a) = f a
6
4
5+ maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
7−fmap m f = maybe Nothing (\a -> Just (f a)) m
6+ maybe b _ Nothing = b
7+ maybe _ f (Just a) = f a
8
8
9+ fmap m f = maybe Nothing (\a -> Just (f a)) m
10+
9−bind m f = maybe Nothing f m
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
2
2
3+ foreign import foo :: () -> {}
4+
3−test = {
5+ test = {
4− foo();
6+ foo();
5− return 0;
7+ return 0;
6− }
8+ }
examples/passing/Module.purs+7−12
@@ -1,8 +1,8 @@
1−module Test where
1+module M1 where
2
2
3 data Foo = Foo String
3 data Foo = Foo String
4
4
5− foo :: Test.Foo -> String
5+ foo :: M1.Foo -> String
6 foo = \f -> case f of Foo s -> s ++ "foo"
6 foo = \f -> case f of Foo s -> s ++ "foo"
7
7
8 bar :: Foo -> String
8 bar :: Foo -> String
@@ -11,15 +11,10 @@ module Test where
11 incr :: Number -> Number
11 incr :: Number -> Number
12 incr x = x + 1
12 incr x = x + 1
13
13
14− module Inner where
14+module M2 where
15
15
16− inner = "Inner"
16+ baz :: M1.Foo -> String
17+ baz = M1.foo
17
18
18−baz :: Test.Foo -> String
19−baz = Test.foo
20−
21−innerCopy :: String
22−innerCopy = Test.Inner.inner
23−
24−match :: Test.Foo -> String
19+ match :: M1.Foo -> String
25−match = \f -> case f of Test.Foo s -> s ++ "foo"
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
1+module Monad where
2− , bind :: forall a b. m a -> (a -> m b) -> m b }
3
2
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 }
5
5
6−id :: Monad Id
6+ data Id a = Id a
7−id = { ret : Id
8− , bind : \ma f -> case ma of Id a -> f a }
9
7
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 }
11
11
12−maybe :: Monad Maybe
12+ data Maybe a = Nothing | Just a
13−maybe = { ret : Just
14− , bind : \ma f -> case ma of
15− Nothing -> Nothing
16− Just a -> f a
17− }
18
13
19−test :: forall m. Monad m -> m Number
14+ maybe :: Monad Maybe
20−test = \m -> m.bind (m.ret 1) (\n1 ->
15+ maybe = { ret : Just
21− m.bind (m.ret "Test") (\n2 ->
16+ , bind : \ma f -> case ma of
22− m.ret n1))
17+ Nothing -> Nothing
18+ Just a -> f a
19+ }
23
20
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))
25
25
26+ test1 = test id
27+
26−test2 = test maybe
28+ test2 = test maybe
examples/passing/MutRec.pursnew file+15
@@ -0,0 +1,15 @@
1+module MutRec where
2+
3+ f 0 = 0
4+ f x = g x + 1
5+
6+ g x = f (x / 2)
7+
8+ data Even = Zero | Even Odd
9+
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+module NamedPatterns where
2+
1−foo = \x -> case x of
3+ foo = \x -> case x of
2− y@{ foo = "Foo" } -> y
4+ y@{ foo = "Foo" } -> y
3− y -> 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
2
2
3+ data Extend r a = Extend { prev :: r a, next :: a }
4+
3−data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) 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
2
2
3−update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
4−update2 = \o -> o { foo = "Foo" }
3+ update1 = \o -> o { foo = "Foo" }
5
4
6−replace = \o -> case o of
5+ update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
7− { foo = "Foo" } -> o { foo = "Bar" }
6+ update2 = \o -> o { foo = "Foo" }
8− { foo = "Bar" } -> o { bar = "Baz" }
9− o -> o
10
7
11−polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
8+ replace = \o -> case o of
12−polyUpdate = \o -> o { foo = "Foo" }
9+ { foo = "Foo" } -> o { foo = "Bar" }
10+ { foo = "Bar" } -> o { bar = "Baz" }
11+ o -> o
13
12
13+ polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
14+ polyUpdate = \o -> o { foo = "Foo" }
15+
14−inferPolyUpdate = \o -> o { foo = "Foo" }
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
2
2
3−append = \o -> { foo: o.foo, bar: 1 }
3+ test = \x -> x.foo + x.bar
4
4
5−apTest = append({foo : "Foo", baz: "Baz"})
5+ append = \o -> { foo: o.foo, bar: 1 }
6
6
7−f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }
7+ apTest = append({foo : "Foo", baz: "Baz"})
8
8
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" }
10
10
11+ g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }
12+
11−typed :: { foo :: Number }
13+ typed :: { foo :: Number }
12−typed = { foo: 0 }
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
2
2
3−test2 = (\x -> x.foo false) { foo : \_ -> 1 }
3+ (@@) :: forall a b. (a -> b) -> a -> b
4+ (@@) = \f x -> f x
4
5
5−test3 = (\(x, y) -> x)(1 + 2 * (1 + 2), true && (false || false))
6+ foo :: String -> String
7+ foo = \s -> s
8+
9+ test8 = foo @@ "Hello World"
6
10
7−k = \x -> \y -> x
11+ bar = \s1 s2 -> s1 ++ s2
8
12
9−test4 = 1 `k` 2
13+module Operators2 where
10
14
11−infixl 5 %%
15+ test1 = \(x, y, z) -> x * y + z(x)(y)
12
16
13−(%%) = \x -> \y -> x * y + y
17+ test2 = (\x -> x.foo false) { foo : \_ -> 1 }
14
18
15−test5 = 1 %% 2 %% 3
19+ test3 = (\(x, y) -> x)(1 + 2 * (1 + 2), true && (false || false))
16
20
17−test6 = ((\x -> x) `k` 2) 3
21+ k = \x -> \y -> x
18
22
19−(<>) = \s1 -> \s2 -> s1 ++ s2
23+ test4 = 1 `k` 2
20
24
21−test7 = "Hello" <> "World!"
25+ infixl 5 %%
22
26
23−module Ops where
24−
25− (@@) :: forall a b. (a -> b) -> a -> b
26− (@@) = \f x -> f x
27+ (%%) = \x -> \y -> x * y + y
27
28
28− foo :: String -> String
29+ test5 = 1 %% 2 %% 3
29− foo = \s -> s
30−
31− test8 = foo @@ "Hello World"
32
30
31+ test6 = ((\x -> x) `k` 2) 3
32+
33− bar = \s1 s2 -> s1 ++ s2
33+ (<>) = \s1 -> \s2 -> s1 ++ s2
34+
35+ test7 = "Hello" <> "World!"
34
36
35−test9 = Ops.foo Ops.@@ "Hello World"
37+ test9 = Operators1.foo Operators1.@@ "Hello World"
36
38
37−test10 = "Hello" `Ops.bar` "World"
39+ test10 = "Hello" `Operators1.bar` "World"
38
40
39−(...) :: forall a. [a] -> [a] -> [a]
41+ (...) :: forall a. [a] -> [a] -> [a]
40−(...) = \as -> \bs -> as
42+ (...) = \as -> \bs -> as
41
43
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
1+module Patterns where
2− { str = "Foo", bool = true } -> true
3− { str = "Bar", bool = b } -> b
4− _ -> false
5
2
6−f = \o -> case o of
3+ test = \x -> case x of
7− { foo = "Foo" } -> o.bar
4+ { str = "Foo", bool = true } -> true
8− _ -> 0
5+ { str = "Bar", bool = b } -> b
6+ _ -> false
9
7
10−g = \o -> case o of
8+ f = \o -> case o of
11− { arr = [x : xs], take = "car" } -> x
9+ { foo = "Foo" } -> o.bar
12− { arr = [_, x : xs], take = "cadr" } -> x
13− _ -> 0
10+ _ -> 0
14
11
12+ g = \o -> case o of
13+ { arr = [x : xs], take = "car" } -> x
14+ { arr = [_, x : xs], take = "cadr" } -> x
15+ _ -> 0
15
16
16−h = \o -> case o of
17− a@[_,_,_] -> a
18− _ -> []
19
17
18+ h = \o -> case o of
19+ a@[_,_,_] -> a
20+ _ -> []
21+
20−isDesc = \o -> case o of
22+ isDesc = \o -> case o of
21− [x, y] | x > y -> true
23+ [x, y] | x > y -> true
22− _ -> false
24+ _ -> false
23−
25+
examples/passing/Person.purs+8−6
@@ -1,7 +1,9 @@
1−data Person = Person { name :: String, age :: Number }
1+module Person where
2
2
3+ data Person = Person { name :: String, age :: Number }
4+
3−foreign import itoa :: Number -> String
5+ foreign import itoa :: Number -> String
4−
6+
5−showPerson :: Person -> String
7+ showPerson :: Person -> String
6−showPerson = \p -> case p of
8+ showPerson = \p -> case p of
7− Person o -> o.name ++ ", aged " ++ itoa(o.age)
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
2
2
3−runId = \id a -> case id of
3+ data Id = Id forall a. a -> a
4− Id f -> f a
5
4
6−data Nat = Nat forall r. r -> (r -> r) -> r
5+ runId = \id a -> case id of
6+ Id f -> f a
7
7
8−runNat = \nat -> case nat of
8+ data Nat = Nat forall r. r -> (r -> r) -> r
9− Nat f -> f 0 (\n -> n + 1)
10
9
11−zero = Nat (\zero _ -> zero)
10+ runNat = \nat -> case nat of
11+ Nat f -> f 0 (\n -> n + 1)
12
12
13−succ = \n -> case n of
14− Nat f -> Nat (\zero succ -> succ (f zero succ))
13+ zero = Nat (\zero _ -> zero)
15
14
16−add = \n m -> case n of
15+ succ = \n -> case n of
17− Nat f -> case m of
18− Nat g -> Nat (\zero succ -> g (f zero succ) succ)
16+ Nat f -> Nat (\zero succ -> succ (f zero succ))
19
17
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+
20−one = succ zero
22+ one = succ zero
21−two = succ zero
23+ two = succ zero
22−four = add two two
24+ four = add two two
23−fourNumber = runNat four
25+ fourNumber = runNat four
examples/passing/Rank2Types.purs+13−11
@@ -1,17 +1,19 @@
1−test1 :: (forall a. (a -> a)) -> Number
1+module Rank2Types where
2−test1 = \f -> f 0
3
2
4−foreign import data ST :: * -> * -> *
3+ test1 :: (forall a. (a -> a)) -> Number
4+ test1 = \f -> f 0
5
5
6−foreign import runST :: forall a. (forall s. ST s a) -> a
6+ foreign import data ST :: * -> * -> *
7
7
8−foreign import exampleST :: forall s. ST s Number
8+ foreign import runST :: forall a. (forall s. ST s a) -> a
9
9
10−testST = runST exampleST
10+ foreign import exampleST :: forall s. ST s Number
11
11
12−foreign import push :: forall el. el -> [el] -> [el]
12+ testST = runST exampleST
13
13
14+ foreign import push :: forall el. el -> [el] -> [el]
15+
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]
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]
15−replicateM = \ret bind n m -> case n of
17+ replicateM = \ret bind n m -> case n of
16− 0 -> ret []
18+ 0 -> ret []
17− n -> bind m (\x -> bind (replicateM ret bind (n - 1) m) (\xs -> ret (push x xs)))
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+module Recursion where
2+
1−fib = \n -> case n of
3+ fib = \n -> case n of
2− 0 -> 1
4+ 0 -> 1
3− 1 -> 1
5+ 1 -> 1
4− n -> fib (n - 1) + fib (n - 2)
6+ n -> fib (n - 1) + fib (n - 2)
examples/passing/TopLevelCase.purs+11−9
@@ -1,12 +1,14 @@
1−gcd :: (Number, Number) -> Number
1+module TopLevelCase where
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)
6
2
7−guardsTest (x:xs) | x > 0 = guardsTest xs
3+ gcd :: (Number, Number) -> Number
8−guardsTest xs = xs
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)
9
8
10−data A = A
9+ guardsTest (x:xs) | x > 0 = guardsTest xs
10+ guardsTest xs = xs
11
11
12+ data A = A
13+
12−parseTest A 0 = 0
14+ parseTest A 0 = 0
examples/passing/TypeDecl.purs+13−11
@@ -1,14 +1,16 @@
1−id :: forall a. (a) -> a
1+module TypeDecl where
2−id = \x -> x
3
2
4−k :: String -> Number -> String
3+ id :: forall a. (a) -> a
5−k = \x -> \y -> x
4+ id = \x -> x
6
5
6+ k :: String -> Number -> String
7+ k = \x -> \y -> x
8+
7−iterate :: forall a. Number -> (a -> a) -> a -> a
9+ iterate :: forall a. Number -> (a -> a) -> a -> a
8−iterate = \n -> \f -> \a -> {
10+ iterate = \n -> \f -> \a -> {
9− var result = a;
11+ var result = a;
10− for (i <- 0 until n) {
12+ for (i <- 0 until n) {
11− result = f result;
13+ result = f result;
14+ }
15+ return result;
12 }
16 }
13− return result;
14− }
examples/passing/TypeSynonyms.purs+26−24
@@ -1,31 +1,33 @@
1−type Lens a b =
1+module TypeSynonyms where
2− { get :: a -> b
3− , set :: a -> b -> a
4− }
5
2
6−composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
3+ type Lens a b =
7−composeLenses = \l1 -> \l2 ->
8− { get: \a -> l2.get (l1.get a)
4+ { get :: a -> b
9− , set: \a -> \c ->
5+ , set :: a -> b -> a
10− {
11− var b = l1.get a;
12− var b1 = l2.set b c;
13− return l1.set a b1;
14 }
6 }
15− }
16
7
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+
17−type Pair a b = { fst :: a, snd :: b }
19+ type Pair a b = { fst :: a, snd :: b }
18
20
19−fst :: forall a b. Lens (Pair a b) a
21+ fst :: forall a b. Lens (Pair a b) a
20−fst =
22+ fst =
21− { get: \p -> p.fst
23+ { get: \p -> p.fst
22− , set: \p -> \a -> { fst: a, snd: p.snd }
24+ , set: \p -> \a -> { fst: a, snd: p.snd }
23− }
25+ }
24
26
25−test1 :: forall a b c. Lens (Pair (Pair a b) c) a
27+ test1 :: forall a b c. Lens (Pair (Pair a b) c) a
26−test1 = composeLenses fst fst
28+ test1 = composeLenses fst fst
27
29
28−foreign import head :: forall a. Lens [a] a
30+ foreign import head :: forall a. Lens [a] a
29
31
30−test2 :: forall a b c. Lens (Pair [Pair a b] c) a
32+ test2 :: forall a b c. Lens (Pair [Pair a b] c) a
31−test2 = composeLenses fst (composeLenses head fst)
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
2
2
3−k = \x -> \y -> x
3+ s = \x -> \y -> \z -> x z (y z)
4
4
5+ k = \x -> \y -> x
6+
5−iota = \x -> x s k
7+ iota = \x -> x s k
examples/passing/s.purs+3−1
@@ -1 +1,3 @@
1+module S where
2+
1−s = \x y z -> x z (y z)
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 });
1+var l1 = List.Cons({ head: 1, tail: List.Nil });
2−var l2 = Cons({ head: 2, tail: Nil });
2+var l2 = List.Cons({ head: 2, tail: List.Nil });
3−var l3 = Cons({ head: l1, tail: Cons({ head: l2, tail: Nil }) });
3+var l3 = List.Cons({ head: l1, tail: List.Cons({ head: l2, tail: List.Nil }) });
4−var flat = flatten(l3);
4+var flat = List.flatten(l3);
5var f1 = flat.value.head;
5var f1 = flat.value.head;
6var f2 = flat.value.tail.value.head
6var f2 = flat.value.tail.value.head
7console.log([f1, f2]);
7console.log([f1, f2]);
examples/shelltest/Maybe.js+3−3
@@ -1,5 +1,5 @@
1−console.log(bind(Just("a"))(function(a) {
1+console.log(Maybe.bind(Maybe.Just("a"))(function(a) {
2− return bind(Just("b"))(function(b) {
2+ return Maybe.bind(Maybe.Just("b"))(function(b) {
3− return Just(a + b);
3+ return Maybe.Just(a + b);
4 });
4 });
5}));
5}));
examples/shelltest/runAll.test+1−1
@@ -2,7 +2,7 @@
2mkdir -p tests && ../../dist/build/psc/psc ../passing/Maybe.purs -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | nodejs
2mkdir -p tests && ../../dist/build/psc/psc ../passing/Maybe.purs -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | nodejs
3<<<
3<<<
4>>>
4>>>
5−{ ctor: 'Just', value: 'ab' }
5+{ ctor: 'Maybe.Just', value: 'ab' }
6>>>2
6>>>2
7>>>= 0
7>>>= 0
8
8
libraries/jquery/example.purs+10−6
@@ -1,6 +1,10 @@
1+module Example where
2+
3+ import JQuery
4+
1−main = {
5+ main = {
2− var div = create "<div>";
6+ var div = create "<div>";
3− div = div `appendText` "Hello World!" `css` { color: "#FF0000" };
7+ div = div `appendText` "Hello World!" `css` { color: "#FF0000" };
4− div = div `appendTo` select "body";
8+ div = div `appendTo` select "body";
5− return { };
9+ return { };
6− }
10+ }
libraries/jquery/jquery.purs+18−16
@@ -1,23 +1,25 @@
1−-- The jQuery wrapper type
1+module JQuery where
2−foreign import data JQuery :: *
3
2
4−-- Wrapper function for jQuery selection $('..')
3+ -- The jQuery wrapper type
5−foreign import select :: String -> JQuery
4+ foreign import data JQuery :: *
6
5
7−-- Wrapper function for jQuery creation e.g. $('<div>')
6+ -- Wrapper function for jQuery selection $('..')
8−foreign import create :: String -> JQuery
7+ foreign import select :: String -> JQuery
9
8
10−-- .attr({ ... })
9+ -- Wrapper function for jQuery creation e.g. $('<div>')
11−foreign import attr :: forall attr. JQuery -> { | attr } -> JQuery
10+ foreign import create :: String -> JQuery
12
11
13−-- .css({ ... })
12+ -- .attr({ ... })
14−foreign import css :: forall css. JQuery -> { | css } -> JQuery
13+ foreign import attr :: forall attr. JQuery -> { | attr } -> JQuery
15
14
16−-- .append(...)
15+ -- .css({ ... })
17−foreign import append :: JQuery -> JQuery -> JQuery
16+ foreign import css :: forall css. JQuery -> { | css } -> JQuery
18
17
19−-- .appendTo(...)
18+ -- .append(...)
20−foreign import appendTo :: JQuery -> JQuery -> JQuery
19+ foreign import append :: JQuery -> JQuery -> JQuery
21
20
21+ -- .appendTo(...)
22+ foreign import appendTo :: JQuery -> JQuery -> JQuery
23+
22−-- .append(...)
24+ -- .append(...)
23−foreign import appendText :: JQuery -> String -> JQuery
25+ foreign import appendText :: JQuery -> String -> JQuery
libraries/prelude/prelude.purs+177−171
@@ -1,263 +1,269 @@
1−id :: forall a. a -> a
1+module Prelude where
2−id = \x -> x
3
2
4−flip :: forall a b c. (a -> b -> c) -> b -> a -> c
3+ id :: forall a. a -> a
5−flip = \f -> \b -> \a -> f a b
4+ id = \x -> x
6
5
7−konst :: forall a b. a -> b -> a
6+ flip :: forall a b c. (a -> b -> c) -> b -> a -> c
8−konst = \a -> \b -> a
7+ flip = \f -> \b -> \a -> f a b
9
8
10−(|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c
9+ konst :: forall a b. a -> b -> a
11−(|>) = \f -> \g -> \a -> g (f a)
10+ konst = \a -> \b -> a
12
11
13−(<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
12+ (|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c
14−(<|) = flip (|>)
13+ (|>) = \f -> \g -> \a -> g (f a)
15
14
16−-- Maybe
15+ (<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
16+ (<|) = flip (|>)
17
17
18−data Maybe a = Nothing | Just a
18+module Maybe where
19
19
20−maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
20+ data Maybe a = Nothing | Just a
21−maybe b _ Nothing = b
22−maybe _ f (Just a) = f a
23
21
24−fromMaybe :: forall a. a -> Maybe a -> a
22+ maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
25−fromMaybe a = maybe a id
23+ maybe b _ Nothing = b
24+ maybe _ f (Just a) = f a
26
25
27−bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
26+ fromMaybe :: forall a. a -> Maybe a -> a
28−bindMaybe m f = maybe Nothing f m
27+ fromMaybe a = maybe a Prelude.id
29
28
30−-- Either
29+ bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
30+ bindMaybe m f = maybe Nothing f m
31
31
32−data Either a b = Left a | Right b
32+module Either where
33
33
34−either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
34+ data Either a b = Left a | Right b
35−either f _ (Left a) = f a
36−either _ g (Right b) = g b
37
35
38−bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b
36+ either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
39−bindEither = either (\e _ -> Left e) (\a f -> f a)
37+ either f _ (Left a) = f a
38+ either _ g (Right b) = g b
40
39
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)
42
42
43−head :: forall a. [a] -> a
43+module Arrays where
44−head (x : _) = x
45
44
46−headSafe :: forall a. [a] -> Maybe a
45+ import Maybe
47−headSafe (x : _) = Just x
48−headSafe _ = Nothing
49
46
50−tail :: forall a. [a] -> [a]
47+ head :: forall a. [a] -> a
51−tail (_ : xs) = xs
48+ head (x : _) = x
52
49
53−tailSafe :: forall a. [a] -> Maybe [a]
50+ headSafe :: forall a. [a] -> Maybe a
54−tailSafe (_ : xs) = Just xs
51+ headSafe (x : _) = Just x
55−tailSafe _ = Nothing
52+ headSafe _ = Nothing
56
53
57−foreign import map :: forall a b. (a -> b) -> [a] -> [b]
54+ tail :: forall a. [a] -> [a]
55+ tail (_ : xs) = xs
58
56
59−foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a
57+ tailSafe :: forall a. [a] -> Maybe [a]
60−foldr f a (b : bs) = f (foldr f a bs) b
58+ tailSafe (_ : xs) = Just xs
61−foldr _ a [] = a
59+ tailSafe _ = Nothing
62
60
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+
63−foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b
67+ foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b
64−foldl f b as = {
68+ foldl f b as = {
65− var result = b;
69+ var result = b;
66− foreach (a in as) {
70+ foreach (a in as) {
67− result = f a result;
71+ result = f a result;
72+ }
73+ return result;
68 }
74 }
69− return result;
70− }
71
75
72−foreign import member "length" length :: forall a. [a] -> Number
76+ foreign import member "length" length :: forall a. [a] -> Number
73
77
74−foreign import indexOf :: forall a. [a] -> a -> Number
78+ foreign import indexOf :: forall a. [a] -> a -> Number
75
79
76−foreign import lastIndexOf :: forall a. [a] -> a -> Number
80+ foreign import lastIndexOf :: forall a. [a] -> a -> Number
77
81
78−foreign import concat :: forall a. [a] -> [a] -> [a]
82+ foreign import concat :: forall a. [a] -> [a] -> [a]
79
83
80−foreign import join :: [String] -> String
84+ foreign import join :: [String] -> String
81
85
82−foreign import joinWith :: [String] -> String -> String
86+ foreign import joinWith :: [String] -> String -> String
83
87
84−foreign import push :: forall a. [a] -> a -> [a]
88+ foreign import push :: forall a. [a] -> a -> [a]
85
89
86−foreign import reverse :: forall a. [a] -> [a]
90+ foreign import reverse :: forall a. [a] -> [a]
87
91
88−foreign import shift :: forall a. [a] -> [a]
92+ foreign import shift :: forall a. [a] -> [a]
89
93
90−foreign import slice :: forall a. Number -> Number -> [a] -> [a]
94+ foreign import slice :: forall a. Number -> Number -> [a] -> [a]
91
95
92−foreign import sort :: forall a. [a] -> [a]
96+ foreign import sort :: forall a. [a] -> [a]
93
97
94−foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]
98+ foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]
95
99
96−cons :: forall a. a -> [a] -> [a]
100+ cons :: forall a. a -> [a] -> [a]
97−cons = \a -> concat([a])
101+ cons a = concat [a]
98
102
99−concatMap :: forall a b. [a] -> (a -> [b]) -> [b]
103+ concatMap :: forall a b. [a] -> (a -> [b]) -> [b]
100−concatMap as f = {
104+ concatMap as f = {
101− var result = [];
105+ var result = [];
102− foreach (a in as) {
106+ foreach (a in as) {
103− result = result `concat` f a;
107+ result = result `concat` f a;
108+ }
109+ return result;
104 }
110 }
105− return result;
106− }
107
111
108−foreign import filter :: forall a. [a] -> (a -> Boolean) -> [a]
112+ foreign import filter :: forall a. [a] -> (a -> Boolean) -> [a]
109
113
110−empty :: forall a. [a] -> Boolean
114+ empty :: forall a. [a] -> Boolean
111−empty [] = true
115+ empty [] = true
112−empty _ = false
116+ empty _ = false
113
117
114−range :: Number -> Number -> [Number]
118+ range :: Number -> Number -> [Number]
115−range lo hi = {
119+ range lo hi = {
116− var ns = [];
120+ var ns = [];
117− for (n <- lo until hi) {
121+ for (n <- lo until hi) {
118− ns = push ns n;
122+ ns = push ns n;
123+ }
124+ return ns;
119 }
125 }
120− return ns;
126+
121− }
122−
123−zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
127+ 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)
128+ zipWith f (a:as) (b:bs) = cons (f a b) (zipWith f as bs)
125−zipWith _ _ _ = []
129+ zipWith _ _ _ = []
126−
130+
127−any :: forall a. (a -> Boolean) -> [a] -> Boolean
131+ any :: forall a. (a -> Boolean) -> [a] -> Boolean
128−any p as = {
132+ any p as = {
129− for (i <- 0 until length as) {
133+ for (i <- 0 until length as) {
130− if (p (as !! i)) {
134+ if (p (as !! i)) {
131− return true;
135+ return true;
136+ }
132 }
137 }
138+ return false;
133 }
139 }
134− return false;
140+
135− }
136−
137−all :: forall a. (a -> Boolean) -> [a] -> Boolean
141+ all :: forall a. (a -> Boolean) -> [a] -> Boolean
138−all p as = {
142+ all p as = {
139− for (i <- 0 until length as) {
143+ for (i <- 0 until length as) {
140− if (!(p (as !! i))) {
144+ if (!(p (as !! i))) {
141− return false;
145+ return false;
146+ }
142 }
147 }
148+ return true;
143 }
149 }
144− return true;
145− }
146
150
147−-- Pairs
151+module Tuple where
148
152
149−type Tuple a b = { fst :: a, snd :: b }
153+ import Arrays
150
154
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 }
153
156
154−uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
157+ curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
155−uncurry f t = f t.fst t.snd
158+ curry f a b = f { fst: a, snd: b }
156
159
157−tuple :: forall a b. a -> b -> Tuple a b
160+ uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
158−tuple = curry id
161+ uncurry f t = f t.fst t.snd
159
162
160−zip :: forall a b. [a] -> [b] -> [Tuple a b]
163+ tuple :: forall a b. a -> b -> Tuple a b
161−zip = zipWith tuple
164+ tuple = curry Prelude.id
162
165
163−unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]
166+ zip :: forall a b. [a] -> [b] -> [Tuple a b]
164−unzip (t:ts) = case unzip ts of
167+ zip = zipWith tuple
165− { fst = as, snd = bs } -> tuple (cons t.fst as) (cons t.snd bs)
166−unzip [] = tuple [] []
167
168
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 [] []
169
173
170−foreign import member "length" lengthS :: String -> Number
174+module String where
171
175
172−foreign import charAt :: Number -> String -> String
176+ foreign import member "length" lengthS :: String -> Number
173
177
174−foreign import indexOfS :: String -> String -> Number
178+ foreign import charAt :: Number -> String -> String
175
179
176−foreign import lastIndexOfS :: String -> String -> Number
180+ foreign import indexOfS :: String -> String -> Number
177
181
178−foreign import localeCompare :: String -> String -> Number
182+ foreign import lastIndexOfS :: String -> String -> Number
179
183
180−foreign import replace :: String -> String -> String -> String
184+ foreign import localeCompare :: String -> String -> Number
181
185
182−foreign import sliceS :: Number -> Number -> String -> String
186+ foreign import replace :: String -> String -> String -> String
183
187
184−foreign import split :: String -> String -> [String]
188+ foreign import sliceS :: Number -> Number -> String -> String
185
189
186−foreign import substr :: Number -> Number -> String -> String
190+ foreign import split :: String -> String -> [String]
187
191
188−foreign import substring :: Number -> Number -> String -> String
192+ foreign import substr :: Number -> Number -> String -> String
189
193
190−foreign import toLower :: String -> String
194+ foreign import substring :: Number -> Number -> String -> String
191
195
192−foreign import toUpper :: String -> String
196+ foreign import toLower :: String -> String
193
197
194−foreign import trim :: String -> String
198+ foreign import toUpper :: String -> String
195
199
196−-- Regex
200+ foreign import trim :: String -> String
197
201
198−foreign import data Regex :: *
202+module Regex where
199
203
200−foreign import regex :: String -> String -> Regex
204+ foreign import data Regex :: *
201
205
202−foreign import test :: Regex -> String -> Boolean
206+ foreign import regex :: String -> String -> Regex
203
207
204−foreign import match :: Regex -> String -> [String]
208+ foreign import test :: Regex -> String -> Boolean
205
209
206−foreign import replaceR :: Regex -> String -> String -> String
210+ foreign import match :: Regex -> String -> [String]
207
211
208−foreign import search :: Regex -> String -> Number
212+ foreign import replaceR :: Regex -> String -> String -> String
209
213
210−-- Globals
214+ foreign import search :: Regex -> String -> Number
211
215
212−foreign import nan :: Number
216+module Global where
213
217
214−foreign import infinity :: Number
218+ foreign import nan :: Number
215
219
216−foreign import toExponential :: Number -> String
220+ foreign import infinity :: Number
217
221
218−foreign import toFixed :: Number -> Number -> String
222+ foreign import toExponential :: Number -> String
219
223
220−foreign import toPrecision :: Number -> Number -> String
224+ foreign import toFixed :: Number -> Number -> String
221
225
222−foreign import numberToString :: Number -> String
226+ foreign import toPrecision :: Number -> Number -> String
223
227
224−foreign import isNaN :: Number -> Boolean
228+ foreign import numberToString :: Number -> String
225
229
226−foreign import isFinite :: Number -> Boolean
230+ foreign import isNaN :: Number -> Boolean
227
231
228−foreign import parseFloat :: String -> Number
232+ foreign import isFinite :: Number -> Boolean
229
233
230−foreign import parseInt :: String -> Number
234+ foreign import parseFloat :: String -> Number
231
235
232−foreign import encodeURIComponent :: String -> String
236+ foreign import parseInt :: String -> Number
233
237
234−foreign import decodeURIComponent :: String -> String
238+ foreign import encodeURIComponent :: String -> String
235
239
236−foreign import encodeURI :: String -> String
240+ foreign import decodeURIComponent :: String -> String
237
241
238−foreign import decodeURI :: String -> String
242+ foreign import encodeURI :: String -> String
239
243
240−-- Math
244+ foreign import decodeURI :: String -> String
241
245
246+module Math where
247+
242−type Math =
248+ type Math =
243− { abs :: Number -> Number
249+ { abs :: Number -> Number
244− , acos :: Number -> Number
250+ , acos :: Number -> Number
245− , asin :: Number -> Number
251+ , asin :: Number -> Number
246− , atan :: Number -> Number
252+ , atan :: Number -> Number
247− , atan2 :: (Number, Number) -> Number
253+ , atan2 :: (Number, Number) -> Number
248− , aceil :: Number -> Number
254+ , aceil :: Number -> Number
249− , cos :: Number -> Number
255+ , cos :: Number -> Number
250− , exp :: Number -> Number
256+ , exp :: Number -> Number
251− , floor :: Number -> Number
257+ , floor :: Number -> Number
252− , log :: Number -> Number
258+ , log :: Number -> Number
253− , max :: (Number, Number) -> Number
259+ , max :: (Number, Number) -> Number
254− , pow :: (Number, Number) -> Number
260+ , pow :: (Number, Number) -> Number
255− , random :: () -> Number
261+ , random :: () -> Number
256− , round :: Number -> Number
262+ , round :: Number -> Number
257− , sin :: Number -> Number
263+ , sin :: Number -> Number
258− , sqrt :: Number -> Number
264+ , sqrt :: Number -> Number
259− , tan :: Number -> Number
265+ , tan :: Number -> Number
260− }
266+ }
261
267
262−foreign import math :: Math
268+ foreign import math :: Math
263
269
purescript.cabal+5−4
@@ -17,10 +17,11 @@ library
17 build-depends: base >=4 && <5, cmdtheline -any, containers -any,
17 build-depends: base >=4 && <5, cmdtheline -any, containers -any,
18 directory -any, filepath -any, mtl -any, parsec -any, syb -any,
18 directory -any, filepath -any, mtl -any, parsec -any, syb -any,
19 transformers -any, utf8-string -any
19 transformers -any, utf8-string -any
20− exposed-modules: Language.PureScript.Scope Data.Generics.Extras
20+ exposed-modules: Language.PureScript.TypeDeclarations
21+ Language.PureScript.BindingGroups Language.PureScript.Scope
21− Language.PureScript Language.PureScript.CodeGen
22+ Data.Generics.Extras Language.PureScript
22− Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS
23+ Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
23− Language.PureScript.CodeGen.JS.AST
24+ Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST
24 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations
25 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations
25 Language.PureScript.Kinds Language.PureScript.Names
26 Language.PureScript.Kinds Language.PureScript.Names
26 Language.PureScript.Operators Language.PureScript.Optimize
27 Language.PureScript.Operators Language.PureScript.Optimize
src/Language/PureScript.hs+10−8
@@ -26,15 +26,17 @@ import Language.PureScript.Pretty as P
26import Language.PureScript.Optimize as P
26import Language.PureScript.Optimize as P
27import Language.PureScript.Operators as P
27import Language.PureScript.Operators as P
28import Language.PureScript.CaseDeclarations as P
28import Language.PureScript.CaseDeclarations as P
29+import Language.PureScript.TypeDeclarations as P
30+import Language.PureScript.BindingGroups as P
29
31
30import Data.List (intercalate)
32import Data.List (intercalate)
31−import Data.Maybe (mapMaybe)
33+import Control.Monad (forM_, (>=>))
32
34
33−compile :: [Declaration] -> Either String (String, String, Environment)
35+compile :: [Module] -> Either String (String, String, Environment)
34−compile decls = do
36+compile ms = do
35− bracketted <- rebracket decls
37+ bracketted <- rebracket ms
36− desugared <- desugarCases bracketted
38+ desugared <- desugarCasesModule >=> desugarTypeDeclarationsModule >=> (return . createBindingGroupsModule) $ bracketted
37− (_, env) <- runCheck (typeCheckAll desugared)
39+ (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls
38− let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared
40+ let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared
39− let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared
41+ let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared
40 return (js, exts, env)
42 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 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15module Language.PureScript.CaseDeclarations (
15module Language.PureScript.CaseDeclarations (
16− desugarCases
16+ desugarCases,
17+ desugarCasesModule
17) where
18) where
18
19
19import Data.List (groupBy)
20import Data.List (groupBy)
20−import Control.Monad (join, unless)
21+import Control.Applicative ((<$>))
22+import Control.Monad (forM, join, unless)
21import Control.Monad.Error.Class
23import Control.Monad.Error.Class
22
24
23import Language.PureScript.Names
25import Language.PureScript.Names
@@ -25,6 +27,9 @@ import Language.PureScript.Values
25import Language.PureScript.Declarations
27import Language.PureScript.Declarations
26import Language.PureScript.Scope
28import Language.PureScript.Scope
27
29
30+desugarCasesModule :: [Module] -> Either String [Module]
31+desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds
32+
28desugarCases :: [Declaration] -> Either String [Declaration]
33desugarCases :: [Declaration] -> Either String [Declaration]
29desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
34desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
30
35
@@ -39,9 +44,6 @@ toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
39 unless (all ((== map length bs) . map length . fst) tuples) $
44 unless (all ((== map length bs) . map length . fst) tuples) $
40 throwError $ "Argument list lengths differ in declaration " ++ show ident
45 throwError $ "Argument list lengths differ in declaration " ++ show ident
41 return [makeCaseDeclaration ident tuples]
46 return [makeCaseDeclaration ident tuples]
42−toDecls [ModuleDeclaration name decls] = do
43− desugared <- desugarCases decls
44− return [ModuleDeclaration name desugared]
45toDecls ds = return ds
47toDecls ds = return ds
46
48
47toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
49toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
@@ -53,7 +55,7 @@ makeCaseDeclaration ident alternatives =
53 let
55 let
54 argPattern = map length . fst . head $ alternatives
56 argPattern = map length . fst . head $ alternatives
55 args = take (sum argPattern) $ unusedNames (ident, alternatives)
57 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
57 binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]
59 binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]
58 value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)
60 value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)
59 in
61 in
src/Language/PureScript/CodeGen/Externs.hs+24−16
@@ -13,29 +13,37 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15module Language.PureScript.CodeGen.Externs (
15module Language.PureScript.CodeGen.Externs (
16− externToPs
16+ moduleToPs
17) where
17) where
18
18
19−import Data.Maybe (mapMaybe)
19+import Data.Maybe (maybeToList, mapMaybe)
20import qualified Data.Map as M
20import qualified Data.Map as M
21import Language.PureScript.Declarations
21import Language.PureScript.Declarations
22import Language.PureScript.TypeChecker.Monad
22import Language.PureScript.TypeChecker.Monad
23import Language.PureScript.Pretty
23import Language.PureScript.Pretty
24import Language.PureScript.Names
24import Language.PureScript.Names
25+import Data.List (intercalate)
25
26
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+
26−externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String
32+declToPs :: ModuleName -> Environment -> Declaration -> [String]
27−externToPs indent path env (ValueDeclaration name _ _ _) = do
33+declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do
28 (ty, _) <- M.lookup (path, name) $ names env
34 (ty, _) <- M.lookup (path, name) $ names env
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
29− return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
39+ return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
30−externToPs indent path env (DataDeclaration name _ _) = do
40+declToPs path env (DataDeclaration name _ _) = maybeToList $ do
31 (kind, _) <- M.lookup (path, name) $ types env
41 (kind, _) <- M.lookup (path, name) $ types env
32− return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
42+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
33−externToPs indent _ _ (ExternMemberDeclaration member name ty) =
43+declToPs _ _ (ExternMemberDeclaration member name ty) =
34− return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty
44+ return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty
35−externToPs indent _ _ (ExternDataDeclaration name kind) =
45+declToPs _ _ (ExternDataDeclaration name kind) =
36− return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
46+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
37−externToPs indent _ _ (TypeSynonymDeclaration name args ty) =
47+declToPs _ _ (TypeSynonymDeclaration name args ty) =
38− return $ replicate indent ' ' ++ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
48+ return $ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
39−externToPs indent path env (ModuleDeclaration name decls) =
49+declToPs _ _ _ = []
40− return $ replicate indent ' ' ++ "module " ++ show name ++ " where\n" ++ unlines (mapMaybe (externToPs (indent + 2) (subModule path name) env) decls)
41−externToPs _ _ _ _ = Nothing
src/Language/PureScript/CodeGen/JS.hs+54−39
@@ -14,7 +14,8 @@
14
14
15module Language.PureScript.CodeGen.JS (
15module Language.PureScript.CodeGen.JS (
16 module AST,
16 module AST,
17− declToJs
17+ declToJs,
18+ moduleToJs
18) where
19) where
19
20
20import Data.Maybe (mapMaybe)
21import Data.Maybe (mapMaybe)
@@ -32,40 +33,47 @@ import Language.PureScript.CodeGen.Monad
32import Language.PureScript.CodeGen.JS.AST as AST
33import Language.PureScript.CodeGen.JS.AST as AST
33import Language.PureScript.TypeChecker.Monad (NameKind(..))
34import Language.PureScript.TypeChecker.Monad (NameKind(..))
34
35
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+
35−declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]
45+declToJs :: ModuleName -> Declaration -> Environment -> Maybe [JS]
36−declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
46+declToJs mp (ValueDeclaration ident _ _ (Abs args ret)) e =
37− Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :
47+ Just [ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]),
38− maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
48+ setProperty (identToJs ident) (JSVar ident) mp ]
39−declToJs curMod mp (ValueDeclaration ident _ _ val) e =
49+declToJs mp (ValueDeclaration ident _ _ val) e =
40− Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :
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)),
41− maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
55+ setProperty (identToJs ident) (JSVar ident) mp ]
56+ ) vals
42−declToJs curMod _ (ExternMemberDeclaration member ident _) _ =
57+declToJs mp (ExternMemberDeclaration member ident _) _ =
43− Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :
58+ Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]),
44− maybe [] (return . setProperty (show ident) (JSVar ident)) curMod
59+ setProperty (show ident) (JSVar ident) mp ]
45−declToJs curMod mp (DataDeclaration _ _ ctors) _ =
60+declToJs mp (DataDeclaration _ _ ctors) _ =
46 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
61 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
47 let
62 let
48 ctorJs =
63 ctorJs =
49 case maybeTy of
64 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))) ]))
51 Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
66 Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
52 (JSBlock [JSReturn
67 (JSBlock [JSReturn
53− (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))
68+ (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))
54 , ("value", JSVar (Ident "value")) ])])
69 , ("value", JSVar (Ident "value")) ])])
55− in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) curMod
70+ in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]
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
71+declToJs _ _ _ = Nothing
64
72
65−setProperty :: String -> JS -> Ident -> JS
73+setProperty :: String -> JS -> ModuleName -> JS
66−setProperty prop val curMod = JSAssignment (JSAssignProperty prop (JSAssignVariable curMod)) val
74+setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val
67
75
68−valueToJs :: ModulePath -> Environment -> Value -> JS
76+valueToJs :: ModuleName -> Environment -> Value -> JS
69valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n
77valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n
70valueToJs _ _ (StringLiteral s) = JSStringLiteral s
78valueToJs _ _ (StringLiteral s) = JSStringLiteral s
71valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b
79valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b
@@ -82,20 +90,27 @@ valueToJs m e (App val args) = JSApp (valueToJs m e val) (map (valueToJs m e) ar
82valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m e val)])
90valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m e val)])
83valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)
91valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)
84valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)
92valueToJs 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
93+valueToJs m e (Var ident) = varToJs m e ident
86− Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified aliasModule aliasIdent)
87− _ -> qualifiedToJS identToJs ident
88valueToJs m e (TypedValue val _) = valueToJs m e val
94valueToJs m e (TypedValue val _) = valueToJs m e val
89valueToJs _ _ _ = error "Invalid argument to valueToJs"
95valueToJs _ _ _ = error "Invalid argument to valueToJs"
90
96
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+
91qualifiedToJS :: (a -> String) -> Qualified a -> JS
109qualifiedToJS :: (a -> String) -> Qualified a -> JS
92−qualifiedToJS f (Qualified (ModulePath parts) a) =
110+qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))
93− delimited (f a : reverse (map show parts))
111+qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))
94− where delimited [part] = JSVar (Ident (part))
95− delimited (part:parts') = JSAccessor part (delimited parts')
96− delimited _ = error "Invalid argument to delimited"
97
112
98−bindersToJs :: ModulePath -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
113+bindersToJs :: ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
99bindersToJs m e binders vals = do
114bindersToJs m e binders vals = do
100 setNextName $ firstUnusedName (binders, vals)
115 setNextName $ firstUnusedName (binders, vals)
101 valNames <- replicateM (length vals) fresh
116 valNames <- replicateM (length vals) fresh
@@ -111,7 +126,7 @@ bindersToJs m e binders vals = do
111 binderToJs m e v done'' b
126 binderToJs m e v done'' b
112 go _ _ _ _ = error "Invalid arguments to bindersToJs"
127 go _ _ _ _ = error "Invalid arguments to bindersToJs"
113
128
114−binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]
129+binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]
115binderToJs _ _ _ done NullBinder = return done
130binderToJs _ _ _ done NullBinder = return done
116binderToJs _ _ varName done (StringBinder str) =
131binderToJs _ _ varName done (StringBinder str) =
117 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
132 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
@@ -124,11 +139,11 @@ binderToJs _ _ varName done (BooleanBinder False) =
124binderToJs _ _ varName done (VarBinder ident) =
139binderToJs _ _ varName done (VarBinder ident) =
125 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)
140 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)
126binderToJs m _ varName done (NullaryBinder ctor) =
141binderToJs 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]
128binderToJs m e varName done (UnaryBinder ctor b) = do
143binderToJs m e varName done (UnaryBinder ctor b) = do
129 value <- fresh
144 value <- fresh
130 js <- binderToJs m e value done b
145 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]
132binderToJs m e varName done (ObjectBinder bs) = go done bs
147binderToJs m e varName done (ObjectBinder bs) = go done bs
133 where
148 where
134 go :: [JS] -> [(String, Binder)] -> Gen [JS]
149 go :: [JS] -> [(String, Binder)] -> Gen [JS]
@@ -163,7 +178,7 @@ binderToJs m e varName done (NamedBinder ident binder) = do
163 js <- binderToJs m e varName done binder
178 js <- binderToJs m e varName done binder
164 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
179 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
165
180
166−statementToJs :: ModulePath -> Environment -> Statement -> JS
181+statementToJs :: ModuleName -> Environment -> Statement -> JS
167statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))
182statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))
168statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)
183statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)
169statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))
184statementToJs 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)
29
29
30data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
30data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
31
31
32+data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
33+
32data Declaration
34data Declaration
33 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
35 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
36+ | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe PolyType)])]
34 | TypeSynonymDeclaration ProperName [String] PolyType
37 | TypeSynonymDeclaration ProperName [String] PolyType
35 | TypeDeclaration Ident PolyType
38 | TypeDeclaration Ident PolyType
36 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
39 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
40+ | BindingGroupDeclaration [(Ident, Value)]
37 | ExternDeclaration Ident PolyType
41 | ExternDeclaration Ident PolyType
38 | ExternMemberDeclaration String Ident PolyType
42 | ExternMemberDeclaration String Ident PolyType
39 | ExternDataDeclaration ProperName Kind
43 | ExternDataDeclaration ProperName Kind
40 | FixityDeclaration Fixity String
44 | FixityDeclaration Fixity String
41− | ModuleDeclaration ProperName [Declaration]
42− | ImportDeclaration ModulePath (Maybe [Ident])
45+ | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
43 deriving (Show, D.Data, D.Typeable)
46 deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Names.hs+9−19
@@ -17,7 +17,6 @@
17module Language.PureScript.Names where
17module Language.PureScript.Names where
18
18
19import Data.Data
19import Data.Data
20−import Data.List (inits, intercalate)
21
20
22data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
21data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
23
22
@@ -30,26 +29,17 @@ newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, D
30instance Show ProperName where
29instance Show ProperName where
31 show = runProperName
30 show = runProperName
32
31
33−data ModulePath = ModulePath [ProperName] deriving (Eq, Ord, Data, Typeable)
32+data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)
34
33
35−instance Show ModulePath where
34+instance Show ModuleName where
36− show (ModulePath segments) = intercalate "." $ map show segments
35+ show (ModuleName name) = show name
37
36
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)
45
38
46instance (Show a) => Show (Qualified a) where
39instance (Show a) => Show (Qualified a) where
47− show (Qualified (ModulePath names) a) = intercalate "." (map show names ++ [show a])
40+ show (Qualified Nothing a) = show a
48−
41+ show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a
49−qualify :: ModulePath -> Qualified a -> (ModulePath, a)
50−qualify mp (Qualified (ModulePath []) a) = (mp, a)
51−qualify _ (Qualified mp a) = (mp, a)
52
42
53−nameResolution :: ModulePath -> Qualified a -> [(ModulePath, a)]
43+qualify :: ModuleName -> Qualified a -> (ModuleName, a)
54−nameResolution (ModulePath mp) (Qualified (ModulePath []) a) = [ (ModulePath mp', a) | mp' <- reverse $ inits mp ]
44+qualify m (Qualified Nothing a) = (m, a)
55−nameResolution _ (Qualified mp a) = [(mp, 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
33import qualified Text.Parsec.Pos as P
33import qualified Text.Parsec.Pos as P
34import qualified Text.Parsec.Expr as P
34import qualified Text.Parsec.Expr as P
35
35
36−rebracket :: [Declaration] -> Either String [Declaration]
36+rebracket :: [Module] -> Either String [Module]
37−rebracket ds = do
37+rebracket ms = forM ms $ \(Module name ds) -> do
38− m <- collectFixities ds
38+ m <- collectFixities (ModuleName name) ds
39 let opTable = customOperatorTable m
39 let opTable = customOperatorTable m
40− ds' <- G.everywhereM' (G.mkM (matchOperators opTable)) ds
40+ ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds
41− return $ G.everywhere (G.mkT removeParens) ds'
41+ return $ Module name $ G.everywhere (G.mkT removeParens) ds'
42
42
43removeParens :: Value -> Value
43removeParens :: Value -> Value
44removeParens (Parens val) = val
44removeParens (Parens val) = val
@@ -56,8 +56,8 @@ customOperatorTable fixities =
56
56
57type Chain = [Either Value (Qualified Ident)]
57type Chain = [Either Value (Qualified Ident)]
58
58
59−matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
59+matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
60−matchOperators ops val = G.everywhereM' (G.mkM parseChains) val
60+matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val
61 where
61 where
62 parseChains :: Value -> Either String Value
62 parseChains :: Value -> Either String Value
63 parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)
63 parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)
@@ -67,7 +67,7 @@ matchOperators ops val = G.everywhereM' (G.mkM parseChains) val
67 extendChain other = [Left other]
67 extendChain other = [Left other]
68 bracketChain :: Chain -> Either String Value
68 bracketChain :: Chain -> Either String Value
69 bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
69 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
71 ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]]
71 ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]]
72
72
73toAssoc :: Associativity -> P.Assoc
73toAssoc :: Associativity -> P.Assoc
@@ -80,27 +80,24 @@ parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)
80parseOp :: P.Parsec Chain () (Qualified Ident)
80parseOp :: P.Parsec Chain () (Qualified Ident)
81parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator"
81parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator"
82
82
83−matchOp :: Qualified Ident -> P.Parsec Chain () ()
83+matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()
84−matchOp op = do
84+matchOp moduleName op = do
85 ident <- parseOp
85 ident <- parseOp
86− guard (ident == op)
86+ guard (qualify moduleName ident == qualify moduleName op)
87
87
88−collectFixities :: [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
88+collectFixities :: ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
89−collectFixities = go M.empty global
89+collectFixities = go M.empty
90 where
90 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)
92 go m _ [] = return m
92 go m _ [] = return m
93− go m p (FixityDeclaration fixity name : rest) = do
93+ go m moduleName (FixityDeclaration fixity name : rest) = do
94− let qual = Qualified p (Op name)
94+ let qual = Qualified (Just moduleName) (Op name)
95 when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)
95 when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)
96− go (M.insert qual fixity m) p rest
96+ go (M.insert qual fixity m) moduleName 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
97+ go m moduleName (_:ds) = go m moduleName ds
101
98
102globalOp :: String -> Qualified Ident
99globalOp :: String -> Qualified Ident
103−globalOp = Qualified global . Op
100+globalOp = Qualified Nothing . Op
104
101
105builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]
102builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]
106builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)
103builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)
src/Language/PureScript/Parser/Common.hs+3−4
@@ -188,11 +188,10 @@ properName :: P.Parsec String u ProperName
188properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
188properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
189
189
190parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
190parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
191−parseQualified parser = part global
191+parseQualified parser = qual
192 where
192 where
193− part path = (do name <- P.try (properName <* delimiter)
193+ qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)
194− part (subModule path name))
195− <|> (Qualified path <$> P.try parser)
194+ <|> (Qualified Nothing <$> P.try parser)
196 delimiter = indented *> dot
195 delimiter = indented *> dot
197
196
198integerOrFloat :: P.Parsec String u (Either Integer Double)
197integerOrFloat :: P.Parsec String u (Either Integer Double)
src/Language/PureScript/Parser/Declarations.hs+16−19
@@ -14,7 +14,8 @@
14
14
15module Language.PureScript.Parser.Declarations (
15module Language.PureScript.Parser.Declarations (
16 parseDeclaration,
16 parseDeclaration,
17− parseDeclarations
17+ parseModule,
18+ parseModules
18) where
19) where
19
20
20import Control.Applicative
21import Control.Applicative
@@ -84,25 +85,13 @@ parseFixityDeclaration = do
84 name <- operator
85 name <- operator
85 return $ FixityDeclaration fixity name
86 return $ FixityDeclaration fixity name
86
87
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−
99parseImportDeclaration :: P.Parsec String ParseState Declaration
88parseImportDeclaration :: P.Parsec String ParseState Declaration
100parseImportDeclaration = do
89parseImportDeclaration = do
101 reserved "import"
90 reserved "import"
102 indented
91 indented
103− modulePath <- parseModulePath
92+ moduleName <- ModuleName <$> properName
104− idents <- P.optionMaybe $ parens $ commaSep1 parseIdent
93+ idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)
105− return $ ImportDeclaration modulePath idents
94+ return $ ImportDeclaration moduleName idents
106
95
107parseDeclaration :: P.Parsec String ParseState Declaration
96parseDeclaration :: P.Parsec String ParseState Declaration
108parseDeclaration = P.choice
97parseDeclaration = P.choice
@@ -112,8 +101,16 @@ parseDeclaration = P.choice
112 , parseValueDeclaration
101 , parseValueDeclaration
113 , parseExternDeclaration
102 , parseExternDeclaration
114 , parseFixityDeclaration
103 , parseFixityDeclaration
115− , parseModuleDeclaration
116 , parseImportDeclaration ] P.<?> "declaration"
104 , parseImportDeclaration ] P.<?> "declaration"
117
105
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+
118−parseDeclarations :: P.Parsec String ParseState [Declaration]
115+parseModules :: P.Parsec String ParseState [Module]
119−parseDeclarations = whiteSpace *> mark (P.many (same *> parseDeclaration)) <* P.eof
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
32 where
32 where
33 namesV :: Value -> [Ident]
33 namesV :: Value -> [Ident]
34 namesV (Abs args _) = args
34 namesV (Abs args _) = args
35− namesV (Var (Qualified (ModulePath []) name)) = [name]
35+ namesV (Var (Qualified Nothing name)) = [name]
36 namesV _ = []
36 namesV _ = []
37 namesS :: Statement -> [Ident]
37 namesS :: Statement -> [Ident]
38 namesS (VariableIntroduction name _) = [name]
38 namesS (VariableIntroduction name _) = [name]
src/Language/PureScript/TypeChecker.hs+138−79
@@ -26,114 +26,173 @@ import Language.PureScript.TypeChecker.Synonyms as T
26
26
27import Data.Maybe
27import Data.Maybe
28import qualified Data.Map as M
28import qualified Data.Map as M
29+import Control.Monad.State
30+import Control.Monad.Error
31+import Data.Either (rights, lefts)
29
32
30−import Language.PureScript.Values
31import Language.PureScript.Types
33import Language.PureScript.Types
32import Language.PureScript.Names
34import Language.PureScript.Names
33import Language.PureScript.Kinds
35import Language.PureScript.Kinds
34import Language.PureScript.Declarations
36import Language.PureScript.Declarations
35
37
36−import Control.Monad.State
38+addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, Maybe Type)] -> Kind -> Check ()
37−import Control.Monad.Error
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 ()
38
79
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+
39−typeCheckAll :: [Declaration] -> Check ()
85+typeCheckAll :: ModuleName -> [Declaration] -> Check ()
40−typeCheckAll [] = return ()
86+typeCheckAll _ [] = return ()
41−typeCheckAll (DataDeclaration name args dctors : rest) = do
87+typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do
42 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
88 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
43− env <- getEnv
89+ typeIsNotDefined moduleName name
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)
90+ ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)
47− putEnv $ env { types = M.insert (modulePath, name) (ctorKind, Data) (types env) }
91+ addDataType moduleName name args dctors ctorKind
48− forM_ dctors $ \(dctor, maybeTy) ->
92+ typeCheckAll moduleName rest
93+typeCheckAll moduleName (DataBindingGroupDeclaration tys : rest) = do
49− rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $ do
94+ rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do
50− env' <- getEnv
95+ forM_ tys $ \(name, _, _) ->
51− guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')
96+ typeIsNotDefined moduleName name
52− let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)
97+ ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)
53− let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
98+ forM (zip tys ks) $ \((name, args, dctors), ctorKind) ->
54− let polyType = mkForAll args dctorTy
99+ addDataType moduleName name args dctors ctorKind
55− putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }
56− typeCheckAll rest
100+ typeCheckAll moduleName rest
57−typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
101+typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do
58 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
102 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
59− env <- getEnv
103+ typeIsNotDefined moduleName name
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]
104+ kind <- kindsOf moduleName name args [ty]
63− putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)
105+ addTypeSynonym moduleName name args ty kind
64− , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }
65− typeCheckAll rest
106+ typeCheckAll moduleName rest
66−typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =
107+typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
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
108+typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do
70 rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
109 rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
71− env <- getEnv
110+ valueIsNotDefined moduleName name
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
111+ [ty] <- typesOf moduleName [(name, val)]
77− putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
112+ addValue moduleName name ty
78− typeCheckAll rest
113+ typeCheckAll moduleName rest
79−typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
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
80−typeCheckAll (ExternDataDeclaration name kind : rest) = do
123+typeCheckAll moduleName (ExternDataDeclaration name kind : rest) = do
81 env <- getEnv
124 env <- getEnv
82− modulePath <- checkModulePath `fmap` get
83− guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
125+ guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)
84− putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env) }
126+ putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
85− typeCheckAll rest
127+ typeCheckAll moduleName rest
86−typeCheckAll (ExternMemberDeclaration member name ty : rest) = do
128+typeCheckAll moduleName (ExternMemberDeclaration member name ty : rest) = do
87 rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do
129 rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do
88 env <- getEnv
130 env <- getEnv
89− modulePath <- checkModulePath `fmap` get
90− kind <- kindOf ty
131+ kind <- kindOf moduleName ty
91 guardWith "Expected kind *" $ kind == Star
132 guardWith "Expected kind *" $ kind == Star
92− case M.lookup (modulePath, name) (names env) of
133+ case M.lookup (moduleName, name) (names env) of
93 Just _ -> throwError $ show name ++ " is already defined"
134 Just _ -> throwError $ show name ++ " is already defined"
94 Nothing -> case ty of
135 Nothing -> case ty of
95 _ | isSingleArgumentFunction ty -> do
136 _ | isSingleArgumentFunction ty -> do
96− putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)
137+ putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env)
97− , members = M.insert (modulePath, name) member (members env) })
138+ , members = M.insert (moduleName, name) member (members env) })
98 | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."
139 | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."
99− typeCheckAll rest
140+ typeCheckAll moduleName rest
100 where
141 where
101 isSingleArgumentFunction (Function [_] _) = True
142 isSingleArgumentFunction (Function [_] _) = True
102 isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t
143 isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t
103 isSingleArgumentFunction _ = False
144 isSingleArgumentFunction _ = False
104−typeCheckAll (ExternDeclaration name ty : rest) = do
145+typeCheckAll moduleName (ExternDeclaration name ty : rest) = do
105 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
146 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
106 env <- getEnv
147 env <- getEnv
107− modulePath <- checkModulePath `fmap` get
108− kind <- kindOf ty
148+ kind <- kindOf moduleName ty
109 guardWith "Expected kind *" $ kind == Star
149 guardWith "Expected kind *" $ kind == Star
110− case M.lookup (modulePath, name) (names env) of
150+ case M.lookup (moduleName, name) (names env) of
111 Just _ -> throwError $ show name ++ " is already defined"
151 Just _ -> throwError $ show name ++ " is already defined"
112− Nothing -> putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env) })
152+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) })
113− typeCheckAll rest
153+ typeCheckAll moduleName rest
114−typeCheckAll (FixityDeclaration _ name : rest) = do
154+typeCheckAll moduleName (FixityDeclaration _ name : rest) = do
115− typeCheckAll rest
155+ typeCheckAll moduleName rest
116 env <- getEnv
156 env <- getEnv
117− modulePath <- checkModulePath `fmap` get
118− guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (modulePath, Op name) $ names env
157+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, 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
158+typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
123 env <- getEnv
159 env <- getEnv
124− currentModule <- checkModulePath `fmap` get
125 rethrow errorMessage $ do
160 rethrow errorMessage $ do
126− guardWith ("Module " ++ show modulePath ++ " does not exist") $ moduleExists env
161+ guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env
127 case idents of
162 case idents of
163+ Nothing -> do
128− Nothing -> bindIdents (map snd $ filterModule env) currentModule env
164+ shadowIdents (map snd $ filterModule (names env)) env
129− Just idents' -> bindIdents idents' currentModule env
165+ shadowTypes (map snd $ filterModule (types env)) env
166+ Just idents' -> do
167+ shadowIdents (lefts idents') env
168+ shadowTypes (rights idents') env
130− typeCheckAll rest
169+ typeCheckAll currentModule rest
131− where errorMessage = (("Error in import declaration " ++ show modulePath ++ ":\n") ++)
170+ where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
132− filterModule = filter ((== modulePath) . fst) . M.keys . names
171+ filterModule = filter ((== moduleName) . fst) . M.keys
133− moduleExists env = not $ null $ filterModule env
172+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
134− bindIdents idents' currentModule env =
173+ shadowIdents idents' env =
135 forM_ idents' $ \ident -> do
174 forM_ idents' $ \ident -> do
136 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
175 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
137− case (modulePath, ident) `M.lookup` names env of
176+ case (moduleName, ident) `M.lookup` names env of
138− Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias modulePath ident) (names e) })
177+ Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
139− Nothing -> throwError (show modulePath ++ "." ++ show ident ++ " is undefined")
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 @@
15{-# LANGUAGE DeriveDataTypeable #-}
15{-# LANGUAGE DeriveDataTypeable #-}
16
16
17module Language.PureScript.TypeChecker.Kinds (
17module Language.PureScript.TypeChecker.Kinds (
18+ kindOf,
18 kindsOf,
19 kindsOf,
19− kindOf
20+ kindsOfAll
20) where
21) where
21
22
22import Language.PureScript.Types
23import Language.PureScript.Types
@@ -28,6 +29,7 @@ import Language.PureScript.Unknown
28
29
29import Control.Monad.State
30import Control.Monad.State
30import Control.Monad.Error
31import Control.Monad.Error
32+import Control.Monad.Reader
31
33
32import Control.Applicative
34import Control.Applicative
33
35
@@ -53,14 +55,31 @@ instance Unifiable Kind where
53 unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2
55 unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2
54 unknowns _ = []
56 unknowns _ = []
55
57
56−kindOf :: Type -> Check Kind
58+kindOf :: ModuleName -> Type -> Check Kind
57−kindOf ty = fmap (\(k, _, _) -> k) . runSubst $ starIfUnknown <$> infer Nothing M.empty ty
59+kindOf moduleName ty = fmap (\(k, _, _) -> k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty
58
60
59−kindsOf :: Maybe ProperName -> [String] -> [Type] -> Check Kind
61+kindsOf :: ModuleName -> ProperName -> [String] -> [PolyType] -> Check Kind
60−kindsOf name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst $ do
62+kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst (SubstContext moduleName) $ do
61 tyCon <- fresh
63 tyCon <- fresh
62 kargs <- replicateM (length args) fresh
64 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
64 tyCon ~~ foldr FunKind Star kargs
83 tyCon ~~ foldr FunKind Star kargs
65 forM_ ks $ \k -> k ~~ Star
84 forM_ ks $ \k -> k ~~ Star
66 return tyCon
85 return tyCon
@@ -70,56 +89,51 @@ starIfUnknown (KUnknown _) = Star
70starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
89starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
71starIfUnknown k = k
90starIfUnknown k = k
72
91
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
92+infer :: Type -> Subst Kind
77−infer name m (Array t) = do
93+infer (Array t) = do
78− k <- infer name m t
94+ k <- infer t
79 k ~~ Star
95 k ~~ Star
80 return Star
96 return Star
81−infer name m (Object row) = do
97+infer (Object row) = do
82− k <- inferRow name m row
98+ k <- inferRow row
83 k ~~ Row
99 k ~~ Row
84 return Star
100 return Star
85−infer name m (Function args ret) = do
101+infer (Function args ret) = do
86− ks <- inferAll name m args
102+ ks <- mapM infer args
87− k <- infer name m ret
103+ k <- infer ret
88 k ~~ Star
104 k ~~ Star
89 forM ks (~~ Star)
105 forM ks (~~ Star)
90 return Star
106 return Star
91−infer _ m (TypeVar v) =
107+infer (TypeVar v) = do
92− case M.lookup v m of
108+ moduleName <- substCurrentModule <$> ask
93− Just k -> return k
109+ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
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
110+infer (TypeConstructor v) = do
97 env <- liftCheck getEnv
111 env <- liftCheck getEnv
98− modulePath <- checkModulePath `fmap` get
112+ moduleName <- substCurrentModule `fmap` ask
99− case M.lookup (qualify modulePath v) (types env) of
113+ case M.lookup (qualify moduleName v) (types env) of
100 Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"
114 Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"
101 Just (kind, _) -> return kind
115 Just (kind, _) -> return kind
102−infer name m (TypeApp t1 t2) = do
116+infer (TypeApp t1 t2) = do
103 k0 <- fresh
117 k0 <- fresh
104− k1 <- infer name m t1
118+ k1 <- infer t1
105− k2 <- infer name m t2
119+ k2 <- infer t2
106 k1 ~~ FunKind k2 k0
120 k1 ~~ FunKind k2 k0
107 return k0
121 return k0
108−infer name m (ForAll ident ty) = do
122+infer (ForAll ident ty) = do
109 k <- fresh
123 k <- fresh
110− infer name (M.insert ident k m) ty
124+ moduleName <- substCurrentModule <$> ask
125+ bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty
111−infer _ _ _ = return Star
126+infer _ = return Star
112
127
113−inferRow :: Maybe (ProperName, Kind) -> M.Map String Kind -> Row -> Subst Kind
128+inferRow :: Row -> Subst Kind
114−inferRow _ m (RowVar v) = do
129+inferRow (RowVar v) = do
115− case M.lookup v m of
130+ moduleName <- substCurrentModule <$> ask
116− Just k -> return k
131+ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
117− Nothing -> throwError $ "Unbound row variable " ++ v
118−inferRow _ _ REmpty = return Row
132+inferRow REmpty = return Row
119−inferRow name m (RCons _ ty row) = do
133+inferRow (RCons _ ty row) = do
120− k1 <- infer name m ty
134+ k1 <- infer ty
121− k2 <- inferRow name m row
135+ k2 <- inferRow row
122 k1 ~~ Star
136 k1 ~~ Star
123 k2 ~~ Row
137 k2 ~~ Row
124 return Row
138 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
28import Control.Applicative
28import Control.Applicative
29import Control.Monad.State
29import Control.Monad.State
30import Control.Monad.Error
30import Control.Monad.Error
31+import Control.Monad.Reader
31
32
32import qualified Data.Map as M
33import qualified Data.Map as M
33
34
35+data NameKind
36+ = Value
37+ | Extern
38+ | Alias ModuleName Ident
34−data NameKind = Value | Extern | Alias ModulePath Ident | LocalVariable deriving Show
39+ | LocalVariable deriving Show
35
40
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
37
47
38data Environment = Environment
48data Environment = Environment
39− { names :: M.Map (ModulePath, Ident) (Type, NameKind)
49+ { names :: M.Map (ModuleName, Ident) (Type, NameKind)
40− , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)
50+ , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
41− , dataConstructors :: M.Map (ModulePath, ProperName) Type
51+ , dataConstructors :: M.Map (ModuleName, ProperName) Type
42− , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)
52+ , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
43− , members :: M.Map (ModulePath, Ident) String
53+ , members :: M.Map (ModuleName, Ident) String
44 } deriving (Show)
54 } deriving (Show)
45
55
46emptyEnvironment :: Environment
56emptyEnvironment :: Environment
47emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
57emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
48
58
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
50bindNames newNames action = do
60bindNames newNames action = do
51− orig <- get
61+ orig <- get
52 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
62 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
53 a <- action
63 a <- action
54 modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
64 modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
55 return a
65 return a
56
66
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+
57−bindLocalVariables :: (Functor m, MonadState CheckState m) => [(Ident, Type)] -> m a -> m a
75+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a
58−bindLocalVariables bindings action = do
76+bindLocalVariables moduleName bindings action =
59− modulePath <- checkModulePath `fmap` get
60− bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((modulePath, name), (ty, LocalVariable))) action
77+ bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action
61
78
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+
62−lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => Qualified Ident -> m Type
83+lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type
63−lookupVariable var = do
84+lookupVariable currentModule (Qualified moduleName var) = do
64 env <- getEnv
85 env <- getEnv
65− modulePath <- checkModulePath <$> get
86+ case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
66− let tries = map (First . flip M.lookup (names env)) (nameResolution modulePath var)
67− case getFirst (mconcat tries) of
68 Nothing -> throwError $ show var ++ " is undefined"
87 Nothing -> throwError $ show var ++ " is undefined"
69 Just (ty, _) -> return ty
88 Just (ty, _) -> return ty
70
89
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+
71data AnyUnifiable where
97data AnyUnifiable where
72 AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable
98 AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable
73
99
74data CheckState = CheckState { checkEnv :: Environment
100data CheckState = CheckState { checkEnv :: Environment
75 , checkNextVar :: Int
101 , checkNextVar :: Int
76− , checkModulePath :: ModulePath
77 }
102 }
78
103
79newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
104newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
@@ -90,7 +115,7 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
90
115
91runCheck :: Check a -> Either String (a, Environment)
116runCheck :: Check a -> Either String (a, Environment)
92runCheck c = do
117runCheck c = do
93− (a, s) <- flip runStateT (CheckState emptyEnvironment 0 global) $ unCheck c
118+ (a, s) <- flip runStateT (CheckState emptyEnvironment 0) $ unCheck c
94 return (a, checkEnv s)
119 return (a, checkEnv s)
95
120
96guardWith :: (MonadError e m) => e -> Bool -> m ()
121guardWith :: (MonadError e m) => e -> Bool -> m ()
@@ -100,14 +125,6 @@ guardWith e False = throwError e
100rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
125rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
101rethrow f = flip catchError $ \e -> throwError (f e)
126rethrow f = flip catchError $ \e -> throwError (f e)
102
127
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−
111newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
128newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
112
129
113instance Monoid Substitution where
130instance Monoid Substitution where
@@ -117,21 +134,23 @@ instance Monoid Substitution where
117data SubstState = SubstState { substSubst :: Substitution
134data SubstState = SubstState { substSubst :: Substitution
118 , substFutureEscapeChecks :: [AnyUnifiable] }
135 , substFutureEscapeChecks :: [AnyUnifiable] }
119
136
137+newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)
138+
120−newtype Subst a = Subst { unSubst :: StateT SubstState Check a }
139+newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }
121− deriving (Functor, Monad, Applicative, MonadPlus)
140+ deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)
122
141
123instance MonadState CheckState Subst where
142instance MonadState CheckState Subst where
124− get = Subst . lift $ get
143+ get = Subst . lift . lift $ get
125− put = Subst . lift . put
144+ put = Subst . lift . lift . put
126
145
127deriving instance MonadError String Subst
146deriving instance MonadError String Subst
128
147
129liftCheck :: Check a -> Subst a
148liftCheck :: Check a -> Subst a
130−liftCheck = Subst . lift
149+liftCheck = Subst . lift . lift
131
150
132−runSubst :: (Unifiable a) => Subst a -> Check (a, Substitution, [AnyUnifiable])
151+runSubst :: (Unifiable a) => SubstContext -> Subst a -> Check (a, Substitution, [AnyUnifiable])
133−runSubst subst = do
152+runSubst context subst = do
134− (a, s) <- flip runStateT (SubstState mempty []) . unSubst $ subst
153+ (a, s) <- flip runStateT (SubstState mempty []) . flip runReaderT context . unSubst $ subst
135 return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)
154 return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)
136
155
137substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
156substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
@@ -163,6 +182,13 @@ class (Typeable t, Data t, Show t) => Unifiable t where
163 apply :: Substitution -> t -> t
182 apply :: Substitution -> t -> t
164 unknowns :: t -> [Int]
183 unknowns :: t -> [Int]
165
184
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+
166occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
192occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
167occursCheck (Unknown u) t =
193occursCheck (Unknown u) t =
168 case isUnknown t of
194 case isUnknown t of
src/Language/PureScript/TypeChecker/Synonyms.hs+8−8
@@ -27,22 +27,22 @@ import Data.Generics.Extras
27import Control.Monad.Writer
27import Control.Monad.Writer
28import Control.Monad.Error
28import Control.Monad.Error
29
29
30−buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
30+buildTypeSubstitution :: ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
31−buildTypeSubstitution name n = go n []
31+buildTypeSubstitution moduleName name n = go n []
32 where
32 where
33 go :: Int -> [Type] -> Type -> Either String (Maybe Type)
33 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)
35 go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
35 go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
36 go m args (TypeApp f arg) = go (m - 1) (arg:args) f
36 go m args (TypeApp f arg) = go (m - 1) (arg:args) f
37 go _ _ _ = return Nothing
37 go _ _ _ = return Nothing
38
38
39−saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d
39+saturateTypeSynonym :: (Data d) => ModuleName -> Qualified ProperName -> Int -> d -> Either String d
40−saturateTypeSynonym name n = everywhereM' (mkM replace)
40+saturateTypeSynonym moduleName name n = everywhereM' (mkM replace)
41 where
41 where
42− replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t
42+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution moduleName name n t
43
43
44−saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d
44+saturateAllTypeSynonyms :: (Data d) => ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d
45−saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns
45+saturateAllTypeSynonyms moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym moduleName name n result) d syns
46
46
47
47
48
48
src/Language/PureScript/TypeChecker/Types.hs+84−55
@@ -15,11 +15,12 @@
15{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
15{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
16
16
17module Language.PureScript.TypeChecker.Types (
17module Language.PureScript.TypeChecker.Types (
18− typeOf
18+ typesOf
19) where
19) where
20
20
21import Data.List
21import Data.List
22import Data.Maybe (fromMaybe)
22import Data.Maybe (fromMaybe)
23+import Data.Either (lefts, rights)
23import qualified Data.Data as D
24import qualified Data.Data as D
24import Data.Generics
25import Data.Generics
25 (mkT, something, everywhere, everywhereBut, mkQ, extQ)
26 (mkT, something, everywhere, everywhereBut, mkQ, extQ)
@@ -36,6 +37,7 @@ import Language.PureScript.Unknown
36
37
37import Control.Monad.State
38import Control.Monad.State
38import Control.Monad.Error
39import Control.Monad.Error
40+import Control.Monad.Reader
39
41
40import Control.Applicative
42import Control.Applicative
41import Control.Arrow (Arrow(..))
43import Control.Arrow (Arrow(..))
@@ -131,41 +133,57 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
131 ret1 `unifyTypes` ret2
133 ret1 `unifyTypes` ret2
132 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
134 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
133 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
135 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
134− modulePath <- checkModulePath `fmap` get
136+ env <- getEnv
137+ moduleName <- substCurrentModule `fmap` ask
135− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)
138+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)
136 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
139 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
137 t3 `unifyTypes` t5
140 t3 `unifyTypes` t5
138 t4 `unifyTypes` t6
141 t4 `unifyTypes` t6
139 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
142 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
140 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
143 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
141
144
142−isFunction :: Value -> Bool
145+typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
143−isFunction (Abs _ _) = True
146+typeConstructorsAreEqual env moduleName c1 c2 =
144−isFunction (TypedValue untyped _) = isFunction untyped
147+ let
145−isFunction _ = False
148+ c1' = qualify moduleName c1
146−
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+
147−typeOf :: Maybe Ident -> Value -> Check Type
158+typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]
148−typeOf name val = do
159+typesOf moduleName vals = do
149− (ty, sub, checks) <- runSubst $ case name of
160+ (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do
150− Just ident | isFunction val ->
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)
151− case val of
168+ tys <- forM es $ \e -> case e of
152− TypedValue value ty -> do
169+ Left (_, ty, val) -> do
153− kind <- liftCheck $ kindOf ty
170+ kind <- liftCheck $ kindOf moduleName ty
154− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
171+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
155− ty' <- replaceAllTypeSynonyms ty
172+ ty' <- replaceAllTypeSynonyms ty
156− modulePath <- checkModulePath <$> get
173+ bindNames dict $ check val ty'
157− bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check value ty'
158− return ty'
174+ return ty'
159− _ -> do
175+ Right (ident, val) -> do
160− me <- fresh
161− modulePath <- checkModulePath <$> get
162− ty <- bindNames (M.singleton (modulePath, ident) (me, LocalVariable)) $ infer val
176+ ty <- bindNames dict $ infer val
163− ty ~~ me
177+ ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
164− return ty
178+ return ty
165− _ -> infer val
179+ return tys
166− escapeCheck checks ty sub
180+ forM tys $ flip (escapeCheck checks) sub
167− skolemEscapeCheck ty
181+ forM tys $ skolemEscapeCheck
168− return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
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)
169
187
170escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
188escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
171escapeCheck checks ty sub =
189escapeCheck checks ty sub =
@@ -234,11 +252,12 @@ replaceVarWithUnknown ident ty = do
234 ru <- fresh
252 ru <- fresh
235 return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty
253 return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty
236
254
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
238replaceAllTypeSynonyms d = do
256replaceAllTypeSynonyms d = do
239 env <- getEnv
257 env <- getEnv
258+ moduleName <- substCurrentModule <$> ask
240− let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env
259+ let syns = map (\((path, name), (args, _)) -> (Qualified (Just path) name, length args)) . M.toList $ typeSynonyms env
241− either throwError return $ saturateAllTypeSynonyms syns d
260+ either throwError return $ saturateAllTypeSynonyms moduleName syns d
242
261
243desaturateAllTypeSynonyms :: (D.Data d) => d -> d
262desaturateAllTypeSynonyms :: (D.Data d) => d -> d
244desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
263desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
@@ -249,8 +268,8 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
249expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
268expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
250expandTypeSynonym name args = do
269expandTypeSynonym name args = do
251 env <- getEnv
270 env <- getEnv
252− modulePath <- checkModulePath `fmap` get
271+ moduleName <- substCurrentModule `fmap` ask
253− case M.lookup (qualify modulePath name) (typeSynonyms env) of
272+ case M.lookup (qualify moduleName name) (typeSynonyms env) of
254 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
273 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
255 Nothing -> error "Type synonym was not defined"
274 Nothing -> error "Type synonym was not defined"
256
275
@@ -308,7 +327,8 @@ infer' (Accessor prop val) = do
308 Just ty -> return ty
327 Just ty -> return ty
309infer' (Abs args ret) = do
328infer' (Abs args ret) = do
310 ts <- replicateM (length args) fresh
329 ts <- replicateM (length args) fresh
330+ moduleName <- substCurrentModule <$> ask
311− bindLocalVariables (zip args ts) $ do
331+ bindLocalVariables moduleName (zip args ts) $ do
312 body <- infer' ret
332 body <- infer' ret
313 return $ Function ts body
333 return $ Function ts body
314infer' app@(App _ _) = do
334infer' app@(App _ _) = do
@@ -318,7 +338,8 @@ infer' app@(App _ _) = do
318 checkFunctionApplications ft argss ret
338 checkFunctionApplications ft argss ret
319 return ret
339 return ret
320infer' (Var var) = do
340infer' (Var var) = do
341+ moduleName <- substCurrentModule <$> ask
321− ty <- lookupVariable var
342+ ty <- lookupVariable moduleName var
322 replaceAllTypeSynonyms ty
343 replaceAllTypeSynonyms ty
323infer' (Block ss) = do
344infer' (Block ss) = do
324 ret <- fresh
345 ret <- fresh
@@ -327,8 +348,8 @@ infer' (Block ss) = do
327 return ret
348 return ret
328infer' (Constructor c) = do
349infer' (Constructor c) = do
329 env <- getEnv
350 env <- getEnv
330− modulePath <- checkModulePath `fmap` get
351+ moduleName <- substCurrentModule `fmap` ask
331− case M.lookup (qualify modulePath c) (dataConstructors env) of
352+ case M.lookup (qualify moduleName c) (dataConstructors env) of
332 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
353 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
333 Just ty -> replaceAllTypeSynonyms ty
354 Just ty -> replaceAllTypeSynonyms ty
334infer' (Case vals binders) = do
355infer' (Case vals binders) = do
@@ -343,7 +364,8 @@ infer' (IfThenElse cond th el) = do
343 t2 ~~ t3
364 t2 ~~ t3
344 return t2
365 return t2
345infer' (TypedValue val ty) = do
366infer' (TypedValue val ty) = do
367+ moduleName <- substCurrentModule <$> ask
346− kind <- liftCheck $ kindOf ty
368+ kind <- liftCheck $ kindOf moduleName ty
347 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
369 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
348 ty' <- replaceAllTypeSynonyms ty
370 ty' <- replaceAllTypeSynonyms ty
349 check val ty'
371 check val ty'
@@ -440,16 +462,16 @@ inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty
440inferBinder val (VarBinder name) = return $ M.singleton name val
462inferBinder val (VarBinder name) = return $ M.singleton name val
441inferBinder val (NullaryBinder ctor) = do
463inferBinder val (NullaryBinder ctor) = do
442 env <- getEnv
464 env <- getEnv
443− modulePath <- checkModulePath <$> get
465+ moduleName <- substCurrentModule <$> ask
444− case M.lookup (qualify modulePath ctor) (dataConstructors env) of
466+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of
445 Just ty -> do
467 Just ty -> do
446 ty `subsumes` val
468 ty `subsumes` val
447 return M.empty
469 return M.empty
448 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
470 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
449inferBinder val (UnaryBinder ctor binder) = do
471inferBinder val (UnaryBinder ctor binder) = do
450 env <- getEnv
472 env <- getEnv
451− modulePath <- checkModulePath <$> get
473+ moduleName <- substCurrentModule <$> ask
452− case M.lookup (qualify modulePath ctor) (dataConstructors env) of
474+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of
453 Just ty -> do
475 Just ty -> do
454 fn <- replaceAllVarsWithUnknowns ty
476 fn <- replaceAllVarsWithUnknowns ty
455 case fn of
477 case fn of
@@ -490,8 +512,9 @@ inferBinder val (NamedBinder name binder) = do
490checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()
512checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()
491checkBinders _ _ [] = return ()
513checkBinders _ _ [] = return ()
492checkBinders nvals ret ((binders, grd, val):bs) = do
514checkBinders nvals ret ((binders, grd, val):bs) = do
515+ moduleName <- substCurrentModule <$> ask
493 m1 <- M.unions <$> zipWithM inferBinder nvals binders
516 m1 <- M.unions <$> zipWithM inferBinder nvals binders
494− bindLocalVariables (M.toList m1) $ do
517+ bindLocalVariables moduleName (M.toList m1) $ do
495 check val ret
518 check val ret
496 case grd of
519 case grd of
497 Nothing -> return ()
520 Nothing -> return ()
@@ -501,8 +524,8 @@ checkBinders nvals ret ((binders, grd, val):bs) = do
501assignVariable :: Ident -> Subst ()
524assignVariable :: Ident -> Subst ()
502assignVariable name = do
525assignVariable name = do
503 env <- checkEnv <$> get
526 env <- checkEnv <$> get
504− modulePath <- checkModulePath <$> get
527+ moduleName <- substCurrentModule <$> ask
505− case M.lookup (modulePath, name) (names env) of
528+ case M.lookup (moduleName, name) (names env) of
506 Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
529 Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
507 _ -> return ()
530 _ -> return ()
508
531
@@ -525,16 +548,18 @@ checkStatement mass ret (If ifst) = do
525 allCodePathsReturn <- checkIfStatement mass ret ifst
548 allCodePathsReturn <- checkIfStatement mass ret ifst
526 return (allCodePathsReturn, mass)
549 return (allCodePathsReturn, mass)
527checkStatement mass ret (For ident start end inner) = do
550checkStatement mass ret (For ident start end inner) = do
551+ moduleName <- substCurrentModule <$> ask
528 assignVariable ident
552 assignVariable ident
529 check start Number
553 check start Number
530 check end Number
554 check end Number
531− (allCodePathsReturn, _) <- bindLocalVariables [(ident, Number)] $ checkBlock mass ret inner
555+ (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner
532 return (allCodePathsReturn, mass)
556 return (allCodePathsReturn, mass)
533checkStatement mass ret (ForEach ident vals inner) = do
557checkStatement mass ret (ForEach ident vals inner) = do
558+ moduleName <- substCurrentModule <$> ask
534 assignVariable ident
559 assignVariable ident
535 val <- fresh
560 val <- fresh
536 check vals (Array val)
561 check vals (Array val)
537− (allCodePathsReturn, _) <- bindLocalVariables [(ident, val)] $ checkBlock mass ret inner
562+ (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, val)] $ checkBlock mass ret inner
538 guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
563 guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
539 return (False, mass)
564 return (False, mass)
540checkStatement mass _ (ValueStatement val) = do
565checkStatement mass _ (ValueStatement val) = do
@@ -562,8 +587,9 @@ checkElseStatement mass ret (ElseIf ifst) = checkIfStatement mass ret ifst
562checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)
587checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)
563checkBlock mass _ [] = return (False, mass)
588checkBlock mass _ [] = return (False, mass)
564checkBlock mass ret (s:ss) = do
589checkBlock mass ret (s:ss) = do
590+ moduleName <- substCurrentModule <$> ask
565 (b1, mass1) <- checkStatement mass ret s
591 (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
567 (True, []) -> return (True, mass1)
593 (True, []) -> return (True, mass1)
568 (True, _) -> throwError "Unreachable code"
594 (True, _) -> throwError "Unreachable code"
569 (False, ss') -> checkBlock mass1 ret ss'
595 (False, ss') -> checkBlock mass1 ret ss'
@@ -602,18 +628,21 @@ check' (Binary op left right) ty = checkBinary op left right ty
602check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)
628check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)
603check' (Indexer index vals) ty = check index Number >> check vals (Array ty)
629check' (Indexer index vals) ty = check index Number >> check vals (Array ty)
604check' (Abs args ret) (Function argTys retTy) = do
630check' (Abs args ret) (Function argTys retTy) = do
631+ moduleName <- substCurrentModule <$> ask
605 guardWith "Incorrect number of function arguments" (length args == length argTys)
632 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
607check' app@(App _ _) ret = do
634check' app@(App _ _) ret = do
608 let (f, argss) = unfoldApplication app
635 let (f, argss) = unfoldApplication app
609 ft <- infer f
636 ft <- infer f
610 checkFunctionApplications ft argss ret
637 checkFunctionApplications ft argss ret
611check' (Var var) ty = do
638check' (Var var) ty = do
639+ moduleName <- substCurrentModule <$> ask
612− ty1 <- lookupVariable var
640+ ty1 <- lookupVariable moduleName var
613 repl <- replaceAllTypeSynonyms ty1
641 repl <- replaceAllTypeSynonyms ty1
614 repl `subsumes` ty
642 repl `subsumes` ty
615check' (TypedValue val ty1) ty2 = do
643check' (TypedValue val ty1) ty2 = do
644+ moduleName <- substCurrentModule <$> ask
616− kind <- liftCheck $ kindOf ty1
645+ kind <- liftCheck $ kindOf moduleName ty1
617 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
646 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
618 ty1 `subsumes` ty2
647 ty1 `subsumes` ty2
619 check val ty1
648 check val ty1
@@ -643,8 +672,8 @@ check' (Block ss) ret = do
643 guardWith "Block is missing a return statement" allCodePathsReturn
672 guardWith "Block is missing a return statement" allCodePathsReturn
644check' (Constructor c) ty = do
673check' (Constructor c) ty = do
645 env <- getEnv
674 env <- getEnv
646− modulePath <- checkModulePath <$> get
675+ moduleName <- substCurrentModule <$> ask
647− case M.lookup (qualify modulePath c) (dataConstructors env) of
676+ case M.lookup (qualify moduleName c) (dataConstructors env) of
648 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
677 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
649 Just ty1 -> do
678 Just ty1 -> do
650 repl <- replaceAllTypeSynonyms ty1
679 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)
22import qualified System.IO.UTF8 as U
22import qualified System.IO.UTF8 as U
23import Text.Parsec (ParseError)
23import Text.Parsec (ParseError)
24
24
25−readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Declaration])
25+readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])
26−readInput Nothing = getContents >>= return . P.runIndentParser P.parseDeclarations
26+readInput Nothing = getContents >>= return . P.runIndentParser P.parseModules
27readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do
27readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do
28 text <- U.readFile inputFile
28 text <- U.readFile inputFile
29− return $ P.runIndentParser P.parseDeclarations text
29+ return $ P.runIndentParser P.parseModules text
30
30
31compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
31compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
32compile input output externs = do
32compile input output externs = do
33− asts <- readInput input
33+ modules <- readInput input
34− case asts of
34+ case modules of
35 Left err -> do
35 Left err -> do
36 U.print err
36 U.print err
37 exitFailure
37 exitFailure
38− Right decls ->
38+ Right ms ->
39− case P.compile decls of
39+ case P.compile ms of
40 Left err -> do
40 Left err -> do
41 U.putStrLn err
41 U.putStrLn err
42 exitFailure
42 exitFailure
tests/Main.hs+4−4
@@ -27,12 +27,12 @@ import qualified Data.Map as M
27
27
28compile :: FilePath -> IO (Either String P.Environment)
28compile :: FilePath -> IO (Either String P.Environment)
29compile inputFile = do
29compile inputFile = do
30− ast <- P.runIndentParser P.parseDeclarations <$> U.readFile inputFile
30+ modules <- P.runIndentParser P.parseModules <$> U.readFile inputFile
31− case ast of
31+ case modules of
32 Left parseError -> do
32 Left parseError -> do
33 return (Left $ show parseError)
33 return (Left $ show parseError)
34− Right decls -> do
34+ Right ms -> do
35− case P.compile decls of
35+ case P.compile ms of
36 Left typeError -> do
36 Left typeError -> do
37 return (Left typeError)
37 return (Left typeError)
38 Right (_, _, env) -> do
38 Right (_, _, env) -> do