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/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.hs24
-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/Main.hs (renamed from psci/PSCi.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.hs14
-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
42 files changed, 1050 insertions, 1888 deletions
diff --git a/examples/failing/365.purs b/examples/failing/365.purs
deleted file mode 100644
index 9a97030..0000000
--- a/examples/failing/365.purs
+++ /dev/null
@@ -1,11 +0,0 @@
-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
deleted file mode 100644
index 29cad3f..0000000
--- a/examples/failing/RowConstructors1.purs
+++ /dev/null
@@ -1,6 +0,0 @@
-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
deleted file mode 100644
index 36ff33b..0000000
--- a/examples/failing/RowConstructors2.purs
+++ /dev/null
@@ -1,6 +0,0 @@
-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
deleted file mode 100644
index ce321ef..0000000
--- a/examples/failing/RowConstructors3.purs
+++ /dev/null
@@ -1,6 +0,0 @@
-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
deleted file mode 100644
index c34eaae..0000000
--- a/examples/failing/TypeSynonyms5.purs
+++ /dev/null
@@ -1,3 +0,0 @@
-module Main where
-
-type T = T
diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs
index 5398249..f61a950 100644
--- a/examples/passing/Collatz.purs
+++ b/examples/passing/Collatz.purs
@@ -1,20 +1,9 @@
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 af68c40..b883a4e 100644
--- a/examples/passing/Guards.purs
+++ b/examples/passing/Guards.purs
@@ -1,39 +1,29 @@
module Main where
-foreign import jsMod
- """
- function jsMod(x) {
- return function (y) {
- return x % y;
- };
- }
- """ :: Number -> Number -> Number
+ import Prelude
-infixl 7 %
-(%) = jsMod
+ collatz = \x -> case x of
+ y | y % 2 == 0 -> y / 2
+ y -> y * 3 + 1
-collatz = \x -> case x of
- y | y % 2 == 0 -> y / 2
- y -> y * 3 + 1
+ -- Guards have access to current scope
+ collatz2 = \x y -> case x of
+ z | y > 0 -> z / 2
+ z -> z * 3 + 1
--- Guards have access to current scope
-collatz2 = \x y -> case x of
- z | y > 0 -> z / 2
- z -> z * 3 + 1
+ min :: forall a. (Ord a) => a -> a -> a
+ min n m | n < m = n
+ | otherwise = m
-min :: forall a. (Ord a) => a -> a -> a
-min n m | n < m = n
- | otherwise = m
+ max :: forall a. (Ord a) => a -> a -> a
+ max n m = case unit of
+ _ | m < n -> n
+ | otherwise -> m
-max :: forall a. (Ord a) => a -> a -> a
-max n m = case unit of
- _ | m < n -> n
- | otherwise -> m
+ testIndentation :: Number -> Number -> Number
+ testIndentation x y | x > 0
+ = x + y
+ | otherwise
+ = y - x
-testIndentation :: Number -> Number -> Number
-testIndentation x y | x > 0
- = x + y
- | otherwise
- = y - x
-
-main = Debug.Trace.trace $ min "Done" "ZZZZ"
+ main = Debug.Trace.trace $ min "Done" "ZZZZ"
diff --git a/examples/passing/Let2.purs b/examples/passing/Let2.purs
deleted file mode 100644
index e4ef059..0000000
--- a/examples/passing/Let2.purs
+++ /dev/null
@@ -1,15 +0,0 @@
-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 5536772..9ee7a5d 100644
--- a/examples/passing/OperatorAssociativity.purs
+++ b/examples/passing/OperatorAssociativity.purs
@@ -35,13 +35,21 @@ 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
deleted file mode 100644
index ae3104e..0000000
--- a/examples/passing/OperatorInlining.purs
+++ /dev/null
@@ -1,46 +0,0 @@
-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 a222fe1..d38f7ed 100644
--- a/examples/passing/Operators.purs
+++ b/examples/passing/Operators.purs
@@ -61,6 +61,9 @@ 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)
@@ -91,6 +94,7 @@ 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
deleted file mode 100644
index 8d2480c..0000000
--- a/examples/passing/RebindableSyntax.purs
+++ /dev/null
@@ -1,37 +0,0 @@
-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
deleted file mode 100644
index b09e0d8..0000000
--- a/examples/passing/RowConstructors.purs
+++ /dev/null
@@ -1,40 +0,0 @@
-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 a0ade1b..2c938d0 100644
--- a/examples/passing/TopLevelCase.purs
+++ b/examples/passing/TopLevelCase.purs
@@ -1,28 +1,18 @@
module Main where
-foreign import jsMod
- """
- function jsMod(x) {
- return function (y) {
- return x % y;
- };
- }
- """ :: Number -> Number -> Number
+ import Prelude
-infixl 7 %
-(%) = jsMod
+ 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
-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
+ guardsTest (x:xs) | x > 0 = guardsTest xs
+ guardsTest xs = xs
-guardsTest (x:xs) | x > 0 = guardsTest xs
-guardsTest xs = xs
+ data A = A
-data A = A
+ parseTest A 0 = 0
-parseTest A 0 = 0
-
-main = Debug.Trace.trace "Done"
+ main = Debug.Trace.trace "Done"
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index be4d07a..1531461 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -1,89 +1,50 @@
module Prelude
- ( Unit(..), unit
- , ($), (#)
+ ( otherwise
, 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
- , Num
+ , Ring, (-)
+ , (%)
+ , negate
, DivisionRing
+ , Num
, Eq, (==), (/=)
- , Ordering(..), Ord, compare, (<), (>), (<=), (>=)
- , Bounded, top, bottom
- , Lattice, sup, inf, (||), (&&)
- , BoundedLattice
- , ComplementedLattice, not
- , DistributiveLattice
- , BooleanAlgebra
- , Show, show
+ , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
+ , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement
+ , BoolLike, (&&), (||)
+ , not
+ , Semigroup, (<>), (++)
+ , Unit(..), unit
) where
- -- | 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 {}
-
- infixr 0 $
- infixl 0 #
-
- -- | Applies a function to its argument.
- -- |
- -- | ```purescript
- -- | length $ groupBy productCategory $ filter isInStock $ products
- -- | ```
- -- |
- -- | is equivalent to:
- -- |
- -- | ```purescript
- -- | length (groupBy productCategory (filter isInStock products))
- -- | ```
- -- |
- -- | `($)` 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
-
- -- | Applies an argument to a function.
- -- |
- -- | ```purescript
- -- | products # filter isInStock # groupBy productCategory # length
- -- | ```
- -- |
- -- | is equivalent to:
+ -- | An alias for `true`, which can be useful in guard clauses:
-- |
-- | ```purescript
- -- | length (groupBy productCategory (filter isInStock products))
+ -- | max x y | x >= y = x
+ -- | | otherwise = y
-- | ```
-- |
- -- | `(#)` 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
+ otherwise :: Boolean
+ otherwise = true
-- | Flips the order of the arguments to a function of two arguments.
-- |
-- | ```purescript
-- | flip const 1 2 = const 2 1 = 2
-- | ```
+ -- |
flip :: forall a b c. (a -> b -> c) -> b -> a -> c
flip f b a = f a b
@@ -92,29 +53,104 @@ module Prelude
-- | ```purescript
-- | const 1 "hello" = 1
-- | ```
+ -- |
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.
+ -- | This function returns its first argument, and can be used to assert type equalities.
+ -- | This can be useful when types are otherwise ambiguous.
-- |
-- | ```purescript
-- | main = print $ [] `asTypeOf` [0]
-- | ```
-- |
- -- | If instead, we had written `main = print []`, the type of the argument
- -- | `[]` would have been ambiguous, resulting in a compile-time error.
+ -- | 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 alias for `true`, which can be useful in guard clauses:
+ 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
-- |
-- | ```purescript
- -- | max x y | x >= y = x
- -- | | otherwise = y
+ -- | length $ groupBy productCategory $ filter isInStock products
-- | ```
- otherwise :: Boolean
- otherwise = true
+ -- |
+ -- | is equivalent to
+ -- |
+ -- | ```purescript
+ -- | length (groupBy productCategory (filter isInStock (products)))
+ -- | ```
+ -- |
+ -- | `($)` 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
+
+ -- | Applies a function to its argument
+ -- |
+ -- | ```purescript
+ -- | products # groupBy productCategory # filter isInStock # length
+ -- | ```
+ -- |
+ -- | is equivalent to
+ -- |
+ -- | ```purescript
+ -- | length (groupBy productCategory (filter isInStock (products)))
+ -- | ```
+ -- |
+ -- | `(#)` 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 :
+
+ -- | An infix alias for `cons`.
+ -- |
+ -- | Note, the running time of this function is `O(n)`.
+ (:) :: forall a. a -> [a] -> [a]
+ (:) = cons
-- | Attaches an element to the front of an array, creating a new array.
-- |
@@ -132,70 +168,72 @@ module Prelude
}
""" :: forall a. a -> [a] -> [a]
- infixr 6 :
-
- -- | An infix alias for `cons`.
+ -- | The `Show` type class represents those types which can be converted into a human-readable `String` representation.
-- |
- -- | Note, the running time of this function is `O(n)`.
- (:) :: forall a. a -> [a] -> [a]
- (:) = cons
+ -- | 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 9 >>>
- infixr 9 <<<
+ foreign import showStringImpl
+ """
+ function showStringImpl(s) {
+ return JSON.stringify(s);
+ }
+ """ :: String -> String
- -- | 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
+ instance showUnit :: Show Unit where
+ show (Unit {}) = "Unit {}"
- instance semigroupoidArr :: Semigroupoid (->) where
- (<<<) f g x = f (g x)
+ instance showString :: Show String where
+ show = showStringImpl
- -- | 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
+ instance showBoolean :: Show Boolean where
+ show true = "true"
+ show false = "false"
- -- | `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
+ foreign import showNumberImpl
+ """
+ function showNumberImpl(n) {
+ return n.toString();
+ }
+ """ :: Number -> String
- instance categoryArr :: Category (->) where
- id x = x
+ instance showNumber :: Show Number where
+ show = showNumberImpl
+
+ foreign import showArrayImpl
+ """
+ function showArrayImpl(f) {
+ return function(xs) {
+ var ss = [];
+ for (var i = 0, l = xs.length; i < l; i++) {
+ ss[i] = f(xs[i]);
+ }
+ return '[' + ss.join(',') + ']';
+ };
+ }
+ """ :: forall a. (a -> String) -> [a] -> String
+
+ instance showArray :: (Show a) => Show [a] where
+ show = showArrayImpl show
infixl 4 <$>
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.
-- |
- -- | Instances must satisfy the following laws:
+ -- | `Functor` instances should 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
@@ -204,12 +242,10 @@ 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
@@ -221,69 +257,48 @@ 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`.
-- |
- -- | Instances must satisfy the following law in addition to the `Functor`
- -- | laws:
+ -- | `Apply` instances should satisfy the following law:
-- |
- -- | - 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
- 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`.
+ -- | 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.
-- |
- -- | Instances must satisfy the following laws in addition to the `Apply`
- -- | laws:
+ -- | `Applicative` instances should satisfy the following 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
- 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` 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
@@ -294,9 +309,8 @@ 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:
-- |
@@ -307,13 +321,15 @@ module Prelude
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
- -- | Instances must satisfy the following law in addition to the `Apply`
- -- | laws:
+ -- | `Bind` instances should satisfy the following law:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`
-- |
- -- | Associativity tells us that we can regroup operations which use `do`
- -- | notation so that we can unambiguously write, for example:
+ -- | 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:
-- |
-- | ```purescript
-- | do x <- m1
@@ -323,29 +339,29 @@ module Prelude
class (Apply m) <= Bind m where
(>>=) :: forall a b. m a -> (a -> m b) -> m b
- 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.
+ -- | 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.
-- |
- -- | Instances must satisfy the following laws in addition to the
- -- | `Applicative` and `Bind` laws:
+ -- | `Monad` instances should satisfy the following 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
- instance monadArr :: Monad ((->) r)
+ -- | `return` is an alias for `pure`.
+ return :: forall m a. (Monad m) => a -> m a
+ return = pure
- -- | `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
@@ -356,12 +372,10 @@ 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
@@ -373,152 +387,68 @@ module Prelude
a' <- a
return (f' a')
- infixr 5 <>
- infixr 5 ++
-
- -- | 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
-
- -- | `(++)` is an alias for `(<>)`.
- (++) :: forall s. (Semigroup s) => s -> s -> s
- (++) = (<>)
+ instance functorArr :: Functor ((->) r) where
+ (<$>) = (<<<)
- instance semigroupString :: Semigroup String where
- (<>) = concatString
+ instance applyArr :: Apply ((->) r) where
+ (<*>) f g x = f x (g x)
- instance semigroupUnit :: Semigroup Unit where
- (<>) _ _ = unit
+ instance applicativeArr :: Applicative ((->) r) where
+ pure = const
- instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
- (<>) f g = \x -> f x <> g x
+ instance bindArr :: Bind ((->) r) where
+ (>>=) m f x = f (m x) x
- instance semigroupOrdering :: Semigroup Ordering where
- (<>) LT _ = LT
- (<>) GT _ = GT
- (<>) EQ y = y
+ instance monadArr :: Monad ((->) r)
- foreign import concatString
- """
- function concatString(s1) {
- return function(s2) {
- return s1 + s2;
- };
- }
- """ :: String -> String -> String
+ infixl 7 *
+ infixl 7 /
+ infixl 7 %
+ infixl 6 -
infixl 6 +
- infixl 7 *
- -- | 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`
+ -- | 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`
+ -- |
class Semiring a where
(+) :: a -> a -> a
zero :: a
(*) :: a -> a -> a
one :: a
- instance semiringNumber :: Semiring Number where
- (+) = numAdd
- zero = 0
- (*) = numMul
- one = 1
-
- 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.
- -- |
- -- | 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
-
- infixl 7 /
-
- -- | The `ModuloSemiring` class is for types that support addition,
- -- | multiplication, division, and modulo (division remainder) operations.
+ -- | Addition, multiplication, modulo operation and division, satisfying:
-- |
- -- | Instances must satisfy the following law in addition to the `Semiring`
- -- | laws:
+ -- | - ```a / b * b + (a `mod` b) = a```
-- |
- -- | - 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.
+ -- | Addition, multiplication, and subtraction.
-- |
- -- | Instances must satisfy the following law in addition to the `Ring` and
- -- | `ModuloSemiring` laws:
+ -- | Has the same laws as `Semiring` but additionally satisfying:
-- |
- -- | - Multiplicative inverse: `(one / x) * x = one`
+ -- | - `a` is an abelian group under addition
-- |
- -- | As a consequence of this ```a `mod` b = zero``` as no divide operation
- -- | will have a remainder.
- class (Ring a, ModuloSemiring a) <= DivisionRing a
-
- instance divisionRingNumber :: DivisionRing Number
+ class (Semiring a) <= Ring a where
+ (-) :: a -> a -> a
- instance divisionRingUnit :: DivisionRing Unit
+ negate :: forall a. (Ring a) => a -> a
+ negate a = zero - a
- -- | The `Num` class is for types that are commutative fields.
+ -- | Ring where every nonzero element has a multiplicative inverse so that:
-- |
- -- | Instances must satisfy the following law in addition to the
- -- | `DivisionRing` laws:
+ -- | - ```a `mod` b = zero```
-- |
- -- | - Commutative multiplication: `a * b = b * a`
- class (DivisionRing a) <= Num a
-
- instance numNumber :: Num Number
+ class (Ring a, ModuloSemiring a) <= DivisionRing a
- instance numUnit :: Num Unit
+ -- | A commutative field
+ class (DivisionRing a) <= Num a
foreign import numAdd
"""
@@ -529,6 +459,15 @@ 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) {
@@ -547,15 +486,44 @@ module Prelude
}
""" :: Number -> Number -> Number
- foreign import numSub
+ foreign import numMod
"""
- function numSub(n1) {
+ function numMod(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 /=
@@ -573,33 +541,6 @@ 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) {
@@ -618,6 +559,22 @@ 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) {
@@ -633,14 +590,34 @@ module Prelude
}
""" :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean
- -- | The `Ordering` data type represents the three possible outcomes of
- -- | comparing two values:
+ 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:
-- |
-- | `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_:
@@ -648,45 +625,11 @@ 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
@@ -694,27 +637,30 @@ 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) {
@@ -730,148 +676,145 @@ module Prelude
}
""" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
- -- | 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
+ unsafeCompare :: forall a. a -> a -> Ordering
+ unsafeCompare = unsafeCompareImpl LT EQ GT
- infixr 2 ||
- infixr 3 &&
+ instance ordUnit :: Ord Unit where
+ compare (Unit {}) (Unit {}) = EQ
- -- | The `sup` operator.
- (||) :: forall a. (Lattice a) => a -> a -> a
- (||) = sup
+ instance ordBoolean :: Ord Boolean where
+ compare false false = EQ
+ compare false true = LT
+ compare true true = EQ
+ compare true false = GT
- -- | The `inf` operator.
- (&&) :: forall a. (Lattice a) => a -> a -> a
- (&&) = inf
+ instance ordNumber :: Ord Number 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 ordString :: Ord String where
+ compare = unsafeCompare
- instance boundedLatticeBoolean :: BoundedLattice Boolean
+ 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 boundedLatticeUnit :: BoundedLattice Unit
+ 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
- -- | 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 numShr
+ """
+ function numShr(n1) {
+ return function(n2) {
+ return n1 >> n2;
+ };
+ }
+ """ :: Number -> Number -> Number
- instance complementedLatticeBoolean :: ComplementedLattice Boolean where
- not = boolNot
+ foreign import numZshr
+ """
+ function numZshr(n1) {
+ return function(n2) {
+ return n1 >>> n2;
+ };
+ }
+ """ :: Number -> Number -> Number
- instance complementedLatticeUnit :: ComplementedLattice Unit where
- not _ = unit
+ foreign import numAnd
+ """
+ function numAnd(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 numOr
+ """
+ function numOr(n1) {
+ return function(n2) {
+ return n1 | n2;
+ };
+ }
+ """ :: Number -> Number -> Number
- instance distributiveLatticeBoolean :: DistributiveLattice Boolean
+ foreign import numXor
+ """
+ function numXor(n1) {
+ return function(n2) {
+ return n1 ^ n2;
+ };
+ }
+ """ :: Number -> Number -> Number
- instance distributiveLatticeUnit :: DistributiveLattice Unit
+ foreign import numComplement
+ """
+ function numComplement(n) {
+ return ~n;
+ }
+ """ :: Number -> Number
- -- | 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
+ instance bitsNumber :: Bits Number where
+ (.&.) = numAnd
+ (.|.) = numOr
+ (.^.) = numXor
+ shl = numShl
+ shr = numShr
+ zshr = numZshr
+ complement = numComplement
- instance booleanAlgebraBoolean :: BooleanAlgebra Boolean
+ infixr 2 ||
+ infixr 3 &&
- instance booleanAlgebraUnit :: BooleanAlgebra Unit
+ -- | 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
- 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 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 boolNot
"""
@@ -880,62 +823,46 @@ module Prelude
}
""" :: Boolean -> Boolean
- -- | 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
-
- instance showBoolean :: Show Boolean where
- show true = "true"
- show false = "false"
+ instance boolLikeBoolean :: BoolLike Boolean where
+ (&&) = boolAnd
+ (||) = boolOr
+ not = boolNot
- instance showNumber :: Show Number where
- show = showNumberImpl
+ infixr 5 <>
- instance showString :: Show String where
- show = showStringImpl
+ -- | 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 showUnit :: Show Unit where
- show _ = "unit"
+ foreign import concatString
+ """
+ function concatString(s1) {
+ return function(s2) {
+ return s1 + s2;
+ };
+ }
+ """ :: String -> String -> String
- instance showArray :: (Show a) => Show [a] where
- show = showArrayImpl show
+ instance semigroupUnit :: Semigroup Unit where
+ (<>) (Unit {}) (Unit {}) = Unit {}
- instance showOrdering :: Show Ordering where
- show LT = "LT"
- show GT = "GT"
- show EQ = "EQ"
+ instance semigroupString :: Semigroup String where
+ (<>) = concatString
- foreign import showNumberImpl
- """
- function showNumberImpl(n) {
- return n.toString();
- }
- """ :: Number -> String
+ instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
+ (<>) f g = \x -> f x <> g x
- foreign import showStringImpl
- """
- function showStringImpl(s) {
- return JSON.stringify(s);
- }
- """ :: String -> String
+ infixr 5 ++
- 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
+ -- | `(++)` is an alias for `(<>)`.
+ (++) :: forall s. (Semigroup s) => s -> s -> s
+ (++) = (<>)
module Data.Function where
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index c5dfdf9..370826c 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -52,29 +52,27 @@ 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 P.MultipleErrors IO) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make))
+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))
-runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors a)
+runMake :: P.Options P.Make -> Make a -> IO (Either String a)
runMake opts = runExceptT . flip runReaderT opts . unMake
-makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
-makeIO f io = do
- e <- liftIO $ tryIOError io
- either (throwError . P.errorMessage . f) return e
+makeIO :: IO a -> Make a
+makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError
instance P.MonadMake Make where
- getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do
+ getTimestamp path = makeIO $ do
exists <- doesFileExist path
traverse (const $ getModificationTime path) $ guard exists
- readTextFile path = makeIO (const (P.CannotReadFile path))$ do
+ readTextFile path = makeIO $ do
putStrLn $ "Reading " ++ path
readFile path
- writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do
+ writeTextFile path text = makeIO $ do
mkdirp path
putStrLn $ "Writing " ++ path
writeFile path text
- progress = liftIO . putStrLn
+ progress = makeIO . putStrLn
compile :: PSCMakeOptions -> IO ()
compile (PSCMakeOptions input outputDir opts usePrefix) = do
@@ -86,8 +84,8 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do
Right ms -> do
e <- runMake opts $ P.make outputDir ms prefix
case e of
- Left errs -> do
- putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
+ Left err -> do
+ putStrLn err
exitFailure
Right _ -> do
exitSuccess
diff --git a/psc/Main.hs b/psc/Main.hs
index 45653a7..6be836d 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 errs -> do
- hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
+ Left err -> do
+ hPutStrLn stderr err
exitFailure
Right (js, exts, _) -> do
case output of
diff --git a/psci/Commands.hs b/psci/Commands.hs
new file mode 100644
index 0000000..e7a8025
--- /dev/null
+++ b/psci/Commands.hs
@@ -0,0 +1,78 @@
+-----------------------------------------------------------------------------
+--
+-- 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
deleted file mode 100644
index 0e5c1d3..0000000
--- a/psci/Completion.hs
+++ /dev/null
@@ -1,232 +0,0 @@
-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 366fc66..c7bebd2 100644
--- a/psci/Directive.hs
+++ b/psci/Directive.hs
@@ -15,85 +15,46 @@
module Directive where
-import Data.Maybe (fromJust, listToMaybe)
-import Data.List (isPrefixOf)
-import Data.Tuple (swap)
-
-import Types
-
--- |
--- List of all avaliable directives.
---
-directives :: [Directive]
-directives = map fst directiveStrings
+import Data.List (nub, isPrefixOf)
+
+data Directive
+ = Help
+ | Quit
+ | Reset
+ | Browse
+ | Load
+ | Type
+ | Kind
+ | Show
+ deriving Eq
-- |
--- A mapping of directives to the different strings that can be used to invoke
--- them.
+-- Maps given directive to relating command strings.
--
-directiveStrings :: [(Directive, [String])]
-directiveStrings =
- [ (Help , ["?", "help"])
- , (Quit , ["quit"])
- , (Reset , ["reset"])
- , (Browse , ["browse"])
- , (Load , ["load", "module"])
- , (Type , ["type"])
- , (Kind , ["kind"])
- , (Show , ["show"])
- ]
+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"]
-- |
--- Like directiveStrings, but the other way around.
+-- Tries to parse given string into a directive.
--
-directiveStrings' :: [(String, Directive)]
-directiveStrings' = concatMap go directiveStrings
- where
- go (dir, strs) = map (\s -> (s, dir)) strs
-
--- |
--- 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
+parseDirective cmd =
+ case filter (matches . snd) mapping of
+ [directive] -> Just $ fst directive
+ _ -> Nothing
+ where
+ mapping :: [(Directive, [String])]
+ mapping = zip directives (map commands directives)
--- |
--- True if the given directive takes an argument, false otherwise.
-hasArgument :: Directive -> Bool
-hasArgument Help = False
-hasArgument Quit = False
-hasArgument Reset = False
-hasArgument _ = True
+ matches :: [String] -> Bool
+ matches = any (cmd `isPrefixOf`)
-- |
-- The help menu.
@@ -102,12 +63,17 @@ help :: [(Directive, String, String)]
help =
[ (Help, "", "Show this help menu")
, (Quit, "", "Quit PSCi")
- , (Reset, "", "Discard all imported modules and declared bindings")
- , (Browse, "<module>", "See all functions in <module>")
+ , (Reset, "", "Reset")
+ , (Browse, "<module>", "Browse <module>")
, (Load, "<file>", "Load <file> for importing")
, (Type, "<expr>", "Show the type of <expr>")
, (Kind, "<type>", "Show the kind of <type>")
- , (Show, "import", "Show all imported modules")
- , (Show, "loaded", "Show all loaded modules")
+ , (Show, "import", "Show imported modules")
+ , (Show, "loaded", "Show loaded modules")
]
+-- |
+-- List of all avaliable directives.
+--
+directives :: [Directive]
+directives = nub . map (\(dir, _, _) -> dir) $ help
diff --git a/psci/PSCi.hs b/psci/Main.hs
index 1f611a8..5969d70 100644
--- a/psci/PSCi.hs
+++ b/psci/Main.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : PSCi
+-- Module : Main
-- Copyright : (c) Phil Freeman 2013
-- License : MIT
--
@@ -19,18 +19,18 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
-module PSCi where
+module Main where
import Data.Foldable (traverse_)
-import Data.List (intercalate, nub, sort)
+import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)
+import Data.Maybe (mapMaybe)
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,21 +50,70 @@ 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 (parseCommand)
-import Completion (completion)
-import Types
+import Parser
+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 :: [ImportedModule]
-defaultImports = [(P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
+defaultImports :: [C.ImportedModule]
+defaultImports = [(P.ModuleName [P.ProperName "Prelude"], D.Implicit, Nothing)]
-- |
-- Locates the node executable.
@@ -126,24 +175,17 @@ expandTilde p = return p
--
helpMessage :: String
helpMessage = "The following commands are available:\n\n " ++
- intercalate "\n " (map line D.help) ++
- "\n\n" ++ extraHelp
+ intercalate "\n " (map line D.help)
where
- 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"
-
+ 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)
-- |
-- The welcome prologue.
@@ -166,6 +208,129 @@ 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
@@ -182,26 +347,24 @@ 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 P.MultipleErrors IO) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make))
+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))
-runMake :: Make a -> IO (Either P.MultipleErrors a)
+runMake :: Make a -> IO (Either String a)
runMake = runExceptT . flip runReaderT options . unMake
-makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
-makeIO f io = do
- e <- liftIO $ tryIOError io
- either (throwError . P.errorMessage . f) return e
+makeIO :: IO a -> Make a
+makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError
instance P.MonadMake Make where
- getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do
+ getTimestamp path = makeIO $ do
exists <- doesFileExist path
traverse (const $ getModificationTime path) $ guard exists
- readTextFile path = makeIO (const (P.CannotReadFile path)) $ readFile path
- writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do
+ readTextFile path = makeIO $ readFile path
+ writeTextFile path text = makeIO $ do
mkdirp path
writeFile path text
- progress s = unless (s == "Compiling $PSCI") $ liftIO . putStrLn $ s
+ progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
@@ -244,7 +407,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
in
P.Module [] moduleName (importDecl `map` imports) Nothing
-importDecl :: ImportedModule -> P.Declaration
+importDecl :: C.ImportedModule -> P.Declaration
importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
modulesDir :: FilePath
@@ -263,7 +426,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 errs -> printErrors errs
+ Left err -> PSCI $ outputStrLn err
Right _ -> do
psciIO $ writeFile indexFile "require('$PSCI').main();"
process <- psciIO findNodeProcess
@@ -284,7 +447,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 -> printErrors err
+ Left err -> PSCI $ outputStrLn err
Right _ -> PSCI $ lift (put st')
-- |
@@ -296,7 +459,7 @@ handleShowLoadedModules = do
psciIO $ readModules loadedModules >>= putStrLn
return ()
where readModules = return . unlines . sort . nub . map toModuleName
- toModuleName = N.runModuleName . (\ (P.Module _ mdName _ _) -> mdName) . snd
+ toModuleName = N.runModuleName . (\ (D.Module _ mdName _ _) -> mdName) . snd
-- |
-- Show the imported modules in psci.
@@ -313,17 +476,17 @@ handleShowImportedModules = do
Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'
Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType
- showDeclType P.Implicit = ""
- showDeclType (P.Explicit refs) = refsList refs
- showDeclType (P.Hiding refs) = "hiding " ++ refsList refs
+ showDeclType D.Implicit = ""
+ showDeclType (D.Explicit refs) = refsList refs
+ showDeclType (D.Hiding refs) = "hiding " ++ refsList refs
refsList refs = "(" ++ commaList (map showRef refs) ++ ")"
showRef :: P.DeclarationRef -> String
- 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
+ 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
commaList :: [String] -> String
commaList = intercalate ", "
@@ -331,13 +494,13 @@ handleShowImportedModules = do
-- |
-- Imports a module, preserving the initial state on failure.
--
-handleImport :: ImportedModule -> PSCI ()
+handleImport :: C.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 errs -> printErrors errs
+ Left err -> PSCI $ outputStrLn err
Right _ -> do
PSCI $ lift $ put st
return ()
@@ -351,7 +514,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 errs -> printErrors errs
+ Left err -> PSCI $ outputStrLn err
Right env' ->
case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
@@ -385,16 +548,12 @@ handleBrowse moduleName = do
let loadedModules = psciLoadedModules st
env <- psciIO . runMake $ P.make modulesDir loadedModules []
case env of
- Left errs -> printErrors errs
+ Left err -> PSCI $ outputStrLn err
Right env' ->
if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules
then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
else printModuleSignatures moduleName env'
--- | Pretty-print errors
-printErrors :: P.MultipleErrors -> PSCI ()
-printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False
-
-- |
-- Takes a value and prints its kind
--
@@ -405,7 +564,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 errs -> printErrors errs
+ Left err -> PSCI $ outputStrLn err
Right env' ->
case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
Just (_, typ') -> do
@@ -419,9 +578,9 @@ handleKindOf typ = do
-- Commands
-- |
--- Parses the input and returns either a Metacommand, or an error as a string.
+-- Parses the input and returns either a Metacommand or an expression.
--
-getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe C.Command))
getCommand singleLineMode = do
firstLine <- getInputLine "> "
case firstLine of
@@ -434,14 +593,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 :: 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
+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
absPath <- psciIO $ expandTilde filePath
exists <- psciIO $ doesFileExist absPath
if exists then do
@@ -452,7 +611,7 @@ handleCommand (LoadFile filePath) = do
Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
else
PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
-handleCommand ResetState = do
+handleCommand C.Reset = do
files <- psciImportedFilenames <$> PSCI (lift get)
PSCI . lift . modify $ \st -> st
{ psciImportedFilenames = files
@@ -460,14 +619,14 @@ handleCommand ResetState = do
, psciLetBindings = []
}
loadAllImportedModules
-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])
+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])
loadUserConfig = do
configFile <- (</> ".psci") <$> getCurrentDirectory
exists <- doesFileExist configFile
@@ -503,7 +662,7 @@ loop PSCiOptions{..} = do
case c of
Left err -> outputStrLn err >> go
Right Nothing -> go
- Right (Just QuitPSCi) -> outputStrLn quitMessage
+ Right (Just C.Quit) -> outputStrLn quitMessage
Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go
multiLineMode :: Parser Bool
@@ -531,8 +690,8 @@ psciOptions = PSCiOptions <$> multiLineMode
<*> many inputFile
<*> nodeFlagsFlag
-runPSCi :: IO ()
-runPSCi = execParser opts >>= loop
+main :: IO ()
+main = 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 05eda11..d28cc7b 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -19,23 +19,22 @@ 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 Language.PureScript.Parser.Common (mark, same)
-
-import qualified Directive as D
-import Types
+import qualified Language.PureScript.Parser.Common as C (mark, same)
-- |
-- Parses PSCI metacommands or expressions input from the user.
--
-parseCommand :: String -> Either String Command
+parseCommand :: String -> Either String C.Command
parseCommand cmdString =
case cmdString of
(':' : cmd) -> parseDirective cmd
@@ -46,7 +45,7 @@ parseRest p s = either (Left . show) Right $ do
ts <- P.lex "" s
P.runTokenParser "" (p <* eof) ts
-psciCommand :: P.TokenParser Command
+psciCommand :: P.TokenParser C.Command
psciCommand = choice (map try parsers)
where
parsers =
@@ -65,31 +64,25 @@ trimStart = dropWhile isSpace
trimEnd :: String -> String
trimEnd = reverse . trimStart . reverse
-parseDirective :: String -> Either String Command
+parseDirective :: String -> Either String C.Command
parseDirective 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
+ 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
-- |
-- Parses expressions entered at the PSCI repl.
--
-psciExpression :: P.TokenParser Command
-psciExpression = Expression <$> P.parseValue
+psciExpression :: P.TokenParser C.Command
+psciExpression = C.Expression <$> P.parseValue
-- |
-- PSCI version of @let@.
@@ -97,21 +90,21 @@ psciExpression = Expression <$> P.parseValue
-- However, since we don't support the @Eff@ monad,
-- we actually want the normal @let@.
--
-psciLet :: P.TokenParser Command
-psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
+psciLet :: P.TokenParser C.Command
+psciLet = C.Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
where
manyDecls :: P.TokenParser [P.Declaration]
- manyDecls = mark (many1 (same *> P.parseLocalDeclaration))
+ manyDecls = C.mark (many1 (C.same *> P.parseLocalDeclaration))
-- | Imports must be handled separately from other declarations, so that
-- :show import works, for example.
-psciImport :: P.TokenParser Command
-psciImport = Import <$> P.parseImportDeclaration'
+psciImport :: P.TokenParser C.Command
+psciImport = C.Import <$> P.parseImportDeclaration'
-- | Any other declaration that we don't need a 'special case' parser for
-- (like let or import declarations).
-psciOtherDeclaration :: P.TokenParser Command
-psciOtherDeclaration = Decls . (:[]) <$> do
+psciOtherDeclaration :: P.TokenParser C.Command
+psciOtherDeclaration = C.Decls . (:[]) <$> do
decl <- discardPositionInfo <$> P.parseDeclaration
if acceptable decl
then return decl
@@ -130,10 +123,3 @@ 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
deleted file mode 100644
index bc683c2..0000000
--- a/psci/Types.hs
+++ /dev/null
@@ -1,167 +0,0 @@
------------------------------------------------------------------------------
---
--- 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
deleted file mode 100644
index e430648..0000000
--- a/psci/main/Main.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main where
-
-import PSCi
-
-main :: IO ()
-main = runPSCi
diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs
deleted file mode 100644
index a703ca2..0000000
--- a/psci/tests/Main.hs
+++ /dev/null
@@ -1,137 +0,0 @@
-{-# 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 09c44d4..3de7978 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.6.9.4
+version: 0.6.9.5
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -148,12 +148,10 @@ executable psci
main-is: Main.hs
buildable: True
- hs-source-dirs: psci psci/main
- other-modules: Types
+ hs-source-dirs: psci
+ other-modules: Commands
Parser
Directive
- Completion
- PSCi
ghc-options: -Wall -O2
executable psc-docs
@@ -184,14 +182,3 @@ 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 609f5fb..d0d293f 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 MultipleErrors m, MonadReader (Options Compile) m)
+compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
=> [Module] -> [String] -> m (String, String, Environment)
compile = compile' initEnvironment
-compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)
+compile' :: (Functor m, Applicative m, MonadError String 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) <- runSupplyT 0 $ desugar sorted
+ (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted
(elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
- regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
+ regrouped <- interpretMultipleErrors True $ 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 MultipleErrors m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]
+generateMain :: (MonadError String 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 . errorMessage $ NameIsUndefined (Ident C.main)
+ throwError $ show mmi ++ "." ++ C.main ++ " is undefined"
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 MultipleErrors m) => MonadMake m where
+class (MonadReader (P.Options P.Make) m, MonadError String 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) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
+ (desugared, nextVar) <- interpretMultipleErrors True $ 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 <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
+ regrouped <- interpretMultipleErrors True . 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 . errorMessage . ErrorParsingExterns) return $ P.parseModulesFromFiles id [(externsFile, externs)]
+ externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]
case externsModules of
[m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
- _ -> throwError . errorMessage . InvalidExternsFile $ externsFile
+ _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"
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 065ef0b..f857fa0 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, [Type])]
+exportedDctors :: Module -> ProperName -> [ProperName]
exportedDctors (Module _ _ decls exps) ident =
- filter (isDctorExported ident exps . fst) dctors
+ filter (isDctorExported ident exps) dctors
where
dctors = concatMap getDctors (flattenDecls decls)
- getDctors (DataDeclaration _ _ _ ctors) = ctors
+ getDctors (DataDeclaration _ _ _ ctors) = map fst ctors
getDctors (PositionedDeclaration _ _ d) = getDctors d
getDctors _ = []
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index 454fbdb..97c3dc6 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -30,12 +30,10 @@ data SourcePos = SourcePos
-- Column number
--
, sourcePosColumn :: Int
- } deriving (Eq, Show, D.Data, D.Typeable)
+ } deriving (Eq, D.Data, D.Typeable)
-displaySourcePos :: SourcePos -> String
-displaySourcePos sp =
- "line " ++ show (sourcePosLine sp) ++
- ", column " ++ show (sourcePosColumn sp)
+instance Show SourcePos where
+ show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
data SourceSpan = SourceSpan
{ -- |
@@ -49,10 +47,7 @@ data SourceSpan = SourceSpan
-- End of the span
--
, spanEnd :: SourcePos
- } deriving (Eq, Show, D.Data, D.Typeable)
+ } deriving (Eq, D.Data, D.Typeable)
-displaySourceSpan :: SourceSpan -> String
-displaySourceSpan sp =
- spanName sp ++ " " ++
- displaySourcePos (spanStart sp) ++ " - " ++
- displaySourcePos (spanEnd sp)
+instance Show SourceSpan where
+ show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index ad27785..caf7017 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -84,28 +84,10 @@ inlineValues :: JS -> JS
inlineValues = everywhereOnJS convert
where
convert :: JS -> JS
- 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 (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 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
@@ -119,83 +101,58 @@ inlineOperator (m, op) f = everywhereOnJS convert
inlineCommonOperators :: JS -> JS
inlineCommonOperators = applyAll $
- [ 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
+ [ 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
] ++
[ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
where
- binary :: (String, String) -> String -> BinaryOperator -> JS -> JS
- binary dict opString op = everywhereOnJS convert
+ binary :: String -> String -> BinaryOperator -> JS -> JS
+ binary dictName opString op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y
+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y
convert other = other
- binary' :: String -> String -> BinaryOperator -> JS -> JS
- binary' moduleName opString op = everywhereOnJS convert
+ binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
+ binaryFunction dictName fnName op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y
+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y
convert other = other
- binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS
- binaryFunction dict fnName op = everywhereOnJS convert
+ unary :: String -> String -> UnaryOperator -> JS -> JS
+ unary dictName fnName op = everywhereOnJS convert
where
convert :: JS -> JS
- 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 (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x
convert other = other
mkFn :: Int -> JS -> JS
mkFn 0 = everywhereOnJS convert
@@ -233,62 +190,12 @@ inlineCommonOperators = applyAll $
go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
go _ _ _ = Nothing
-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
+isPreludeDict :: String -> JS -> Bool
+isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName
+isPreludeDict _ _ = False
isPreludeFn :: String -> JS -> Bool
-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)
+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
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
index eadc51f..4fc86fe 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
@@ -15,8 +15,6 @@
module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where
-import Data.Monoid
-
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST
@@ -32,13 +30,10 @@ 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
@@ -51,7 +46,6 @@ 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
@@ -62,35 +56,25 @@ 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 ++
@@ -110,19 +94,10 @@ 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') _) = ident == ident'
- isSelfCall ident (JSApp fn _) = isSelfCall ident fn
+ 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 _ _ = 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
+ isFunction :: JS -> Bool
+ isFunction (JSFunction _ _ _) = True
+ isFunction _ = False
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 6978e7b..51ba984 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -15,7 +15,7 @@
module Language.PureScript.Constants where
--- Operators
+-- Prelude Operators
($) :: String
($) = "$"
@@ -65,6 +65,15 @@ module Language.PureScript.Constants where
(/=) :: String
(/=) = "/="
+(.&.) :: String
+(.&.) = ".&."
+
+(.|.) :: String
+(.|.) = ".|."
+
+(.^.) :: String
+(.^.) = ".^."
+
(&&) :: String
(&&) = "&&"
@@ -74,32 +83,11 @@ module Language.PureScript.Constants where
unsafeIndex :: String
unsafeIndex = "unsafeIndex"
-(.|.) :: String
-(.|.) = ".|."
-
-(.&.) :: String
-(.&.) = ".&."
-
-(.^.) :: String
-(.^.) = ".^."
-
--- Functions
+-- Prelude Operator 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"
@@ -112,8 +100,8 @@ zshr = "zshr"
complement :: String
complement = "complement"
-fromNumber :: String
-fromNumber = "fromNumber"
+not :: String
+not = "not"
-- Prelude Values
@@ -123,12 +111,6 @@ zero = "zero"
one :: String
one = "one"
-bottom :: String
-bottom = "bottom"
-
-top :: String
-top = "top"
-
return :: String
return = "return"
@@ -190,47 +172,32 @@ bindEffDictionary = "bindEff"
semiringNumber :: String
semiringNumber = "semiringNumber"
-semiringInt :: String
-semiringInt = "semiringInt"
-
ringNumber :: String
ringNumber = "ringNumber"
-ringInt :: String
-ringInt = "ringInt"
-
moduloSemiringNumber :: String
moduloSemiringNumber = "moduloSemiringNumber"
-moduloSemiringInt :: String
-moduloSemiringInt = "moduloSemiringInt"
+numNumber :: String
+numNumber = "numNumber"
ordNumber :: String
ordNumber = "ordNumber"
-ordInt :: String
-ordInt = "ordInt"
-
eqNumber :: String
eqNumber = "eqNumber"
-eqInt :: String
-eqInt = "eqInt"
-
eqString :: String
eqString = "eqString"
eqBoolean :: String
eqBoolean = "eqBoolean"
-boundedBoolean :: String
-boundedBoolean = "boundedBoolean"
-
-latticeBoolean :: String
-latticeBoolean = "latticeBoolean"
+bitsNumber :: String
+bitsNumber = "bitsNumber"
-complementedLatticeBoolean :: String
-complementedLatticeBoolean = "complementedLatticeBoolean"
+boolLikeBoolean :: String
+boolLikeBoolean = "boolLikeBoolean"
semigroupString :: String
semigroupString = "semigroupString"
@@ -270,9 +237,3 @@ 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 617e49b..07d8b19 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -36,19 +36,11 @@ import Language.PureScript.TypeClassDictionaries
import qualified Text.PrettyPrint.Boxes as Box
-import qualified Text.Parsec as P
-
-- |
-- A type of error messages
--
data ErrorMessage
- = ErrorParsingExterns P.ParseError
- | ErrorParsingPrelude P.ParseError
- | InvalidExternsFile FilePath
- | CannotGetFileInfo FilePath
- | CannotReadFile FilePath
- | CannotWriteFile FilePath
- | InfiniteType Type
+ = InfiniteType Type
| InfiniteKind Kind
| CannotReorderOperators
| MultipleFixities Ident
@@ -78,7 +70,6 @@ data ErrorMessage
| InvalidDoLet
| CycleInDeclaration Ident
| CycleInTypeSynonym (Maybe ProperName)
- | CycleInModules [ModuleName]
| NameIsUndefined Ident
| NameNotInScope Ident
| UndefinedTypeVariable ProperName
@@ -135,12 +126,6 @@ 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"
@@ -171,7 +156,6 @@ errorCode InvalidDoBind = "InvalidDoBind"
errorCode InvalidDoLet = "InvalidDoLet"
errorCode (CycleInDeclaration _) = "CycleInDeclaration"
errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"
-errorCode (CycleInModules _) = "CycleInModules"
errorCode (NameIsUndefined _) = "NameIsUndefined"
errorCode (NameNotInScope _) = "NameNotInScope"
errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"
@@ -193,13 +177,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
@@ -261,24 +245,6 @@ 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"
@@ -312,7 +278,6 @@ 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
]
@@ -439,7 +404,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 srcSpan err) = paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":"
+ go (PositionedError pos err) = paras [ line $ "Error at " ++ show pos ++ ":"
, indent $ go err
]
@@ -525,8 +490,8 @@ renderBox = unlines . map trimEnd . lines . Box.render
-- |
-- Interpret multiple errors in a monad supporting errors
--
-interpretMultipleErrors :: (MonadError MultipleErrors m) => Either MultipleErrors a -> m a
-interpretMultipleErrors = either throwError return
+interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a
+interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) 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 177ae6c..1af1ab4 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -28,7 +28,6 @@ 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
@@ -40,7 +39,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]
--
-- Reports an error if the module graph contains a cycle.
--
-sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
+sortModules :: (MonadError String 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
@@ -71,7 +70,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (
-- |
-- Convert a strongly connected component of the module graph to a module
--
-toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module
+toModule :: (MonadError String m) => SCC Module -> m Module
toModule (AcyclicSCC m) = return m
toModule (CyclicSCC [m]) = return m
-toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)
+toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms)
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index d4f8a5b..3135be1 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -126,7 +126,9 @@ parseNameAndType :: TokenParser t -> TokenParser (String, t)
parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p
parseRowEnding :: TokenParser Type
-parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType
+parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> P.choice (map P.try
+ [ parseTypeWildcard
+ , TypeVar <$> identifier ])
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 8c5efb3..b5e311b 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -157,6 +157,7 @@ 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 829bb04..ce5c0bc 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -25,7 +25,7 @@ import Data.Maybe (catMaybes)
import Data.List (nub, groupBy)
import Control.Applicative
-import Control.Monad ((<=<), forM, replicateM, join, unless)
+import Control.Monad ((<=<), forM, join, unless, replicateM)
import Control.Monad.Except (throwError)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.Supply.Class
@@ -130,20 +130,12 @@ makeCaseDeclaration ident alternatives = do
value = foldr (Abs . Left) (Case vars binders) args
return $ ValueDeclaration ident Value [] (Right value)
where
- -- 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)
@@ -153,15 +145,11 @@ makeCaseDeclaration ident alternatives = do
name <- freshName
return (Ident name)
- -- 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
- -- Resolve a pair of names. VarBinder beats NullBinder, and everything
- -- else results in Nothing.
resolveName :: Maybe (Maybe Ident) ->
Maybe (Maybe Ident) ->
Maybe (Maybe Ident)
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 966fa1d..9667655 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -44,8 +44,11 @@ desugarDo d =
let (f, _, _) = everywhereOnValuesM return replace return
in f d
where
+ prelude :: ModuleName
+ prelude = ModuleName [ProperName C.prelude]
+
bind :: Expr
- bind = Var (Qualified Nothing (Op (C.>>=)))
+ bind = Var (Qualified (Just prelude) (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 be5e2d7..75b9b42 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 $ nub (map fst ds)
+ ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys (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 03b80f2..84aab4a 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -23,6 +23,7 @@ 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
@@ -30,6 +31,7 @@ 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
@@ -96,19 +98,12 @@ bindLocalTypeVariables moduleName bindings =
-- |
-- Update the visibility of all names to Defined
--
-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)
+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) } }
a <- action
- modifyEnv $ \e -> e { names = orig }
+ modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
return a
-- |
@@ -200,16 +195,18 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
-- |
-- Run a computation in the Check monad, starting with an empty @Environment@
--
-runCheck :: (MonadError MultipleErrors m) => Check a -> m (a, Environment)
+runCheck :: (MonadReader (Options mode) m, MonadError String 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' :: (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)
+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)
-- |
-- 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 9f5da02..b83d80f 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
- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
+ makeBindingGroupVisible $ 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 <$> withBindingGroupVisible (j ret)
+inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (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,9 +320,7 @@ 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']
- bindNames dict $ do
- makeBindingGroupVisible
- inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
+ makeBindingGroupVisible $ bindNames dict $ 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')
@@ -444,7 +442,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' <- withBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
+ val' <- makeBindingGroupVisible $ 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
@@ -470,7 +468,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' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy
+ ret' <- makeBindingGroupVisible $ 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 5c998ee..e7ac794 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 P.MultipleErrors (String, String, P.Environment)
+loadPrelude :: Either String (String, String, P.Environment)
loadPrelude =
case P.parseModulesFromFiles id [("", P.prelude)] of
- Left parseError -> Left . P.errorMessage . P.ErrorParsingPrelude $ parseError
+ Left parseError -> Left (show parseError)
Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }
-compile :: P.Options P.Compile -> [FilePath] -> IO (Either P.MultipleErrors (String, String, P.Environment))
+compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))
compile opts inputFiles = do
modules <- P.parseModulesFromFiles id <$> readInput inputFiles
case modules of
Left parseError ->
- return . Left . P.errorMessage . P.ErrorParsingPrelude $ parseError
+ return (Left $ show parseError)
Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts
-assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
+assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (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 . P.prettyPrintMultipleErrors False) $ \(js, _, _) -> do
+ assert preludeExterns options inputFile $ either (return . Just) $ \(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 errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
+ Left err -> putStrLn err >> 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 errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
+ Left err -> putStrLn err >> exitFailure
Right (preludeJs, exts, _) -> do
tmp <- getTemporaryDirectory
let preludeExterns = tmp ++ pathSeparator : "prelude.externs"
@@ -105,3 +105,4 @@ main = do
forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)
exitSuccess
+