summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/failing/365.purs11
-rw-r--r--examples/failing/RowConstructors1.purs6
-rw-r--r--examples/failing/RowConstructors2.purs6
-rw-r--r--examples/failing/RowConstructors3.purs6
-rw-r--r--examples/failing/TypeSynonyms5.purs3
-rw-r--r--examples/passing/CaseStatement.purs19
-rw-r--r--examples/passing/Collatz.purs13
-rw-r--r--examples/passing/Guards.purs52
-rw-r--r--examples/passing/Let2.purs15
-rw-r--r--examples/passing/OperatorAssociativity.purs8
-rw-r--r--examples/passing/OperatorInlining.purs46
-rw-r--r--examples/passing/Operators.purs4
-rw-r--r--examples/passing/RebindableSyntax.purs37
-rw-r--r--examples/passing/RowConstructors.purs40
-rw-r--r--examples/passing/TopLevelCase.purs32
-rw-r--r--prelude/prelude.purs999
-rw-r--r--psc-make/Main.hs26
-rw-r--r--psc/Main.hs4
-rw-r--r--psci/Commands.hs78
-rw-r--r--psci/Completion.hs232
-rw-r--r--psci/Directive.hs116
-rw-r--r--psci/PSCi.hs (renamed from psci/Main.hs)319
-rw-r--r--psci/Parser.hs68
-rw-r--r--psci/Types.hs167
-rw-r--r--psci/main/Main.hs6
-rw-r--r--psci/tests/Main.hs137
-rw-r--r--purescript.cabal19
-rw-r--r--src/Language/PureScript.hs22
-rw-r--r--src/Language/PureScript/AST/Declarations.hs6
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs17
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs195
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs35
-rw-r--r--src/Language/PureScript/Constants.hs77
-rw-r--r--src/Language/PureScript/Errors.hs45
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs7
-rw-r--r--src/Language/PureScript/Parser/Types.hs4
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs1
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs55
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs5
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs31
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs12
-rw-r--r--tests/Main.hs17
43 files changed, 1934 insertions, 1066 deletions
diff --git a/examples/failing/365.purs b/examples/failing/365.purs
new file mode 100644
index 0000000..9a97030
--- /dev/null
+++ b/examples/failing/365.purs
@@ -0,0 +1,11 @@
+module Main where
+
+class C a where
+ f :: a -> a
+ g :: a -> a
+
+instance cS :: C String where
+ f s = s
+ g = f
+
+main = g "Done"
diff --git a/examples/failing/RowConstructors1.purs b/examples/failing/RowConstructors1.purs
new file mode 100644
index 0000000..29cad3f
--- /dev/null
+++ b/examples/failing/RowConstructors1.purs
@@ -0,0 +1,6 @@
+module Main where
+
+data Foo = Bar
+type Baz = { | Foo }
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/failing/RowConstructors2.purs b/examples/failing/RowConstructors2.purs
new file mode 100644
index 0000000..36ff33b
--- /dev/null
+++ b/examples/failing/RowConstructors2.purs
@@ -0,0 +1,6 @@
+module Main where
+
+type Foo r = (x :: Number | r)
+type Bar = { | Foo }
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/failing/RowConstructors3.purs b/examples/failing/RowConstructors3.purs
new file mode 100644
index 0000000..ce321ef
--- /dev/null
+++ b/examples/failing/RowConstructors3.purs
@@ -0,0 +1,6 @@
+module Main where
+
+type Foo = { x :: Number }
+type Bar = { | Foo }
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/failing/TypeSynonyms5.purs b/examples/failing/TypeSynonyms5.purs
new file mode 100644
index 0000000..c34eaae
--- /dev/null
+++ b/examples/failing/TypeSynonyms5.purs
@@ -0,0 +1,3 @@
+module Main where
+
+type T = T
diff --git a/examples/passing/CaseStatement.purs b/examples/passing/CaseStatement.purs
new file mode 100644
index 0000000..17669c1
--- /dev/null
+++ b/examples/passing/CaseStatement.purs
@@ -0,0 +1,19 @@
+module Main where
+
+data A = A | B | C
+
+f a _ A = a
+f _ a B = a
+f _ _ C = "Done"
+
+g a _ A = a
+g _ b B = b
+g _ _ C = C
+
+data M a = N | J a
+
+h f N a = a
+h f a N = a
+h f (J a) (J b) = J (f a b)
+
+main = Debug.Trace.trace $ f "Done" "Failed" A
diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs
index f61a950..5398249 100644
--- a/examples/passing/Collatz.purs
+++ b/examples/passing/Collatz.purs
@@ -1,9 +1,20 @@
module Main where
-import Prelude
import Control.Monad.Eff
import Control.Monad.ST
+foreign import jsMod
+ """
+ function jsMod(x) {
+ return function (y) {
+ return x % y;
+ };
+ }
+ """ :: Number -> Number -> Number
+
+infixl 7 %
+(%) = jsMod
+
collatz :: Number -> Number
collatz n = runPure (runST (do
r <- newSTRef n
diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs
index b883a4e..af68c40 100644
--- a/examples/passing/Guards.purs
+++ b/examples/passing/Guards.purs
@@ -1,29 +1,39 @@
module Main where
- import Prelude
+foreign import jsMod
+ """
+ function jsMod(x) {
+ return function (y) {
+ return x % y;
+ };
+ }
+ """ :: Number -> Number -> Number
- collatz = \x -> case x of
- y | y % 2 == 0 -> y / 2
- y -> y * 3 + 1
+infixl 7 %
+(%) = jsMod
- -- Guards have access to current scope
- collatz2 = \x y -> case x of
- z | y > 0 -> z / 2
- z -> z * 3 + 1
+collatz = \x -> case x of
+ y | y % 2 == 0 -> y / 2
+ y -> y * 3 + 1
- min :: forall a. (Ord a) => a -> a -> a
- min n m | n < m = n
- | otherwise = m
+-- Guards have access to current scope
+collatz2 = \x y -> case x of
+ z | y > 0 -> z / 2
+ z -> z * 3 + 1
- max :: forall a. (Ord a) => a -> a -> a
- max n m = case unit of
- _ | m < n -> n
- | otherwise -> m
+min :: forall a. (Ord a) => a -> a -> a
+min n m | n < m = n
+ | otherwise = m
- testIndentation :: Number -> Number -> Number
- testIndentation x y | x > 0
- = x + y
- | otherwise
- = y - x
+max :: forall a. (Ord a) => a -> a -> a
+max n m = case unit of
+ _ | m < n -> n
+ | otherwise -> m
- main = Debug.Trace.trace $ min "Done" "ZZZZ"
+testIndentation :: Number -> Number -> Number
+testIndentation x y | x > 0
+ = x + y
+ | otherwise
+ = y - x
+
+main = Debug.Trace.trace $ min "Done" "ZZZZ"
diff --git a/examples/passing/Let2.purs b/examples/passing/Let2.purs
new file mode 100644
index 0000000..e4ef059
--- /dev/null
+++ b/examples/passing/Let2.purs
@@ -0,0 +1,15 @@
+module Main where
+
+test =
+ let f :: Number -> Boolean
+ f 0 = false
+ f n = g (n - 1)
+
+ g :: Number -> Boolean
+ g 0 = true
+ g n = f (n - 1)
+
+ x = f 1
+ in not x
+
+main = Debug.Trace.print test
diff --git a/examples/passing/OperatorAssociativity.purs b/examples/passing/OperatorAssociativity.purs
index 9ee7a5d..5536772 100644
--- a/examples/passing/OperatorAssociativity.purs
+++ b/examples/passing/OperatorAssociativity.purs
@@ -35,21 +35,13 @@ main = do
assert (6 / (3 * 2) == 1) "6 / (3 * 2) == 1"
assert ((6 / 3) * 2 == 4) "(6 / 3) * 2 == 4"
- assert (6 % (2 * 2) == 2) "6 % (2 * 2) == 2"
- assert ((6 % 2) * 2 == 0) "(6 % 2) * 2 == 0"
-
- assert (4 % (9 / 3) == 1) "4 % (9 / 3) == 1"
- assert ((4 % 9) / 2 == 2) "(4 % 9) / 2 == 2"
-
assert (not (1 < 0) == true) "not (1 < 0) == true"
- assert (not (complement (1 + 10) == 8) == true) "not (complement (1 + 10) == 8) == true"
assert (not ((negate 1) < 0) == false) "not ((negate 1) < 0) == false"
assert (negate (1 + 10) == -11) "negate (1 + 10) == -11"
assert (2 * 3 / 4 == 1.5) "2 * 3 / 4 == 1.5"
assert (1 * 2 * 3 * 4 * 5 / 6 == 20) "1 * 2 * 3 * 4 * 5 / 6 == 20"
- assert (complement (2 / 3 * 4) == -3) "complement (2 / 3 * 4) == -3"
assert (1 + 10 - 5 == 6) "1 + 10 - 5 == 6"
assert (1 + 10 * 5 == 51) "1 + 10 * 5 == 51"
diff --git a/examples/passing/OperatorInlining.purs b/examples/passing/OperatorInlining.purs
new file mode 100644
index 0000000..ae3104e
--- /dev/null
+++ b/examples/passing/OperatorInlining.purs
@@ -0,0 +1,46 @@
+module Main where
+
+import Debug.Trace
+
+main = do
+
+ -- semiringNumber
+ print (1 + 2)
+ print (1 * 2)
+
+ -- ringNumber
+ print (1 - 2)
+ print (negate 1)
+
+ -- moduleSemiringNumber
+ print (1 / 2)
+
+ -- ordNumber
+ print (1 > 2)
+ print (1 < 2)
+ print (1 <= 2)
+ print (1 >= 2)
+ print (1 == 2)
+
+ -- eqNumber
+ print (1 == 2)
+ print (1 /= 2)
+
+ -- eqString
+ print ("foo" == "bar")
+ print ("foo" /= "bar")
+
+ -- eqBoolean
+ print (true == false)
+ print (true /= false)
+
+ -- semigroupString
+ print ("foo" ++ "bar")
+ print ("foo" <> "bar")
+
+ -- latticeBoolean
+ print (top && true)
+ print (bottom || false)
+
+ -- complementedLatticeBoolean
+ print (not true)
diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs
index d38f7ed..a222fe1 100644
--- a/examples/passing/Operators.purs
+++ b/examples/passing/Operators.purs
@@ -61,9 +61,6 @@ module Main where
test15 :: Number -> Number -> Boolean
test15 a b = const false $ a `test14` b
- test16 :: Number -> Number -> Number
- test16 x y = x .|. y .&. y
-
test17 :: Number
test17 = negate (-1)
@@ -94,7 +91,6 @@ module Main where
let t13 = test13 k 1 2
let t14 = test14 1 2
let t15 = test15 1 2
- let t16 = test16 1 2
let t17 = test17
let t18 = test18
let t19 = test19
diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs
new file mode 100644
index 0000000..8d2480c
--- /dev/null
+++ b/examples/passing/RebindableSyntax.purs
@@ -0,0 +1,37 @@
+module Main where
+
+example1 :: String
+example1 = do
+ "Do"
+ " notation"
+ " for"
+ " Semigroup"
+ where
+ (>>=) x f = x <> f unit
+
+(*>) :: forall f a b. (Apply f) => f a -> f b -> f b
+(*>) fa fb = const id <$> fa <*> fb
+
+newtype Const a b = Const a
+
+runConst :: forall a b. Const a b -> a
+runConst (Const a) = a
+
+instance functorConst :: Functor (Const a) where
+ (<$>) _ (Const a) = Const a
+
+instance applyConst :: (Semigroup a) => Apply (Const a) where
+ (<*>) (Const a1) (Const a2) = Const (a1 <> a2)
+
+example2 :: Const String Unit
+example2 = do
+ Const "Do"
+ Const " notation"
+ Const " for"
+ Const " Apply"
+ where
+ (>>=) x f = x *> f unit
+
+main = do
+ Debug.Trace.trace example1
+ Debug.Trace.trace $ runConst example2
diff --git a/examples/passing/RowConstructors.purs b/examples/passing/RowConstructors.purs
new file mode 100644
index 0000000..b09e0d8
--- /dev/null
+++ b/examples/passing/RowConstructors.purs
@@ -0,0 +1,40 @@
+module Main where
+
+type Foo = (x :: Number | (y :: Number | (z :: Number)))
+type Bar = (x :: Number, y :: Number, z :: Number)
+type Baz = { w :: Number | Bar }
+
+foo :: { | Foo }
+foo = { x: 0, y: 0, z: 0 }
+
+bar :: { | Bar }
+bar = { x: 0, y: 0, z: 0 }
+
+id' :: Object Foo -> Object Bar
+id' = id
+
+foo' :: { | Foo }
+foo' = id' foo
+
+bar' :: { | Bar }
+bar' = id' bar
+
+baz :: Baz
+baz = { x: 0, y: 0, z: 0, w: 0 }
+
+type Quux r = (q :: Number | r)
+type Norf r = (q' :: Number | Quux r)
+
+quux :: { f :: { | Foo } | Quux Bar }
+quux = { f: foo', x: 0, y: 0, z: 0, q: 0 }
+
+quux' :: { | Norf Bar }
+quux' = { x: 0, y: 0, z: 0, q: 0, q': 0 }
+
+wildcard :: { w :: Number | _ } -> Baz
+wildcard { w: w } = { x: w, y: w, z: w, w: w }
+
+wildcard' :: { | Quux _ } -> Number
+wildcard' { q: q } = q
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/TopLevelCase.purs b/examples/passing/TopLevelCase.purs
index 2c938d0..a0ade1b 100644
--- a/examples/passing/TopLevelCase.purs
+++ b/examples/passing/TopLevelCase.purs
@@ -1,18 +1,28 @@
module Main where
- import Prelude
+foreign import jsMod
+ """
+ function jsMod(x) {
+ return function (y) {
+ return x % y;
+ };
+ }
+ """ :: Number -> Number -> Number
- gcd :: Number -> Number -> Number
- gcd 0 x = x
- gcd x 0 = x
- gcd x y | x > y = gcd (x % y) y
- gcd x y = gcd (y % x) x
+infixl 7 %
+(%) = jsMod
- guardsTest (x:xs) | x > 0 = guardsTest xs
- guardsTest xs = xs
+gcd :: Number -> Number -> Number
+gcd 0 x = x
+gcd x 0 = x
+gcd x y | x > y = gcd (x % y) y
+gcd x y = gcd (y % x) x
- data A = A
+guardsTest (x:xs) | x > 0 = guardsTest xs
+guardsTest xs = xs
- parseTest A 0 = 0
+data A = A
- main = Debug.Trace.trace "Done"
+parseTest A 0 = 0
+
+main = Debug.Trace.trace "Done"
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 1531461..be4d07a 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -1,156 +1,120 @@
module Prelude
- ( otherwise
+ ( Unit(..), unit
+ , ($), (#)
, flip
, const
, asTypeOf
+ , otherwise
+ , (:), cons
, Semigroupoid, (<<<), (>>>)
, Category, id
- , ($), (#)
- , (:), cons
- , Show, show
, Functor, (<$>), (<#>), void
, Apply, (<*>)
, Applicative, pure, liftA1
, Bind, (>>=)
, Monad, return, liftM1, ap
+ , Semigroup, (<>), (++)
, Semiring, (+), zero, (*), one
, ModuloSemiring, (/), mod
- , Ring, (-)
- , (%)
- , negate
- , DivisionRing
+ , Ring, (-), negate
, Num
+ , DivisionRing
, Eq, (==), (/=)
- , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
- , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement
- , BoolLike, (&&), (||)
- , not
- , Semigroup, (<>), (++)
- , Unit(..), unit
+ , Ordering(..), Ord, compare, (<), (>), (<=), (>=)
+ , Bounded, top, bottom
+ , Lattice, sup, inf, (||), (&&)
+ , BoundedLattice
+ , ComplementedLattice, not
+ , DistributiveLattice
+ , BooleanAlgebra
+ , Show, show
) where
- -- | An alias for `true`, which can be useful in guard clauses:
+ -- | The `Unit` type has a single inhabitant, called `unit`. It represents
+ -- | values with no computational content.
-- |
- -- | ```purescript
- -- | max x y | x >= y = x
- -- | | otherwise = y
- -- | ```
- -- |
- otherwise :: Boolean
- otherwise = true
+ -- | `Unit` is often used, wrapped in a monadic type constructor, as the
+ -- | return type of a computation where only
+ -- | the _effects_ are important.
+ newtype Unit = Unit {}
- -- | Flips the order of the arguments to a function of two arguments.
+ -- | `unit` is the sole inhabitant of the `Unit` type.
+ unit :: Unit
+ unit = Unit {}
+
+ infixr 0 $
+ infixl 0 #
+
+ -- | Applies a function to its argument.
-- |
-- | ```purescript
- -- | flip const 1 2 = const 2 1 = 2
+ -- | length $ groupBy productCategory $ filter isInStock $ products
-- | ```
-- |
- flip :: forall a b c. (a -> b -> c) -> b -> a -> c
- flip f b a = f a b
-
- -- | Returns its first argument and ignores its second.
+ -- | is equivalent to:
-- |
-- | ```purescript
- -- | const 1 "hello" = 1
+ -- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
- const :: forall a b. a -> b -> a
- const a _ = a
+ -- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of
+ -- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))`
+ ($) :: forall a b. (a -> b) -> a -> b
+ ($) f x = f x
- -- | This function returns its first argument, and can be used to assert type equalities.
- -- | This can be useful when types are otherwise ambiguous.
+ -- | Applies an argument to a function.
-- |
-- | ```purescript
- -- | main = print $ [] `asTypeOf` [0]
+ -- | products # filter isInStock # groupBy productCategory # length
-- | ```
-- |
- -- | If instead, we had written `main = print []`, the type of the argument `[]` would have
- -- | been ambiguous, resulting in a compile-time error.
- asTypeOf :: forall a. a -> a -> a
- asTypeOf x _ = x
-
- infixr 9 >>>
- infixr 9 <<<
-
- -- | A `Semigroupoid` is similar to a [`Category`](#category) but does not require an identity
- -- | element `id`, just composable morphisms.
- -- |
- -- | `Semigroupoid`s should obey the following rule:
- -- |
- -- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`
- -- |
- -- | One example of a `Semigroupoid` is the function type constructor `(->)`, with `(<<<)` defined
- -- | as function composition.
- 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)
-
- -- | Forwards composition, or `(<<<)` with its arguments reversed.
- (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
- (>>>) f g = g <<< f
-
- -- | `Category`s consist of objects and composable morphisms between them, and as such are
- -- | [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids` must have an identity element.
- -- |
- -- | `Category`s should obey the following rules.
- -- |
- -- | - Left Identity: `id <<< p = p`
- -- | - Right Identity: `p <<< id = p`
- -- |
- class (Semigroupoid a) <= Category a where
- id :: forall t. a t t
-
- instance categoryArr :: Category (->) where
- id x = x
-
- infixr 0 $
- infixl 0 #
-
- -- | Applies a function to its argument
+ -- | is equivalent to:
-- |
-- | ```purescript
- -- | length $ groupBy productCategory $ filter isInStock products
+ -- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
- -- | is equivalent to
+ -- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of
+ -- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))`
+ (#) :: forall a b. a -> (a -> b) -> b
+ (#) x f = f x
+
+ -- | Flips the order of the arguments to a function of two arguments.
-- |
-- | ```purescript
- -- | length (groupBy productCategory (filter isInStock (products)))
+ -- | flip const 1 2 = const 2 1 = 2
-- | ```
- -- |
- -- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of left, so
- -- | `a $ b $ c $ d x` = `a $ (b $ (c $ (d $ x)))` = `a (b (c (d x)))`
- -- |
- ($) :: forall a b. (a -> b) -> a -> b
- ($) f x = f x
+ flip :: forall a b c. (a -> b -> c) -> b -> a -> c
+ flip f b a = f a b
- -- | Applies a function to its argument
+ -- | Returns its first argument and ignores its second.
-- |
-- | ```purescript
- -- | products # groupBy productCategory # filter isInStock # length
+ -- | const 1 "hello" = 1
-- | ```
- -- |
- -- | is equivalent to
+ const :: forall a b. a -> b -> a
+ const a _ = a
+
+ -- | This function returns its first argument, and can be used to assert type
+ -- | equalities. This can be useful when types are otherwise ambiguous.
-- |
-- | ```purescript
- -- | length (groupBy productCategory (filter isInStock (products)))
+ -- | main = print $ [] `asTypeOf` [0]
-- | ```
-- |
- -- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of right, so
- -- | `x # a # b # c # d` = `(((x # a) # b) # c) # d` = `d (c (b (a x)))`
- -- |
- (#) :: forall a b. a -> (a -> b) -> b
- (#) x f = f x
-
- infixr 6 :
+ -- | If instead, we had written `main = print []`, the type of the argument
+ -- | `[]` would have been ambiguous, resulting in a compile-time error.
+ asTypeOf :: forall a. a -> a -> a
+ asTypeOf x _ = x
- -- | An infix alias for `cons`.
+ -- | An alias for `true`, which can be useful in guard clauses:
-- |
- -- | Note, the running time of this function is `O(n)`.
- (:) :: forall a. a -> [a] -> [a]
- (:) = cons
+ -- | ```purescript
+ -- | max x y | x >= y = x
+ -- | | otherwise = y
+ -- | ```
+ otherwise :: Boolean
+ otherwise = true
-- | Attaches an element to the front of an array, creating a new array.
-- |
@@ -168,72 +132,70 @@ module Prelude
}
""" :: forall a. a -> [a] -> [a]
- -- | The `Show` type class represents those types which can be converted into a human-readable `String` representation.
- -- |
- -- | While not required, it is recommended that for any expression `x`, the string `show x` be executable PureScript code
- -- | which evaluates to the same value as the expression `x`.
- class Show a where
- show :: a -> String
-
- foreign import showStringImpl
- """
- function showStringImpl(s) {
- return JSON.stringify(s);
- }
- """ :: String -> String
+ infixr 6 :
- instance showUnit :: Show Unit where
- show (Unit {}) = "Unit {}"
+ -- | An infix alias for `cons`.
+ -- |
+ -- | Note, the running time of this function is `O(n)`.
+ (:) :: forall a. a -> [a] -> [a]
+ (:) = cons
- instance showString :: Show String where
- show = showStringImpl
+ infixr 9 >>>
+ infixr 9 <<<
- instance showBoolean :: Show Boolean where
- show true = "true"
- show false = "false"
+ -- | A `Semigroupoid` is similar to a [`Category`](#category) but does not
+ -- | require an identity element `id`, just composable morphisms.
+ -- |
+ -- | `Semigroupoid`s must satisfy the following law:
+ -- |
+ -- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`
+ -- |
+ -- | One example of a `Semigroupoid` is the function type constructor `(->)`,
+ -- | with `(<<<)` defined as function composition.
+ class Semigroupoid a where
+ (<<<) :: forall b c d. a c d -> a b c -> a b d
- foreign import showNumberImpl
- """
- function showNumberImpl(n) {
- return n.toString();
- }
- """ :: Number -> String
+ instance semigroupoidArr :: Semigroupoid (->) where
+ (<<<) f g x = f (g x)
- instance showNumber :: Show Number where
- show = showNumberImpl
+ -- | Forwards composition, or `(<<<)` with its arguments reversed.
+ (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
+ (>>>) f g = g <<< f
- 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
+ -- | `Category`s consist of objects and composable morphisms between them, and
+ -- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids`
+ -- | must have an identity element.
+ -- |
+ -- | Instances must satisfy the following law in addition to the
+ -- | `Semigroupoid` law:
+ -- |
+ -- | - Identity: `id <<< p = p <<< id = p`
+ class (Semigroupoid a) <= Category a where
+ id :: forall t. a t t
- instance showArray :: (Show a) => Show [a] where
- show = showArrayImpl show
+ instance categoryArr :: Category (->) where
+ id x = x
infixl 4 <$>
infixl 1 <#>
- -- | A `Functor` is a type constructor which supports a mapping operation `(<$>)`.
+ -- | A `Functor` is a type constructor which supports a mapping operation
+ -- | `(<$>)`.
-- |
- -- | `(<$>)` can be used to turn functions `a -> b` into functions `f a -> f b` whose argument and return
- -- | types use the type constructor `f` to represent some computational context.
+ -- | `(<$>)` can be used to turn functions `a -> b` into functions
+ -- | `f a -> f b` whose argument and return types use the type constructor `f`
+ -- | to represent some computational context.
-- |
- -- | `Functor` instances should satisfy the following laws:
+ -- | Instances must satisfy the following laws:
-- |
-- | - Identity: `(<$>) id = id`
-- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`
- -- |
class Functor f where
(<$>) :: forall a b. (a -> b) -> f a -> f b
+ instance functorArr :: Functor ((->) r) where
+ (<$>) = (<<<)
+
-- | `(<#>)` is `(<$>)` with its arguments reversed. For example:
-- |
-- | ```purescript
@@ -242,10 +204,12 @@ module Prelude
(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(<#>) fa f = f <$> fa
- -- | The `void` function is used to ignore the type wrapped by a [`Functor`](#functor), replacing it with `Unit` and
- -- | keeping only the type information provided by the type constructor itself.
+ -- | The `void` function is used to ignore the type wrapped by a
+ -- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type
+ -- | information provided by the type constructor itself.
-- |
- -- | `void` is often useful when using `do` notation to change the return type of a monadic computation:
+ -- | `void` is often useful when using `do` notation to change the return type
+ -- | of a monadic computation:
-- |
-- | ```purescript
-- | main = forE 1 10 \n -> void do
@@ -257,48 +221,69 @@ module Prelude
infixl 4 <*>
- -- | The `Apply` class provides the `(<*>)` which is used to apply a function to an argument under a type constructor.
+ -- | The `Apply` class provides the `(<*>)` which is used to apply a function
+ -- | to an argument under a type constructor.
-- |
- -- | `Apply` can be used to lift functions of two or more arguments to work on values wrapped with the type constructor `f`.
- -- | It might also be understood in terms of the `lift2` function:
+ -- | `Apply` can be used to lift functions of two or more arguments to work on
+ -- | values wrapped with the type constructor `f`. It might also be understood
+ -- | in terms of the `lift2` function:
-- |
-- | ```purescript
-- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c
-- | lift2 f a b = f <$> a <*> b
-- | ```
-- |
- -- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts the function application operator `($)` to arguments
- -- | wrapped with the type constructor `f`.
+ -- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts
+ -- | the function application operator `($)` to arguments wrapped with the
+ -- | type constructor `f`.
-- |
- -- | `Apply` instances should satisfy the following law:
+ -- | Instances must satisfy the following law in addition to the `Functor`
+ -- | laws:
-- |
- -- | - Associative Composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
+ -- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
-- |
-- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.
class (Functor f) <= Apply f where
(<*>) :: forall a b. f (a -> b) -> f a -> f b
- -- | The `Applicative` type class extends the [`Apply`](#apply) type class with a `pure` function, which can be used to
- -- | create values of type `f a` from values of type `a`.
+ instance applyArr :: Apply ((->) r) where
+ (<*>) f g x = f x (g x)
+
+ -- | The `Applicative` type class extends the [`Apply`](#apply) type class
+ -- | with a `pure` function, which can be used to create values of type `f a`
+ -- | from values of type `a`.
-- |
- -- | Where [`Apply`](#apply) provides the ability to lift functions of two or more arguments to functions whose arguments are wrapped using `f`,
- -- | and [`Functor`](#functor) provides the ability to lift functions of one argument, `pure` can be seen as the function which lifts functions of
- -- | _zero_ arguments. That is, `Applicative` functors support a lifting operation for any number of function arguments.
+ -- | Where [`Apply`](#apply) provides the ability to lift functions of two or
+ -- | more arguments to functions whose arguments are wrapped using `f`, and
+ -- | [`Functor`](#functor) provides the ability to lift functions of one
+ -- | argument, `pure` can be seen as the function which lifts functions of
+ -- | _zero_ arguments. That is, `Applicative` functors support a lifting
+ -- | operation for any number of function arguments.
-- |
- -- | `Applicative` instances should satisfy the following laws:
+ -- | Instances must satisfy the following laws in addition to the `Apply`
+ -- | laws:
-- |
-- | - Identity: `(pure id) <*> v = v`
-- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`
-- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`
-- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`
- -- |
class (Apply f) <= Applicative f where
pure :: forall a. a -> f a
- -- | `liftA1` provides a default implementation of `(<$>)` for any [`Applicative`](#applicative) functor,
- -- | without using `(<$>)` as provided by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass relationship.
+ instance applicativeArr :: Applicative ((->) r) where
+ pure = const
+
+ -- | `return` is an alias for `pure`.
+ return :: forall m a. (Applicative m) => a -> m a
+ return = pure
+
+ -- | `liftA1` provides a default implementation of `(<$>)` for any
+ -- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided
+ -- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass
+ -- | relationship.
-- |
- -- | `liftA1` can therefore be used to write [`Functor`](#functor) instances as follows:
+ -- | `liftA1` can therefore be used to write [`Functor`](#functor) instances
+ -- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
@@ -309,8 +294,9 @@ module Prelude
infixl 1 >>=
- -- | The `Bind` type class extends the [`Apply`](#apply) type class with a "bind" operation `(>>=)` which composes computations
- -- | in sequence, using the return value of one computation to determine the next computation.
+ -- | The `Bind` type class extends the [`Apply`](#apply) type class with a
+ -- | "bind" operation `(>>=)` which composes computations in sequence, using
+ -- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
@@ -321,15 +307,13 @@ module Prelude
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
- -- | `Bind` instances should satisfy the following law:
+ -- | Instances must satisfy the following law in addition to the `Apply`
+ -- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`
-- |
- -- | Or, expressed using `do` notation:
- -- |
- -- | - Associativity: `do { z <- do { y <- x ; f y } ; g z } = do { k <- x ; do { y <- f k ; g y } }`
- -- |
- -- | Associativity tells us that we can regroup operations which use do-notation, so that we can unambiguously write, for example:
+ -- | Associativity tells us that we can regroup operations which use `do`
+ -- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
@@ -339,29 +323,29 @@ module Prelude
class (Apply m) <= Bind m where
(>>=) :: forall a b. m a -> (a -> m b) -> m b
- -- | The `Monad` type class combines the operations of the `Bind` and `Applicative` type classes. Therefore, `Monad` instances
- -- | represent type constructors which support sequential composition, and also lifting of functions of arbitrary arity.
+ instance bindArr :: Bind ((->) r) where
+ (>>=) m f x = f (m x) x
+
+ -- | The `Monad` type class combines the operations of the `Bind` and
+ -- | `Applicative` type classes. Therefore, `Monad` instances represent type
+ -- | constructors which support sequential composition, and also lifting of
+ -- | functions of arbitrary arity.
-- |
- -- | `Monad` instances should satisfy the following laws:
+ -- | Instances must satisfy the following laws in addition to the
+ -- | `Applicative` and `Bind` laws:
-- |
-- | - Left Identity: `pure x >>= f = f x`
-- | - Right Identity: `x >>= pure = x`
- -- |
- -- | Or, expressed using `do` notation:
- -- |
- -- | - Left Identity: `do { y <- pure x ; f y } = f x`
- -- | - Right Identity: `do { y <- x ; pure y } = x`
- -- |
class (Applicative m, Bind m) <= Monad m
- -- | `return` is an alias for `pure`.
- return :: forall m a. (Monad m) => a -> m a
- return = pure
+ instance monadArr :: Monad ((->) r)
- -- | `liftM1` provides a default implementation of `(<$>)` for any [`Monad`](#monad),
- -- | without using `(<$>)` as provided by the [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
+ -- | `liftM1` provides a default implementation of `(<$>)` for any
+ -- | [`Monad`](#monad), without using `(<$>)` as provided by the
+ -- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
-- |
- -- | `liftM1` can therefore be used to write [`Functor`](#functor) instances as follows:
+ -- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
+ -- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
@@ -372,10 +356,12 @@ module Prelude
a' <- a
return (f a')
- -- | `ap` provides a default implementation of `(<*>)` for any [`Monad`](#monad),
- -- | without using `(<*>)` as provided by the [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
+ -- | `ap` provides a default implementation of `(<*>)` for any
+ -- | [`Monad`](#monad), without using `(<*>)` as provided by the
+ -- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
-- |
- -- | `ap` can therefore be used to write [`Apply`](#apply) instances as follows:
+ -- | `ap` can therefore be used to write [`Apply`](#apply) instances as
+ -- | follows:
-- |
-- | ```purescript
-- | instance applyF :: Apply F where
@@ -387,69 +373,153 @@ module Prelude
a' <- a
return (f' a')
- instance functorArr :: Functor ((->) r) where
- (<$>) = (<<<)
+ infixr 5 <>
+ infixr 5 ++
- instance applyArr :: Apply ((->) r) where
- (<*>) f g x = f x (g x)
+ -- | The `Semigroup` type class identifies an associative operation on a type.
+ -- |
+ -- | Instances are required to satisfy the following law:
+ -- |
+ -- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
+ -- |
+ -- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
+ -- | concatenation.
+ class Semigroup a where
+ (<>) :: a -> a -> a
- instance applicativeArr :: Applicative ((->) r) where
- pure = const
+ -- | `(++)` is an alias for `(<>)`.
+ (++) :: forall s. (Semigroup s) => s -> s -> s
+ (++) = (<>)
- instance bindArr :: Bind ((->) r) where
- (>>=) m f x = f (m x) x
+ instance semigroupString :: Semigroup String where
+ (<>) = concatString
- instance monadArr :: Monad ((->) r)
+ instance semigroupUnit :: Semigroup Unit where
+ (<>) _ _ = unit
- infixl 7 *
- infixl 7 /
- infixl 7 %
+ instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
+ (<>) f g = \x -> f x <> g x
+
+ instance semigroupOrdering :: Semigroup Ordering where
+ (<>) LT _ = LT
+ (<>) GT _ = GT
+ (<>) EQ y = y
+
+ foreign import concatString
+ """
+ function concatString(s1) {
+ return function(s2) {
+ return s1 + s2;
+ };
+ }
+ """ :: String -> String -> String
- infixl 6 -
infixl 6 +
+ infixl 7 *
- -- | Addition and multiplication, satisfying the following laws:
- -- |
- -- | - `a` is a commutative monoid under addition
- -- | - `a` is a monoid under multiplication
- -- | - multiplication distributes over addition
- -- | - multiplication by `zero` annihilates `a`
- -- |
+ -- | The `Semiring` class is for types that support an addition and
+ -- | multiplication operation.
+ -- |
+ -- | Instances must satisfy the following laws:
+ -- |
+ -- | - Commutative monoid under addition:
+ -- | - Associativity: `(a + b) + c = a + (b + c)`
+ -- | - Identity: `zero + a = a + zero = a`
+ -- | - Commutative: `a + b = b + a`
+ -- | - Monoid under multiplication:
+ -- | - Associativity: `(a * b) * c = a * (b * c)`
+ -- | - Identity: `one * a = a * one = a`
+ -- | - Multiplication distributes over addition:
+ -- | - Left distributivity: `a * (b + c) = (a * b) + (a * c)`
+ -- | - Right distributivity: `(a + b) * c = (a * c) + (b * c)`
+ -- | - Annihiliation: `zero * a = a * zero = zero`
class Semiring a where
(+) :: a -> a -> a
zero :: a
(*) :: a -> a -> a
one :: a
- -- | Addition, multiplication, modulo operation and division, satisfying:
- -- |
- -- | - ```a / b * b + (a `mod` b) = a```
- -- |
- class (Semiring a) <= ModuloSemiring a where
- (/) :: a -> a -> a
- mod :: a -> a -> a
+ instance semiringNumber :: Semiring Number where
+ (+) = numAdd
+ zero = 0
+ (*) = numMul
+ one = 1
- -- | Addition, multiplication, and subtraction.
- -- |
- -- | Has the same laws as `Semiring` but additionally satisfying:
+ instance semiringUnit :: Semiring Unit where
+ (+) _ _ = unit
+ zero = unit
+ (*) _ _ = unit
+ one = unit
+
+ infixl 6 -
+
+ -- | The `Ring` class is for types that support addition, multiplication,
+ -- | and subtraction operations.
-- |
- -- | - `a` is an abelian group under addition
+ -- | Instances must satisfy the following law in addition to the `Semiring`
+ -- | laws:
-- |
+ -- | - Additive inverse: `a + (-a) = (-a) + a = zero`
class (Semiring a) <= Ring a where
(-) :: a -> a -> a
+ instance ringNumber :: Ring Number where
+ (-) = numSub
+
+ instance ringUnit :: Ring Unit where
+ (-) _ _ = unit
+
negate :: forall a. (Ring a) => a -> a
negate a = zero - a
- -- | Ring where every nonzero element has a multiplicative inverse so that:
+ infixl 7 /
+
+ -- | The `ModuloSemiring` class is for types that support addition,
+ -- | multiplication, division, and modulo (division remainder) operations.
-- |
- -- | - ```a `mod` b = zero```
+ -- | Instances must satisfy the following law in addition to the `Semiring`
+ -- | laws:
-- |
+ -- | - Remainder: `a / b * b + (a `mod` b) = a`
+ class (Semiring a) <= ModuloSemiring a where
+ (/) :: a -> a -> a
+ mod :: a -> a -> a
+
+ instance moduloSemiringNumber :: ModuloSemiring Number where
+ (/) = numDiv
+ mod _ _ = 0
+
+ instance moduloSemiringUnit :: ModuloSemiring Unit where
+ (/) _ _ = unit
+ mod _ _ = unit
+
+ -- | A `Ring` where every nonzero element has a multiplicative inverse.
+ -- |
+ -- | Instances must satisfy the following law in addition to the `Ring` and
+ -- | `ModuloSemiring` laws:
+ -- |
+ -- | - Multiplicative inverse: `(one / x) * x = one`
+ -- |
+ -- | As a consequence of this ```a `mod` b = zero``` as no divide operation
+ -- | will have a remainder.
class (Ring a, ModuloSemiring a) <= DivisionRing a
- -- | A commutative field
+ instance divisionRingNumber :: DivisionRing Number
+
+ instance divisionRingUnit :: DivisionRing Unit
+
+ -- | The `Num` class is for types that are commutative fields.
+ -- |
+ -- | Instances must satisfy the following law in addition to the
+ -- | `DivisionRing` laws:
+ -- |
+ -- | - Commutative multiplication: `a * b = b * a`
class (DivisionRing a) <= Num a
+ instance numNumber :: Num Number
+
+ instance numUnit :: Num Unit
+
foreign import numAdd
"""
function numAdd(n1) {
@@ -459,15 +529,6 @@ module Prelude
}
""" :: Number -> Number -> Number
- foreign import numSub
- """
- function numSub(n1) {
- return function(n2) {
- return n1 - n2;
- };
- }
- """ :: Number -> Number -> Number
-
foreign import numMul
"""
function numMul(n1) {
@@ -486,44 +547,15 @@ module Prelude
}
""" :: Number -> Number -> Number
- foreign import numMod
+ foreign import numSub
"""
- function numMod(n1) {
+ function numSub(n1) {
return function(n2) {
- return n1 % n2;
+ return n1 - n2;
};
}
""" :: Number -> Number -> Number
- (%) = numMod
-
- instance semiringNumber :: Semiring Number where
- (+) = numAdd
- zero = 0
- (*) = numMul
- one = 1
-
- instance ringNumber :: Ring Number where
- (-) = numSub
-
- instance moduloSemiringNumber :: ModuloSemiring Number where
- (/) = numDiv
- mod _ _ = 0
-
- instance divisionRingNumber :: DivisionRing Number
-
- instance numNumber :: Num Number
-
- -- | The `Unit` type has a single inhabitant, called `unit`. It represents values with no computational content.
- -- |
- -- | `Unit` is often used, wrapped in a monadic type constructor, as the return type of a computation where only
- -- | the _effects_ are important.
- newtype Unit = Unit {}
-
- -- | `unit` is the sole inhabitant of the `Unit` type.
- unit :: Unit
- unit = Unit {}
-
infix 4 ==
infix 4 /=
@@ -541,6 +573,33 @@ module Prelude
(==) :: a -> a -> Boolean
(/=) :: a -> a -> Boolean
+ instance eqBoolean :: Eq Boolean where
+ (==) = refEq
+ (/=) = refIneq
+
+ instance eqNumber :: Eq Number where
+ (==) = refEq
+ (/=) = refIneq
+
+ instance eqString :: Eq String where
+ (==) = refEq
+ (/=) = refIneq
+
+ instance eqUnit :: Eq Unit where
+ (==) _ _ = true
+ (/=) _ _ = false
+
+ instance eqArray :: (Eq a) => Eq [a] where
+ (==) = eqArrayImpl (==)
+ (/=) xs ys = not (xs == ys)
+
+ instance eqOrdering :: Eq Ordering where
+ (==) LT LT = true
+ (==) GT GT = true
+ (==) EQ EQ = true
+ (==) _ _ = false
+ (/=) x y = not (x == y)
+
foreign import refEq
"""
function refEq(r1) {
@@ -559,22 +618,6 @@ module Prelude
}
""" :: 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) {
@@ -590,34 +633,14 @@ module Prelude
}
""" :: 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)
-
- -- | The `Ordering` data type represents the three possible outcomes of comparing two values:
+ -- | The `Ordering` data type represents the three possible outcomes of
+ -- | comparing two values:
-- |
-- | `LT` - The first value is _less than_ the second.
-- | `GT` - The first value is _greater than_ the second.
-- | `EQ` - The first value is _equal to_ or _incomparable to_ the second.
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"
-
- instance semigroupOrdering :: Semigroup Ordering where
- (<>) LT _ = LT
- (<>) GT _ = GT
- (<>) EQ y = y
-
-- | The `Ord` type class represents types which support comparisons.
-- |
-- | `Ord` instances should satisfy the laws of _partially orderings_:
@@ -625,11 +648,45 @@ module Prelude
-- | - Reflexivity: `a <= a`
-- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b`
-- | - Transitivity: if `a <= b` and `b <= c` then `a <= c`
- -- |
class (Eq a) <= Ord a where
compare :: a -> a -> Ordering
+ 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 ordUnit :: Ord Unit where
+ compare _ _ = EQ
+
+ 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
+
+ instance ordOrdering :: Ord Ordering where
+ compare LT LT = EQ
+ compare EQ EQ = EQ
+ compare GT GT = EQ
+ compare LT _ = LT
+ compare EQ LT = GT
+ compare EQ GT = LT
+ compare GT _ = GT
+
infixl 4 <
+ infixl 4 >
+ infixl 4 <=
+ infixl 4 >=
-- | Test whether one value is _strictly less than_ another.
(<) :: forall a. (Ord a) => a -> a -> Boolean
@@ -637,30 +694,27 @@ module Prelude
LT -> true
_ -> false
- infixl 4 >
-
-- | Test whether one value is _strictly greater than_ another.
(>) :: forall a. (Ord a) => a -> a -> Boolean
(>) a1 a2 = case a1 `compare` a2 of
GT -> true
_ -> false
- infixl 4 <=
-
-- | Test whether one value is _non-strictly less than_ another.
(<=) :: forall a. (Ord a) => a -> a -> Boolean
(<=) a1 a2 = case a1 `compare` a2 of
GT -> false
_ -> true
- infixl 4 >=
-
-- | Test whether one value is _non-strictly greater than_ another.
(>=) :: forall a. (Ord a) => a -> a -> Boolean
(>=) a1 a2 = case a1 `compare` a2 of
LT -> false
_ -> true
+ unsafeCompare :: forall a. a -> a -> Ordering
+ unsafeCompare = unsafeCompareImpl LT EQ GT
+
foreign import unsafeCompareImpl
"""
function unsafeCompareImpl(lt) {
@@ -676,145 +730,148 @@ module Prelude
}
""" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
- unsafeCompare :: forall a. a -> a -> Ordering
- unsafeCompare = unsafeCompareImpl LT EQ GT
+ -- | The `Bounded` type class represents types that are finite partially
+ -- | ordered sets.
+ -- |
+ -- | Instances should satisfy the following law in addition to the `Ord` laws:
+ -- |
+ -- | - Ordering: `bottom <= a <= top`
+ class (Ord a) <= Bounded a where
+ top :: a
+ bottom :: a
+
+ instance boundedBoolean :: Bounded Boolean where
+ top = true
+ bottom = false
+
+ instance boundedUnit :: Bounded Unit where
+ top = unit
+ bottom = unit
+
+ instance boundedOrdering :: Bounded Ordering where
+ top = GT
+ bottom = LT
+
+ -- | The `Lattice` type class represents types that are partially ordered
+ -- | sets with a supremum (`sup` or `||`) and infimum (`inf` or `&&`).
+ -- |
+ -- | Instances should satisfy the following laws in addition to the `Ord`
+ -- | laws:
+ -- |
+ -- | - Associativity:
+ -- | - `a || (b || c) = (a || b) || c`
+ -- | - `a && (b && c) = (a && b) && c`
+ -- | - Commutativity:
+ -- | - `a || b = b || a`
+ -- | - `a && b = b && a`
+ -- | - Absorption:
+ -- | - `a || (a && b) = a`
+ -- | - `a && (a || b) = a`
+ -- | - Idempotent:
+ -- | - `a || a = a`
+ -- | - `a && a = a`
+ class (Ord a) <= Lattice a where
+ sup :: a -> a -> a
+ inf :: a -> a -> a
+
+ instance latticeBoolean :: Lattice Boolean where
+ sup = boolOr
+ inf = boolAnd
+
+ instance latticeUnit :: Lattice Unit where
+ sup _ _ = unit
+ inf _ _ = unit
- instance ordUnit :: Ord Unit where
- compare (Unit {}) (Unit {}) = EQ
+ infixr 2 ||
+ infixr 3 &&
- instance ordBoolean :: Ord Boolean where
- compare false false = EQ
- compare false true = LT
- compare true true = EQ
- compare true false = GT
+ -- | The `sup` operator.
+ (||) :: forall a. (Lattice a) => a -> a -> a
+ (||) = sup
- instance ordNumber :: Ord Number where
- compare = unsafeCompare
+ -- | The `inf` operator.
+ (&&) :: forall a. (Lattice a) => a -> a -> a
+ (&&) = inf
- instance ordString :: Ord String where
- compare = unsafeCompare
+ -- | The `BoundedLattice` type class represents types that are finite
+ -- | lattices.
+ -- |
+ -- | Instances should satisfy the following law in addition to the `Lattice`
+ -- | and `Bounded` laws:
+ -- |
+ -- | - Identity:
+ -- | - `a || bottom = a`
+ -- | - `a && top = a`
+ -- | - Annihiliation:
+ -- | - `a || top = top`
+ -- | - `a && bottom = bottom`
+ class (Bounded a, Lattice a) <= BoundedLattice a
- 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
+ instance boundedLatticeBoolean :: BoundedLattice Boolean
- infixl 10 .&.
- infixl 10 .|.
- infixl 10 .^.
-
- -- | The `Bits` type class identifies types which support bitwise operations.
- 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
+ instance boundedLatticeUnit :: BoundedLattice Unit
- foreign import numShr
- """
- function numShr(n1) {
- return function(n2) {
- return n1 >> n2;
- };
- }
- """ :: Number -> Number -> Number
+ -- | The `ComplementedLattice` type class represents types that are lattices
+ -- | where every member is also uniquely complemented.
+ -- |
+ -- | Instances should satisfy the following law in addition to the
+ -- | `BoundedLattice` laws:
+ -- |
+ -- | - Complemented:
+ -- | - `not a || a == top`
+ -- | - `not a && a == bottom`
+ -- | - Double negation:
+ -- | - `not <<< not == id`
+ class (BoundedLattice a) <= ComplementedLattice a where
+ not :: a -> a
- foreign import numZshr
- """
- function numZshr(n1) {
- return function(n2) {
- return n1 >>> n2;
- };
- }
- """ :: Number -> Number -> Number
+ instance complementedLatticeBoolean :: ComplementedLattice Boolean where
+ not = boolNot
- foreign import numAnd
- """
- function numAnd(n1) {
- return function(n2) {
- return n1 & n2;
- };
- }
- """ :: Number -> Number -> Number
+ instance complementedLatticeUnit :: ComplementedLattice Unit where
+ not _ = unit
- foreign import numOr
- """
- function numOr(n1) {
- return function(n2) {
- return n1 | n2;
- };
- }
- """ :: Number -> Number -> Number
+ -- | The `DistributiveLattice` type class represents types that are lattices
+ -- | where the `&&` and `||` distribute over each other.
+ -- |
+ -- | Instances should satisfy the following law in addition to the `Lattice`
+ -- | laws:
+ -- |
+ -- | - Distributivity: `x && (y || z) = (x && y) || (x && z)`
+ class (Lattice a) <= DistributiveLattice a
- foreign import numXor
- """
- function numXor(n1) {
- return function(n2) {
- return n1 ^ n2;
- };
- }
- """ :: Number -> Number -> Number
+ instance distributiveLatticeBoolean :: DistributiveLattice Boolean
- foreign import numComplement
- """
- function numComplement(n) {
- return ~n;
- }
- """ :: Number -> Number
+ instance distributiveLatticeUnit :: DistributiveLattice Unit
- instance bitsNumber :: Bits Number where
- (.&.) = numAnd
- (.|.) = numOr
- (.^.) = numXor
- shl = numShl
- shr = numShr
- zshr = numZshr
- complement = numComplement
+ -- | The `BooleanAlgebra` type class represents types that are Boolean
+ -- | algebras, also known as Boolean lattices.
+ -- |
+ -- | Instances should satisfy the `ComplementedLattice` and
+ -- | `DistributiveLattice` laws.
+ class (ComplementedLattice a, DistributiveLattice a) <= BooleanAlgebra a
- infixr 2 ||
- infixr 3 &&
+ instance booleanAlgebraBoolean :: BooleanAlgebra Boolean
- -- | The `BoolLike` type class identifies types which support Boolean operations.
- -- |
- -- | `BoolLike` instances are required to satisfy the laws of a _Boolean algebra_.
- -- |
- class BoolLike b where
- (&&) :: b -> b -> b
- (||) :: b -> b -> b
- not :: b -> b
+ instance booleanAlgebraUnit :: BooleanAlgebra Unit
- foreign import boolAnd
+ foreign import boolOr
"""
- function boolAnd(b1) {
+ function boolOr(b1) {
return function(b2) {
- return b1 && b2;
+ return b1 || b2;
};
}
- """ :: Boolean -> Boolean -> Boolean
+ """ :: Boolean -> Boolean -> Boolean
- foreign import boolOr
+ foreign import boolAnd
"""
- function boolOr(b1) {
+ function boolAnd(b1) {
return function(b2) {
- return b1 || b2;
+ return b1 && b2;
};
}
- """ :: Boolean -> Boolean -> Boolean
+ """ :: Boolean -> Boolean -> Boolean
foreign import boolNot
"""
@@ -823,46 +880,62 @@ module Prelude
}
""" :: Boolean -> Boolean
- instance boolLikeBoolean :: BoolLike Boolean where
- (&&) = boolAnd
- (||) = boolOr
- not = boolNot
+ -- | The `Show` type class represents those types which can be converted into
+ -- | a human-readable `String` representation.
+ -- |
+ -- | While not required, it is recommended that for any expression `x`, the
+ -- | string `show x` be executable PureScript code which evaluates to the same
+ -- | value as the expression `x`.
+ class Show a where
+ show :: a -> String
- infixr 5 <>
+ instance showBoolean :: Show Boolean where
+ show true = "true"
+ show false = "false"
- -- | The `Semigroup` type class identifies an associative operation on a type.
- -- |
- -- | `Semigroup` instances are required to satisfy the following law:
- -- |
- -- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
- -- |
- -- | For example, the `String` type is an instance of `Semigroup`, where `(<>)` is defined to be string concatenation.
- class Semigroup a where
- (<>) :: a -> a -> a
+ instance showNumber :: Show Number where
+ show = showNumberImpl
- foreign import concatString
- """
- function concatString(s1) {
- return function(s2) {
- return s1 + s2;
- };
- }
- """ :: String -> String -> String
+ instance showString :: Show String where
+ show = showStringImpl
- instance semigroupUnit :: Semigroup Unit where
- (<>) (Unit {}) (Unit {}) = Unit {}
+ instance showUnit :: Show Unit where
+ show _ = "unit"
- instance semigroupString :: Semigroup String where
- (<>) = concatString
+ instance showArray :: (Show a) => Show [a] where
+ show = showArrayImpl show
- instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
- (<>) f g = \x -> f x <> g x
+ instance showOrdering :: Show Ordering where
+ show LT = "LT"
+ show GT = "GT"
+ show EQ = "EQ"
- infixr 5 ++
+ foreign import showNumberImpl
+ """
+ function showNumberImpl(n) {
+ return n.toString();
+ }
+ """ :: Number -> String
- -- | `(++)` is an alias for `(<>)`.
- (++) :: forall s. (Semigroup s) => s -> s -> s
- (++) = (<>)
+ foreign import showStringImpl
+ """
+ function showStringImpl(s) {
+ return JSON.stringify(s);
+ }
+ """ :: String -> String
+
+ 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
module Data.Function where
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index 547f627..c5dfdf9 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -52,27 +52,29 @@ readInput InputOptions{..} = do
content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)
-newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make))
+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make))
-runMake :: P.Options P.Make -> Make a -> IO (Either String a)
+runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors a)
runMake opts = runExceptT . flip runReaderT opts . unMake
-makeIO :: IO a -> Make a
-makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError
+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
+makeIO f io = do
+ e <- liftIO $ tryIOError io
+ either (throwError . P.errorMessage . f) return e
instance P.MonadMake Make where
- getTimestamp path = makeIO $ do
+ getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do
exists <- doesFileExist path
traverse (const $ getModificationTime path) $ guard exists
- readTextFile path = makeIO $ do
+ readTextFile path = makeIO (const (P.CannotReadFile path))$ do
putStrLn $ "Reading " ++ path
readFile path
- writeTextFile path text = makeIO $ do
+ writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do
mkdirp path
putStrLn $ "Writing " ++ path
writeFile path text
- progress = makeIO . putStrLn
+ progress = liftIO . putStrLn
compile :: PSCMakeOptions -> IO ()
compile (PSCMakeOptions input outputDir opts usePrefix) = do
@@ -84,8 +86,8 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do
Right ms -> do
e <- runMake opts $ P.make outputDir ms prefix
case e of
- Left err -> do
- putStrLn err
+ Left errs -> do
+ putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
exitFailure
Right _ -> do
exitSuccess
@@ -155,8 +157,8 @@ options = P.Options <$> noPrelude
<*> noMagicDo
<*> pure Nothing
<*> noOpts
- <*> (not <$> comments)
<*> verboseErrors
+ <*> (not <$> comments)
<*> pure P.MakeOptions
pscMakeOptions :: Parser PSCMakeOptions
diff --git a/psc/Main.hs b/psc/Main.hs
index 6be836d..45653a7 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -63,8 +63,8 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do
exitFailure
Right ms -> do
case P.compile (map snd ms) prefix `runReaderT` opts of
- Left err -> do
- hPutStrLn stderr err
+ Left errs -> do
+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
exitFailure
Right (js, exts, _) -> do
case output of
diff --git a/psci/Commands.hs b/psci/Commands.hs
deleted file mode 100644
index e7a8025..0000000
--- a/psci/Commands.hs
+++ /dev/null
@@ -1,78 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Commands
--- Copyright : (c) Phil Freeman 2014
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Commands for PSCI.
---
------------------------------------------------------------------------------
-
-module Commands where
-
-import Language.PureScript
-
--- |
--- Valid Meta-commands for PSCI
---
-data Command
- -- |
- -- A purescript expression
- --
- = Expression Expr
- -- |
- -- Show the help command
- --
- | Help
- -- |
- -- Import a module from a loaded file
- --
- | Import ImportedModule
- -- |
- -- Browse a module
- --
- | Browse ModuleName
- -- |
- -- Load a file for use with importing
- --
- | LoadFile FilePath
- -- |
- -- Exit PSCI
- --
- | Quit
- -- |
- -- Reset the state of the REPL
- --
- | Reset
- -- |
- -- Add some declarations to the current evaluation context.
- --
- | Decls [Declaration]
- -- |
- -- Find the type of an expression
- --
- | TypeOf Expr
- -- |
- -- Find the kind of an expression
- --
- | KindOf Type
- -- |
- -- Show command
- --
- | Show String
-
--- | All of the data that is contained by an ImportDeclaration in the AST.
--- That is:
---
--- * A module name, the name of the module which is being imported
--- * An ImportDeclarationType which specifies whether there is an explicit
--- import list, a hiding list, or neither.
--- * If the module is imported qualified, its qualified name in the importing
--- module. Otherwise, Nothing.
---
-type ImportedModule = (ModuleName, ImportDeclarationType, Maybe ModuleName)
diff --git a/psci/Completion.hs b/psci/Completion.hs
new file mode 100644
index 0000000..0e5c1d3
--- /dev/null
+++ b/psci/Completion.hs
@@ -0,0 +1,232 @@
+module Completion where
+
+import Data.Maybe (mapMaybe)
+import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix)
+import Data.Char (isUpper)
+import Data.Function (on)
+import Data.Traversable (traverse)
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
+import Control.Monad.Trans.State.Strict
+
+import System.Console.Haskeline
+
+import qualified Language.PureScript as P
+import qualified Language.PureScript.Names as N
+
+import qualified Directive as D
+import Types
+
+-- Completions may read the state, but not modify it.
+type CompletionM = ReaderT PSCiState IO
+
+-- Lift a `CompletionM` action to a `StateT PSCiState IO` one.
+liftCompletionM :: CompletionM a -> StateT PSCiState IO a
+liftCompletionM act = StateT (\s -> (\a -> (a, s)) <$> runReaderT act s)
+
+-- Haskeline completions
+
+data CompletionContext
+ = CtxDirective String
+ | CtxFilePath String
+ | CtxModule
+ | CtxIdentifier
+ | CtxType
+ | CtxFixed String
+ deriving (Show)
+
+-- |
+-- Loads module, function, and file completions.
+--
+completion :: CompletionFunc (StateT PSCiState IO)
+completion = liftCompletionM . completion'
+
+completion' :: CompletionFunc CompletionM
+completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions
+
+-- |
+-- Decide what kind of completion we need based on input. This function expects
+-- a list of complete words (to the left of the cursor) as the first argument,
+-- and the current word as the second argument.
+completionContext :: [String] -> String -> [CompletionContext]
+completionContext [] _ = [CtxDirective "", CtxIdentifier, CtxFixed "import"]
+completionContext ws w | headSatisfies (":" `isPrefixOf`) ws = completeDirective ws w
+completionContext ws w | headSatisfies (== "import") ws = completeImport ws w
+completionContext _ _ = [CtxIdentifier]
+
+completeDirective :: [String] -> String -> [CompletionContext]
+completeDirective ws w =
+ case ws of
+ [] -> [CtxDirective w]
+ [dir] -> case D.directivesFor <$> stripPrefix ":" dir of
+ -- only offer completions if the directive is unambiguous
+ Just [dir'] -> directiveArg w dir'
+ _ -> []
+
+ -- All directives take exactly one argument. If we haven't yet matched,
+ -- that means one argument has already been supplied. So don't complete
+ -- any others.
+ _ -> []
+
+directiveArg :: String -> Directive -> [CompletionContext]
+directiveArg _ Browse = [CtxModule]
+directiveArg w Load = [CtxFilePath w]
+directiveArg _ Quit = []
+directiveArg _ Reset = []
+directiveArg _ Help = []
+directiveArg _ Show = map CtxFixed replQueryStrings
+directiveArg _ Type = [CtxIdentifier]
+directiveArg _ Kind = [CtxType]
+
+completeImport :: [String] -> String -> [CompletionContext]
+completeImport ws w' =
+ case (ws, w') of
+ (["import"], w) | headSatisfies isUpper w -> [CtxModule]
+ (["import"], _) -> [CtxModule, CtxFixed "qualified"]
+ (["import", "qualified"], _) -> [CtxModule]
+ _ -> []
+
+headSatisfies :: (a -> Bool) -> [a] -> Bool
+headSatisfies p str =
+ case str of
+ (c:_) -> p c
+ _ -> False
+
+-- | Callback for Haskeline's `completeWordWithPrev`.
+-- Expects:
+-- * Line contents to the left of the word, reversed
+-- * Word to be completed
+findCompletions :: String -> String -> CompletionM [Completion]
+findCompletions prev word = do
+ let ctx = completionContext (words (reverse prev)) word
+ completions <- concat <$> traverse getCompletions ctx
+ return $ sortBy directivesFirst completions
+ where
+ getCompletions :: CompletionContext -> CompletionM [Completion]
+ getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion
+
+ prefixedBy :: String -> String -> Maybe Completion
+ prefixedBy w cand = if w `isPrefixOf` cand
+ then Just (simpleCompletion cand)
+ else Nothing
+
+getCompletion :: CompletionContext -> CompletionM [Either String Completion]
+getCompletion ctx =
+ case ctx of
+ CtxFilePath f -> map Right <$> listFiles f
+ CtxModule -> map Left <$> getModuleNames
+ CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames)
+ CtxType -> map Left <$> getTypeNames
+ CtxFixed str -> return [Left str]
+ CtxDirective d -> return (map Left (completeDirectives d))
+
+ where
+ completeDirectives :: String -> [String]
+ completeDirectives = map (':' :) . D.directiveStringsFor
+
+
+getLoadedModules :: CompletionM [P.Module]
+getLoadedModules = asks (map snd . psciLoadedModules)
+
+getImportedModules :: CompletionM [ImportedModule]
+getImportedModules = asks psciImportedModules
+
+getModuleNames :: CompletionM [String]
+getModuleNames = moduleNames <$> getLoadedModules
+
+mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]
+mapLoadedModulesAndQualify f = do
+ ms <- getLoadedModules
+ let argPairs = do m <- ms
+ fm <- f m
+ return (m, fm)
+ concat <$> traverse (uncurry getAllQualifications) argPairs
+
+getIdentNames :: CompletionM [String]
+getIdentNames = mapLoadedModulesAndQualify identNames
+
+getDctorNames :: CompletionM [String]
+getDctorNames = mapLoadedModulesAndQualify dctorNames
+
+getTypeNames :: CompletionM [String]
+getTypeNames = mapLoadedModulesAndQualify typeDecls
+
+-- | Given a module and a declaration in that module, return all possible ways
+-- it could have been referenced given the current PSCiState - including fully
+-- qualified, qualified using an alias, and unqualified.
+getAllQualifications :: (Show a) => P.Module -> (a, P.Declaration) -> CompletionM [String]
+getAllQualifications m (declName, decl) = do
+ imports <- getAllImportsOf m
+ let fullyQualified = qualifyWith (Just (P.getModuleName m))
+ let otherQuals = nub (concatMap qualificationsUsing imports)
+ return $ fullyQualified : otherQuals
+ where
+ qualifyWith mMod = show (P.Qualified mMod declName)
+ referencedBy refs = P.isExported (Just refs) decl
+
+ qualificationsUsing (_, importType, asQ') =
+ let q = qualifyWith asQ'
+ in case importType of
+ P.Implicit -> [q]
+ P.Explicit refs -> if referencedBy refs
+ then [q]
+ else []
+ P.Hiding refs -> if referencedBy refs
+ then []
+ else [q]
+
+
+-- | Returns all the ImportedModule values referring to imports of a particular
+-- module.
+getAllImportsOf :: P.Module -> CompletionM [ImportedModule]
+getAllImportsOf = asks . allImportsOf
+
+nubOnFst :: Eq a => [(a, b)] -> [(a, b)]
+nubOnFst = nubBy ((==) `on` fst)
+
+typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]
+typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations
+ where
+ getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
+ getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)
+ getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)
+ getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
+ getTypeName _ = Nothing
+
+identNames :: P.Module -> [(N.Ident, P.Declaration)]
+identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations
+ where
+ getDeclName :: P.Declaration -> Maybe (P.Ident, P.Declaration)
+ getDeclName d@(P.ValueDeclaration ident _ _ _) = Just (ident, d)
+ getDeclName d@(P.ExternDeclaration _ ident _ _) = Just (ident, d)
+ getDeclName (P.PositionedDeclaration _ _ d) = getDeclName d
+ getDeclName _ = Nothing
+
+dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]
+dctorNames m = nubOnFst $ concatMap dctors dnames
+ where
+ getDataDeclName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
+ getDataDeclName d@(P.DataDeclaration _ name _ _) = Just (name, d)
+ getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d
+ getDataDeclName _ = Nothing
+
+ dnames :: [(N.ProperName, P.Declaration)]
+ dnames = (mapMaybe getDataDeclName onlyDataDecls)
+
+ onlyDataDecls :: [P.Declaration]
+ onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))
+
+ dctors :: (N.ProperName, P.Declaration) -> [(N.ProperName, P.Declaration)]
+ dctors (name, decl) = map (\n -> (n, decl)) (map fst (P.exportedDctors m name))
+
+moduleNames :: [P.Module] -> [String]
+moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]
+
+directivesFirst :: Completion -> Completion -> Ordering
+directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
+ where
+ go (':' : xs) (':' : ys) = compare xs ys
+ go (':' : _) _ = LT
+ go _ (':' : _) = GT
+ go xs ys = compare xs ys
diff --git a/psci/Directive.hs b/psci/Directive.hs
index c7bebd2..366fc66 100644
--- a/psci/Directive.hs
+++ b/psci/Directive.hs
@@ -15,46 +15,85 @@
module Directive where
-import Data.List (nub, isPrefixOf)
-
-data Directive
- = Help
- | Quit
- | Reset
- | Browse
- | Load
- | Type
- | Kind
- | Show
- deriving Eq
+import Data.Maybe (fromJust, listToMaybe)
+import Data.List (isPrefixOf)
+import Data.Tuple (swap)
+
+import Types
-- |
--- Maps given directive to relating command strings.
+-- List of all avaliable directives.
--
-commands :: Directive -> [String]
-commands Help = ["?", "help"]
-commands Quit = ["quit"]
-commands Reset = ["reset"]
-commands Browse = ["browse"]
-commands Load = ["load", "module"]
-commands Type = ["type"]
-commands Kind = ["kind"]
-commands Show = ["show"]
+directives :: [Directive]
+directives = map fst directiveStrings
-- |
--- Tries to parse given string into a directive.
+-- A mapping of directives to the different strings that can be used to invoke
+-- them.
--
-parseDirective :: String -> Maybe Directive
-parseDirective cmd =
- case filter (matches . snd) mapping of
- [directive] -> Just $ fst directive
- _ -> Nothing
+directiveStrings :: [(Directive, [String])]
+directiveStrings =
+ [ (Help , ["?", "help"])
+ , (Quit , ["quit"])
+ , (Reset , ["reset"])
+ , (Browse , ["browse"])
+ , (Load , ["load", "module"])
+ , (Type , ["type"])
+ , (Kind , ["kind"])
+ , (Show , ["show"])
+ ]
+
+-- |
+-- Like directiveStrings, but the other way around.
+--
+directiveStrings' :: [(String, Directive)]
+directiveStrings' = concatMap go directiveStrings
where
- mapping :: [(Directive, [String])]
- mapping = zip directives (map commands directives)
+ go (dir, strs) = map (\s -> (s, dir)) strs
- matches :: [String] -> Bool
- matches = any (cmd `isPrefixOf`)
+-- |
+-- List of all directive strings.
+--
+strings :: [String]
+strings = concatMap snd directiveStrings
+
+-- |
+-- Returns all possible string representations of a directive.
+--
+stringsFor :: Directive -> [String]
+stringsFor d = fromJust (lookup d directiveStrings)
+
+-- |
+-- Returns the default string representation of a directive.
+--
+stringFor :: Directive -> String
+stringFor = head . stringsFor
+
+-- |
+-- Returns the list of directives which could be expanded from the string
+-- argument, together with the string alias that matched.
+--
+directivesFor' :: String -> [(Directive, String)]
+directivesFor' str = go directiveStrings'
+ where
+ go = map swap . filter ((str `isPrefixOf`) . fst)
+
+directivesFor :: String -> [Directive]
+directivesFor = map fst . directivesFor'
+
+directiveStringsFor :: String -> [String]
+directiveStringsFor = map snd . directivesFor'
+
+parseDirective :: String -> Maybe Directive
+parseDirective = listToMaybe . directivesFor
+
+-- |
+-- True if the given directive takes an argument, false otherwise.
+hasArgument :: Directive -> Bool
+hasArgument Help = False
+hasArgument Quit = False
+hasArgument Reset = False
+hasArgument _ = True
-- |
-- The help menu.
@@ -63,17 +102,12 @@ help :: [(Directive, String, String)]
help =
[ (Help, "", "Show this help menu")
, (Quit, "", "Quit PSCi")
- , (Reset, "", "Reset")
- , (Browse, "<module>", "Browse <module>")
+ , (Reset, "", "Discard all imported modules and declared bindings")
+ , (Browse, "<module>", "See all functions in <module>")
, (Load, "<file>", "Load <file> for importing")
, (Type, "<expr>", "Show the type of <expr>")
, (Kind, "<type>", "Show the kind of <type>")
- , (Show, "import", "Show imported modules")
- , (Show, "loaded", "Show loaded modules")
+ , (Show, "import", "Show all imported modules")
+ , (Show, "loaded", "Show all loaded modules")
]
--- |
--- List of all avaliable directives.
---
-directives :: [Directive]
-directives = nub . map (\(dir, _, _) -> dir) $ help
diff --git a/psci/Main.hs b/psci/PSCi.hs
index 5969d70..1f611a8 100644
--- a/psci/Main.hs
+++ b/psci/PSCi.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Main
+-- Module : PSCi
-- Copyright : (c) Phil Freeman 2013
-- License : MIT
--
@@ -19,18 +19,18 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
-module Main where
+module PSCi where
import Data.Foldable (traverse_)
-import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)
-import Data.Maybe (mapMaybe)
+import Data.List (intercalate, nub, sort)
import Data.Traversable (traverse)
import Data.Version (showVersion)
-import Data.Char (isSpace)
import qualified Data.Map as M
import Control.Applicative
import Control.Monad
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT(..), MonadError, runExceptT)
import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
import Control.Monad.Trans.Class
@@ -50,70 +50,21 @@ import System.Process (readProcessWithExitCode)
import qualified Text.Parsec as Par (ParseError)
import qualified Language.PureScript as P
-import qualified Language.PureScript.AST as D
import qualified Language.PureScript.Names as N
import qualified Paths_purescript as Paths
-import qualified Commands as C
import qualified Directive as D
-import Parser
+import Parser (parseCommand)
+import Completion (completion)
+import Types
-data PSCiOptions = PSCiOptions
- { psciMultiLineMode :: Bool
- , psciInputFile :: [FilePath]
- , psciInputNodeFlags :: [String]
- }
-
--- |
--- The PSCI state.
--- Holds a list of imported modules, loaded files, and partial let bindings.
--- The let bindings are partial,
--- because it makes more sense to apply the binding to the final evaluated expression.
---
-data PSCiState = PSCiState
- { psciImportedFilenames :: [FilePath]
- , psciImportedModules :: [C.ImportedModule]
- , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
- , psciLetBindings :: [P.Declaration]
- , psciNodeFlags :: [String]
- }
-
-psciImportedModuleNames :: PSCiState -> [P.ModuleName]
-psciImportedModuleNames (PSCiState{psciImportedModules = is}) =
- map (\(mn, _, _) -> mn) is
-
--- State helpers
-
--- |
--- Updates the state to have more imported modules.
---
-updateImportedFiles :: FilePath -> PSCiState -> PSCiState
-updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
-
--- |
--- Updates the state to have more imported modules.
---
-updateImportedModules :: C.ImportedModule -> PSCiState -> PSCiState
-updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }
-
--- |
--- Updates the state to have more loaded files.
---
-updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
-updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
-
--- |
--- Updates the state to have more let bindings.
---
-updateLets :: [P.Declaration] -> PSCiState -> PSCiState
-updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
-- File helpers
-- |
-- Load the necessary modules.
--
-defaultImports :: [C.ImportedModule]
-defaultImports = [(P.ModuleName [P.ProperName "Prelude"], D.Implicit, Nothing)]
+defaultImports :: [ImportedModule]
+defaultImports = [(P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
-- |
-- Locates the node executable.
@@ -175,17 +126,24 @@ expandTilde p = return p
--
helpMessage :: String
helpMessage = "The following commands are available:\n\n " ++
- intercalate "\n " (map line D.help)
+ intercalate "\n " (map line D.help) ++
+ "\n\n" ++ extraHelp
where
- line :: (D.Directive, String, String) -> String
- line (dir, arg, desc) = intercalate " "
- [ cmd
- , replicate (11 - length cmd) ' '
- , arg
- , replicate (11 - length arg) ' '
- , desc
- ]
- where cmd = ":" ++ head (D.commands dir)
+ line :: (Directive, String, String) -> String
+ line (dir, arg, desc) =
+ let cmd = ':' : D.stringFor dir
+ in intercalate " "
+ [ cmd
+ , replicate (11 - length cmd) ' '
+ , arg
+ , replicate (11 - length arg) ' '
+ , desc
+ ]
+
+ extraHelp =
+ "Further information is available on the PureScript wiki:\n" ++
+ " --> https://github.com/purescript/purescript/wiki/psci"
+
-- |
-- The welcome prologue.
@@ -208,129 +166,6 @@ prologueMessage = intercalate "\n"
quitMessage :: String
quitMessage = "See ya!"
--- Haskeline completions
-
-data CompletionContext = Command String | FilePath String | Module | Identifier
- | Type | Fixed [String] | Multiple [CompletionContext]
- deriving (Show)
-
--- |
--- Decide what kind of completion we need based on input.
-completionContext :: String -> String -> Maybe CompletionContext
-completionContext cmd@"" _ = Just $ Multiple [Command cmd, Identifier]
-completionContext (':' : cmd) word =
- case D.parseDirective dstr of
- Just directive | dstr `elem` D.commands directive -> context directive
- _ -> Just $ Command cmd
- where
- dstr :: String
- dstr = takeWhile (not . isSpace) cmd
-
- context :: D.Directive -> Maybe CompletionContext
- context D.Browse = Just Module
- context D.Load = Just $ FilePath word
- context D.Quit = Nothing
- context D.Reset = Nothing
- context D.Help = Nothing
- context D.Show = Just $ Fixed ["import", "loaded"]
- context D.Type = Just Identifier
- context D.Kind = Just Type
-completionContext _ _ = Just Identifier
-
--- |
--- Loads module, function, and file completions.
---
-completion :: CompletionFunc (StateT PSCiState IO)
-completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
- where
- findCompletions :: String -> String -> StateT PSCiState IO [Completion]
- findCompletions prev word = do
- let ctx = completionContext ((dropWhile isSpace (reverse prev)) ++ word) word
- completions <- case ctx of
- Nothing -> return []
- (Just c) -> (mapMaybe $ either (\cand -> if word `isPrefixOf` cand
- then Just $ simpleCompletion cand
- else Nothing) Just)
- <$> getCompletion c
- return $ sortBy sorter completions
-
- getCompletion :: CompletionContext -> StateT PSCiState IO [Either String Completion]
- getCompletion (FilePath f) = (map Right) <$> listFiles f
- getCompletion Module = (map Left) <$> getModuleNames
- getCompletion Identifier = (map Left) <$> ((++) <$> getIdentNames <*> getDctorNames)
- getCompletion Type = (map Left) <$> getTypeNames
- getCompletion (Fixed list) = return $ (map Left) list
- getCompletion (Multiple contexts) = concat <$> mapM getCompletion contexts
- getCompletion (Command cmd) = return . map (Left . (":" ++)) . nub $ matching
- where
- matching :: [String]
- matching = filter (isPrefixOf cmd) . concatMap (D.commands) $ D.directives
-
- getLoadedModules :: StateT PSCiState IO [P.Module]
- getLoadedModules = map snd . psciLoadedModules <$> get
-
- getModuleNames :: StateT PSCiState IO [String]
- getModuleNames = moduleNames <$> getLoadedModules
-
- mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [a]) -> StateT PSCiState IO [String]
- mapLoadedModulesAndQualify f = do
- ms <- getLoadedModules
- q <- sequence [qualifyIfNeeded m (f m) | m <- ms]
- return $ concat q
-
- getIdentNames :: StateT PSCiState IO [String]
- getIdentNames = mapLoadedModulesAndQualify identNames
-
- getDctorNames :: StateT PSCiState IO [String]
- getDctorNames = mapLoadedModulesAndQualify dctorNames
-
- getTypeNames :: StateT PSCiState IO [String]
- getTypeNames = mapLoadedModulesAndQualify typeDecls
-
- qualifyIfNeeded :: (Show a) => P.Module -> [a] -> StateT PSCiState IO [String]
- qualifyIfNeeded m decls = do
- let name = P.getModuleName m
- imported <- psciImportedModuleNames <$> get
- let qualified = map (P.Qualified $ Just name) decls
- if name `elem` imported then
- return $ map show $ qualified ++ (map (P.Qualified Nothing) decls)
- else
- return $ map show qualified
-
- typeDecls :: P.Module -> [N.ProperName]
- typeDecls m = mapMaybe getTypeName $ filter P.isDataDecl (P.exportedDeclarations m)
- where getTypeName :: P.Declaration -> Maybe N.ProperName
- getTypeName (P.TypeSynonymDeclaration name _ _) = Just name
- getTypeName (P.DataDeclaration _ name _ _) = Just name
- getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
- getTypeName _ = Nothing
-
- identNames :: P.Module -> [N.Ident]
- identNames (P.Module _ _ ds exports) = nub [ ident | ident <- mapMaybe (getDeclName exports) (D.flattenDecls ds) ]
- where getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
- getDeclName exts decl@(P.ValueDeclaration ident _ _ _) | P.isExported exts decl = Just ident
- getDeclName exts decl@(P.ExternDeclaration _ ident _ _) | P.isExported exts decl = Just ident
- getDeclName exts (P.PositionedDeclaration _ _ d) = getDeclName exts d
- getDeclName _ _ = Nothing
-
- dctorNames :: P.Module -> [N.ProperName]
- dctorNames m = nub $ concat $ map (P.exportedDctors m) dnames
- where getDataDeclName :: P.Declaration -> Maybe N.ProperName
- getDataDeclName (P.DataDeclaration _ name _ _) = Just name
- getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d
- getDataDeclName _ = Nothing
-
- dnames :: [N.ProperName]
- dnames = (mapMaybe getDataDeclName onlyDataDecls)
-
- onlyDataDecls :: [P.Declaration]
- onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))
-
- moduleNames :: [P.Module] -> [String]
- moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]
-
- sorter :: Completion -> Completion -> Ordering
- sorter (Completion _ d1 _) (Completion _ d2 _) = if ":" `isPrefixOf` d1 then LT else compare d1 d2
-- Compilation
@@ -347,24 +182,26 @@ newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Fu
psciIO :: IO a -> PSCI a
psciIO io = PSCI . lift $ lift io
-newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }
- deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))
+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make))
-runMake :: Make a -> IO (Either String a)
+runMake :: Make a -> IO (Either P.MultipleErrors a)
runMake = runExceptT . flip runReaderT options . unMake
-makeIO :: IO a -> Make a
-makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError
+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
+makeIO f io = do
+ e <- liftIO $ tryIOError io
+ either (throwError . P.errorMessage . f) return e
instance P.MonadMake Make where
- getTimestamp path = makeIO $ do
+ getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do
exists <- doesFileExist path
traverse (const $ getModificationTime path) $ guard exists
- readTextFile path = makeIO $ readFile path
- writeTextFile path text = makeIO $ do
+ readTextFile path = makeIO (const (P.CannotReadFile path)) $ readFile path
+ writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do
mkdirp path
writeFile path text
- progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s
+ progress s = unless (s == "Compiling $PSCI") $ liftIO . putStrLn $ s
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
@@ -407,7 +244,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
in
P.Module [] moduleName (importDecl `map` imports) Nothing
-importDecl :: C.ImportedModule -> P.Declaration
+importDecl :: ImportedModule -> P.Declaration
importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
modulesDir :: FilePath
@@ -426,7 +263,7 @@ handleDeclaration val = do
let nodeArgs = psciNodeFlags st ++ [indexFile]
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
case e of
- Left err -> PSCI $ outputStrLn err
+ Left errs -> printErrors errs
Right _ -> do
psciIO $ writeFile indexFile "require('$PSCI').main();"
process <- psciIO findNodeProcess
@@ -447,7 +284,7 @@ handleDecls ds = do
let m = createTemporaryModule False st' (P.ObjectLiteral [])
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
case e of
- Left err -> PSCI $ outputStrLn err
+ Left err -> printErrors err
Right _ -> PSCI $ lift (put st')
-- |
@@ -459,7 +296,7 @@ handleShowLoadedModules = do
psciIO $ readModules loadedModules >>= putStrLn
return ()
where readModules = return . unlines . sort . nub . map toModuleName
- toModuleName = N.runModuleName . (\ (D.Module _ mdName _ _) -> mdName) . snd
+ toModuleName = N.runModuleName . (\ (P.Module _ mdName _ _) -> mdName) . snd
-- |
-- Show the imported modules in psci.
@@ -476,17 +313,17 @@ handleShowImportedModules = do
Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'
Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType
- showDeclType D.Implicit = ""
- showDeclType (D.Explicit refs) = refsList refs
- showDeclType (D.Hiding refs) = "hiding " ++ refsList refs
+ showDeclType P.Implicit = ""
+ showDeclType (P.Explicit refs) = refsList refs
+ showDeclType (P.Hiding refs) = "hiding " ++ refsList refs
refsList refs = "(" ++ commaList (map showRef refs) ++ ")"
showRef :: P.DeclarationRef -> String
- showRef (D.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
- showRef (D.ValueRef ident) = show ident
- showRef (D.TypeClassRef pn) = show pn
- showRef (D.TypeInstanceRef ident) = show ident
- showRef (D.PositionedDeclarationRef _ _ ref) = showRef ref
+ showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
+ showRef (P.ValueRef ident) = show ident
+ showRef (P.TypeClassRef pn) = show pn
+ showRef (P.TypeInstanceRef ident) = show ident
+ showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
commaList :: [String] -> String
commaList = intercalate ", "
@@ -494,13 +331,13 @@ handleShowImportedModules = do
-- |
-- Imports a module, preserving the initial state on failure.
--
-handleImport :: C.ImportedModule -> PSCI ()
+handleImport :: ImportedModule -> PSCI ()
handleImport im = do
st <- updateImportedModules im <$> PSCI (lift get)
let m = createTemporaryModuleForImports st
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
case e of
- Left err -> PSCI $ outputStrLn err
+ Left errs -> printErrors errs
Right _ -> do
PSCI $ lift $ put st
return ()
@@ -514,7 +351,7 @@ handleTypeOf val = do
let m = createTemporaryModule False st val
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
case e of
- Left err -> PSCI $ outputStrLn err
+ Left errs -> printErrors errs
Right env' ->
case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
@@ -548,12 +385,16 @@ handleBrowse moduleName = do
let loadedModules = psciLoadedModules st
env <- psciIO . runMake $ P.make modulesDir loadedModules []
case env of
- Left err -> PSCI $ outputStrLn err
+ Left errs -> printErrors errs
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'
+-- | Pretty-print errors
+printErrors :: P.MultipleErrors -> PSCI ()
+printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False
+
-- |
-- Takes a value and prints its kind
--
@@ -564,7 +405,7 @@ handleKindOf typ = do
mName = P.ModuleName [P.ProperName "$PSCI"]
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
case e of
- Left err -> PSCI $ outputStrLn err
+ Left errs -> printErrors errs
Right env' ->
case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
Just (_, typ') -> do
@@ -578,9 +419,9 @@ handleKindOf typ = do
-- Commands
-- |
--- Parses the input and returns either a Metacommand or an expression.
+-- Parses the input and returns either a Metacommand, or an error as a string.
--
-getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe C.Command))
+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
getCommand singleLineMode = do
firstLine <- getInputLine "> "
case firstLine of
@@ -593,14 +434,14 @@ getCommand singleLineMode = do
go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
-- |
--- Performs an action for each meta-command given, and also for expressions..
+-- Performs an action for each meta-command given, and also for expressions.
--
-handleCommand :: C.Command -> PSCI ()
-handleCommand (C.Expression val) = handleDeclaration val
-handleCommand C.Help = PSCI $ outputStrLn helpMessage
-handleCommand (C.Import im) = handleImport im
-handleCommand (C.Decls l) = handleDecls l
-handleCommand (C.LoadFile filePath) = do
+handleCommand :: Command -> PSCI ()
+handleCommand (Expression val) = handleDeclaration val
+handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
+handleCommand (Import im) = handleImport im
+handleCommand (Decls l) = handleDecls l
+handleCommand (LoadFile filePath) = do
absPath <- psciIO $ expandTilde filePath
exists <- psciIO $ doesFileExist absPath
if exists then do
@@ -611,7 +452,7 @@ handleCommand (C.LoadFile filePath) = do
Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
else
PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
-handleCommand C.Reset = do
+handleCommand ResetState = do
files <- psciImportedFilenames <$> PSCI (lift get)
PSCI . lift . modify $ \st -> st
{ psciImportedFilenames = files
@@ -619,14 +460,14 @@ handleCommand C.Reset = do
, psciLetBindings = []
}
loadAllImportedModules
-handleCommand (C.TypeOf val) = handleTypeOf val
-handleCommand (C.KindOf typ) = handleKindOf typ
-handleCommand (C.Browse moduleName) = handleBrowse moduleName
-handleCommand (C.Show "loaded") = handleShowLoadedModules
-handleCommand (C.Show "import") = handleShowImportedModules
-handleCommand _ = PSCI $ outputStrLn "Unknown command"
-
-loadUserConfig :: IO (Maybe [C.Command])
+handleCommand (TypeOf val) = handleTypeOf val
+handleCommand (KindOf typ) = handleKindOf typ
+handleCommand (BrowseModule moduleName) = handleBrowse moduleName
+handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
+handleCommand (ShowInfo QueryImport) = handleShowImportedModules
+handleCommand QuitPSCi = error "`handleCommand QuitPSCi` was called. This is a bug."
+
+loadUserConfig :: IO (Maybe [Command])
loadUserConfig = do
configFile <- (</> ".psci") <$> getCurrentDirectory
exists <- doesFileExist configFile
@@ -662,7 +503,7 @@ loop PSCiOptions{..} = do
case c of
Left err -> outputStrLn err >> go
Right Nothing -> go
- Right (Just C.Quit) -> outputStrLn quitMessage
+ Right (Just QuitPSCi) -> outputStrLn quitMessage
Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go
multiLineMode :: Parser Bool
@@ -690,8 +531,8 @@ psciOptions = PSCiOptions <$> multiLineMode
<*> many inputFile
<*> nodeFlagsFlag
-main :: IO ()
-main = execParser opts >>= loop
+runPSCi :: IO ()
+runPSCi = execParser opts >>= loop
where
opts = info (version <*> helper <*> psciOptions) infoModList
infoModList = fullDesc <> headerInfo <> footerInfo
diff --git a/psci/Parser.hs b/psci/Parser.hs
index d28cc7b..05eda11 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -19,22 +19,23 @@ module Parser
import Prelude hiding (lex)
-import qualified Commands as C
-import qualified Directive as D
-
import Data.Char (isSpace)
+import Data.List (intercalate)
import Control.Applicative hiding (many)
import Text.Parsec hiding ((<|>))
import qualified Language.PureScript as P
-import qualified Language.PureScript.Parser.Common as C (mark, same)
+import Language.PureScript.Parser.Common (mark, same)
+
+import qualified Directive as D
+import Types
-- |
-- Parses PSCI metacommands or expressions input from the user.
--
-parseCommand :: String -> Either String C.Command
+parseCommand :: String -> Either String Command
parseCommand cmdString =
case cmdString of
(':' : cmd) -> parseDirective cmd
@@ -45,7 +46,7 @@ parseRest p s = either (Left . show) Right $ do
ts <- P.lex "" s
P.runTokenParser "" (p <* eof) ts
-psciCommand :: P.TokenParser C.Command
+psciCommand :: P.TokenParser Command
psciCommand = choice (map try parsers)
where
parsers =
@@ -64,25 +65,31 @@ trimStart = dropWhile isSpace
trimEnd :: String -> String
trimEnd = reverse . trimStart . reverse
-parseDirective :: String -> Either String C.Command
+parseDirective :: String -> Either String Command
parseDirective cmd =
- case D.parseDirective dstr of
- Just D.Help -> return C.Help
- Just D.Quit -> return C.Quit
- Just D.Reset -> return C.Reset
- Just D.Browse -> C.Browse <$> parseRest P.moduleName arg
- Just D.Load -> return $ C.LoadFile (trim arg)
- Just D.Show -> return $ C.Show (trim arg)
- Just D.Type -> C.TypeOf <$> parseRest P.parseValue arg
- Just D.Kind -> C.KindOf <$> parseRest P.parseType arg
- Nothing -> Left $ "Unrecognized command. Type :? for help."
- where (dstr, arg) = break isSpace cmd
+ case D.directivesFor' dstr of
+ [(d, _)] -> commandFor d
+ [] -> Left "Unrecognized directive. Type :? for help."
+ ds -> Left ("Ambiguous directive. Possible matches: " ++
+ intercalate ", " (map snd ds) ++ ". Type :? for help.")
+ where
+ (dstr, arg) = break isSpace cmd
+
+ commandFor d = case d of
+ Help -> return ShowHelp
+ Quit -> return QuitPSCi
+ Reset -> return ResetState
+ Browse -> BrowseModule <$> parseRest P.moduleName arg
+ Load -> return $ LoadFile (trim arg)
+ Show -> ShowInfo <$> parseReplQuery' (trim arg)
+ Type -> TypeOf <$> parseRest P.parseValue arg
+ Kind -> KindOf <$> parseRest P.parseType arg
-- |
-- Parses expressions entered at the PSCI repl.
--
-psciExpression :: P.TokenParser C.Command
-psciExpression = C.Expression <$> P.parseValue
+psciExpression :: P.TokenParser Command
+psciExpression = Expression <$> P.parseValue
-- |
-- PSCI version of @let@.
@@ -90,21 +97,21 @@ psciExpression = C.Expression <$> P.parseValue
-- However, since we don't support the @Eff@ monad,
-- we actually want the normal @let@.
--
-psciLet :: P.TokenParser C.Command
-psciLet = C.Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
+psciLet :: P.TokenParser Command
+psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
where
manyDecls :: P.TokenParser [P.Declaration]
- manyDecls = C.mark (many1 (C.same *> P.parseLocalDeclaration))
+ manyDecls = mark (many1 (same *> P.parseLocalDeclaration))
-- | Imports must be handled separately from other declarations, so that
-- :show import works, for example.
-psciImport :: P.TokenParser C.Command
-psciImport = C.Import <$> P.parseImportDeclaration'
+psciImport :: P.TokenParser Command
+psciImport = Import <$> P.parseImportDeclaration'
-- | Any other declaration that we don't need a 'special case' parser for
-- (like let or import declarations).
-psciOtherDeclaration :: P.TokenParser C.Command
-psciOtherDeclaration = C.Decls . (:[]) <$> do
+psciOtherDeclaration :: P.TokenParser Command
+psciOtherDeclaration = Decls . (:[]) <$> do
decl <- discardPositionInfo <$> P.parseDeclaration
if acceptable decl
then return decl
@@ -123,3 +130,10 @@ acceptable (P.ExternInstanceDeclaration _ _ _ _) = True
acceptable (P.TypeClassDeclaration _ _ _ _) = True
acceptable (P.TypeInstanceDeclaration _ _ _ _ _) = True
acceptable _ = False
+
+parseReplQuery' :: String -> Either String ReplQuery
+parseReplQuery' str =
+ case parseReplQuery str of
+ Nothing -> Left ("Don't know how to show " ++ str ++ ". Try one of: " ++
+ intercalate ", " replQueryStrings ++ ".")
+ Just query -> Right query
diff --git a/psci/Types.hs b/psci/Types.hs
new file mode 100644
index 0000000..bc683c2
--- /dev/null
+++ b/psci/Types.hs
@@ -0,0 +1,167 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Types
+-- Copyright : (c) Phil Freeman 2014
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Type declarations and associated basic functions for PSCI.
+--
+-----------------------------------------------------------------------------
+
+module Types where
+
+import qualified Language.PureScript as P
+
+data PSCiOptions = PSCiOptions
+ { psciMultiLineMode :: Bool
+ , psciInputFile :: [FilePath]
+ , psciInputNodeFlags :: [String]
+ }
+
+-- |
+-- The PSCI state.
+-- Holds a list of imported modules, loaded files, and partial let bindings.
+-- The let bindings are partial,
+-- because it makes more sense to apply the binding to the final evaluated expression.
+--
+data PSCiState = PSCiState
+ { psciImportedFilenames :: [FilePath]
+ , psciImportedModules :: [ImportedModule]
+ , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
+ , psciLetBindings :: [P.Declaration]
+ , psciNodeFlags :: [String]
+ }
+
+-- | All of the data that is contained by an ImportDeclaration in the AST.
+-- That is:
+--
+-- * A module name, the name of the module which is being imported
+-- * An ImportDeclarationType which specifies whether there is an explicit
+-- import list, a hiding list, or neither.
+-- * If the module is imported qualified, its qualified name in the importing
+-- module. Otherwise, Nothing.
+--
+type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)
+
+psciImportedModuleNames :: PSCiState -> [P.ModuleName]
+psciImportedModuleNames (PSCiState{psciImportedModules = is}) =
+ map (\(mn, _, _) -> mn) is
+
+allImportsOf :: P.Module -> PSCiState -> [ImportedModule]
+allImportsOf m (PSCiState{psciImportedModules = is}) =
+ filter isImportOfThis is
+ where
+ name = P.getModuleName m
+ isImportOfThis (name', _, _) = name == name'
+
+-- State helpers
+
+-- |
+-- Updates the state to have more imported modules.
+--
+updateImportedFiles :: FilePath -> PSCiState -> PSCiState
+updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
+
+-- |
+-- Updates the state to have more imported modules.
+--
+updateImportedModules :: ImportedModule -> PSCiState -> PSCiState
+updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }
+
+-- |
+-- Updates the state to have more loaded files.
+--
+updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
+updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
+
+-- |
+-- Updates the state to have more let bindings.
+--
+updateLets :: [P.Declaration] -> PSCiState -> PSCiState
+updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
+
+-- |
+-- Valid Meta-commands for PSCI
+--
+data Command
+ -- |
+ -- A purescript expression
+ --
+ = Expression P.Expr
+ -- |
+ -- Show the help (ie, list of directives)
+ --
+ | ShowHelp
+ -- |
+ -- Import a module from a loaded file
+ --
+ | Import ImportedModule
+ -- |
+ -- Browse a module
+ --
+ | BrowseModule P.ModuleName
+ -- |
+ -- Load a file for use with importing
+ --
+ | LoadFile FilePath
+ -- |
+ -- Exit PSCI
+ --
+ | QuitPSCi
+ -- |
+ -- Reset the state of the REPL
+ --
+ | ResetState
+ -- |
+ -- Add some declarations to the current evaluation context.
+ --
+ | Decls [P.Declaration]
+ -- |
+ -- Find the type of an expression
+ --
+ | TypeOf P.Expr
+ -- |
+ -- Find the kind of an expression
+ --
+ | KindOf P.Type
+ -- |
+ -- Shows information about the current state of the REPL
+ --
+ | ShowInfo ReplQuery
+
+data ReplQuery
+ = QueryLoaded
+ | QueryImport
+ deriving (Eq, Show)
+
+-- | A list of all ReplQuery values.
+replQueries :: [ReplQuery]
+replQueries = [QueryLoaded, QueryImport]
+
+replQueryStrings :: [String]
+replQueryStrings = map showReplQuery replQueries
+
+showReplQuery :: ReplQuery -> String
+showReplQuery QueryLoaded = "loaded"
+showReplQuery QueryImport = "import"
+
+parseReplQuery :: String -> Maybe ReplQuery
+parseReplQuery "loaded" = Just QueryLoaded
+parseReplQuery "import" = Just QueryImport
+parseReplQuery _ = Nothing
+
+data Directive
+ = Help
+ | Quit
+ | Reset
+ | Browse
+ | Load
+ | Type
+ | Kind
+ | Show
+ deriving (Eq, Show)
diff --git a/psci/main/Main.hs b/psci/main/Main.hs
new file mode 100644
index 0000000..e430648
--- /dev/null
+++ b/psci/main/Main.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import PSCi
+
+main :: IO ()
+main = runPSCi
diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs
new file mode 100644
index 0000000..a703ca2
--- /dev/null
+++ b/psci/tests/Main.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+
+import Control.Monad.Trans.State.Strict (runStateT)
+import Control.Monad (when)
+
+import System.Exit (exitFailure)
+import System.Console.Haskeline
+
+import Test.HUnit
+
+import qualified Language.PureScript as P
+
+import PSCi
+import Completion
+import Types
+
+main :: IO ()
+main = do
+ Counts{..} <- runTestTT allTests
+ when (errors + failures > 0) exitFailure
+
+allTests :: Test
+allTests = completionTests
+
+completionTests :: Test
+completionTests =
+ TestLabel "completionTests"
+ (TestList (map (TestCase . assertCompletedOk) completionTestData))
+
+-- If the cursor is at the right end of the line, with the 1st element of the
+-- pair as the text in the line, then pressing tab should offer all the
+-- elements of the list (which is the 2nd element) as completions.
+completionTestData :: [(String, [String])]
+completionTestData =
+ -- basic directives
+ [ (":h", [":help"])
+ , (":re", [":reset"])
+ , (":q", [":quit"])
+ , (":mo", [":module"])
+ , (":b", [":browse"])
+
+ -- :browse should complete modules
+ , (":b Prel", [":b Prelude", ":b Prelude.Unsafe"])
+ , (":b Prelude.", [":b Prelude.Unsafe"])
+
+ -- :load, :module should complete file paths
+ , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"])
+ , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"])
+
+ -- :quit, :help, :reset should not complete
+ , (":help ", [])
+ , (":quit ", [])
+ , (":reset ", [])
+
+ -- :show should complete to "loaded" and "import"
+ , (":show ", [":show import", ":show loaded"])
+ , (":show a", [])
+
+ -- :type should complete values and data constructors in scope
+ , (":type Prelude.Unsafe.un", [":type Prelude.Unsafe.unsafeIndex"])
+ , (":type un", [":type unit"])
+ , (":type E", [":type EQ"])
+
+ -- :kind should complete types in scope
+ , (":kind C", [":kind Control.Monad.Eff.Pure"])
+ , (":kind O", [":kind Ordering"])
+
+ -- Only one argument for directives should be completed
+ , (":show import ", [])
+ , (":type EQ ", [])
+ , (":kind Ordering ", [])
+
+ -- import should complete module names
+ , ("import Control.Monad.S", ["import Control.Monad.ST"])
+ , ("import qualified Control.Monad.S", ["import qualified Control.Monad.ST"])
+ , ("import Control.Monad.", map ("import Control.Monad." ++)
+ ["Eff", "Eff.Unsafe", "ST"])
+
+ -- a few other import tests
+ , ("impor", ["import"])
+ , ("import q", ["import qualified"])
+ , ("import ", map ("import " ++) allModuleNames ++ ["import qualified"])
+ , ("import Prelude.Unsafe ", [])
+
+ -- String and number literals should not be completed
+ , ("\"hi", [])
+ , ("34", [])
+
+ -- Identifiers and data constructors should be completed
+ , ("un", ["unit"])
+ , ("Debug.Trace.", map ("Debug.Trace." ++) ["print", "trace"])
+ , ("G", ["GT"])
+ , ("Prelude.L", ["Prelude.LT"])
+
+ -- if a module is imported qualified, values should complete under the
+ -- qualified name, as well as the original name.
+ , ("ST.new", ["ST.newSTRef"])
+ , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])
+ ]
+ where
+ allModuleNames = [ "Control.Monad.Eff"
+ , "Control.Monad.Eff.Unsafe"
+ , "Control.Monad.ST"
+ , "Data.Function"
+ , "Debug.Trace"
+ , "Prelude"
+ , "Prelude.Unsafe"
+ ]
+
+assertCompletedOk :: (String, [String]) -> Assertion
+assertCompletedOk (line, expecteds) = do
+ (unusedR, completions) <- runCM (completion' (reverse line, ""))
+ let unused = reverse unusedR
+ let actuals = map ((unused ++) . replacement) completions
+ expecteds @=? actuals
+
+runCM :: CompletionM a -> IO a
+runCM act = do
+ psciState <- getPSCiState
+ fmap fst (runStateT (liftCompletionM act) psciState)
+
+getPSCiState :: IO PSCiState
+getPSCiState = do
+ modulesOrFirstError <- loadAllModules []
+ case modulesOrFirstError of
+ Left err ->
+ print err >> exitFailure
+ Right modules ->
+ let imports = controlMonadSTasST : defaultImports
+ in return (PSCiState [] imports modules [] [])
+
+controlMonadSTasST :: ImportedModule
+controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
+ where
+ s = P.moduleNameFromString
diff --git a/purescript.cabal b/purescript.cabal
index 588bcef..09c44d4 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.6.9.3
+version: 0.6.9.4
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -148,10 +148,12 @@ executable psci
main-is: Main.hs
buildable: True
- hs-source-dirs: psci
- other-modules: Commands
+ hs-source-dirs: psci psci/main
+ other-modules: Types
Parser
Directive
+ Completion
+ PSCi
ghc-options: -Wall -O2
executable psc-docs
@@ -182,3 +184,14 @@ test-suite tests
main-is: Main.hs
buildable: True
hs-source-dirs: tests
+
+test-suite psci-tests
+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
+ mtl -any, optparse-applicative >= 0.10.0, parsec -any,
+ haskeline >= 0.7.0.0, purescript -any, transformers -any,
+ process -any, HUnit -any
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ buildable: True
+ hs-source-dirs: psci psci/tests
+ ghc-options: -Wall
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index d0d293f..609f5fb 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -89,20 +89,20 @@ import qualified Paths_purescript as Paths
--
-- * Pretty-print the generated Javascript
--
-compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
+compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)
=> [Module] -> [String] -> m (String, String, Environment)
compile = compile' initEnvironment
-compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
+compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)
=> Environment -> [Module] -> [String] -> m (String, String, Environment)
compile' env ms prefix = do
noPrelude <- asks optionsNoPrelude
additional <- asks optionsAdditional
mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
(sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
- (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted
+ (desugared, nextVar) <- runSupplyT 0 $ desugar sorted
(elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
- regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
+ regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
let corefn = map (CoreFn.moduleToCoreFn env') regrouped
let entryPoints = moduleNameFromString `map` entryPointModules additional
let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
@@ -115,21 +115,21 @@ compile' env ms prefix = do
let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
return (pjs, exts, env')
-generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]
+generateMain :: (MonadError MultipleErrors m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]
generateMain env js = do
main <- asks optionsMain
additional <- asks optionsAdditional
case moduleNameFromString <$> main of
Just mmi -> do
when ((mmi, Ident C.main) `M.notMember` names env) $
- throwError $ show mmi ++ "." ++ C.main ++ " is undefined"
+ throwError . errorMessage $ NameIsUndefined (Ident C.main)
return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]
_ -> return js
-- |
-- A type class which collects the IO actions we need to be able to run in "make" mode
--
-class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where
+class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m) => MonadMake m where
-- |
-- Get a file timestamp
--
@@ -196,7 +196,7 @@ make outputDir ms prefix = do
marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
- (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
+ (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
evalSupplyT nextVar $ go initEnvironment desugared
@@ -216,7 +216,7 @@ make outputDir ms prefix = do
(Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
- regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
+ regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
let mod' = Module coms moduleName' regrouped exps
let corefn = CoreFn.moduleToCoreFn env' mod'
@@ -240,10 +240,10 @@ make outputDir ms prefix = do
rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
externs <- readTextFile externsFile
- externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]
+ externsModules <- fmap (map snd) . either (throwError . errorMessage . ErrorParsingExterns) return $ P.parseModulesFromFiles id [(externsFile, externs)]
case externsModules of
[m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
- _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"
+ _ -> throwError . errorMessage . InvalidExternsFile $ externsFile
reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index f857fa0..065ef0b 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -78,12 +78,12 @@ isDctorExported ident (Just exps) ctor = test `any` exps
-- |
-- Return the exported data constructors for a given type.
--
-exportedDctors :: Module -> ProperName -> [ProperName]
+exportedDctors :: Module -> ProperName -> [(ProperName, [Type])]
exportedDctors (Module _ _ decls exps) ident =
- filter (isDctorExported ident exps) dctors
+ filter (isDctorExported ident exps . fst) dctors
where
dctors = concatMap getDctors (flattenDecls decls)
- getDctors (DataDeclaration _ _ _ ctors) = map fst ctors
+ getDctors (DataDeclaration _ _ _ ctors) = ctors
getDctors (PositionedDeclaration _ _ d) = getDctors d
getDctors _ = []
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index 97c3dc6..454fbdb 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -30,10 +30,12 @@ data SourcePos = SourcePos
-- Column number
--
, sourcePosColumn :: Int
- } deriving (Eq, D.Data, D.Typeable)
+ } deriving (Eq, Show, D.Data, D.Typeable)
-instance Show SourcePos where
- show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
+displaySourcePos :: SourcePos -> String
+displaySourcePos sp =
+ "line " ++ show (sourcePosLine sp) ++
+ ", column " ++ show (sourcePosColumn sp)
data SourceSpan = SourceSpan
{ -- |
@@ -47,7 +49,10 @@ data SourceSpan = SourceSpan
-- End of the span
--
, spanEnd :: SourcePos
- } deriving (Eq, D.Data, D.Typeable)
+ } deriving (Eq, Show, D.Data, D.Typeable)
-instance Show SourceSpan where
- show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)
+displaySourceSpan :: SourceSpan -> String
+displaySourceSpan sp =
+ spanName sp ++ " " ++
+ displaySourcePos (spanStart sp) ++ " - " ++
+ displaySourcePos (spanEnd sp)
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index caf7017..ad27785 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -84,10 +84,28 @@ inlineValues :: JS -> JS
inlineValues = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.zero fn = JSNumericLiteral (Left 0)
- convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.one fn = JSNumericLiteral (Left 1)
- convert (JSApp (JSApp fn [x]) [y]) | isPreludeFn (C.%) fn = JSBinary Modulus x y
+ convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0)
+ | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1)
+ | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0)
+ | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1)
+ | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False
+ | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True
+ convert (JSApp fn [value]) | isFn fromNumber fn = JSBinary BitwiseOr value (JSNumericLiteral (Left 0))
+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])
+ | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0))
+ | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0))
+ | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0))
+ | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0))
convert other = other
+ fnZero = (C.prelude, C.zero)
+ fnOne = (C.prelude, C.one)
+ fnBottom = (C.prelude, C.bottom)
+ fnTop = (C.prelude, C.top)
+ fromNumber = (C.dataInt, C.fromNumber)
+ fnAdd = (C.prelude, (C.+))
+ fnDivide = (C.prelude, (C./))
+ fnMultiply = (C.prelude, (C.*))
+ fnSubtract = (C.prelude, (C.-))
inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
inlineOperator (m, op) f = everywhereOnJS convert
@@ -101,58 +119,83 @@ inlineOperator (m, op) f = everywhereOnJS convert
inlineCommonOperators :: JS -> JS
inlineCommonOperators = applyAll $
- [ binary C.semiringNumber (C.+) Add
- , binary C.semiringNumber (C.*) Multiply
- , binary C.ringNumber (C.-) Subtract
- , unary C.ringNumber C.negate Negate
- , binary C.moduloSemiringNumber (C./) Divide
-
- , binary C.ordNumber (C.<) LessThan
- , binary C.ordNumber (C.>) GreaterThan
- , binary C.ordNumber (C.<=) LessThanOrEqualTo
- , binary C.ordNumber (C.>=) GreaterThanOrEqualTo
-
- , binary C.eqNumber (C.==) EqualTo
- , binary C.eqNumber (C./=) NotEqualTo
- , binary C.eqString (C.==) EqualTo
- , binary C.eqString (C./=) NotEqualTo
- , binary C.eqBoolean (C.==) EqualTo
- , binary C.eqBoolean (C./=) NotEqualTo
-
- , binary C.semigroupString (C.<>) Add
- , binary C.semigroupString (C.++) Add
-
- , binaryFunction C.bitsNumber C.shl ShiftLeft
- , binaryFunction C.bitsNumber C.shr ShiftRight
- , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
- , binary C.bitsNumber (C..&.) BitwiseAnd
- , binary C.bitsNumber (C..|.) BitwiseOr
- , binary C.bitsNumber (C..^.) BitwiseXor
- , unary C.bitsNumber C.complement BitwiseNot
-
- , binary C.boolLikeBoolean (C.&&) And
- , binary C.boolLikeBoolean (C.||) Or
- , unary C.boolLikeBoolean C.not Not
+ [ binary semiringNumber (C.+) Add
+ , binary semiringNumber (C.*) Multiply
+
+ , binary ringNumber (C.-) Subtract
+ , unary ringNumber C.negate Negate
+ , binary ringInt (C.-) Subtract
+ , unary ringInt C.negate Negate
+
+ , binary moduloSemiringNumber (C./) Divide
+ , binary moduloSemiringInt C.mod Modulus
+
+ , binary eqNumber (C.==) EqualTo
+ , binary eqNumber (C./=) NotEqualTo
+ , binary eqInt (C.==) EqualTo
+ , binary eqInt (C./=) NotEqualTo
+ , binary eqString (C.==) EqualTo
+ , binary eqString (C./=) NotEqualTo
+ , binary eqBoolean (C.==) EqualTo
+ , binary eqBoolean (C./=) NotEqualTo
+
+ , binary ordNumber (C.<) LessThan
+ , binary ordNumber (C.>) GreaterThan
+ , binary ordNumber (C.<=) LessThanOrEqualTo
+ , binary ordNumber (C.>=) GreaterThanOrEqualTo
+ , binary ordInt (C.<) LessThan
+ , binary ordInt (C.>) GreaterThan
+ , binary ordInt (C.<=) LessThanOrEqualTo
+ , binary ordInt (C.>=) GreaterThanOrEqualTo
+
+ , binary semigroupString (C.<>) Add
+ , binary semigroupString (C.++) Add
+
+ , binary latticeBoolean (C.&&) And
+ , binary latticeBoolean (C.||) Or
+ , binaryFunction latticeBoolean C.inf And
+ , binaryFunction latticeBoolean C.sup Or
+ , unary complementedLatticeBoolean C.not Not
+
+ , binary' C.dataIntBits (C..|.) BitwiseOr
+ , binary' C.dataIntBits (C..&.) BitwiseAnd
+ , binary' C.dataIntBits (C..^.) BitwiseXor
+ , binary' C.dataIntBits C.shl ShiftLeft
+ , binary' C.dataIntBits C.shr ShiftRight
+ , binary' C.dataIntBits C.zshr ZeroFillShiftRight
+ , unary' C.dataIntBits C.complement BitwiseNot
] ++
[ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
where
- binary :: String -> String -> BinaryOperator -> JS -> JS
- binary dictName opString op = everywhereOnJS convert
+ binary :: (String, String) -> String -> BinaryOperator -> JS -> JS
+ binary dict opString op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y
+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y
convert other = other
- binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
- binaryFunction dictName fnName op = everywhereOnJS convert
+ binary' :: String -> String -> BinaryOperator -> JS -> JS
+ binary' moduleName opString op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y
+ convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y
convert other = other
- unary :: String -> String -> UnaryOperator -> JS -> JS
- unary dictName fnName op = everywhereOnJS convert
+ binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS
+ binaryFunction dict fnName op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x
+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y
+ convert other = other
+ unary :: (String, String) -> String -> UnaryOperator -> JS -> JS
+ unary dict fnName op = everywhereOnJS convert
+ where
+ convert :: JS -> JS
+ convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x
+ convert other = other
+ unary' :: String -> String -> UnaryOperator -> JS -> JS
+ unary' moduleName fnName op = everywhereOnJS convert
+ where
+ convert :: JS -> JS
+ convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x
convert other = other
mkFn :: Int -> JS -> JS
mkFn 0 = everywhereOnJS convert
@@ -190,12 +233,62 @@ inlineCommonOperators = applyAll $
go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
go _ _ _ = Nothing
-isPreludeDict :: String -> JS -> Bool
-isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName
-isPreludeDict _ _ = False
+isDict :: (String, String) -> JS -> Bool
+isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName
+isDict _ _ = False
+
+isFn :: (String, String) -> JS -> Bool
+isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName
+isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName
+isFn _ _ = False
isPreludeFn :: String -> JS -> Bool
-isPreludeFn fnName (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
-isPreludeFn fnName (JSIndexer (JSStringLiteral fnName') (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
-isPreludeFn fnName (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op fnName)
-isPreludeFn _ _ = False
+isPreludeFn fnName = isFn (C.prelude, fnName)
+
+semiringNumber :: (String, String)
+semiringNumber = (C.prelude, C.semiringNumber)
+
+semiringInt :: (String, String)
+semiringInt = (C.dataInt, C.semiringInt)
+
+ringNumber :: (String, String)
+ringNumber = (C.prelude, C.ringNumber)
+
+ringInt :: (String, String)
+ringInt = (C.dataInt, C.ringInt)
+
+moduloSemiringNumber :: (String, String)
+moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)
+
+moduloSemiringInt :: (String, String)
+moduloSemiringInt = (C.dataInt, C.moduloSemiringInt)
+
+eqNumber :: (String, String)
+eqNumber = (C.prelude, C.eqNumber)
+
+eqInt :: (String, String)
+eqInt = (C.dataInt, C.eqInt)
+
+eqString :: (String, String)
+eqString = (C.prelude, C.eqNumber)
+
+eqBoolean :: (String, String)
+eqBoolean = (C.prelude, C.eqNumber)
+
+ordNumber :: (String, String)
+ordNumber = (C.prelude, C.ordNumber)
+
+ordInt :: (String, String)
+ordInt = (C.dataInt, C.ordInt)
+
+semigroupString :: (String, String)
+semigroupString = (C.prelude, C.semigroupString)
+
+boundedBoolean :: (String, String)
+boundedBoolean = (C.prelude, C.boundedBoolean)
+
+latticeBoolean :: (String, String)
+latticeBoolean = (C.prelude, C.latticeBoolean)
+
+complementedLatticeBoolean :: (String, String)
+complementedLatticeBoolean = (C.prelude, C.complementedLatticeBoolean)
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
index 4fc86fe..eadc51f 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
@@ -15,6 +15,8 @@
module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where
+import Data.Monoid
+
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST
@@ -30,10 +32,13 @@ tco' = everywhereOnJS convert
where
tcoLabel :: String
tcoLabel = "tco"
+
tcoVar :: String -> String
tcoVar arg = "__tco_" ++ arg
+
copyVar :: String -> String
copyVar arg = "__copy_" ++ arg
+
convert :: JS -> JS
convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
let
@@ -46,6 +51,7 @@ tco' = everywhereOnJS convert
JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
| otherwise -> js
convert js = js
+
collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
@@ -56,25 +62,35 @@ tco' = everywhereOnJS convert
collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
(args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
collectAllFunctionArgs allArgs f body = (allArgs, body, f)
+
isTailCall :: String -> JS -> Bool
isTailCall ident js =
let
numSelfCalls = everythingOnJS (+) countSelfCalls js
numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js
numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js
+ numSelfCallWithFnArgs = everythingOnJS (+) countSelfCallsWithFnArgs js
in
numSelfCalls > 0
&& numSelfCalls == numSelfCallsInTailPosition
&& numSelfCallsUnderFunctions == 0
+ && numSelfCallWithFnArgs == 0
where
countSelfCalls :: JS -> Int
countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
countSelfCalls _ = 0
+
countSelfCallsInTailPosition :: JS -> Int
countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
countSelfCallsInTailPosition _ = 0
+
+ countSelfCallsUnderFunctions :: JS -> Int
countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
countSelfCallsUnderFunctions _ = 0
+
+ countSelfCallsWithFnArgs :: JS -> Int
+ countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0
+
toLoop :: String -> [String] -> JS -> JS
toLoop ident allArgs js = JSBlock $
map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
@@ -94,10 +110,19 @@ tco' = everywhereOnJS convert
collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
collectSelfCallArgs allArgumentValues _ = allArgumentValues
+
isSelfCall :: String -> JS -> Bool
- isSelfCall ident (JSApp (JSVar ident') args) | ident == ident' && not (any isFunction args) = True
- isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn
+ isSelfCall ident (JSApp (JSVar ident') _) = ident == ident'
+ isSelfCall ident (JSApp fn _) = isSelfCall ident fn
isSelfCall _ _ = False
- isFunction :: JS -> Bool
- isFunction (JSFunction _ _ _) = True
- isFunction _ = False
+
+ isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool
+ isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True
+ isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)
+ isSelfCallWithFnArgs _ _ _ = False
+
+ hasFunction :: JS -> Bool
+ hasFunction = getAny . everythingOnJS mappend (Any . isFunction)
+ where
+ isFunction (JSFunction _ _ _) = True
+ isFunction _ = False
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 51ba984..6978e7b 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -15,7 +15,7 @@
module Language.PureScript.Constants where
--- Prelude Operators
+-- Operators
($) :: String
($) = "$"
@@ -65,15 +65,6 @@ module Language.PureScript.Constants where
(/=) :: String
(/=) = "/="
-(.&.) :: String
-(.&.) = ".&."
-
-(.|.) :: String
-(.|.) = ".|."
-
-(.^.) :: String
-(.^.) = ".^."
-
(&&) :: String
(&&) = "&&"
@@ -83,11 +74,32 @@ module Language.PureScript.Constants where
unsafeIndex :: String
unsafeIndex = "unsafeIndex"
--- Prelude Operator Functions
+(.|.) :: String
+(.|.) = ".|."
+
+(.&.) :: String
+(.&.) = ".&."
+
+(.^.) :: String
+(.^.) = ".^."
+
+-- Functions
negate :: String
negate = "negate"
+not :: String
+not = "not"
+
+sup :: String
+sup = "sup"
+
+inf :: String
+inf = "inf"
+
+mod :: String
+mod = "mod"
+
shl :: String
shl = "shl"
@@ -100,8 +112,8 @@ zshr = "zshr"
complement :: String
complement = "complement"
-not :: String
-not = "not"
+fromNumber :: String
+fromNumber = "fromNumber"
-- Prelude Values
@@ -111,6 +123,12 @@ zero = "zero"
one :: String
one = "one"
+bottom :: String
+bottom = "bottom"
+
+top :: String
+top = "top"
+
return :: String
return = "return"
@@ -172,32 +190,47 @@ bindEffDictionary = "bindEff"
semiringNumber :: String
semiringNumber = "semiringNumber"
+semiringInt :: String
+semiringInt = "semiringInt"
+
ringNumber :: String
ringNumber = "ringNumber"
+ringInt :: String
+ringInt = "ringInt"
+
moduloSemiringNumber :: String
moduloSemiringNumber = "moduloSemiringNumber"
-numNumber :: String
-numNumber = "numNumber"
+moduloSemiringInt :: String
+moduloSemiringInt = "moduloSemiringInt"
ordNumber :: String
ordNumber = "ordNumber"
+ordInt :: String
+ordInt = "ordInt"
+
eqNumber :: String
eqNumber = "eqNumber"
+eqInt :: String
+eqInt = "eqInt"
+
eqString :: String
eqString = "eqString"
eqBoolean :: String
eqBoolean = "eqBoolean"
-bitsNumber :: String
-bitsNumber = "bitsNumber"
+boundedBoolean :: String
+boundedBoolean = "boundedBoolean"
+
+latticeBoolean :: String
+latticeBoolean = "latticeBoolean"
-boolLikeBoolean :: String
-boolLikeBoolean = "boolLikeBoolean"
+complementedLatticeBoolean :: String
+complementedLatticeBoolean = "complementedLatticeBoolean"
semigroupString :: String
semigroupString = "semigroupString"
@@ -237,3 +270,9 @@ st = "Control_Monad_ST"
dataFunction :: String
dataFunction = "Data_Function"
+
+dataInt :: String
+dataInt = "Data_Int"
+
+dataIntBits :: String
+dataIntBits = "Data_Int_Bits"
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 07d8b19..617e49b 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -36,11 +36,19 @@ import Language.PureScript.TypeClassDictionaries
import qualified Text.PrettyPrint.Boxes as Box
+import qualified Text.Parsec as P
+
-- |
-- A type of error messages
--
data ErrorMessage
- = InfiniteType Type
+ = ErrorParsingExterns P.ParseError
+ | ErrorParsingPrelude P.ParseError
+ | InvalidExternsFile FilePath
+ | CannotGetFileInfo FilePath
+ | CannotReadFile FilePath
+ | CannotWriteFile FilePath
+ | InfiniteType Type
| InfiniteKind Kind
| CannotReorderOperators
| MultipleFixities Ident
@@ -70,6 +78,7 @@ data ErrorMessage
| InvalidDoLet
| CycleInDeclaration Ident
| CycleInTypeSynonym (Maybe ProperName)
+ | CycleInModules [ModuleName]
| NameIsUndefined Ident
| NameNotInScope Ident
| UndefinedTypeVariable ProperName
@@ -126,6 +135,12 @@ instance UnificationError Kind ErrorMessage where
-- Get the error code for a particular error type
--
errorCode :: ErrorMessage -> String
+errorCode (ErrorParsingExterns _) = "ErrorParsingExterns"
+errorCode (ErrorParsingPrelude _) = "ErrorParsingPrelude"
+errorCode (InvalidExternsFile _) = "InvalidExternsFile"
+errorCode (CannotGetFileInfo _) = "CannotGetFileInfo"
+errorCode (CannotReadFile _) = "CannotReadFile"
+errorCode (CannotWriteFile _) = "CannotWriteFile"
errorCode (InfiniteType _) = "InfiniteType"
errorCode (InfiniteKind _) = "InfiniteKind"
errorCode CannotReorderOperators = "CannotReorderOperators"
@@ -156,6 +171,7 @@ errorCode InvalidDoBind = "InvalidDoBind"
errorCode InvalidDoLet = "InvalidDoLet"
errorCode (CycleInDeclaration _) = "CycleInDeclaration"
errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"
+errorCode (CycleInModules _) = "CycleInModules"
errorCode (NameIsUndefined _) = "NameIsUndefined"
errorCode (NameNotInScope _) = "NameNotInScope"
errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"
@@ -177,13 +193,13 @@ errorCode (IncorrectConstructorArity _) = "IncorrectConstructorArity"
errorCode SubsumptionCheckFailed = "SubsumptionCheckFailed"
errorCode (ExprDoesNotHaveType _ _) = "ExprDoesNotHaveType"
errorCode (PropertyIsMissing _ _) = "PropertyIsMissing"
-errorCode (ErrorUnifyingTypes _ _ _) = "ErrorUnifyingTypes"
errorCode (CannotApplyFunction _ _) = "CannotApplyFunction"
errorCode TypeSynonymInstance = "TypeSynonymInstance"
errorCode InvalidNewtype = "InvalidNewtype"
errorCode (InvalidInstanceHead _) = "InvalidInstanceHead"
errorCode (TransitiveExportError _ _) = "TransitiveExportError"
errorCode (NotYetDefined _ e) = errorCode e
+errorCode (ErrorUnifyingTypes _ _ e) = errorCode e
errorCode (ErrorInExpression _ e) = errorCode e
errorCode (ErrorInModule _ e) = errorCode e
errorCode (ErrorInInstance _ _ e) = errorCode e
@@ -245,6 +261,24 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim
wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
go :: ErrorMessage -> Box.Box
+ go (CannotGetFileInfo path) = paras [ line "Unable to read file info: "
+ , indent . line $ path
+ ]
+ go (CannotReadFile path) = paras [ line "Unable to read file: "
+ , indent . line $ path
+ ]
+ go (CannotWriteFile path) = paras [ line "Unable to write file: "
+ , indent . line $ path
+ ]
+ go (ErrorParsingExterns err) = paras [ line "Error parsing externs files: "
+ , indent . line . show $ err
+ ]
+ go (ErrorParsingPrelude err) = paras [ line "Error parsing prelude: "
+ , indent . line . show $ err
+ ]
+ go (InvalidExternsFile path) = paras [ line "Externs file is invalid: "
+ , indent . line $ path
+ ]
go InvalidDoBind = line "Bind statement cannot be the last statement in a do block"
go InvalidDoLet = line "Let statement cannot be the last statement in a do block"
go CannotReorderOperators = line "Unable to reorder operators"
@@ -278,6 +312,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim
go (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ show nm
go (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ show nm
go (CycleInDeclaration nm) = line $ "Cycle in declaration of " ++ show nm
+ go (CycleInModules mns) = line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns)
go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
, indent $ go err
]
@@ -404,7 +439,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim
go (ErrorInForeignImport nm err) = paras [ line $ "Error in foreign import " ++ show nm ++ ":"
, go err
]
- go (PositionedError pos err) = paras [ line $ "Error at " ++ show pos ++ ":"
+ go (PositionedError srcSpan err) = paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":"
, indent $ go err
]
@@ -490,8 +525,8 @@ renderBox = unlines . map trimEnd . lines . Box.render
-- |
-- Interpret multiple errors in a monad supporting errors
--
-interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a
-interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return
+interpretMultipleErrors :: (MonadError MultipleErrors m) => Either MultipleErrors a -> m a
+interpretMultipleErrors = either throwError return
-- |
-- Rethrow an error with a more detailed error message in the case of failure
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 1af1ab4..177ae6c 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -28,6 +28,7 @@ import Data.Maybe (mapMaybe)
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Types
+import Language.PureScript.Errors
-- |
-- A list of modules with their dependencies
@@ -39,7 +40,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]
--
-- Reports an error if the module graph contains a cycle.
--
-sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph)
+sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
sortModules ms = do
let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
ms' <- mapM toModule $ stronglyConnComp verts
@@ -70,7 +71,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (
-- |
-- Convert a strongly connected component of the module graph to a module
--
-toModule :: (MonadError String m) => SCC Module -> m Module
+toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module
toModule (AcyclicSCC m) = return m
toModule (CyclicSCC [m]) = return m
-toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms)
+toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 3135be1..d4f8a5b 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -126,9 +126,7 @@ parseNameAndType :: TokenParser t -> TokenParser (String, t)
parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p
parseRowEnding :: TokenParser Type
-parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> P.choice (map P.try
- [ parseTypeWildcard
- , TypeVar <$> identifier ])
+parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType
parseRow :: TokenParser Type
parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index b5e311b..8c5efb3 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -157,7 +157,6 @@ getProperName _ = error "Expected DataDeclaration"
--
toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration
toBindingGroup _ (AcyclicSCC d) = return d
-toBindingGroup _ (CyclicSCC [d]) = return d
toBindingGroup moduleName (CyclicSCC ds') =
-- Once we have a mutually-recursive group of declarations, we need to sort
-- them further by their immediate dependencies (those outside function
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 3f48f88..829bb04 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -21,10 +21,11 @@ module Language.PureScript.Sugar.CaseDeclarations (
desugarCasesModule
) where
+import Data.Maybe (catMaybes)
import Data.List (nub, groupBy)
import Control.Applicative
-import Control.Monad ((<=<), forM, join, unless, replicateM)
+import Control.Monad ((<=<), forM, replicateM, join, unless)
import Control.Monad.Except (throwError)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.Supply.Class
@@ -120,31 +121,53 @@ toTuple _ = error "Not a value declaration"
makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
makeCaseDeclaration ident alternatives = do
let namedArgs = map findName . fst <$> alternatives
- args <- mapM argName $ foldl1 resolveNames namedArgs
- let
- vars = map (Var . Qualified Nothing) args
- binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
- value = foldr (Abs . Left) (Case vars binders) args
+ argNames = map join $ foldl1 resolveNames namedArgs
+ args <- if allUnique (catMaybes argNames)
+ then mapM argName argNames
+ else replicateM (length argNames) (Ident <$> freshName)
+ let vars = map (Var . Qualified Nothing) args
+ binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
+ value = foldr (Abs . Left) (Case vars binders) args
return $ ValueDeclaration ident Value [] (Right value)
where
- findName :: Binder -> Maybe Ident
- findName (VarBinder name) = Just name
+ -- We will construct a table of potential names.
+ -- VarBinders will become Just (Just _) which is a potential name.
+ -- NullBinder will become Just Nothing, which indicates that we may
+ -- have to generate a name.
+ -- Everything else becomes Nothing, which indicates that we definitely
+ --have to generate a name.
+ findName :: Binder -> Maybe (Maybe Ident)
+ findName NullBinder = Just Nothing
+ findName (VarBinder name) = Just (Just name)
findName (PositionedBinder _ _ binder) = findName binder
findName _ = Nothing
+ -- We still have to make sure the generated names are unique, or else
+ -- we will end up constructing an invalid function.
+ allUnique :: (Eq a) => [a] -> Bool
+ allUnique xs = length xs == length (nub xs)
+
argName :: (MonadSupply m) => Maybe Ident -> m Ident
argName (Just name) = return name
- argName Nothing = do
+ argName _ = do
name <- freshName
return (Ident name)
- resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]
+ -- Combine two lists of potential names from two case alternatives
+ -- by zipping correspoding columns.
+ resolveNames :: [Maybe (Maybe Ident)] ->
+ [Maybe (Maybe Ident)] ->
+ [Maybe (Maybe Ident)]
resolveNames = zipWith resolveName
- resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident
- resolveName (Just a) (Just b)
- | a == b = Just a
+ -- Resolve a pair of names. VarBinder beats NullBinder, and everything
+ -- else results in Nothing.
+ resolveName :: Maybe (Maybe Ident) ->
+ Maybe (Maybe Ident) ->
+ Maybe (Maybe Ident)
+ resolveName (Just (Just a)) (Just (Just b))
+ | a == b = Just (Just a)
| otherwise = Nothing
- resolveName Nothing Nothing = Nothing
- resolveName (Just a) Nothing = Just a
- resolveName Nothing (Just b) = Just b
+ resolveName (Just Nothing) a = a
+ resolveName a (Just Nothing) = a
+ resolveName _ _ = Nothing
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 9667655..966fa1d 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -44,11 +44,8 @@ desugarDo d =
let (f, _, _) = everywhereOnValuesM return replace return
in f d
where
- prelude :: ModuleName
- prelude = ModuleName [ProperName C.prelude]
-
bind :: Expr
- bind = Var (Qualified (Just prelude) (Op (C.>>=)))
+ bind = Var (Qualified Nothing (Op (C.>>=)))
replace :: Expr -> m Expr
replace (Do els) = go els
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 75b9b42..be5e2d7 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -116,7 +116,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
checkOverlaps :: [DictionaryValue] -> Check Expr
checkOverlaps dicts =
case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of
- ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys (map fst ds)
+ ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys $ nub (map fst ds)
_ -> case chooseSimplestDictionaries dicts of
[] -> throwError . errorMessage $ NoInstanceFound className tys
d : _ -> return $ dictionaryValueToValue d
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 84aab4a..03b80f2 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -23,7 +23,6 @@ import qualified Data.Map as M
import Control.Applicative
import Control.Monad.Except
-import Control.Monad.Reader.Class
import Control.Monad.State
import Control.Monad.Unify
@@ -31,7 +30,6 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
-import Language.PureScript.Options
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
@@ -98,12 +96,19 @@ bindLocalTypeVariables moduleName bindings =
-- |
-- Update the visibility of all names to Defined
--
-makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
-makeBindingGroupVisible action = do
- orig <- get
- modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } }
+makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()
+makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }
+
+-- | Update the visibility of all names to Defined in the scope of the provided action
+withBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
+withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action
+
+-- | Perform an action while preserving the names from the @Environment@.
+preservingNames :: (Functor m, MonadState CheckState m) => m a -> m a
+preservingNames action = do
+ orig <- gets (names . checkEnv)
a <- action
- modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
+ modifyEnv $ \e -> e { names = orig }
return a
-- |
@@ -195,18 +200,16 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
-- |
-- Run a computation in the Check monad, starting with an empty @Environment@
--
-runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment)
+runCheck :: (MonadError MultipleErrors m) => Check a -> m (a, Environment)
runCheck = runCheck' initEnvironment
-- |
-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
--
-runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)
-runCheck' env c = do
- verbose <- asks optionsVerboseErrors
- interpretMultipleErrors verbose $ do
- (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
- return (a, checkEnv s)
+runCheck' :: (MonadError MultipleErrors m) => Environment -> Check a -> m (a, Environment)
+runCheck' env c = interpretMultipleErrors $ do
+ (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
+ return (a, checkEnv s)
-- |
-- Make an assertion, failing with an error message
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index b83d80f..9f5da02 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -247,7 +247,7 @@ infer' (Accessor prop val) = do
infer' (Abs (Left arg) ret) = do
ty <- fresh
Just moduleName <- checkCurrentModule <$> get
- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
+ withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
body@(TypedValue _ _ bodyTy) <- infer' ret
return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy
infer' (Abs (Right _) _) = error "Binder was not desugared"
@@ -298,7 +298,7 @@ infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val
infer' _ = error "Invalid argument to infer"
inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)
-inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)
+inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)
inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- liftCheck $ kindOfWithScopedVars ty
@@ -320,7 +320,9 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
- makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
+ bindNames dict $ do
+ makeBindingGroupVisible
+ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do
(d' : ds', val') <- inferLetBinding seen (d : ds) ret j
return (PositionedDeclaration pos com d' : ds', val')
@@ -442,7 +444,7 @@ check' val t@(ConstrainedType constraints ty) = do
dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
n <- liftCheck freshDictionaryName
return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
- val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
+ val' <- withBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)
constraints) $ check val ty
return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
@@ -468,7 +470,7 @@ check' (ArrayLiteral vals) t@(TypeApp a ty) = do
check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do
t =?= tyFunction
Just moduleName <- checkCurrentModule <$> get
- ret' <- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy
+ ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy
return $ TypedValue True (Abs (Left arg) ret') ty
check' (Abs (Right _) _) _ = error "Binder was not desugared"
check' (App f arg) ret = do
diff --git a/tests/Main.hs b/tests/Main.hs
index e7ac794..5c998ee 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -35,21 +35,21 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do
text <- readFile inputFile
return (inputFile, text)
-loadPrelude :: Either String (String, String, P.Environment)
+loadPrelude :: Either P.MultipleErrors (String, String, P.Environment)
loadPrelude =
case P.parseModulesFromFiles id [("", P.prelude)] of
- Left parseError -> Left (show parseError)
+ Left parseError -> Left . P.errorMessage . P.ErrorParsingPrelude $ parseError
Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }
-compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))
+compile :: P.Options P.Compile -> [FilePath] -> IO (Either P.MultipleErrors (String, String, P.Environment))
compile opts inputFiles = do
modules <- P.parseModulesFromFiles id <$> readInput inputFiles
case modules of
Left parseError ->
- return (Left $ show parseError)
+ return . Left . P.errorMessage . P.ErrorParsingPrelude $ parseError
Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts
-assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
+assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
assert preludeExterns opts inputFile f = do
e <- compile opts [preludeExterns, inputFile]
maybeErr <- f e
@@ -64,7 +64,7 @@ assertCompiles preludeJs preludeExterns inputFile = do
{ P.optionsMain = Just "Main"
, P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]
}
- assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do
+ assert preludeExterns options inputFile $ either (return . Just . P.prettyPrintMultipleErrors False) $ \(js, _, _) -> do
process <- findNodeProcess
result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
case result of
@@ -77,7 +77,7 @@ assertDoesNotCompile preludeExterns inputFile = do
putStrLn $ "Assert " ++ inputFile ++ " does not compile"
assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->
case e of
- Left err -> putStrLn err >> return Nothing
+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
Right _ -> return $ Just "Should not have compiled"
findNodeProcess :: IO (Maybe String)
@@ -88,7 +88,7 @@ main :: IO ()
main = do
putStrLn "Compiling Prelude"
case loadPrelude of
- Left err -> putStrLn err >> exitFailure
+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
Right (preludeJs, exts, _) -> do
tmp <- getTemporaryDirectory
let preludeExterns = tmp ++ pathSeparator : "prelude.externs"
@@ -105,4 +105,3 @@ main = do
forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)
exitSuccess
-