summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-11-08 21:23:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-11-08 21:23:00 (GMT)
commitffa65f27c5b68bd44bab7169c36cc05b651c29f8 (patch)
tree07952979b9b4f5c1f06a846384084b9376bc014c
parent657524098de0309d959c2e93175116bc3e20db5e (diff)
version 0.6.00.6.0
-rw-r--r--LICENSE2
-rw-r--r--examples/failing/MultipleErrors2.purs5
-rw-r--r--examples/passing/MutRec2.purs17
-rw-r--r--examples/passing/MutRec3.purs17
-rw-r--r--examples/passing/ObjectUpdate2.purs14
-rw-r--r--examples/passing/TypeClassImport.purs18
-rw-r--r--prelude/prelude.purs944
-rw-r--r--psc-docs/Main.hs (renamed from docgen/Main.hs)19
-rw-r--r--psc-make/Main.hs38
-rw-r--r--psc/Main.hs44
-rw-r--r--psci/Commands.hs11
-rw-r--r--psci/Main.hs108
-rw-r--r--psci/Parser.hs19
-rw-r--r--purescript.cabal26
-rw-r--r--src/Language/PureScript.hs48
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs17
-rw-r--r--src/Language/PureScript/Errors.hs17
-rw-r--r--src/Language/PureScript/Parser.hs2
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs14
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs6
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs4
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs2
-rw-r--r--src/Language/PureScript/Sugar/Names.hs2
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs2
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs2
-rw-r--r--src/Language/PureScript/TypeChecker.hs6
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs17
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs71
-rw-r--r--tests/Main.hs23
29 files changed, 368 insertions, 1147 deletions
diff --git a/LICENSE b/LICENSE
index 87b8a3c..6e34c48 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,6 +1,6 @@
The MIT License (MIT)
-Copyright (c) 2013 Phil Freeman
+Copyright (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
diff --git a/examples/failing/MultipleErrors2.purs b/examples/failing/MultipleErrors2.purs
new file mode 100644
index 0000000..f4f4a98
--- /dev/null
+++ b/examples/failing/MultipleErrors2.purs
@@ -0,0 +1,5 @@
+module MultipleErrors2 where
+
+foo = itDoesntExist
+
+bar = neitherDoesThis
diff --git a/examples/passing/MutRec2.purs b/examples/passing/MutRec2.purs
new file mode 100644
index 0000000..6f828b0
--- /dev/null
+++ b/examples/passing/MutRec2.purs
@@ -0,0 +1,17 @@
+module Main where
+
+data A = A B
+
+data B = B A
+
+foreign import data S :: *
+
+f :: A -> S
+f a = case a of A b -> g b
+
+g b = case b of B a -> f a
+
+showN :: A -> S
+showN a = f a
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/MutRec3.purs b/examples/passing/MutRec3.purs
new file mode 100644
index 0000000..0db2de8
--- /dev/null
+++ b/examples/passing/MutRec3.purs
@@ -0,0 +1,17 @@
+module Main where
+
+data A = A B
+
+data B = B A
+
+foreign import data S :: *
+
+f a = case a of A b -> g b
+
+g :: B -> S
+g b = case b of B a -> f a
+
+showN :: A -> S
+showN a = f a
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/ObjectUpdate2.purs b/examples/passing/ObjectUpdate2.purs
new file mode 100644
index 0000000..98af5d3
--- /dev/null
+++ b/examples/passing/ObjectUpdate2.purs
@@ -0,0 +1,14 @@
+module Main where
+
+type X r = { | r }
+
+foreign import x "var x = {};" :: forall r. X r
+
+blah :: forall r. X r -> X r
+blah x = x
+
+test = blah x
+ { baz = "blah"
+ }
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/TypeClassImport.purs b/examples/passing/TypeClassImport.purs
new file mode 100644
index 0000000..4ddcaea
--- /dev/null
+++ b/examples/passing/TypeClassImport.purs
@@ -0,0 +1,18 @@
+module Main where
+
+foreign import data T :: *
+
+foreign import data C :: *
+
+foreign import t "var t = null;" :: T
+
+foreign import inst """
+ var inst = {
+ show: function(t) {
+ return 'Done';
+ }
+ }""" :: C
+
+foreign import instance inst :: Show T
+
+main = Debug.Trace.print t
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
deleted file mode 100644
index 8a4d317..0000000
--- a/prelude/prelude.purs
+++ /dev/null
@@ -1,944 +0,0 @@
-module Prelude
- ( flip
- , const
- , asTypeOf
- , Semigroupoid, (<<<), (>>>)
- , Category, id
- , ($), (#)
- , (:), cons
- , Show, show
- , Functor, (<$>), void
- , Apply, (<*>)
- , Applicative, pure, liftA1
- , Bind, (>>=)
- , Monad, return, liftM1, ap
- , Num, (+), (-), (*), (/), (%)
- , negate
- , Eq, (==), (/=), refEq, refIneq
- , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
- , Bits, (&), (|), (^), shl, shr, zshr, complement
- , BoolLike, (&&), (||)
- , not
- , Semigroup, (<>), (++)
- , Unit(..), unit
- ) where
-
- flip :: forall a b c. (a -> b -> c) -> b -> a -> c
- flip f b a = f a b
-
- const :: forall a b. a -> b -> a
- const a _ = a
-
- asTypeOf :: forall a. a -> a -> a
- asTypeOf x _ = x
-
- infixr 9 >>>
- infixr 9 <<<
-
- class Semigroupoid a where
- (<<<) :: forall b c d. a c d -> a b c -> a b d
-
- instance semigroupoidArr :: Semigroupoid (->) where
- (<<<) f g x = f (g x)
-
- (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
- (>>>) f g = g <<< f
-
- class (Semigroupoid a) <= Category a where
- id :: forall t. a t t
-
- instance categoryArr :: Category (->) where
- id x = x
-
- infixr 0 $
- infixl 0 #
-
- ($) :: forall a b. (a -> b) -> a -> b
- ($) f x = f x
-
- (#) :: forall a b. a -> (a -> b) -> b
- (#) x f = f x
-
- infixr 6 :
-
- (:) :: forall a. a -> [a] -> [a]
- (:) = cons
-
- foreign import cons
- "function cons(e) {\
- \ return function(l) {\
- \ return [e].concat(l);\
- \ };\
- \}" :: forall a. a -> [a] -> [a]
-
- class Show a where
- show :: a -> String
-
- foreign import showStringImpl
- "function showStringImpl(s) {\
- \ return JSON.stringify(s);\
- \}" :: String -> String
-
- instance showUnit :: Show Unit where
- show (Unit {}) = "Unit {}"
-
- instance showString :: Show String where
- show = showStringImpl
-
- instance showBoolean :: Show Boolean where
- show true = "true"
- show false = "false"
-
- foreign import showNumberImpl "function showNumberImpl(n) {\
- \ return n.toString();\
- \}" :: Number -> String
-
- instance showNumber :: Show Number where
- show = showNumberImpl
-
- foreign import showArrayImpl
- "function showArrayImpl(f) {\
- \ return function(xs) {\
- \ var ss = [];\
- \ for (var i = 0, l = xs.length; i < l; i++) {\
- \ ss[i] = f(xs[i]);\
- \ }\
- \ return '[' + ss.join(',') + ']';\
- \ };\
- \}" :: forall a. (a -> String) -> [a] -> String
-
- instance showArray :: (Show a) => Show [a] where
- show = showArrayImpl show
-
- infixl 4 <$>
-
- class Functor f where
- (<$>) :: forall a b. (a -> b) -> f a -> f b
-
- void :: forall f a. (Functor f) => f a -> f Unit
- void fa = const unit <$> fa
-
- infixl 4 <*>
-
- class (Functor f) <= Apply f where
- (<*>) :: forall a b. f (a -> b) -> f a -> f b
-
- class (Apply f) <= Applicative f where
- pure :: forall a. a -> f a
-
- liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
- liftA1 f a = pure f <*> a
-
- infixl 1 >>=
-
- class (Apply m) <= Bind m where
- (>>=) :: forall a b. m a -> (a -> m b) -> m b
-
- class (Applicative m, Bind m) <= Monad m
-
- return :: forall m a. (Monad m) => a -> m a
- return = pure
-
- liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
- liftM1 f a = do
- a' <- a
- return (f a')
-
- ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
- ap f a = do
- f' <- f
- a' <- a
- return (f' a')
-
- instance functorArr :: Functor ((->) r) where
- (<$>) = (<<<)
-
- instance applyArr :: Apply ((->) r) where
- (<*>) f g x = f x (g x)
-
- instance applicativeArr :: Applicative ((->) r) where
- pure = const
-
- instance bindArr :: Bind ((->) r) where
- (>>=) m f x = f (m x) x
-
- instance monadArr :: Monad ((->) r)
-
- infixl 7 *
- infixl 7 /
- infixl 7 %
-
- infixl 6 -
- infixl 6 +
-
- class Num a where
- (+) :: a -> a -> a
- (-) :: a -> a -> a
- (*) :: a -> a -> a
- (/) :: a -> a -> a
- (%) :: a -> a -> a
- negate :: a -> a
-
- foreign import numAdd "function numAdd(n1) {\
- \ return function(n2) {\
- \ return n1 + n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numSub "function numSub(n1) {\
- \ return function(n2) {\
- \ return n1 - n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numMul "function numMul(n1) {\
- \ return function(n2) {\
- \ return n1 * n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numDiv "function numDiv(n1) {\
- \ return function(n2) {\
- \ return n1 / n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numMod "function numMod(n1) {\
- \ return function(n2) {\
- \ return n1 % n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numNegate "function numNegate(n) {\
- \ return -n;\
- \}" :: Number -> Number
-
- instance numNumber :: Num Number where
- (+) = numAdd
- (-) = numSub
- (*) = numMul
- (/) = numDiv
- (%) = numMod
- negate = numNegate
-
- newtype Unit = Unit {}
-
- unit :: Unit
- unit = Unit {}
-
- infix 4 ==
- infix 4 /=
-
- class Eq a where
- (==) :: a -> a -> Boolean
- (/=) :: a -> a -> Boolean
-
- foreign import refEq
- "function refEq(r1) {\
- \ return function(r2) {\
- \ return r1 === r2;\
- \ };\
- \}" :: forall a. a -> a -> Boolean
-
- foreign import refIneq
- "function refIneq(r1) {\
- \ return function(r2) {\
- \ return r1 !== r2;\
- \ };\
- \}" :: forall a. a -> a -> Boolean
-
- instance eqUnit :: Eq Unit where
- (==) (Unit {}) (Unit {}) = true
- (/=) (Unit {}) (Unit {}) = false
-
- instance eqString :: Eq String where
- (==) = refEq
- (/=) = refIneq
-
- instance eqNumber :: Eq Number where
- (==) = refEq
- (/=) = refIneq
-
- instance eqBoolean :: Eq Boolean where
- (==) = refEq
- (/=) = refIneq
-
- foreign import eqArrayImpl
- "function eqArrayImpl(f) {\
- \ return function(xs) {\
- \ return function(ys) {\
- \ if (xs.length !== ys.length) return false;\
- \ for (var i = 0; i < xs.length; i++) {\
- \ if (!f(xs[i])(ys[i])) return false;\
- \ }\
- \ return true;\
- \ };\
- \ };\
- \}" :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean
-
- instance eqArray :: (Eq a) => Eq [a] where
- (==) xs ys = eqArrayImpl (==) xs ys
- (/=) xs ys = not (xs == ys)
-
- data Ordering = LT | GT | EQ
-
- instance eqOrdering :: Eq Ordering where
- (==) LT LT = true
- (==) GT GT = true
- (==) EQ EQ = true
- (==) _ _ = false
- (/=) x y = not (x == y)
-
- instance showOrdering :: Show Ordering where
- show LT = "LT"
- show GT = "GT"
- show EQ = "EQ"
-
- class (Eq a) <= Ord a where
- compare :: a -> a -> Ordering
-
- infixl 4 <
-
- (<) :: forall a. (Ord a) => a -> a -> Boolean
- (<) a1 a2 = case a1 `compare` a2 of
- LT -> true
- _ -> false
-
- infixl 4 >
-
- (>) :: forall a. (Ord a) => a -> a -> Boolean
- (>) a1 a2 = case a1 `compare` a2 of
- GT -> true
- _ -> false
-
- infixl 4 <=
-
- (<=) :: forall a. (Ord a) => a -> a -> Boolean
- (<=) a1 a2 = case a1 `compare` a2 of
- GT -> false
- _ -> true
-
- infixl 4 >=
-
- (>=) :: forall a. (Ord a) => a -> a -> Boolean
- (>=) a1 a2 = case a1 `compare` a2 of
- LT -> false
- _ -> true
-
- foreign import unsafeCompareImpl
- "function unsafeCompareImpl(lt) {\
- \ return function(eq) {\
- \ return function(gt) {\
- \ return function(x) {\
- \ return function(y) {\
- \ return x < y ? lt : x > y ? gt : eq;\
- \ };\
- \ };\
- \ };\
- \ };\
- \}" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
-
- unsafeCompare :: forall a. a -> a -> Ordering
- unsafeCompare = unsafeCompareImpl LT EQ GT
-
- instance ordUnit :: Ord Unit where
- compare (Unit {}) (Unit {}) = EQ
-
- instance ordBoolean :: Ord Boolean where
- compare false false = EQ
- compare false true = LT
- compare true true = EQ
- compare true false = GT
-
- instance ordNumber :: Ord Number where
- compare = unsafeCompare
-
- instance ordString :: Ord String where
- compare = unsafeCompare
-
- instance ordArray :: (Ord a) => Ord [a] where
- compare [] [] = EQ
- compare [] _ = LT
- compare _ [] = GT
- compare (x:xs) (y:ys) = case compare x y of
- EQ -> compare xs ys
- other -> other
-
- infixl 10 &
- infixl 10 |
- infixl 10 ^
-
- class Bits b where
- (&) :: b -> b -> b
- (|) :: b -> b -> b
- (^) :: b -> b -> b
- shl :: b -> Number -> b
- shr :: b -> Number -> b
- zshr :: b -> Number -> b
- complement :: b -> b
-
- foreign import numShl "function numShl(n1) {\
- \ return function(n2) {\
- \ return n1 << n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numShr "function numShr(n1) {\
- \ return function(n2) {\
- \ return n1 >> n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numZshr "function numZshr(n1) {\
- \ return function(n2) {\
- \ return n1 >>> n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numAnd "function numAnd(n1) {\
- \ return function(n2) {\
- \ return n1 & n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numOr "function numOr(n1) {\
- \ return function(n2) {\
- \ return n1 | n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numXor "function numXor(n1) {\
- \ return function(n2) {\
- \ return n1 ^ n2;\
- \ };\
- \}" :: Number -> Number -> Number
-
- foreign import numComplement "function numComplement(n) {\
- \ return ~n;\
- \}" :: Number -> Number
-
- instance bitsNumber :: Bits Number where
- (&) = numAnd
- (|) = numOr
- (^) = numXor
- shl = numShl
- shr = numShr
- zshr = numZshr
- complement = numComplement
-
- infixr 2 ||
- infixr 3 &&
-
- class BoolLike b where
- (&&) :: b -> b -> b
- (||) :: b -> b -> b
- not :: b -> b
-
- foreign import boolAnd "function boolAnd(b1) {\
- \ return function(b2) {\
- \ return b1 && b2;\
- \ };\
- \}" :: Boolean -> Boolean -> Boolean
-
- foreign import boolOr "function boolOr(b1) {\
- \ return function(b2) {\
- \ return b1 || b2;\
- \ };\
- \}" :: Boolean -> Boolean -> Boolean
-
- foreign import boolNot "function boolNot(b) {\
- \ return !b;\
- \}" :: Boolean -> Boolean
-
- instance boolLikeBoolean :: BoolLike Boolean where
- (&&) = boolAnd
- (||) = boolOr
- not = boolNot
-
- infixr 5 <>
-
- class Semigroup a where
- (<>) :: a -> a -> a
-
- foreign import concatString
- "function concatString(s1) {\
- \ return function(s2) {\
- \ return s1 + s2;\
- \ };\
- \}" :: String -> String -> String
-
- instance semigroupUnit :: Semigroup Unit where
- (<>) (Unit {}) (Unit {}) = Unit {}
-
- instance semigroupString :: Semigroup String where
- (<>) = concatString
-
- instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
- (<>) f g = \x -> f x <> g x
-
- infixr 5 ++
-
- (++) :: forall s. (Semigroup s) => s -> s -> s
- (++) = (<>)
-
-module Data.Function where
-
- on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
- on f g x y = g x `f` g y
-
- foreign import data Fn0 :: * -> *
- foreign import data Fn1 :: * -> * -> *
- foreign import data Fn2 :: * -> * -> * -> *
- foreign import data Fn3 :: * -> * -> * -> * -> *
- foreign import data Fn4 :: * -> * -> * -> * -> * -> *
- foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
- foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
- foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
- foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
- foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
- foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
-
- foreign import mkFn0
- "function mkFn0(fn) {\
- \ return function() {\
- \ return fn({});\
- \ };\
- \}" :: forall a. (Unit -> a) -> Fn0 a
-
- foreign import mkFn1
- "function mkFn1(fn) {\
- \ return function(a) {\
- \ return fn(a);\
- \ };\
- \}" :: forall a b. (a -> b) -> Fn1 a b
-
- foreign import mkFn2
- "function mkFn2(fn) {\
- \ return function(a, b) {\
- \ return fn(a)(b);\
- \ };\
- \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c
-
- foreign import mkFn3
- "function mkFn3(fn) {\
- \ return function(a, b, c) {\
- \ return fn(a)(b)(c);\
- \ };\
- \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
-
- foreign import mkFn4
- "function mkFn4(fn) {\
- \ return function(a, b, c, d) {\
- \ return fn(a)(b)(c)(d);\
- \ };\
- \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
-
- foreign import mkFn5
- "function mkFn5(fn) {\
- \ return function(a, b, c, d, e) {\
- \ return fn(a)(b)(c)(d)(e);\
- \ };\
- \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
-
- foreign import mkFn6
- "function mkFn6(fn) {\
- \ return function(a, b, c, d, e, f) {\
- \ return fn(a)(b)(c)(d)(e)(f);\
- \ };\
- \}" :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
-
- foreign import mkFn7
- "function mkFn7(fn) {\
- \ return function(a, b, c, d, e, f, g) {\
- \ return fn(a)(b)(c)(d)(e)(f)(g);\
- \ };\
- \}" :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
-
- foreign import mkFn8
- "function mkFn8(fn) {\
- \ return function(a, b, c, d, e, f, g, h) {\
- \ return fn(a)(b)(c)(d)(e)(f)(g)(h);\
- \ };\
- \}" :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
-
- foreign import mkFn9
- "function mkFn9(fn) {\
- \ return function(a, b, c, d, e, f, g, h, i) {\
- \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);\
- \ };\
- \}" :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
-
- foreign import mkFn10
- "function mkFn10(fn) {\
- \ return function(a, b, c, d, e, f, g, h, i, j) {\
- \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);\
- \ };\
- \}" :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
-
- foreign import runFn0
- "function runFn0(fn) {\
- \ return fn();\
- \}" :: forall a. Fn0 a -> a
-
- foreign import runFn1
- "function runFn1(fn) {\
- \ return function(a) {\
- \ return fn(a);\
- \ };\
- \}" :: forall a b. Fn1 a b -> a -> b
-
- foreign import runFn2
- "function runFn2(fn) {\
- \ return function(a) {\
- \ return function(b) {\
- \ return fn(a, b);\
- \ };\
- \ };\
- \}" :: forall a b c. Fn2 a b c -> a -> b -> c
-
- foreign import runFn3
- "function runFn3(fn) {\
- \ return function(a) {\
- \ return function(b) {\
- \ return function(c) {\
- \ return fn(a, b, c);\
- \ };\
- \ };\
- \ };\
- \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
-
- foreign import runFn4
- "function runFn4(fn) {\
- \ return function(a) {\
- \ return function(b) {\
- \ return function(c) {\
- \ return function(d) {\
- \ return fn(a, b, c, d);\
- \ };\
- \ };\
- \ };\
- \ };\
- \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
-
- foreign import runFn5
- "function runFn5(fn) {\
- \ return function(a) {\
- \ return function(b) {\
- \ return function(c) {\
- \ return function(d) {\
- \ return function(e) {\
- \ return fn(a, b, c, d, e);\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
-
- foreign import runFn6
- "function runFn6(fn) {\
- \ return function(a) {\
- \ return function(b) {\
- \ return function(c) {\
- \ return function(d) {\
- \ return function(e) {\
- \ return function(f) {\
- \ return fn(a, b, c, d, e, f);\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \}" :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
-
- foreign import runFn7
- "function runFn7(fn) {\
- \ return function(a) {\
- \ return function(b) {\
- \ return function(c) {\
- \ return function(d) {\
- \ return function(e) {\
- \ return function(f) {\
- \ return function(g) {\
- \ return fn(a, b, c, d, e, f, g);\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \}" :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
-
- foreign import runFn8
- "function runFn8(fn) {\
- \ return function(a) {\
- \ return function(b) {\
- \ return function(c) {\
- \ return function(d) {\
- \ return function(e) {\
- \ return function(f) {\
- \ return function(g) {\
- \ return function(h) {\
- \ return fn(a, b, c, d, e, f, g, h);\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \}" :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
-
- foreign import runFn9
- "function runFn9(fn) {\
- \ return function(a) {\
- \ return function(b) {\
- \ return function(c) {\
- \ return function(d) {\
- \ return function(e) {\
- \ return function(f) {\
- \ return function(g) {\
- \ return function(h) {\
- \ return function(i) {\
- \ return fn(a, b, c, d, e, f, g, h, i);\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \}" :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
-
- foreign import runFn10
- "function runFn10(fn) {\
- \ return function(a) {\
- \ return function(b) {\
- \ return function(c) {\
- \ return function(d) {\
- \ return function(e) {\
- \ return function(f) {\
- \ return function(g) {\
- \ return function(h) {\
- \ return function(i) {\
- \ return function(j) {\
- \ return fn(a, b, c, d, e, f, g, h, i, j);\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \ };\
- \}" :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
-
-module Data.Eq where
-
- newtype Ref a = Ref a
-
- liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
- liftRef f (Ref x) (Ref y) = f x y
-
- instance eqRef :: Eq (Ref a) where
- (==) = liftRef refEq
- (/=) = liftRef refIneq
-
- instance functorRef :: Functor Ref where
- (<$>) f (Ref x) = Ref (f x)
-
-module Prelude.Unsafe where
-
- foreign import unsafeIndex
- "function unsafeIndex(xs) {\
- \ return function(n) {\
- \ return xs[n];\
- \ };\
- \}" :: forall a. [a] -> Number -> a
-
-module Control.Monad.Eff where
-
- foreign import data Eff :: # ! -> * -> *
-
- foreign import returnE "function returnE(a) {\
- \ return function() {\
- \ return a;\
- \ };\
- \}" :: forall e a. a -> Eff e a
-
- foreign import bindE "function bindE(a) {\
- \ return function(f) {\
- \ return function() {\
- \ return f(a())();\
- \ };\
- \ };\
- \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
-
- type Pure a = forall e. Eff e a
-
- foreign import runPure "function runPure(f) {\
- \ return f();\
- \}" :: forall a. Pure a -> a
-
- instance functorEff :: Functor (Eff e) where
- (<$>) = liftA1
-
- instance applyEff :: Apply (Eff e) where
- (<*>) = ap
-
- instance applicativeEff :: Applicative (Eff e) where
- pure = returnE
-
- instance bindEff :: Bind (Eff e) where
- (>>=) = bindE
-
- instance monadEff :: Monad (Eff e)
-
- foreign import untilE "function untilE(f) {\
- \ return function() {\
- \ while (!f());\
- \ return {};\
- \ };\
- \}" :: forall e. Eff e Boolean -> Eff e Unit
-
- foreign import whileE "function whileE(f) {\
- \ return function(a) {\
- \ return function() {\
- \ while (f()) {\
- \ a();\
- \ }\
- \ return {};\
- \ };\
- \ };\
- \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
-
- foreign import forE "function forE(lo) {\
- \ return function(hi) {\
- \ return function(f) {\
- \ return function() {\
- \ for (var i = lo; i < hi; i++) {\
- \ f(i)();\
- \ }\
- \ };\
- \ };\
- \ };\
- \}" :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
-
-
- foreign import foreachE "function foreachE(as) {\
- \ return function(f) {\
- \ return function() {\
- \ for (var i = 0; i < as.length; i++) {\
- \ f(as[i])();\
- \ }\
- \ };\
- \ };\
- \}" :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit
-
-module Control.Monad.Eff.Unsafe where
-
- import Control.Monad.Eff
-
- foreign import unsafeInterleaveEff
- "function unsafeInterleaveEff(f) {\
- \ return f;\
- \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
-
-module Debug.Trace where
-
- import Control.Monad.Eff
-
- foreign import data Trace :: !
-
- foreign import trace "function trace(s) {\
- \ return function() {\
- \ console.log(s);\
- \ return {};\
- \ };\
- \}" :: forall r. String -> Eff (trace :: Trace | r) Unit
-
- print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
- print o = trace (show o)
-
-module Control.Monad.ST where
-
- import Control.Monad.Eff
-
- foreign import data ST :: * -> !
-
- foreign import data STRef :: * -> * -> *
-
- foreign import data STArray :: * -> * -> *
-
- foreign import newSTRef "function newSTRef(val) {\
- \ return function() {\
- \ return { value: val };\
- \ };\
- \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
-
- foreign import readSTRef "function readSTRef(ref) {\
- \ return function() {\
- \ return ref.value;\
- \ };\
- \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
-
- foreign import modifySTRef "function modifySTRef(ref) {\
- \ return function(f) {\
- \ return function() {\
- \ return ref.value = f(ref.value);\
- \ };\
- \ };\
- \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
-
- foreign import writeSTRef "function writeSTRef(ref) {\
- \ return function(a) {\
- \ return function() {\
- \ return ref.value = a;\
- \ };\
- \ };\
- \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
-
- foreign import newSTArray "function newSTArray(len) {\
- \ return function(a) {\
- \ return function() {\
- \ var arr = [];\
- \ for (var i = 0; i < len; i++) {\
- \ arr[i] = a;\
- \ };\
- \ return arr;\
- \ };\
- \ };\
- \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)
-
- foreign import peekSTArray "function peekSTArray(arr) {\
- \ return function(i) {\
- \ return function() {\
- \ return arr[i];\
- \ };\
- \ };\
- \}" :: forall a h r. STArray h a -> Number -> Eff (st :: ST h | r) a
-
- foreign import pokeSTArray "function pokeSTArray(arr) {\
- \ return function(i) {\
- \ return function(a) {\
- \ return function() {\
- \ return arr[i] = a;\
- \ };\
- \ };\
- \ };\
- \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a
-
- foreign import runST "function runST(f) {\
- \ return f;\
- \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
-
- foreign import runSTArray "function runSTArray(f) {\
- \ return f;\
- \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]
diff --git a/docgen/Main.hs b/psc-docs/Main.hs
index d8c61db..a9f5c00 100644
--- a/docgen/Main.hs
+++ b/psc-docs/Main.hs
@@ -17,6 +17,7 @@ module Main where
import Control.Applicative
import Control.Monad
import Control.Monad.Writer
+import Control.Arrow (first)
import Data.Function (on)
import Data.List
import Data.Version (showVersion)
@@ -29,19 +30,17 @@ import System.IO (stderr)
docgen :: Bool -> [FilePath] -> IO ()
docgen showHierarchy input = do
- ms <- mapM parseFile (nub input)
- U.putStrLn . runDocs $ (renderModules showHierarchy) (concat ms)
- exitSuccess
-
-parseFile :: FilePath -> IO [P.Module]
-parseFile input = do
- text <- U.readFile input
- case P.runIndentParser input P.parseModules text of
+ e <- P.parseModulesFromFiles <$> mapM (fmap (first Just) . parseFile) (nub input)
+ case e of
Left err -> do
U.hPutStr stderr $ show err
exitFailure
Right ms -> do
- return ms
+ U.putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)
+ exitSuccess
+
+parseFile :: FilePath -> IO (FilePath, String)
+parseFile input = (,) input <$> U.readFile input
type Docs = Writer [String] ()
@@ -229,7 +228,7 @@ term = docgen <$> includeHeirarcy <*> inputFiles
termInfo :: TermInfo
termInfo = defTI
- { termName = "docgen"
+ { termName = "psc-docs"
, version = showVersion Paths.version
, termDoc = "Generate Markdown documentation from PureScript extern files"
}
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index 1f00e69..67f0238 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -12,13 +12,14 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
module Main where
import Control.Applicative
import Control.Monad.Error
+import Data.Bool (bool)
import Data.Version (showVersion)
import System.Console.CmdTheLine
@@ -28,19 +29,19 @@ import System.FilePath (takeDirectory)
import System.Exit (exitSuccess, exitFailure)
import System.IO.Error (tryIOError)
-import Text.Parsec (ParseError)
-
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import qualified System.IO.UTF8 as U
-readInput :: [FilePath] -> IO (Either ParseError [(FilePath, P.Module)])
-readInput input = fmap collect $ forM input $ \inputFile -> do
- text <- U.readFile inputFile
- return $ (inputFile, P.runIndentParser inputFile P.parseModules text)
- where
- collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]
- collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)
+data InputOptions = InputOptions
+ { ioNoPrelude :: Bool
+ , ioInputFiles :: [FilePath]
+ }
+
+readInput :: InputOptions -> IO [(Maybe FilePath, String)]
+readInput InputOptions{..} = do
+ content <- forM ioInputFiles $ \inputFile -> (Just inputFile, ) <$> U.readFile inputFile
+ return $ bool ((Nothing, P.prelude) :) id ioNoPrelude content
newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)
@@ -66,9 +67,9 @@ instance P.MonadMake Make where
liftError = either throwError return
progress = makeIO . U.putStrLn
-compile :: FilePath -> [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO ()
-compile prelude input outputDir opts usePrefix = do
- modules <- readInput allInputFiles
+compile :: [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO ()
+compile input outputDir opts usePrefix = do
+ modules <- P.parseModulesFromFiles <$> readInput (InputOptions (P.optionsNoPrelude opts) input)
case modules of
Left err -> do
U.print err
@@ -86,9 +87,6 @@ compile prelude input outputDir opts usePrefix = do
then ["Generated by psc-make version " ++ showVersion Paths.version]
else []
- allInputFiles | P.optionsNoPrelude opts = input
- | otherwise = prelude : input
-
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
@@ -127,8 +125,8 @@ noPrefix :: Term Bool
noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ])
{ optDoc = "Do not include comment header"}
-term :: FilePath -> Term (IO ())
-term prelude = compile prelude <$> inputFiles <*> outputDirectory <*> options <*> (not <$> noPrefix)
+term :: Term (IO ())
+term = compile <$> inputFiles <*> outputDirectory <*> options <*> (not <$> noPrefix)
termInfo :: TermInfo
termInfo = defTI
@@ -138,7 +136,5 @@ termInfo = defTI
}
main :: IO ()
-main = do
- prelude <- P.preludeFilename
- run (term prelude, termInfo)
+main = run (term, termInfo)
diff --git a/psc/Main.hs b/psc/Main.hs
index a272ba9..713bcce 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -12,13 +12,14 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
module Main where
import Control.Applicative
import Control.Monad.Error
+import Data.Bool (bool)
import Data.Version (showVersion)
import System.Console.CmdTheLine
@@ -27,26 +28,25 @@ import System.FilePath (takeDirectory)
import System.Exit (exitSuccess, exitFailure)
import System.IO (stderr)
-import Text.Parsec (ParseError)
-
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import qualified System.IO.UTF8 as U
-readInput :: Maybe [FilePath] -> IO (Either ParseError [(FilePath, P.Module)])
-readInput Nothing = do
- text <- getContents
- return $ map ((,) undefined) <$> P.runIndentParser "" P.parseModules text
-readInput (Just input) = fmap collect $ forM input $ \inputFile -> do
- text <- U.readFile inputFile
- return $ (inputFile, P.runIndentParser inputFile P.parseModules text)
- where
- collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]
- collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)
+data InputOptions = InputOptions
+ { ioNoPrelude :: Bool
+ , ioUseStdIn :: Bool
+ , ioInputFiles :: [FilePath]
+ }
+
+readInput :: InputOptions -> IO [(Maybe FilePath, String)]
+readInput InputOptions{..}
+ | ioUseStdIn = return . (Nothing ,) <$> getContents
+ | otherwise = do content <- forM ioInputFiles $ \inputFile -> (Just inputFile, ) <$> U.readFile inputFile
+ return $ bool ((Nothing, P.prelude) :) id ioNoPrelude content
-compile :: FilePath -> P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()
-compile prelude opts stdin input output externs usePrefix = do
- modules <- readInput stdInOrInputFiles
+compile :: P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()
+compile opts stdin input output externs usePrefix = do
+ modules <- P.parseModulesFromFiles <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)
case modules of
Left err -> do
U.hPutStr stderr $ show err
@@ -65,10 +65,6 @@ compile prelude opts stdin input output externs usePrefix = do
Nothing -> return ()
exitSuccess
where
- stdInOrInputFiles :: Maybe [FilePath]
- stdInOrInputFiles | stdin = Nothing
- | P.optionsNoPrelude opts = Just input
- | otherwise = Just $ prelude : input
prefix = if usePrefix
then ["Generated by psc version " ++ showVersion Paths.version]
else []
@@ -137,8 +133,8 @@ options = P.Options <$> noPrelude <*> noTco <*> noMagicDo <*> runMain <*> noOpts
where
additionalOptions = P.CompileOptions <$> browserNamespace <*> dceModules <*> codeGenModules
-term :: FilePath -> Term (IO ())
-term prelude = compile prelude <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix)
+term :: Term (IO ())
+term = compile <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix)
termInfo :: TermInfo
termInfo = defTI
@@ -148,8 +144,6 @@ termInfo = defTI
}
main :: IO ()
-main = do
- prelude <- P.preludeFilename
- run (term prelude, termInfo)
+main = run (term, termInfo)
diff --git a/psci/Commands.hs b/psci/Commands.hs
index 88a67ac..67c6785 100644
--- a/psci/Commands.hs
+++ b/psci/Commands.hs
@@ -34,6 +34,10 @@ data Command
--
| Import ModuleName
-- |
+ -- Browse a module
+ --
+ | Browse ModuleName
+ -- |
-- Load a file for use with importing
--
| LoadFile FilePath
@@ -57,6 +61,10 @@ data Command
-- Find the kind of an expression
--
| KindOf Type
+ -- |
+ -- Show command
+ --
+ | Show String
-- |
-- The help menu.
@@ -65,9 +73,12 @@ help :: [[String]]
help =
[ [":? ", "Show this help menu"]
, [":i <module> ", "Import <module> for use in PSCI"]
+ , [":b <module> ", "Browse <module>"]
, [":m <file> ", "Load <file> for importing"]
, [":q ", "Quit PSCi"]
, [":r ", "Reset"]
+ , [":s import ", "Show imported modules"]
+ , [":s loaded ", "Show loaded modules"]
, [":t <expr> ", "Show the type of <expr>"]
, [":k <type> ", "Show the kind of <type>"]
]
diff --git a/psci/Main.hs b/psci/Main.hs
index e498c99..87b9adf 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -28,7 +28,7 @@ import qualified Control.Monad.Trans.State.Lazy as L
import Control.Monad.Error (ErrorT(..), MonadError)
import Control.Monad.Error.Class (MonadError(..))
-import Data.List (intercalate, isPrefixOf, nub, sortBy)
+import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)
import Data.Maybe (mapMaybe)
import Data.Foldable (traverse_)
import Data.Version (showVersion)
@@ -54,6 +54,8 @@ import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import qualified System.IO.UTF8 as U
(writeFile, putStrLn, print, readFile)
+import qualified Language.PureScript.Names as N
+import qualified Language.PureScript.Declarations as D
-- |
-- The PSCI state.
@@ -64,7 +66,7 @@ import qualified System.IO.UTF8 as U
data PSCiState = PSCiState
{ psciImportedFilenames :: [FilePath]
, psciImportedModuleNames :: [P.ModuleName]
- , psciLoadedModules :: [(FilePath, P.Module)]
+ , psciLoadedModules :: [(Maybe FilePath, P.Module)]
, psciLetBindings :: [P.Expr -> P.Expr]
}
@@ -85,7 +87,7 @@ updateImports name st = st { psciImportedModuleNames = name : psciImportedModule
-- |
-- Updates the state to have more loaded files.
--
-updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState
+updateModules :: [(Maybe FilePath, P.Module)] -> PSCiState -> PSCiState
updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
-- |
@@ -126,6 +128,17 @@ loadModule :: FilePath -> IO (Either String [P.Module])
loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename
-- |
+-- Load all modules, including the Prelude
+--
+loadAllModules :: [FilePath] -> IO (Either ParseError [(Maybe FilePath, P.Module)])
+loadAllModules files = do
+ filesAndContent <- forM files $ \filename -> do
+ content <- U.readFile filename
+ return (Just filename, content)
+ return $ P.parseModulesFromFiles $ (Nothing, P.prelude) : filesAndContent
+
+
+-- |
-- Expands tilde in path.
--
expandTilde :: FilePath -> IO FilePath
@@ -290,7 +303,7 @@ handleDeclaration :: P.Expr -> PSCI ()
handleDeclaration value = do
st <- PSCI $ lift get
let m = createTemporaryModule True st value
- e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) []
case e of
Left err -> PSCI $ outputStrLn err
Right _ -> do
@@ -303,17 +316,38 @@ handleDeclaration value = do
Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
-- |
+-- Show actual loaded modules in psci.
+--
+handleShowLoadedModules :: PSCI ()
+handleShowLoadedModules = do
+ PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get
+ psciIO $ readModules loadedModules >>= putStrLn
+ return ()
+ where readModules = return . unlines . sort . nub . map toModuleName
+ toModuleName = N.runModuleName . (\ (D.Module mdName _ _) -> mdName) . snd
+
+-- |
+-- Show the imported modules in psci.
+--
+handleShowImportedModules :: PSCI ()
+handleShowImportedModules = do
+ PSCiState { psciImportedModuleNames = importedModuleNames } <- PSCI $ lift get
+ psciIO $ readModules importedModuleNames >>= putStrLn
+ return ()
+ where readModules = return . unlines . sort . map N.runModuleName
+
+-- |
-- Imports a module, preserving the initial state on failure.
--
handleImport :: P.ModuleName -> PSCI ()
handleImport moduleName = do
- s <- liftM (updateImports moduleName) $ PSCI $ lift get
- let m = createTemporaryModuleForImports s
- e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules s ++ [("$PSCI.purs", m)]) []
+ st <- updateImports moduleName <$> PSCI (lift get)
+ let m = createTemporaryModuleForImports st
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) []
case e of
Left err -> PSCI $ outputStrLn err
Right _ -> do
- PSCI $ lift $ put s
+ PSCI $ lift $ put st
return ()
-- |
@@ -323,7 +357,7 @@ handleTypeOf :: P.Expr -> PSCI ()
handleTypeOf value = do
st <- PSCI $ lift get
let m = createTemporaryModule False st value
- e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) []
case e of
Left err -> PSCI $ outputStrLn err
Right env' ->
@@ -332,6 +366,40 @@ handleTypeOf value = do
Nothing -> PSCI $ outputStrLn "Could not find type"
-- |
+-- Pretty print a module's signatures
+--
+printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
+printModuleSignatures moduleName env =
+ PSCI $ let namesEnv = P.names env
+ moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv
+ in case moduleNamesIdent of
+ [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."
+ _ -> ( outputStrLn
+ . unlines
+ . sort
+ . map (showType . findType namesEnv)) moduleNamesIdent
+ where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
+ findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
+ showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String
+ showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType
+ showType _ = error "The impossible happened in printModuleSignatures."
+
+-- |
+-- Browse a module and displays its signature (if module exists).
+--
+handleBrowse :: P.ModuleName -> PSCI ()
+handleBrowse moduleName = do
+ st <- PSCI $ lift get
+ let loadedModules = psciLoadedModules st
+ env <- psciIO . runMake $ P.make modulesDir options loadedModules []
+ case env of
+ Left err -> PSCI $ outputStrLn err
+ Right env' ->
+ if moduleName `notElem` (nub . map ((\ (P.Module modName _ _ ) -> modName) . snd)) loadedModules
+ then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
+ else printModuleSignatures moduleName env'
+
+-- |
-- Takes a value and prints its kind
--
handleKindOf :: P.Type -> PSCI ()
@@ -339,7 +407,7 @@ handleKindOf typ = do
st <- PSCI $ lift get
let m = createTemporaryModuleForKind st typ
mName = P.ModuleName [P.ProperName "$PSCI"]
- e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) []
case e of
Left err -> PSCI $ outputStrLn err
Right env' ->
@@ -385,18 +453,20 @@ handleCommand (LoadFile filePath) = do
m <- psciIO $ loadModule absPath
case m of
Left err -> PSCI $ outputStrLn err
- Right mods -> PSCI . lift $ modify (updateModules (map ((,) absPath) mods))
+ Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Just absPath)) mods))
else
PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
handleCommand Reset = do
files <- psciImportedFilenames <$> PSCI (lift get)
- filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . psciIO . loadModule $ file) files
- let modulesOrFirstError = fmap concat $ sequence filesAndModules
+ modulesOrFirstError <- psciIO $ loadAllModules files
case modulesOrFirstError of
- Left err -> psciIO $ putStrLn err >> exitFailure
+ Left err -> psciIO $ putStrLn (show err) >> exitFailure
Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules [])
handleCommand (TypeOf val) = handleTypeOf val
handleCommand (KindOf typ) = handleKindOf typ
+handleCommand (Browse moduleName) = handleBrowse moduleName
+handleCommand (Show "loaded") = handleShowLoadedModules
+handleCommand (Show "import") = handleShowImportedModules
handleCommand _ = PSCI $ outputStrLn "Unknown command"
singleLineFlag :: Cmd.Term Bool
@@ -429,15 +499,13 @@ loadUserConfig = do
loop :: Bool -> [FilePath] -> IO ()
loop singleLineMode files = do
config <- loadUserConfig
- preludeFilename <- P.preludeFilename
- filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . loadModule $ file) (preludeFilename : files)
- let modulesOrFirstError = fmap concat $ sequence filesAndModules
+ modulesOrFirstError <- loadAllModules files
case modulesOrFirstError of
- Left err -> putStrLn err >> exitFailure
+ Left err -> putStrLn (show err) >> exitFailure
Right modules -> do
historyFilename <- getHistoryFilename
- let settings = defaultSettings {historyFile = Just historyFilename}
- flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do
+ let settings = defaultSettings { historyFile = Just historyFilename }
+ flip evalStateT (PSCiState files defaultImports modules []) . runInputT (setComplete completion settings) $ do
outputStrLn prologueMessage
traverse_ (mapM_ (runPSCI . handleCommand)) config
go
diff --git a/psci/Parser.hs b/psci/Parser.hs
index b507f1e..9fe45cc 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -42,7 +42,7 @@ psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> C.mark (many1 (C
--
parseCommand :: String -> Either ParseError Command
parseCommand = P.runIndentParser "" $ choice
- [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf)
+ [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf <|> psciBrowse <|> psciShowModules)
, try psciLet
, psciExpression
] <* eof
@@ -70,8 +70,10 @@ psciImport = Import <$> (char 'i' *> P.whiteSpace *> P.moduleName)
--
psciLoadFile :: Parsec String P.ParseState Command
psciLoadFile = LoadFile . trimEnd <$> (char 'm' *> P.whiteSpace *> manyTill anyChar eof)
- where
- trimEnd = reverse . dropWhile isSpace . reverse
+
+-- | Trim end of input string
+trimEnd :: String -> String
+trimEnd = reverse . dropWhile isSpace . reverse
-- |
-- Parses 'Commands.Quit' command.
@@ -97,3 +99,14 @@ psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue)
--
psciKindOf :: Parsec String P.ParseState Command
psciKindOf = KindOf <$> (char 'k' *> P.whiteSpace *> P.parseType)
+
+-- |
+-- Parses 'Commands.Browse' command.
+--
+psciBrowse :: Parsec String P.ParseState Command
+psciBrowse = Browse <$> (char 'b' *> P.whiteSpace *> P.moduleName)
+
+-- |
+-- Show Command
+psciShowModules :: Parsec String P.ParseState Command
+psciShowModules = Show . trimEnd <$> (char 's' *> P.whiteSpace *> manyTill anyChar eof)
diff --git a/purescript.cabal b/purescript.cabal
index f756633..4c0f3be 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.5.7.1
+version: 0.6.0
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -14,8 +14,6 @@ Homepage: http://www.purescript.org/
author: Phil Freeman <paf31@cantab.net>,
Gary Burgess <gary.burgess@gmail.com>,
Hardy Jones <jones3.hardy@gmail.com>
-data-files: prelude/prelude.purs
-data-dir: ""
extra-source-files: examples/passing/*.purs
, examples/failing/*.purs
@@ -25,14 +23,20 @@ source-repository head
location: https://github.com/purescript/purescript.git
library
- build-depends: base >=4 && <5, cmdtheline == 0.2.*, containers -any, unordered-containers -any,
- directory >= 1.2, filepath -any, mtl >= 2.1.0 && < 2.3.0, parsec -any,
- transformers >= 0.3 && < 0.5, utf8-string -any,
+ build-depends: base >=4 && <5,
+ cmdtheline == 0.2.*,
+ containers -any,
+ unordered-containers -any,
+ directory >= 1.2,
+ filepath -any,
+ mtl >= 2.1.0 && < 2.3.0,
+ parsec -any,
+ transformers >= 0.3 && < 0.5,
+ utf8-string -any,
pattern-arrows >= 0.0.2 && < 0.1,
- monad-unify >= 0.2.2 && < 0.3,
+ monad-unify >= 0.2.2 && < 0.3,
+ file-embed >= 0.0.7 && < 0.0.8,
time -any
- if (!os(windows))
- build-depends: unix -any
exposed-modules: Language.PureScript
Language.PureScript.Constants
Language.PureScript.Options
@@ -123,12 +127,12 @@ executable psci
Parser
ghc-options: -Wall -O2
-executable docgen
+executable psc-docs
build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any,
process -any, mtl -any
main-is: Main.hs
buildable: True
- hs-source-dirs: docgen
+ hs-source-dirs: psc-docs
other-modules:
ghc-options: -Wall -O2
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index f4cc5dd..c8bc10c 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -13,9 +13,9 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-}
-module Language.PureScript (module P, compile, compile', MonadMake(..), make, preludeFilename) where
+module Language.PureScript (module P, compile, compile', MonadMake(..), make, prelude) where
import Language.PureScript.Types as P
import Language.PureScript.Kinds as P
@@ -36,20 +36,23 @@ import Language.PureScript.Supply as P
import Language.PureScript.Renamer as P
import qualified Language.PureScript.Constants as C
-import qualified Paths_purescript as Paths
import Data.List (sortBy, groupBy, intercalate)
import Data.Time.Clock
import Data.Function (on)
-import Data.Maybe (listToMaybe, fromMaybe)
+import Data.Maybe (fromMaybe)
+import Data.FileEmbed (embedFile)
+import Data.Traversable (traverse)
+
import Control.Monad.Error
import Control.Arrow ((&&&))
import Control.Applicative
+
import qualified Data.Map as M
import qualified Data.Set as S
+import qualified Data.ByteString.UTF8 as BU
-import System.FilePath ((</>), pathSeparator)
-import System.Directory (getHomeDirectory, doesFileExist)
+import System.FilePath ((</>))
-- |
-- Compile a collection of modules
@@ -136,7 +139,7 @@ class MonadMake m where
-- If timestamps have not changed, the externs file can be used to provide the module's types without
-- having to typecheck the module again.
--
-make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(FilePath, Module)] -> [String] -> m Environment
+make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Maybe FilePath, Module)] -> [String] -> m Environment
make outputDir opts ms prefix = do
let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
@@ -145,13 +148,13 @@ make outputDir opts ms prefix = do
toRebuild <- foldM (\s (Module moduleName' _ _) -> do
let filePath = runModuleName moduleName'
- jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"
- externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"
- inputFile = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap
+ jsFile = outputDir </> filePath </> "index.js"
+ externsFile = outputDir </> filePath </> "externs.purs"
+ inputFile = join $ M.lookup moduleName' filePathMap
jsTimestamp <- getTimestamp jsFile
externsTimestamp <- getTimestamp externsFile
- inputTimestamp <- getTimestamp inputFile
+ inputTimestamp <- join <$> traverse getTimestamp inputFile
return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
(Just t1, Just t2, Just t3) | t1 < min t2 t3 -> s
@@ -172,8 +175,8 @@ make outputDir opts ms prefix = do
go env' ms'
go env ((True, m@(Module moduleName' _ exps)) : ms') = do
let filePath = runModuleName moduleName'
- jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"
- externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"
+ jsFile = outputDir </> filePath </> "index.js"
+ externsFile = outputDir </> filePath </> "externs.purs"
lift . progress $ "Compiling " ++ runModuleName moduleName'
@@ -200,7 +203,7 @@ make outputDir opts ms prefix = do
toRebuild' = toRebuild `S.union` S.fromList deps
(:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
- let externsFile = outputDir ++ pathSeparator : runModuleName moduleName' ++ pathSeparator : "externs.purs"
+ let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
externs <- readTextFile externsFile
externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
case externsModules of
@@ -231,18 +234,5 @@ importPrim = addDefaultImport (ModuleName [ProperName C.prim])
importPrelude :: Module -> Module
importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
-preludeFilename :: IO FilePath
-preludeFilename = fromMaybe missingPrelude . listToMaybe <$> do
- fs <- sequence [homePrelude, cabalPrelude]
- filterM doesFileExist fs
- where
- missingPrelude :: FilePath
- missingPrelude = error "No Prelude found in user home or cabal path."
-
- homePrelude :: IO FilePath
- homePrelude = do
- homeDir <- getHomeDirectory
- return $ homeDir </> ".purescript" </> "prelude" </> "prelude.purs"
-
- cabalPrelude :: IO FilePath
- cabalPrelude = Paths.getDataFileName "prelude/prelude.purs"
+prelude :: String
+prelude = BU.toString $(embedFile "prelude/prelude.purs")
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 9fead75..db8b6e9 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -26,8 +26,11 @@ import Data.Maybe (catMaybes)
import Data.Function (on)
import Data.List (nub, (\\), delete, sortBy)
+import qualified Data.Map as M
+
import Control.Monad (foldM, replicateM, forM)
import Control.Applicative
+import Control.Arrow (second)
import Language.PureScript.Names
import Language.PureScript.Declarations
@@ -51,7 +54,7 @@ moduleToJs opts (Module name decls (Just exps)) env = do
let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
let isModuleEmpty = null exps
let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
- let moduleExports = JSObjectLiteral $ concatMap exportToJs exps
+ let moduleExports = JSObjectLiteral . map (second var) . M.toList . M.unions $ map exportToJs exps
return $ case optionsAdditional opts of
MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
CompileOptions ns _ _ | not isModuleEmpty ->
@@ -154,12 +157,12 @@ declToJs _ _ _ _ = return Nothing
-- |
-- Generate key//value pairs for an object literal exporting values from a module.
--
-exportToJs :: DeclarationRef -> [(String, JS)]
-exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors
-exportToJs (ValueRef name) = [(runIdent name, var name)]
-exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]
-exportToJs (TypeClassRef name) = [(runProperName name, var $ Ident $ runProperName name)]
-exportToJs _ = []
+exportToJs :: DeclarationRef -> M.Map String Ident
+exportToJs (TypeRef _ (Just dctors)) = M.fromList [ (n, Ident n) | (ProperName n) <- dctors ]
+exportToJs (ValueRef name) = M.singleton (runIdent name) name
+exportToJs (TypeInstanceRef name) = M.singleton (runIdent name) name
+exportToJs (TypeClassRef name) = M.singleton (runProperName name) (Ident $ runProperName name)
+exportToJs _ = M.empty
-- |
-- Generate code in the simplified Javascript intermediate representation for a variable based on a
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 9c0179b..11555ff 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -16,10 +16,12 @@
module Language.PureScript.Errors where
+import Data.Either (lefts, rights)
import Data.List (intersperse, intercalate)
import Data.Monoid
import Control.Monad.Error
+import Control.Applicative ((<$>))
import Language.PureScript.Declarations
import Language.PureScript.Pretty
@@ -121,3 +123,18 @@ rethrow f = flip catchError $ \e -> throwError (f e)
--
rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a
rethrowWithPosition pos = rethrow (positionError pos <>)
+
+-- |
+-- Collect errors in in parallel
+--
+parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
+parU xs f = forM xs (withError . f) >>= collectErrors
+ where
+ withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
+ withError u = catchError (Right <$> u) (return . Left)
+
+ collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
+ collectErrors es = case lefts es of
+ [err] -> throwError err
+ [] -> return $ rights es
+ errs -> throwError $ MultipleErrors errs
diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs
index 81c1baf..4176ed8 100644
--- a/src/Language/PureScript/Parser.hs
+++ b/src/Language/PureScript/Parser.hs
@@ -31,4 +31,4 @@ import Language.PureScript.Parser.Common as P
import Language.PureScript.Parser.Types as P
import Language.PureScript.Parser.State as P
import Language.PureScript.Parser.Kinds as P
-import Language.PureScript.Parser.Declarations as P
+import Language.PureScript.Parser.Declarations as P \ No newline at end of file
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index db9fee6..fc62868 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -19,6 +19,7 @@ module Language.PureScript.Parser.Declarations (
parseDeclaration,
parseModule,
parseModules,
+ parseModulesFromFiles,
parseValue,
parseGuard,
parseBinder,
@@ -26,6 +27,7 @@ module Language.PureScript.Parser.Declarations (
) where
import Data.Maybe (isJust, fromMaybe)
+import Data.Traversable (forM)
import Control.Applicative
import Control.Arrow ((+++))
@@ -231,6 +233,18 @@ parseModule = do
return $ Module name decls exports
-- |
+-- Parse a collection of modules
+--
+parseModulesFromFiles :: [(Maybe FilePath, String)] -> Either P.ParseError [(Maybe FilePath, Module)]
+parseModulesFromFiles input =
+ fmap collect . forM input $ \(filename, content) -> do
+ ms <- runIndentParser (fromMaybe "" filename) parseModules content
+ return (filename, ms)
+ where
+ collect :: [(k, [v])] -> [(k, v)]
+ collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
+
+-- |
-- Parse a collection of modules
--
parseModules :: P.Parsec String ParseState [Module]
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index c9d6f5c..5baf578 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -52,14 +52,14 @@ collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (colla
--
createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]
createBindingGroups moduleName ds = do
- values <- mapM (createBindingGroupsForValue moduleName) $ filter isValueDecl ds
+ values <- parU (filter isValueDecl ds) (createBindingGroupsForValue moduleName)
let dataDecls = filter isDataDecl ds
allProperNames = map getProperName dataDecls
dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
- dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts
+ dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
let allIdents = map getIdent values
valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
- bindingGroupDecls <- mapM (toBindingGroup moduleName) $ stronglyConnComp valueVerts
+ bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
return $ filter isImportDecl ds ++
filter isExternDataDecl ds ++
filter isExternInstanceDecl ds ++
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 72178be..56ab9fb 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -43,7 +43,7 @@ desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
-desugarAbs = mapM f
+desugarAbs = flip parU f
where
(f, _, _) = everywhereOnValuesM return replace return
@@ -57,7 +57,7 @@ desugarAbs = mapM f
-- Replace all top-level binders with case expressions.
--
desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
-desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
+desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
where
desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 16ca51c..e9595f3 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -33,7 +33,7 @@ import Control.Monad.Trans.Class
-- and all @DoNotationLet@ constructors with let expressions.
--
desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
-desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts
+desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts
desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 97fd33d..80673be 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -176,7 +176,7 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $
--
renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
renameInModule imports exports (Module mn decls exps) =
- Module mn <$> mapM go decls <*> pure exps
+ Module mn <$> parU decls go <*> pure exps
where
(go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 7ecf7af..e5cc304 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -66,7 +66,7 @@ removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts
rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module
rebracketModule opTable (Module mn ds exts) =
let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
- in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts
+ in Module mn <$> (map removeParens <$> parU ds f) <*> pure exts
removeParens :: Declaration -> Declaration
removeParens =
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 697cff6..b131cb9 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -53,7 +53,7 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
desugarModule :: Module -> Desugar Module
desugarModule (Module name decls (Just exps)) = do
- (newExpss, declss) <- unzip <$> mapM (desugarDecl name exps) decls
+ (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)
return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
desugarModule _ = error "Exports should have been elaborated in name desugaring"
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 6bedf85..fc1ebed 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -183,7 +183,11 @@ typeCheckAll mainModuleName moduleName exps = go
forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
valueIsNotDefined moduleName name
tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
- vals' <- forM (zipWith (\(name, nameKind, _) (_, (val, ty)) -> (name, val, nameKind, ty)) vals tys) $ \(name, val, nameKind, ty) -> do
+ vals' <- forM [ (name, val, nameKind, ty)
+ | (name, nameKind, _) <- vals
+ , (name', (val, ty)) <- tys
+ , name == name'
+ ] $ \(name, val, nameKind, ty) -> do
addValue moduleName name ty nameKind
return (name, nameKind, val)
return $ BindingGroupDeclaration vals'
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 521c6c6..e8b1935 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -28,7 +28,6 @@ import Language.PureScript.Options
import Language.PureScript.Errors
import Data.Maybe
-import Data.Either (lefts, rights)
import Control.Applicative
import Control.Monad.State
@@ -233,19 +232,3 @@ liftUnify unify = do
(a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
return (a, unifyCurrentSubstitution ust)
-
--- |
--- Typecheck in parallel
---
-parU :: [a] -> (a -> UnifyT t Check b) -> UnifyT t Check [b]
-parU xs f = forM xs (withError . f) >>= collectErrors
- where
- withError :: UnifyT t Check a -> UnifyT t Check (Either ErrorStack a)
- withError u = catchError (Right <$> u) (return . Left)
-
- collectErrors :: [Either ErrorStack a] -> UnifyT t Check [a]
- collectErrors es = case lefts es of
- [err] -> throwError err
- [] -> return $ rights es
- errs -> throwError $ MultipleErrors errs
-
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index a9c45b2..f8988e0 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -192,10 +192,10 @@ typesOf mainModuleName moduleName vals = do
skolemEscapeCheck val'
-- Check rows do not contain duplicate labels
checkDuplicateLabels val'
- -- Remove type synonyms placeholders, remove duplicate row fields, and replace
+ -- Remove type synonyms placeholders, and replace
-- top-level unification variables with named type variables.
- let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'
- ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty
+ let val'' = overTypes desaturateAllTypeSynonyms val'
+ ty' = varIfUnknown . desaturateAllTypeSynonyms $ ty
return (ident, (val'', ty'))
where
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
@@ -527,41 +527,33 @@ checkDuplicateLabels =
def = return
go :: Expr -> Check Expr
- go e@(TypedValue _ _ ty) = checkDups ty >> return e
- go other = return other
+ go e@(TypedValue _ val ty) = do
+ checkDups ty
+ return e
+
+ where
+ checkDups :: Type -> Check ()
+ checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
+ checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts
+ checkDups (ForAll _ t _) = checkDups t
+ checkDups (ConstrainedType args t) = do
+ mapM_ (checkDups) $ concatMap snd args
+ checkDups t
+ checkDups r@(RCons _ _ _) =
+ let (ls, _) = rowToList r in
+ case firstDup . sort . map fst $ ls of
+ Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)
+ Nothing -> return ()
+ checkDups _ = return ()
- checkDups :: Type -> Check ()
- checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
- checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts
- checkDups (ForAll _ t _) = checkDups t
- checkDups (ConstrainedType args t) = do
- mapM_ (checkDups) $ concatMap snd args
- checkDups t
- checkDups r@(RCons _ _ _) =
- let (ls, _) = rowToList r in
- case firstDup . sort . map fst $ ls of
- Just l -> throwError . strMsg $ "Duplicate label " ++ show l ++ " in row"
- Nothing -> return ()
- checkDups _ = return ()
+ firstDup :: (Eq a) => [a] -> Maybe a
+ firstDup (x : xs@(x' : _))
+ | x == x' = Just x
+ | otherwise = firstDup xs
+ firstDup _ = Nothing
+
+ go other = return other
- firstDup :: (Eq a) => [a] -> Maybe a
- firstDup (x : xs@(x' : _))
- | x == x' = Just x
- | otherwise = firstDup xs
- firstDup _ = Nothing
-
--- |
--- Ensure a row contains no duplicate labels
---
-setify :: Type -> Type
-setify = rowFromList . first (M.toList . M.fromList) . rowToList
-
--- |
--- \"Setify\" all rows occuring inside a value
---
-setifyAll :: Type -> Type
-setifyAll = everywhereOnTypes setify
-
-- |
-- Replace outermost unsolved unification variables with named type variables
--
@@ -1018,10 +1010,11 @@ check' (TypeClassDictionaryConstructorApp name ps) t = do
return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t
check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do
ensureNoDuplicateProperties ps
- us <- zip (map fst ps) <$> replicateM (length ps) fresh
+ -- We need to be careful to avoid duplicate labels here.
+ -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns.
let (propsToCheck, rest) = rowToList row
- propsToRemove = map fst ps
- remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck
+ (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck
+ us <- zip (map fst removedProps) <$> replicateM (length ps) fresh
obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))
ps' <- checkProperties ps row True
return $ TypedValue True (ObjectUpdate obj' ps') t
diff --git a/tests/Main.hs b/tests/Main.hs
index 390dab7..8bbdcd5 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -22,6 +22,7 @@ import Data.List (isSuffixOf)
import Data.Traversable (traverse)
import Control.Monad
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
+import Control.Applicative
import System.Exit
import System.Process
import System.FilePath (pathSeparator)
@@ -29,18 +30,24 @@ import System.Directory (getCurrentDirectory, getTemporaryDirectory, getDirector
import Text.Parsec (ParseError)
import qualified System.IO.UTF8 as U
-readInput :: [FilePath] -> IO (Either ParseError [P.Module])
-readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do
+readInput :: [FilePath] -> IO [(Maybe FilePath, String)]
+readInput inputFiles = forM inputFiles $ \inputFile -> do
text <- U.readFile inputFile
- return $ P.runIndentParser inputFile P.parseModules text
+ return (Just inputFile, text)
+
+loadPrelude :: Either String (String, String, P.Environment)
+loadPrelude =
+ case P.parseModulesFromFiles [(Nothing, P.prelude)] of
+ Left parseError -> Left (show parseError)
+ Right ms -> P.compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) (map snd ms) []
compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))
compile opts inputFiles = do
- modules <- readInput inputFiles
+ modules <- P.parseModulesFromFiles <$> readInput inputFiles
case modules of
Left parseError ->
return (Left $ show parseError)
- Right ms -> return $ P.compile opts ms []
+ Right ms -> return $ P.compile opts (map snd ms) []
assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
assert preludeExterns opts inputFile f = do
@@ -79,10 +86,8 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
main :: IO ()
main = do
- prelude <- P.preludeFilename
- putStrLn "Compiling Prelude"
- preludeResult <- compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) [prelude]
- case preludeResult of
+ putStrLn "Compiling Prelude"
+ case loadPrelude of
Left err -> putStrLn err >> exitFailure
Right (preludeJs, exts, _) -> do
tmp <- getTemporaryDirectory