summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2015-03-18 00:08:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-03-18 00:08:00 (GMT)
commit60cc603d9533094f3e224517801af909e62f0c5a (patch)
tree76b7cf0e32fa5b4c78aa223093cf3693ab13f3c5
parentce534e93c9b8ca5318d48b274a455af79fe594ed (diff)
version 0.6.90.6.9
-rw-r--r--LICENSE62
-rw-r--r--examples/passing/InstanceBeforeClass.purs9
-rw-r--r--examples/passing/OperatorAssociativity.purs16
-rw-r--r--examples/passing/SequenceDesugared.purs34
-rw-r--r--hierarchy/Main.hs2
-rw-r--r--prelude/prelude.purs404
-rw-r--r--psc-docs/Main.hs43
-rw-r--r--psc-make/Main.hs2
-rw-r--r--psc/Main.hs2
-rw-r--r--psci/Commands.hs33
-rw-r--r--psci/Main.hs185
-rw-r--r--psci/Parser.hs139
-rw-r--r--purescript.cabal8
-rw-r--r--src/Control/Monad/Supply.hs (renamed from src/Language/PureScript/Supply.hs)27
-rw-r--r--src/Control/Monad/Supply/Class.hs36
-rw-r--r--src/Control/Monad/Unify.hs16
-rw-r--r--src/Language/PureScript.hs64
-rw-r--r--src/Language/PureScript/AST/Declarations.hs34
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs4
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs4
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs580
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs13
-rw-r--r--src/Language/PureScript/CoreFn/Module.hs4
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs4
-rw-r--r--src/Language/PureScript/Errors.hs559
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs2
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs22
-rw-r--r--src/Language/PureScript/Pretty/JS.hs28
-rw-r--r--src/Language/PureScript/Pretty/Values.hs6
-rw-r--r--src/Language/PureScript/Renamer.hs2
-rw-r--r--src/Language/PureScript/Sugar.hs17
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs35
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs56
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs21
-rw-r--r--src/Language/PureScript/Sugar/Names.hs195
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs18
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs40
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs43
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs19
-rw-r--r--src/Language/PureScript/TypeChecker.hs96
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs47
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs11
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs26
-rw-r--r--src/Language/PureScript/TypeChecker/Rows.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs5
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs11
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs24
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs60
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs15
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs23
-rw-r--r--tests/Main.hs2
51 files changed, 2077 insertions, 1033 deletions
diff --git a/LICENSE b/LICENSE
index cbb46c0..c7a284a 100644
--- a/LICENSE
+++ b/LICENSE
@@ -37,6 +37,8 @@ PureScript uses the following Haskell library packages. Their license files foll
transformers
unordered-containers
utf8-string
+ split
+ boxes
base LICENSE file:
@@ -620,3 +622,63 @@ utf8-string LICENSE file:
* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+split LICENSE file:
+
+ Copyright (c) 2008 Brent Yorgey, Louis Wasserman
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ 3. Neither the name of the author nor the names of other contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ SUCH DAMAGE.
+
+boxes LICENSE file:
+
+ Copyright (c) Brent Yorgey 2008
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ 3. Neither the name of the author nor the names of other contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ All other rights are reserved.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ SUCH DAMAGE.
diff --git a/examples/passing/InstanceBeforeClass.purs b/examples/passing/InstanceBeforeClass.purs
new file mode 100644
index 0000000..837df05
--- /dev/null
+++ b/examples/passing/InstanceBeforeClass.purs
@@ -0,0 +1,9 @@
+module Main where
+
+instance fooNumber :: Foo Number where
+ foo = 0
+
+class Foo a where
+ foo :: a
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/OperatorAssociativity.purs b/examples/passing/OperatorAssociativity.purs
index 715be7e..9ee7a5d 100644
--- a/examples/passing/OperatorAssociativity.purs
+++ b/examples/passing/OperatorAssociativity.purs
@@ -40,3 +40,19 @@ main = do
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"
+ assert (10 * 5 - 1 == 49) "10 * 5 - 1 == 49"
+
+ trace "Success!"
diff --git a/examples/passing/SequenceDesugared.purs b/examples/passing/SequenceDesugared.purs
new file mode 100644
index 0000000..101b8f8
--- /dev/null
+++ b/examples/passing/SequenceDesugared.purs
@@ -0,0 +1,34 @@
+module Main where
+
+import Control.Monad.Eff
+
+data Sequence t = Sequence (forall m a. (Monad m) => t (m a) -> m (t a))
+
+sequence :: forall t. Sequence t -> (forall m a. (Monad m) => t (m a) -> m (t a))
+sequence (Sequence s) = s
+
+sequenceArraySeq :: forall m a. (Monad m) => Array (m a) -> m (Array a)
+sequenceArraySeq [] = pure []
+sequenceArraySeq (x:xs) = (:) <$> x <*> sequenceArraySeq xs
+
+sequenceArray :: Sequence []
+sequenceArray = Sequence (sequenceArraySeq)
+
+sequenceArray' :: Sequence []
+sequenceArray' = Sequence ((\val -> case val of
+ [] -> pure []
+ (x:xs) -> (:) <$> x <*> sequence sequenceArray' xs))
+
+sequenceArray'' :: Sequence []
+sequenceArray'' = Sequence (sequenceArraySeq :: forall m a. (Monad m) => Array (m a) -> m (Array a))
+
+sequenceArray''' :: Sequence []
+sequenceArray''' = Sequence ((\val -> case val of
+ [] -> pure []
+ (x:xs) -> (:) <$> x <*> sequence sequenceArray''' xs) :: forall m a. (Monad m) => Array (m a) -> m (Array a))
+
+main = do
+ sequence sequenceArray $ [Debug.Trace.trace "Done"]
+ sequence sequenceArray' $ [Debug.Trace.trace "Done"]
+ sequence sequenceArray'' $ [Debug.Trace.trace "Done"]
+ sequence sequenceArray''' $ [Debug.Trace.trace "Done"]
diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs
index 5393a84..3828fd2 100644
--- a/hierarchy/Main.hs
+++ b/hierarchy/Main.hs
@@ -64,7 +64,7 @@ compile (HierarchyOptions input mOutput) = do
case modules of
Left err -> hPutStr stderr (show err) >> exitFailure
Right ms -> do
- for_ ms $ \(P.Module moduleName decls _) ->
+ for_ ms $ \(P.Module _ moduleName decls _) ->
let name = runModuleName moduleName
tcs = filter P.isTypeClassDeclaration decls
supers = sort . nub . filter (not . null) $ fmap superClasses tcs
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index ceb99e0..1531461 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -20,7 +20,7 @@ module Prelude
, negate
, DivisionRing
, Num
- , Eq, (==), (/=), refEq, refIneq
+ , Eq, (==), (/=)
, Ord, Ordering(..), compare, (<), (>), (<=), (>=)
, Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement
, BoolLike, (&&), (||)
@@ -31,27 +31,38 @@ module Prelude
-- | An alias for `true`, which can be useful in guard clauses:
-- |
- -- | E.g.
+ -- | ```purescript
+ -- | max x y | x >= y = x
+ -- | | otherwise = y
+ -- | ```
-- |
- -- | max x y | x >= y = x
- -- | | otherwise = y
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
-- | Returns its first argument and ignores its second.
+ -- |
+ -- | ```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.
-- |
- -- | E.g.
- -- |
- -- | main = print $ [] `asTypeOf` [0]
+ -- | ```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.
@@ -61,15 +72,33 @@ module Prelude
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
@@ -79,17 +108,57 @@ module Prelude
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, 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.
+ -- |
+ -- | ```purescript
+ -- | cons 1 [2, 3, 4] = [1, 2, 3, 4]
+ -- | ```
+ -- |
+ -- | Note, the running time of this function is `O(n)`.
foreign import cons
"""
function cons(e) {
@@ -99,6 +168,10 @@ module Prelude
}
""" :: forall a. a -> [a] -> [a]
+ -- | The `Show` type class represents those types which can be converted into a human-readable `String` representation.
+ -- |
+ -- | While not required, it is recommended that for any expression `x`, the string `show x` be executable PureScript code
+ -- | which evaluates to the same value as the expression `x`.
class Show a where
show :: a -> String
@@ -148,41 +221,166 @@ module Prelude
infixl 4 <$>
infixl 1 <#>
+ -- | 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.
+ -- |
+ -- | `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
+ -- | `(<#>)` is `(<$>)` with its arguments reversed. For example:
+ -- |
+ -- | ```purescript
+ -- | [1, 2, 3] <#> \n -> n * n
+ -- | ```
(<#>) :: 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.
+ -- |
+ -- | `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
+ -- | print n
+ -- | print (n * n)
+ -- | ```
void :: forall f a. (Functor f) => f a -> f Unit
void fa = const unit <$> fa
infixl 4 <*>
+ -- | 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:
+ -- |
+ -- | ```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`.
+ -- |
+ -- | `Apply` instances should satisfy the following law:
+ -- |
+ -- | - Associative Composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
+ -- |
+ -- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.
class (Functor f) <= Apply f where
(<*>) :: forall a b. f (a -> b) -> f a -> f b
+ -- | The `Applicative` type class extends the [`Apply`](#apply) type class with a `pure` function, which can be used to
+ -- | create values of type `f a` from values of type `a`.
+ -- |
+ -- | Where [`Apply`](#apply) provides the ability to lift functions of two or more arguments to functions whose arguments are wrapped using `f`,
+ -- | and [`Functor`](#functor) provides the ability to lift functions of one argument, `pure` can be seen as the function which lifts functions of
+ -- | _zero_ arguments. That is, `Applicative` functors support a lifting operation for any number of function arguments.
+ -- |
+ -- | `Applicative` instances should satisfy the following laws:
+ -- |
+ -- | - Identity: `(pure id) <*> v = v`
+ -- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`
+ -- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`
+ -- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`
+ -- |
class (Apply f) <= Applicative f where
pure :: forall a. a -> f a
+ -- | `liftA1` provides a default implementation of `(<$>)` for any [`Applicative`](#applicative) functor,
+ -- | without using `(<$>)` as provided by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass relationship.
+ -- |
+ -- | `liftA1` can therefore be used to write [`Functor`](#functor) instances as follows:
+ -- |
+ -- | ```purescript
+ -- | instance functorF :: Functor F where
+ -- | (<$>) = liftA1
+ -- | ```
liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
liftA1 f a = pure f <*> a
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 `>>=` operator can also be expressed using `do` notation, as follows:
+ -- |
+ -- | ```purescript
+ -- | x >>= f = do y <- x
+ -- | f y
+ -- | ```
+ -- |
+ -- | where the function argument of `f` is given the name `y`.
+ -- |
+ -- | `Bind` instances should satisfy the following law:
+ -- |
+ -- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`
+ -- |
+ -- | Or, expressed using `do` notation:
+ -- |
+ -- | - Associativity: `do { z <- do { y <- x ; f y } ; g z } = do { k <- x ; do { y <- f k ; g y } }`
+ -- |
+ -- | Associativity tells us that we can regroup operations which use do-notation, so that we can unambiguously write, for example:
+ -- |
+ -- | ```purescript
+ -- | do x <- m1
+ -- | y <- m2 x
+ -- | m3 x y
+ -- | ```
class (Apply m) <= Bind m where
(>>=) :: forall a b. m a -> (a -> m b) -> m b
+ -- | The `Monad` type class combines the operations of the `Bind` and `Applicative` type classes. Therefore, `Monad` instances
+ -- | represent type constructors which support sequential composition, and also lifting of functions of arbitrary arity.
+ -- |
+ -- | `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
+ -- | `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` can therefore be used to write [`Functor`](#functor) instances as follows:
+ -- |
+ -- | ```purescript
+ -- | instance functorF :: Functor F where
+ -- | (<$>) = liftM1
+ -- | ```
liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
liftM1 f a = do
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` can therefore be used to write [`Apply`](#apply) instances as follows:
+ -- |
+ -- | ```purescript
+ -- | instance applyF :: Apply F where
+ -- | (<*>) = ap
+ -- | ```
ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
ap f a = do
f' <- f
@@ -210,28 +408,43 @@ module Prelude
infixl 6 -
infixl 6 +
- -- | Addition and multiplication
+ -- | 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
- -- | Semiring with modulo operation and division where
- -- | ```a / b * b + (a `mod` b) = a```
+ -- | Addition, multiplication, modulo operation and division, satisfying:
+ -- |
+ -- | - ```a / b * b + (a `mod` b) = a```
+ -- |
class (Semiring a) <= ModuloSemiring a where
(/) :: a -> a -> a
mod :: a -> a -> a
- -- | Addition, multiplication, and subtraction
+ -- | Addition, multiplication, and subtraction.
+ -- |
+ -- | Has the same laws as `Semiring` but additionally satisfying:
+ -- |
+ -- | - `a` is an abelian group under addition
+ -- |
class (Semiring a) <= Ring a where
(-) :: a -> a -> a
negate :: forall a. (Ring a) => a -> a
negate a = zero - a
- -- | Ring where every nonzero element has a multiplicative inverse (possibly
- -- | a non-commutative field) so that ```a `mod` b = zero```
+ -- | Ring where every nonzero element has a multiplicative inverse so that:
+ -- |
+ -- | - ```a `mod` b = zero```
+ -- |
class (Ring a, ModuloSemiring a) <= DivisionRing a
-- | A commutative field
@@ -301,14 +514,29 @@ module Prelude
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 /=
+ -- | The `Eq` type class represents types which support decidable equality.
+ -- |
+ -- | `Eq` instances should satisfy the following laws:
+ -- |
+ -- | - Reflexivity: `x == x = true`
+ -- | - Symmetry: `x == y = y == x`
+ -- | - Transitivity: if `x == y` and `y == z` then `x == z`
+ -- | - Negation: `x /= y = not (x == y)`
+ -- |
+ -- | `(/=)` may be implemented in terms of `(==)`, but it might give a performance improvement to implement it separately.
class Eq a where
(==) :: a -> a -> Boolean
(/=) :: a -> a -> Boolean
@@ -366,6 +594,11 @@ module Prelude
(==) 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
@@ -380,11 +613,25 @@ module Prelude
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_:
+ -- |
+ -- | - 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
infixl 4 <
+ -- | Test whether one value is _strictly less than_ another.
(<) :: forall a. (Ord a) => a -> a -> Boolean
(<) a1 a2 = case a1 `compare` a2 of
LT -> true
@@ -392,6 +639,7 @@ module Prelude
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
@@ -399,6 +647,7 @@ module Prelude
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
@@ -406,6 +655,7 @@ module Prelude
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
@@ -456,6 +706,7 @@ module Prelude
infixl 10 .|.
infixl 10 .^.
+ -- | The `Bits` type class identifies types which support bitwise operations.
class Bits b where
(.&.) :: b -> b -> b
(.|.) :: b -> b -> b
@@ -538,6 +789,10 @@ module Prelude
infixr 2 ||
infixr 3 &&
+ -- | 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
@@ -575,6 +830,13 @@ module Prelude
infixr 5 <>
+ -- | 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
@@ -598,26 +860,57 @@ module Prelude
infixr 5 ++
+ -- | `(++)` is an alias for `(<>)`.
(++) :: forall s. (Semigroup s) => s -> s -> s
(++) = (<>)
module Data.Function where
+ -- | The `on` function is used to change the domain of a binary operator.
+ -- |
+ -- | For example, we can create a function which compares two records based on the values of their `x` properties:
+ -- |
+ -- | ```purescript
+ -- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering
+ -- | compareX = compare `on` _.x
+ -- | ```
on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
on f g x y = g x `f` g y
+ -- | A function of zero arguments
foreign import data Fn0 :: * -> *
+
+ -- | A function of one argument
foreign import data Fn1 :: * -> * -> *
+
+ -- | A function of two arguments
foreign import data Fn2 :: * -> * -> * -> *
+
+ -- | A function of three arguments
foreign import data Fn3 :: * -> * -> * -> * -> *
+
+ -- | A function of four arguments
foreign import data Fn4 :: * -> * -> * -> * -> * -> *
+
+ -- | A function of five arguments
foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
+
+ -- | A function of six arguments
foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
+
+ -- | A function of seven arguments
foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
+
+ -- | A function of eight arguments
foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
+
+ -- | A function of nine arguments
foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
+
+ -- | A function of ten arguments
foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
+ -- | Create a function of no arguments
foreign import mkFn0
"""
function mkFn0(fn) {
@@ -627,6 +920,7 @@ module Data.Function where
}
""" :: forall a. (Unit -> a) -> Fn0 a
+ -- | Create a function of one argument
foreign import mkFn1
"""
function mkFn1(fn) {
@@ -636,6 +930,7 @@ module Data.Function where
}
""" :: forall a b. (a -> b) -> Fn1 a b
+ -- | Create a function of two arguments from a curried function
foreign import mkFn2
"""
function mkFn2(fn) {
@@ -645,6 +940,7 @@ module Data.Function where
}
""" :: forall a b c. (a -> b -> c) -> Fn2 a b c
+ -- | Create a function of three arguments from a curried function
foreign import mkFn3
"""
function mkFn3(fn) {
@@ -654,6 +950,7 @@ module Data.Function where
}
""" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
+ -- | Create a function of four arguments from a curried function
foreign import mkFn4
"""
function mkFn4(fn) {
@@ -663,6 +960,7 @@ module Data.Function where
}
""" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
+ -- | Create a function of five arguments from a curried function
foreign import mkFn5
"""
function mkFn5(fn) {
@@ -672,6 +970,7 @@ module Data.Function where
}
""" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
+ -- | Create a function of six arguments from a curried function
foreign import mkFn6
"""
function mkFn6(fn) {
@@ -681,6 +980,7 @@ module Data.Function where
}
""" :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
+ -- | Create a function of seven arguments from a curried function
foreign import mkFn7
"""
function mkFn7(fn) {
@@ -690,6 +990,7 @@ module Data.Function where
}
""" :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
+ -- | Create a function of eight arguments from a curried function
foreign import mkFn8
"""
function mkFn8(fn) {
@@ -699,6 +1000,7 @@ module Data.Function where
}
""" :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
+ -- | Create a function of nine arguments from a curried function
foreign import mkFn9
"""
function mkFn9(fn) {
@@ -708,6 +1010,7 @@ module Data.Function where
}
""" :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
+ -- | Create a function of ten arguments from a curried function
foreign import mkFn10
"""
function mkFn10(fn) {
@@ -717,6 +1020,7 @@ module Data.Function where
}
""" :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
+ -- | Apply a function of no arguments
foreign import runFn0
"""
function runFn0(fn) {
@@ -724,6 +1028,7 @@ module Data.Function where
}
""" :: forall a. Fn0 a -> a
+ -- | Apply a function of one argument
foreign import runFn1
"""
function runFn1(fn) {
@@ -733,6 +1038,7 @@ module Data.Function where
}
""" :: forall a b. Fn1 a b -> a -> b
+ -- | Apply a function of two arguments
foreign import runFn2
"""
function runFn2(fn) {
@@ -744,6 +1050,7 @@ module Data.Function where
}
""" :: forall a b c. Fn2 a b c -> a -> b -> c
+ -- | Apply a function of three arguments
foreign import runFn3
"""
function runFn3(fn) {
@@ -757,6 +1064,7 @@ module Data.Function where
}
""" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
+ -- | Apply a function of four arguments
foreign import runFn4
"""
function runFn4(fn) {
@@ -772,6 +1080,7 @@ module Data.Function where
}
""" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
+ -- | Apply a function of five arguments
foreign import runFn5
"""
function runFn5(fn) {
@@ -789,6 +1098,7 @@ module Data.Function where
}
""" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
+ -- | Apply a function of six arguments
foreign import runFn6
"""
function runFn6(fn) {
@@ -808,6 +1118,7 @@ module Data.Function where
}
""" :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
+ -- | Apply a function of seven arguments
foreign import runFn7
"""
function runFn7(fn) {
@@ -829,6 +1140,7 @@ module Data.Function where
}
""" :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
+ -- | Apply a function of eight arguments
foreign import runFn8
"""
function runFn8(fn) {
@@ -852,6 +1164,7 @@ module Data.Function where
}
""" :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
+ -- | Apply a function of nine arguments
foreign import runFn9
"""
function runFn9(fn) {
@@ -877,6 +1190,7 @@ module Data.Function where
}
""" :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
+ -- | Apply a function of ten arguments
foreign import runFn10
"""
function runFn10(fn) {
@@ -906,6 +1220,9 @@ module Data.Function where
module Prelude.Unsafe where
+ -- | Find the element of an array at the specified index.
+ -- |
+ -- | Note: this function can cause unpredictable failure at runtime if the index is out-of-bounds.
foreign import unsafeIndex
"""
function unsafeIndex(xs) {
@@ -915,8 +1232,18 @@ module Prelude.Unsafe where
}
""" :: forall a. [a] -> Number -> a
-module Control.Monad.Eff where
+module Control.Monad.Eff
+ ( Eff()
+ , Pure()
+ , runPure
+ , untilE, whileE, forE, foreachE
+ ) where
+ -- | The `Eff` type constructor is used to represent _native_ effects.
+ -- |
+ -- | See [Handling Native Effects with the Eff Monad](https://github.com/purescript/purescript/wiki/Handling-Native-Effects-with-the-Eff-Monad) for more details.
+ -- |
+ -- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type.
foreign import data Eff :: # ! -> * -> *
foreign import returnE
@@ -939,8 +1266,15 @@ module Control.Monad.Eff where
}
""" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
+ -- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled.
+ -- |
+ -- | The `runPure` function can be used to run pure computations and obtain their result.
type Pure a = forall e. Eff e a
+ -- | Run a pure computation and return its result.
+ -- |
+ -- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
+ -- | is to use parentheses instead.
foreign import runPure
"""
function runPure(f) {
@@ -962,6 +1296,10 @@ module Control.Monad.Eff where
instance monadEff :: Monad (Eff e)
+ -- | Loop until a condition becomes `true`.
+ -- |
+ -- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`,
+ -- | until its return value is `true`.
foreign import untilE
"""
function untilE(f) {
@@ -972,6 +1310,10 @@ module Control.Monad.Eff where
}
""" :: forall e. Eff e Boolean -> Eff e Unit
+ -- | Loop while a condition is `true`.
+ -- |
+ -- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is
+ -- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends.
foreign import whileE
"""
function whileE(f) {
@@ -986,6 +1328,10 @@ module Control.Monad.Eff where
}
""" :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
+ -- | Loop over a consecutive collection of numbers.
+ -- |
+ -- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs
+ -- | between `lo` (inclusive) and `hi` (exclusive).
foreign import forE
"""
function forE(lo) {
@@ -1001,7 +1347,9 @@ module Control.Monad.Eff where
}
""" :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
-
+ -- | Loop over an array of values.
+ -- |
+ -- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`.
foreign import foreachE
"""
function foreachE(as) {
@@ -1019,6 +1367,9 @@ module Control.Monad.Eff.Unsafe where
import Control.Monad.Eff
+ -- | Change the type of an effectful computation, allowing it to be run in another context.
+ -- |
+ -- | Note: use of this function can result in arbitrary side-effects.
foreign import unsafeInterleaveEff
"""
function unsafeInterleaveEff(f) {
@@ -1030,8 +1381,10 @@ module Debug.Trace where
import Control.Monad.Eff
+ -- | The `Trace` effect represents those computations which write to the console.
foreign import data Trace :: !
+ -- | Write a `String` to the console.
foreign import trace
"""
function trace(s) {
@@ -1042,6 +1395,7 @@ module Debug.Trace where
}
""" :: forall r. String -> Eff (trace :: Trace | r) Unit
+ -- | Write a value to the console, using its `Show` instance to produce a `String`.
print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
print o = trace (show o)
@@ -1049,10 +1403,17 @@ module Control.Monad.ST where
import Control.Monad.Eff
+ -- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation.
+ -- |
+ -- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access.
+ -- |
+ -- | The `runST` function can be used to handle the `ST` effect.
foreign import data ST :: * -> !
+ -- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect.
foreign import data STRef :: * -> * -> *
+ -- | Create a new mutable reference.
foreign import newSTRef
"""
function newSTRef(val) {
@@ -1062,6 +1423,7 @@ module Control.Monad.ST where
}
""" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
+ -- | Read the current value of a mutable reference.
foreign import readSTRef
"""
function readSTRef(ref) {
@@ -1071,6 +1433,7 @@ module Control.Monad.ST where
}
""" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
+ -- | Modify the value of a mutable reference by applying a function to the current value.
foreign import modifySTRef
"""
function modifySTRef(ref) {
@@ -1082,6 +1445,7 @@ module Control.Monad.ST where
}
""" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
+ -- | Set the value of a mutable reference.
foreign import writeSTRef
"""
function writeSTRef(ref) {
@@ -1093,6 +1457,12 @@ module Control.Monad.ST where
}
""" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
+ -- | Run an `ST` computation.
+ -- |
+ -- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references
+ -- | to the surrounding computation.
+ -- |
+ -- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead.
foreign import runST
"""
function runST(f) {
@@ -1100,5 +1470,9 @@ module Control.Monad.ST where
}
""" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
+ -- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`.
+ -- |
+ -- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
+ -- | is to use parentheses instead.
pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
pureST st = runPure (runST st)
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index 41113f2..9255880 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -30,21 +30,37 @@ import qualified Paths_purescript as Paths
import System.Exit (exitSuccess, exitFailure)
import System.IO (hPutStrLn, stderr)
+import Etags
+import Ctags
+
+-- Available output formats
+data Format = Markdown -- Output documentation in Markdown format
+ | Ctags -- Output ctags symbol index suitable for use with vi
+ | Etags -- Output etags symbol index suitable for use with emacs
+
data PSCDocsOptions = PSCDocsOptions
- { pscdInputFiles :: [FilePath]
+ { pscdFormat :: Format
+ , pscdInputFiles :: [FilePath]
}
docgen :: PSCDocsOptions -> IO ()
-docgen (PSCDocsOptions input) = do
+docgen (PSCDocsOptions fmt input) = do
e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
case e of
Left err -> do
hPutStrLn stderr $ show err
exitFailure
Right ms -> do
- putStrLn . runDocs $ renderModules (map snd ms)
+ case fmt of
+ Markdown -> putStrLn . runDocs $ renderModules (map snd ms)
+ Etags -> ldump $ dumpEtags $ pairs ms
+ Ctags -> ldump $ dumpCtags $ pairs ms
exitSuccess
-
+ where pairs :: [(Maybe String, m)] -> [(String, m)]
+ pairs = map (\(k,m) -> (fromMaybe "" k,m))
+ ldump :: [String] -> IO ()
+ ldump = mapM_ putStrLn
+
parseFile :: FilePath -> IO (FilePath, String)
parseFile input = (,) input <$> readFile input
@@ -86,9 +102,12 @@ renderModules ms = do
mapM_ renderModule ms
renderModule :: P.Module -> Docs
-renderModule mdl@(P.Module moduleName _ exps) = do
+renderModule mdl@(P.Module coms moduleName _ exps) = do
headerLevel 2 $ "Module " ++ P.runModuleName moduleName
spacer
+ unless (null coms) $ do
+ renderComments coms
+ spacer
renderTopLevel exps (P.exportedDeclarations mdl)
spacer
@@ -219,8 +238,20 @@ inputFile = strArgument $
metavar "FILE"
<> help "The input .purs file(s)"
+instance Read Format where
+ readsPrec _ "etags" = [(Etags, "")]
+ readsPrec _ "ctags" = [(Ctags, "")]
+ readsPrec _ "markdown" = [(Markdown, "")]
+ readsPrec _ _ = []
+
+format :: Parser Format
+format = option auto $ value Markdown
+ <> long "format"
+ <> metavar "FORMAT"
+ <> help "Set output FORMAT (markdown | etags | ctags)"
+
pscDocsOptions :: Parser PSCDocsOptions
-pscDocsOptions = PSCDocsOptions <$> many inputFile
+pscDocsOptions = PSCDocsOptions <$> format <*> many inputFile
main :: IO ()
main = execParser opts >>= docgen
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index 2bf5ced..547f627 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -155,7 +155,7 @@ options = P.Options <$> noPrelude
<*> noMagicDo
<*> pure Nothing
<*> noOpts
- <*> comments
+ <*> (not <$> comments)
<*> verboseErrors
<*> pure P.MakeOptions
diff --git a/psc/Main.hs b/psc/Main.hs
index 25709a1..6be836d 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -180,7 +180,7 @@ options = P.Options <$> noPrelude
<*> runMain
<*> noOpts
<*> verboseErrors
- <*> comments
+ <*> (not <$> comments)
<*> additionalOptions
where
additionalOptions =
diff --git a/psci/Commands.hs b/psci/Commands.hs
index 49bc820..e7a8025 100644
--- a/psci/Commands.hs
+++ b/psci/Commands.hs
@@ -32,7 +32,7 @@ data Command
-- |
-- Import a module from a loaded file
--
- | Import ModuleName
+ | Import ImportedModule
-- |
-- Browse a module
--
@@ -50,9 +50,9 @@ data Command
--
| Reset
-- |
- -- Binds a value to a name
+ -- Add some declarations to the current evaluation context.
--
- | Let [Declaration]
+ | Decls [Declaration]
-- |
-- Find the type of an expression
--
@@ -66,22 +66,13 @@ data Command
--
| Show String
--- |
--- The help menu.
+-- | All of the data that is contained by an ImportDeclaration in the AST.
+-- That is:
--
-help :: [(String, String, String)]
-help =
- [ (":?", "", "Show this help menu")
- , (":i", "<module>", "Import <module> for use in PSCI")
- , (":b", "<module>", "Browse <module>")
- , (":m", "<file>", "Load <file> for importing")
- , (":q", "", "Quit PSCi")
- , (":r", "", "Reset")
- , (":s", "import", "Show imported modules")
- , (":s", "loaded", "Show loaded modules")
- , (":t", "<expr>", "Show the type of <expr>")
- , (":k", "<type>", "Show the kind of <type>")
- ]
-
-commands :: [String]
-commands = map (\ (a, _, _) -> a) help
+-- * 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/Main.hs b/psci/Main.hs
index 2b8bc82..5969d70 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -54,12 +54,14 @@ import qualified Language.PureScript.AST as D
import qualified Language.PureScript.Names as N
import qualified Paths_purescript as Paths
-import Commands as C
+import qualified Commands as C
+import qualified Directive as D
import Parser
data PSCiOptions = PSCiOptions
- { psciMultiLineMode :: Bool
+ { psciMultiLineMode :: Bool
, psciInputFile :: [FilePath]
+ , psciInputNodeFlags :: [String]
}
-- |
@@ -70,11 +72,16 @@ data PSCiOptions = PSCiOptions
--
data PSCiState = PSCiState
{ psciImportedFilenames :: [FilePath]
- , psciImportedModuleNames :: [P.ModuleName]
+ , 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
-- |
@@ -86,8 +93,8 @@ updateImportedFiles filename st = st { psciImportedFilenames = filename : psciIm
-- |
-- Updates the state to have more imported modules.
--
-updateImports :: P.ModuleName -> PSCiState -> PSCiState
-updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }
+updateImportedModules :: C.ImportedModule -> PSCiState -> PSCiState
+updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }
-- |
-- Updates the state to have more loaded files.
@@ -105,8 +112,8 @@ updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
-- |
-- Load the necessary modules.
--
-defaultImports :: [P.ModuleName]
-defaultImports = [P.ModuleName [P.ProperName "Prelude"]]
+defaultImports :: [C.ImportedModule]
+defaultImports = [(P.ModuleName [P.ProperName "Prelude"], D.Implicit, Nothing)]
-- |
-- Locates the node executable.
@@ -168,9 +175,17 @@ expandTilde p = return p
--
helpMessage :: String
helpMessage = "The following commands are available:\n\n " ++
- intercalate "\n " (map line C.help)
- where line :: (String, String, String) -> String
- line (cmd, arg, desc) = intercalate " " [cmd, arg, replicate (11 - length arg) ' ', desc]
+ intercalate "\n " (map line D.help)
+ where
+ line :: (D.Directive, String, String) -> String
+ line (dir, arg, desc) = intercalate " "
+ [ cmd
+ , replicate (11 - length cmd) ' '
+ , arg
+ , replicate (11 - length arg) ' '
+ , desc
+ ]
+ where cmd = ":" ++ head (D.commands dir)
-- |
-- The welcome prologue.
@@ -203,19 +218,23 @@ data CompletionContext = Command String | FilePath String | Module | Identifier
-- Decide what kind of completion we need based on input.
completionContext :: String -> String -> Maybe CompletionContext
completionContext cmd@"" _ = Just $ Multiple [Command cmd, Identifier]
-completionContext cmd@(':' : _ ) _
- | cmd `elem` C.commands || cmd == ":" = Just $ Command cmd
-completionContext (':' : c : _) word = case c of
- 'i' -> Just Module
- 'b' -> Just Module
- 'm' -> Just $ FilePath word
- 'q' -> Nothing
- 'r' -> Nothing
- '?' -> Nothing
- 's' -> Just $ Fixed ["import", "loaded"]
- 't' -> Just Identifier
- 'k' -> Just Type
- _ -> Nothing
+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
-- |
@@ -236,13 +255,16 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
return $ sortBy sorter completions
getCompletion :: CompletionContext -> StateT PSCiState IO [Either String Completion]
- getCompletion (Command s) = return $ (map Left) $ nub $ filter (isPrefixOf s) C.commands
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
@@ -284,7 +306,7 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
getTypeName _ = Nothing
identNames :: P.Module -> [N.Ident]
- identNames (P.Module _ ds exports) = nub [ ident | ident <- mapMaybe (getDeclName exports) (D.flattenDecls ds) ]
+ 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
@@ -305,7 +327,7 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))
moduleNames :: [P.Module] -> [String]
- moduleNames ms = nub [show moduleName | P.Module moduleName _ _ <- ms]
+ 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
@@ -351,10 +373,9 @@ mkdirp = createDirectoryIfMissing True . takeDirectory
-- Makes a volatile module to execute the current expression.
--
createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
-createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} val =
+createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =
let
moduleName = P.ModuleName [P.ProperName "$PSCI"]
- importDecl m = P.ImportDeclaration m P.Unqualified Nothing
traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
@@ -362,31 +383,32 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB
mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue
decls = if exec then [itDecl, mainDecl] else [itDecl]
in
- P.Module moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
+ P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
-- |
-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
--
createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
-createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =
+createTemporaryModuleForKind PSCiState{psciImportedModules = imports} typ =
let
moduleName = P.ModuleName [P.ProperName "$PSCI"]
- importDecl m = P.ImportDeclaration m P.Unqualified Nothing
itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
in
- P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
+ P.Module [] moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
-- |
-- Makes a volatile module to execute the current imports.
--
createTemporaryModuleForImports :: PSCiState -> P.Module
-createTemporaryModuleForImports PSCiState{psciImportedModuleNames = imports} =
+createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
let
moduleName = P.ModuleName [P.ProperName "$PSCI"]
- importDecl m = P.ImportDeclaration m P.Unqualified Nothing
in
- P.Module moduleName (importDecl `map` imports) Nothing
+ P.Module [] moduleName (importDecl `map` imports) Nothing
+
+importDecl :: C.ImportedModule -> P.Declaration
+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
modulesDir :: FilePath
modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
@@ -401,24 +423,25 @@ handleDeclaration :: P.Expr -> PSCI ()
handleDeclaration val = do
st <- PSCI $ lift get
let m = createTemporaryModule True st val
+ let nodeArgs = psciNodeFlags st ++ [indexFile]
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
case e of
Left err -> PSCI $ outputStrLn err
Right _ -> do
psciIO $ writeFile indexFile "require('$PSCI').main();"
process <- psciIO findNodeProcess
- result <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process
+ result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
case result of
Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
-- |
--- Takes a let declaration and updates the environment, then run a make. If the declaration fails,
--- restore the pre-let environment.
+-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
+-- restore the original environment.
--
-handleLet :: [P.Declaration] -> PSCI ()
-handleLet ds = do
+handleDecls :: [P.Declaration] -> PSCI ()
+handleDecls ds = do
st <- PSCI $ lift get
let st' = updateLets ds st
let m = createTemporaryModule False st' (P.ObjectLiteral [])
@@ -436,24 +459,44 @@ handleShowLoadedModules = do
psciIO $ readModules loadedModules >>= putStrLn
return ()
where readModules = return . unlines . sort . nub . map toModuleName
- toModuleName = N.runModuleName . (\ (D.Module mdName _ _) -> mdName) . snd
+ toModuleName = N.runModuleName . (\ (D.Module _ mdName _ _) -> mdName) . snd
-- |
-- Show the imported modules in psci.
--
handleShowImportedModules :: PSCI ()
handleShowImportedModules = do
- PSCiState { psciImportedModuleNames = importedModuleNames } <- PSCI $ lift get
- psciIO $ readModules importedModuleNames >>= putStrLn
+ PSCiState { psciImportedModules = importedModules } <- PSCI $ lift get
+ psciIO $ showModules importedModules >>= putStrLn
return ()
- where readModules = return . unlines . sort . map N.runModuleName
+ where
+ showModules = return . unlines . sort . map showModule
+ showModule (mn, declType, asQ) =
+ "import " ++ case asQ of
+ Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'
+ Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType
+
+ showDeclType D.Implicit = ""
+ showDeclType (D.Explicit refs) = refsList refs
+ showDeclType (D.Hiding refs) = "hiding " ++ refsList refs
+ refsList refs = "(" ++ commaList (map showRef refs) ++ ")"
+
+ showRef :: P.DeclarationRef -> String
+ showRef (D.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
+ showRef (D.ValueRef ident) = show ident
+ showRef (D.TypeClassRef pn) = show pn
+ showRef (D.TypeInstanceRef ident) = show ident
+ showRef (D.PositionedDeclarationRef _ _ ref) = showRef ref
+
+ commaList :: [String] -> String
+ commaList = intercalate ", "
-- |
-- Imports a module, preserving the initial state on failure.
--
-handleImport :: P.ModuleName -> PSCI ()
-handleImport moduleName = do
- st <- updateImports moduleName <$> PSCI (lift get)
+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
@@ -507,7 +550,7 @@ handleBrowse moduleName = do
case env of
Left err -> PSCI $ outputStrLn err
Right env' ->
- if moduleName `notElem` (nub . map ((\ (P.Module modName _ _ ) -> modName) . snd)) loadedModules
+ 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'
@@ -528,7 +571,7 @@ handleKindOf typ = do
let chk = P.CheckState env' 0 0 (Just mName)
k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
case k of
- Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack
+ Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack
Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
Nothing -> PSCI $ outputStrLn "Could not find kind"
@@ -537,7 +580,7 @@ handleKindOf typ = do
-- |
-- 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
@@ -552,12 +595,12 @@ getCommand singleLineMode = do
-- |
-- Performs an action for each meta-command given, and also for expressions..
--
-handleCommand :: Command -> PSCI ()
-handleCommand (Expression val) = handleDeclaration val
-handleCommand Help = PSCI $ outputStrLn helpMessage
-handleCommand (Import moduleName) = handleImport moduleName
-handleCommand (Let l) = handleLet 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
@@ -568,22 +611,22 @@ handleCommand (LoadFile filePath) = do
Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
else
PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
-handleCommand Reset = do
+handleCommand C.Reset = do
files <- psciImportedFilenames <$> PSCI (lift get)
PSCI . lift . modify $ \st -> st
{ psciImportedFilenames = files
- , psciImportedModuleNames = defaultImports
+ , psciImportedModules = defaultImports
, psciLetBindings = []
}
loadAllImportedModules
-handleCommand (TypeOf val) = handleTypeOf val
-handleCommand (KindOf typ) = handleKindOf typ
-handleCommand (Browse moduleName) = handleBrowse moduleName
-handleCommand (Show "loaded") = handleShowLoadedModules
-handleCommand (Show "import") = handleShowImportedModules
+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 [Command])
+loadUserConfig :: IO (Maybe [C.Command])
loadUserConfig = do
configFile <- (</> ".psci") <$> getCurrentDirectory
exists <- doesFileExist configFile
@@ -608,7 +651,7 @@ loop PSCiOptions{..} = do
Right modules -> do
historyFilename <- getHistoryFilename
let settings = defaultSettings { historyFile = Just historyFilename }
- flip evalStateT (PSCiState psciInputFile defaultImports modules []) . runInputT (setComplete completion settings) $ do
+ flip evalStateT (PSCiState psciInputFile defaultImports modules [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
outputStrLn prologueMessage
traverse_ (mapM_ (runPSCI . handleCommand)) config
go
@@ -619,7 +662,7 @@ loop PSCiOptions{..} = do
case c of
Left err -> outputStrLn err >> go
Right Nothing -> go
- Right (Just Quit) -> outputStrLn quitMessage
+ Right (Just C.Quit) -> outputStrLn quitMessage
Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go
multiLineMode :: Parser Bool
@@ -633,9 +676,19 @@ inputFile = strArgument $
metavar "FILE"
<> Opts.help "Optional .purs files to load on start"
+nodeFlagsFlag :: Parser [String]
+nodeFlagsFlag = option parser $
+ long "node-opts"
+ <> metavar "NODE_OPTS"
+ <> value []
+ <> Opts.help "Flags to pass to node, separated by spaces"
+ where
+ parser = words <$> str
+
psciOptions :: Parser PSCiOptions
psciOptions = PSCiOptions <$> multiLineMode
<*> many inputFile
+ <*> nodeFlagsFlag
main :: IO ()
main = execParser opts >>= loop
diff --git a/psci/Parser.hs b/psci/Parser.hs
index 2058f9b..d28cc7b 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -13,13 +13,14 @@
--
-----------------------------------------------------------------------------
-module Parser (
- parseCommand
+module Parser
+ ( parseCommand
) where
import Prelude hiding (lex)
-import Commands
+import qualified Commands as C
+import qualified Directive as D
import Data.Char (isSpace)
@@ -33,50 +34,92 @@ 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 splitCommand cmdString of
- Just ('?', _) -> return Help
- Just ('q', _) -> return Quit
- Just ('r', _) -> return Reset
- Just ('i', moduleName) -> Import <$> parseRest P.moduleName moduleName
- Just ('b', moduleName) -> Browse <$> parseRest P.moduleName moduleName
- Just ('m', filename) -> return $ LoadFile (trimEnd filename)
- Just ('s', command) -> return $ Show (trimEnd command)
- Just ('t', expr) -> TypeOf <$> parseRest P.parseValue expr
- Just ('k', ty) -> KindOf <$> parseRest P.parseType ty
- Just _ -> Left $ "Unrecognized command. Type :? for help."
- Nothing -> parseRest (psciLet <|> psciExpression) cmdString
+ case cmdString of
+ (':' : cmd) -> parseDirective cmd
+ _ -> parseRest psciCommand cmdString
+
+parseRest :: P.TokenParser a -> String -> Either String a
+parseRest p s = either (Left . show) Right $ do
+ ts <- P.lex "" s
+ P.runTokenParser "" (p <* eof) ts
+
+psciCommand :: P.TokenParser C.Command
+psciCommand = choice (map try parsers)
where
- parseRest :: P.TokenParser a -> String -> Either String a
- parseRest p s = either (Left . show) Right $ do
- ts <- P.lex "" s
- P.runTokenParser "" (p <* eof) ts
-
- trimEnd :: String -> String
- trimEnd = reverse . dropWhile isSpace . reverse
-
- -- |
- -- Split a command into a command char and the trailing string
- --
- splitCommand :: String -> Maybe (Char, String)
- splitCommand (':' : c : s) = Just (c, dropWhile isSpace s)
- splitCommand _ = Nothing
-
- -- |
- -- Parses expressions entered at the PSCI repl.
- --
- psciExpression :: P.TokenParser Command
- psciExpression = Expression <$> P.parseValue
-
- -- |
- -- PSCI version of @let@.
- -- This is essentially let from do-notation.
- -- However, since we don't support the @Eff@ monad,
- -- we actually want the normal @let@.
- --
- psciLet :: P.TokenParser Command
- psciLet = Let <$> (P.reserved "let" *> P.indented *> manyDecls)
- where
- manyDecls :: P.TokenParser [P.Declaration]
- manyDecls = C.mark (many1 (C.same *> P.parseDeclaration))
+ parsers =
+ [ psciLet
+ , psciImport
+ , psciOtherDeclaration
+ , psciExpression
+ ]
+
+trim :: String -> String
+trim = trimEnd . trimStart
+
+trimStart :: String -> String
+trimStart = dropWhile isSpace
+
+trimEnd :: String -> String
+trimEnd = reverse . trimStart . reverse
+
+parseDirective :: String -> Either String C.Command
+parseDirective cmd =
+ case D.parseDirective dstr of
+ Just D.Help -> return C.Help
+ Just D.Quit -> return C.Quit
+ Just D.Reset -> return C.Reset
+ Just D.Browse -> C.Browse <$> parseRest P.moduleName arg
+ Just D.Load -> return $ C.LoadFile (trim arg)
+ Just D.Show -> return $ C.Show (trim arg)
+ Just D.Type -> C.TypeOf <$> parseRest P.parseValue arg
+ Just D.Kind -> C.KindOf <$> parseRest P.parseType arg
+ Nothing -> Left $ "Unrecognized command. Type :? for help."
+ where (dstr, arg) = break isSpace cmd
+
+-- |
+-- Parses expressions entered at the PSCI repl.
+--
+psciExpression :: P.TokenParser C.Command
+psciExpression = C.Expression <$> P.parseValue
+
+-- |
+-- PSCI version of @let@.
+-- This is essentially let from do-notation.
+-- However, since we don't support the @Eff@ monad,
+-- we actually want the normal @let@.
+--
+psciLet :: P.TokenParser C.Command
+psciLet = C.Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
+ where
+ manyDecls :: P.TokenParser [P.Declaration]
+ 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 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 C.Command
+psciOtherDeclaration = C.Decls . (:[]) <$> do
+ decl <- discardPositionInfo <$> P.parseDeclaration
+ if acceptable decl
+ then return decl
+ else fail "this kind of declaration is not supported in psci"
+
+discardPositionInfo :: P.Declaration -> P.Declaration
+discardPositionInfo (P.PositionedDeclaration _ _ d) = d
+discardPositionInfo d = d
+
+acceptable :: P.Declaration -> Bool
+acceptable (P.DataDeclaration _ _ _ _) = True
+acceptable (P.TypeSynonymDeclaration _ _ _) = True
+acceptable (P.ExternDeclaration _ _ _ _) = True
+acceptable (P.ExternDataDeclaration _ _) = True
+acceptable (P.ExternInstanceDeclaration _ _ _ _) = True
+acceptable (P.TypeClassDeclaration _ _ _ _) = True
+acceptable (P.TypeInstanceDeclaration _ _ _ _ _) = True
+acceptable _ = False
diff --git a/purescript.cabal b/purescript.cabal
index 223e9b3..9f31d36 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.6.8
+version: 0.6.9
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -35,7 +35,8 @@ library
utf8-string >= 1 && < 2,
pattern-arrows >= 0.0.2 && < 0.1,
file-embed >= 0.0.7 && < 0.0.8,
- time -any
+ time -any,
+ boxes >= 0.1.4 && < 0.2.0
exposed-modules: Language.PureScript
Language.PureScript.AST
Language.PureScript.AST.Binders
@@ -96,7 +97,6 @@ library
Language.PureScript.Sugar.Operators
Language.PureScript.Sugar.TypeClasses
Language.PureScript.Sugar.TypeDeclarations
- Language.PureScript.Supply
Language.PureScript.Traversals
Language.PureScript.TypeChecker
Language.PureScript.TypeChecker.Entailment
@@ -112,6 +112,8 @@ library
Language.PureScript.Types
Control.Monad.Unify
+ Control.Monad.Supply
+ Control.Monad.Supply.Class
exposed: True
buildable: True
hs-source-dirs: src
diff --git a/src/Language/PureScript/Supply.hs b/src/Control/Monad/Supply.hs
index 8ff03c8..895f6b4 100644
--- a/src/Language/PureScript/Supply.hs
+++ b/src/Control/Monad/Supply.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Supply
+-- Module : Control.Monad.Supply
-- Copyright : (c) Phil Freeman 2014
-- License : MIT
--
@@ -14,19 +14,19 @@
-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.PureScript.Supply where
+module Control.Monad.Supply where
import Data.Functor.Identity
import Control.Applicative
import Control.Monad.State
import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.Writer
-newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)
+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
+ deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)
runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
runSupplyT n = flip runStateT n . unSupplyT
@@ -40,17 +40,4 @@ runSupply :: Integer -> Supply a -> (a, Integer)
runSupply n = runIdentity . runSupplyT n
evalSupply :: Integer -> Supply a -> a
-evalSupply n = runIdentity . evalSupplyT n
-
-fresh :: (Monad m) => SupplyT m Integer
-fresh = SupplyT $ do
- n <- get
- put (n + 1)
- return n
-
-freshName :: (Functor m, Monad m) => SupplyT m String
-freshName = ('_' :) . show <$> fresh
-
-instance (MonadError e m) => MonadError e (SupplyT m) where
- throwError = SupplyT . throwError
- catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)
+evalSupply n = runIdentity . evalSupplyT n \ No newline at end of file
diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs
new file mode 100644
index 0000000..3869224
--- /dev/null
+++ b/src/Control/Monad/Supply/Class.hs
@@ -0,0 +1,36 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.Supply.Class
+-- Copyright : (c) PureScript 2015
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- A class for monads supporting a supply of fresh names
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Control.Monad.Supply.Class where
+
+import Control.Monad.Supply
+import Control.Monad.State
+
+class (Monad m) => MonadSupply m where
+ fresh :: m Integer
+
+instance (Monad m) => MonadSupply (SupplyT m) where
+ fresh = SupplyT $ do
+ n <- get
+ put (n + 1)
+ return n
+
+instance (MonadSupply m) => MonadSupply (StateT s m) where
+ fresh = lift fresh
+
+freshName :: (MonadSupply m) => m String
+freshName = liftM (('_' :) . show) fresh
diff --git a/src/Control/Monad/Unify.hs b/src/Control/Monad/Unify.hs
index 4fe55e9..c4ef0a0 100644
--- a/src/Control/Monad/Unify.hs
+++ b/src/Control/Monad/Unify.hs
@@ -20,11 +20,9 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
module Control.Monad.Unify where
-import Data.String (IsString)
import Data.Monoid
import Control.Applicative
@@ -85,9 +83,15 @@ defaultUnifyState :: (Partial t) => UnifyState t
defaultUnifyState = UnifyState 0 mempty
-- |
+-- A class for errors which support unification errors
+--
+class UnificationError t e where
+ occursCheckFailed :: t -> e
+
+-- |
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
--
-newtype UnifyT t m a = UnifyT { unUnify :: (StateT (UnifyState t) m) a }
+newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }
deriving (Functor, Monad, Applicative, Alternative, MonadPlus)
instance (MonadState s m) => MonadState s (UnifyT t m) where
@@ -113,7 +117,7 @@ substituteOne u t = Substitution $ M.singleton u t
-- |
-- Replace a unification variable with the specified value in the current substitution
--
-(=:=) :: (IsString e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
+(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
(=:=) u t' = do
st <- UnifyT get
let sub = unifyCurrentSubstitution st
@@ -128,10 +132,10 @@ substituteOne u t = Substitution $ M.singleton u t
-- |
-- Perform the occurs check, to make sure a unification variable does not occur inside a value
--
-occursCheck :: (IsString e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
+occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
occursCheck u t =
case isUnknown t of
- Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ "Occurs check fails"
+ Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t
_ -> return ()
-- |
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index a1a5ef7..d0d293f 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -13,15 +13,29 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell, FlexibleContexts #-}
-
-module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript
+ ( module P
+ , compile
+ , compile'
+ , RebuildPolicy(..)
+ , MonadMake(..)
+ , make
+ , prelude
+ , version
+ ) where
import Data.FileEmbed (embedFile)
import Data.Function (on)
import Data.List (sortBy, groupBy, intercalate)
import Data.Maybe (fromMaybe)
import Data.Time.Clock
+import Data.Version (Version)
import qualified Data.Traversable as T (traverse)
import qualified Data.ByteString.UTF8 as BU
import qualified Data.Map as M
@@ -48,12 +62,14 @@ import Language.PureScript.Parser as P
import Language.PureScript.Pretty as P
import Language.PureScript.Renamer as P
import Language.PureScript.Sugar as P
-import Language.PureScript.Supply as P
+import Control.Monad.Supply as P
import Language.PureScript.TypeChecker as P
import Language.PureScript.Types as P
import qualified Language.PureScript.CoreFn as CoreFn
import qualified Language.PureScript.Constants as C
+import qualified Paths_purescript as Paths
+
-- |
-- Compile a collection of modules
--
@@ -84,15 +100,15 @@ compile' env ms prefix = do
additional <- asks optionsAdditional
mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
(sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
- (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
+ (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted
(elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
- regrouped <- stringifyErrorStack True $ 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
let renamed = renameInModules elim
let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional
- let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
+ let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module _ mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)
let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
js' <- generateMain env' js
@@ -154,15 +170,15 @@ traverseEither f (Right y) = Right <$> f y
-- If timestamps have not changed, the externs file can be used to provide the module's types without
-- having to typecheck the module again.
--
-make :: (Functor m, Applicative m, Monad m, MonadMake m)
+make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)
=> FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
make outputDir ms prefix = do
noPrelude <- asks optionsNoPrelude
- let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
+ let filePathMap = M.fromList (map (\(fp, Module _ mn _ _) -> (mn, fp)) ms)
(sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms
- toRebuild <- foldM (\s (Module moduleName' _ _) -> do
+ toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
let filePath = runModuleName moduleName'
jsFile = outputDir </> filePath </> "index.js"
@@ -180,30 +196,29 @@ make outputDir ms prefix = do
marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
- (desugared, nextVar) <- stringifyErrorStack True $ 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
where
- go :: (Functor m, Applicative m, Monad m, MonadMake m)
- => Environment -> [(Bool, Module)] -> SupplyT m Environment
+ go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
go env [] = return env
go env ((False, m) : ms') = do
(_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
go env' ms'
- go env ((True, m@(Module moduleName' _ exps)) : ms') = do
+ go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
let filePath = runModuleName moduleName'
jsFile = outputDir </> filePath </> "index.js"
externsFile = outputDir </> filePath </> "externs.purs"
lift . progress $ "Compiling " ++ runModuleName moduleName'
- (Module _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
+ (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
- regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
+ regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
- let mod' = Module moduleName' regrouped exps
+ let mod' = Module coms moduleName' regrouped exps
let corefn = CoreFn.moduleToCoreFn env' mod'
let [renamed] = renameInModules [corefn]
@@ -216,18 +231,18 @@ make outputDir ms prefix = do
go env' ms'
- rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
+ rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
rebuildIfNecessary _ _ [] = return []
- rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
+ rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
let deps = fromMaybe [] $ moduleName' `M.lookup` graph
toRebuild' = toRebuild `S.union` S.fromList deps
(:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
- rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
+ rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
externs <- readTextFile externsFile
externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]
case externsModules of
- [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
+ [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
_ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"
reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
@@ -240,9 +255,9 @@ reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
-- Add an import declaration for a module if it does not already explicitly import it.
--
addDefaultImport :: ModuleName -> Module -> Module
-addDefaultImport toImport m@(Module mn decls exps) =
+addDefaultImport toImport m@(Module coms mn decls exps) =
if isExistingImport `any` decls || mn == toImport then m
- else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps
+ else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
where
isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
@@ -256,3 +271,6 @@ importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
prelude :: String
prelude = BU.toString $(embedFile "prelude/prelude.purs")
+
+version :: Version
+version = Paths.version
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index ef097e5..f857fa0 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -30,14 +30,15 @@ import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
-- |
--- A module declaration, consisting of a module name, a list of declarations, and a list of the
--- declarations that are explicitly exported. If the export list is Nothing, everything is exported.
+-- A module declaration, consisting of comments about the module, a module name,
+-- a list of declarations, and a list of the declarations that are
+-- explicitly exported. If the export list is Nothing, everything is exported.
--
-data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
+data Module = Module [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
-- | Return a module's name.
getModuleName :: Module -> ModuleName
-getModuleName (Module name _ _) = name
+getModuleName (Module _ name _ _) = name
-- |
-- Test if a declaration is exported, given a module's export list.
@@ -60,7 +61,7 @@ isExported (Just exps) decl = any (matches decl) exps
matches _ _ = False
exportedDeclarations :: Module -> [Declaration]
-exportedDeclarations (Module _ decls exps) = filter (isExported exps) (flattenDecls decls)
+exportedDeclarations (Module _ _ decls exps) = filter (isExported exps) (flattenDecls decls)
-- |
-- Test if a data constructor for a given type is exported, given a module's export list.
@@ -78,7 +79,7 @@ isDctorExported ident (Just exps) ctor = test `any` exps
-- Return the exported data constructors for a given type.
--
exportedDctors :: Module -> ProperName -> [ProperName]
-exportedDctors (Module _ decls exps) ident =
+exportedDctors (Module _ _ decls exps) ident =
filter (isDctorExported ident exps) dctors
where
dctors = concatMap getDctors (flattenDecls decls)
@@ -126,15 +127,15 @@ instance Eq DeclarationRef where
--
data ImportDeclarationType
-- |
- -- Unqualified import
+ -- An import with no explicit list: `import M`
--
- = Unqualified
+ = Implicit
-- |
- -- Qualified import with a list of references to import
+ -- An import with an explicit list of references to import: `import M (foo)`
--
- | Qualifying [DeclarationRef]
+ | Explicit [DeclarationRef]
-- |
- -- Import with hiding clause with a list of references to hide
+ -- An import with a list of references to hide: `import M hiding (foo)`
--
| Hiding [DeclarationRef]
deriving (Show, D.Data, D.Typeable)
@@ -260,11 +261,18 @@ isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d
isExternDecl _ = False
-- |
--- Test if a declaration is a type class or instance declaration
+-- Test if a declaration is a type class instance declaration
+--
+isTypeClassInstanceDeclaration :: Declaration -> Bool
+isTypeClassInstanceDeclaration TypeInstanceDeclaration{} = True
+isTypeClassInstanceDeclaration (PositionedDeclaration _ _ d) = isTypeClassInstanceDeclaration d
+isTypeClassInstanceDeclaration _ = False
+
+-- |
+-- Test if a declaration is a type class declaration
--
isTypeClassDeclaration :: Declaration -> Bool
isTypeClassDeclaration TypeClassDeclaration{} = True
-isTypeClassDeclaration TypeInstanceDeclaration{} = True
isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d
isTypeClassDeclaration _ = False
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index 90b9e94..97c3dc6 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -30,7 +30,7 @@ data SourcePos = SourcePos
-- Column number
--
, sourcePosColumn :: Int
- } deriving (D.Data, D.Typeable)
+ } deriving (Eq, D.Data, D.Typeable)
instance Show SourcePos where
show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
@@ -47,7 +47,7 @@ data SourceSpan = SourceSpan
-- End of the span
--
, spanEnd :: SourcePos
- } deriving (D.Data, D.Typeable)
+ } deriving (Eq, D.Data, D.Typeable)
instance Show SourceSpan where
show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 5fc401e..956b06e 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -36,8 +36,8 @@ import Language.PureScript.Comments
-- Generate foreign imports for all declarations in a module
--
moduleToPs :: Module -> Environment -> String
-moduleToPs (Module _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
-moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
+moduleToPs (Module _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
+moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
tell [ "module " ++ runModuleName moduleName ++ " where"]
mapM_ declToPs ds
mapM_ exportToPs exts
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index e677751..c93b7a3 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -13,7 +13,10 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE GADTs, ViewPatterns, FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Language.PureScript.CodeGen.JS (
module AST,
@@ -28,7 +31,8 @@ import qualified Data.Traversable as T (traverse)
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad (foldM, replicateM, forM)
-import Control.Monad.Reader (MonadReader, asks, lift)
+import Control.Monad.Reader (MonadReader, asks)
+import Control.Monad.Supply.Class
import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.CodeGen.JS.Common as Common
@@ -36,7 +40,6 @@ import Language.PureScript.CoreFn
import Language.PureScript.Names
import Language.PureScript.CodeGen.JS.Optimizer
import Language.PureScript.Options
-import Language.PureScript.Supply
import Language.PureScript.Traversals (sndM)
import qualified Language.PureScript.Constants as C
@@ -44,320 +47,313 @@ import qualified Language.PureScript.Constants as C
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
-- module.
--
-moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => Module Ann -> SupplyT m [JS]
-moduleToJs (Module name imps exps foreigns decls) = do
- additional <- lift $ asks optionsAdditional
- jsImports <- lift . T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
+moduleToJs :: forall m mode. (Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
+ => Module Ann -> m [JS]
+moduleToJs (Module coms mn imps exps foreigns decls) = do
+ additional <- asks optionsAdditional
+ jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
- jsDecls <- mapM (bindToJs name) decls
- optimized <- lift $ T.traverse (T.traverse optimize) jsDecls
+ jsDecls <- mapM bindToJs decls
+ optimized <- T.traverse (T.traverse optimize) jsDecls
let isModuleEmpty = null exps
- let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ concat optimized
+ comments <- not <$> asks optionsNoComments
+ let strict = JSStringLiteral "use strict"
+ let header = if comments && not (null coms) then JSComment coms strict else strict
+ let moduleBody = header : jsImports ++ foreigns' ++ concat optimized
let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
return $ case additional of
MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
CompileOptions ns _ _ | not isModuleEmpty ->
[ JSVariableIntroduction ns
(Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
- , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))
+ , JSAssignment (JSAccessor (moduleNameToJs mn) (JSVar ns))
(JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
]
_ -> []
--- |
--- Generates Javascript code for a module import.
---
-importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS
-importToJs mn = do
- additional <- asks optionsAdditional
- let moduleBody = case additional of
- MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
- CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
- return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
+ where
--- |
--- Generate code in the simplified Javascript intermediate representation for a declaration
---
-bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => ModuleName -> Bind Ann -> SupplyT m [JS]
-bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val
-bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
+ -- |
+ -- Generates Javascript code for a module import.
+ --
+ importToJs :: ModuleName -> m JS
+ importToJs mn' = do
+ additional <- asks optionsAdditional
+ let moduleBody = case additional of
+ MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn')]
+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn') (JSVar ns)
+ return $ JSVariableIntroduction (moduleNameToJs mn') (Just moduleBody)
--- |
--- Generate code in the simplified Javascript intermediate representation for a single non-recursive
--- declaration.
---
--- The main purpose of this function is to handle code generation for comments.
---
-nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => ModuleName -> Ident -> Expr Ann -> SupplyT m JS
-nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
- withoutComment <- lift $ asks optionsNoComments
- if withoutComment
- then nonRecToJS m i (modifyAnn removeComments e)
- else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)
-nonRecToJS mp ident val = do
- js <- valueToJs mp val
- return $ JSVariableIntroduction (identToJs ident) (Just js)
+ -- |
+ -- Generate code in the simplified Javascript intermediate representation for a declaration
+ --
+ bindToJs :: Bind Ann -> m [JS]
+ bindToJs (NonRec ident val) = return <$> nonRecToJS ident val
+ bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)
+ -- |
+ -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
+ -- declaration.
+ --
+ -- The main purpose of this function is to handle code generation for comments.
+ --
+ nonRecToJS :: Ident -> Expr Ann -> m JS
+ nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
+ withoutComment <- asks optionsNoComments
+ if withoutComment
+ then nonRecToJS i (modifyAnn removeComments e)
+ else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)
+ nonRecToJS ident val = do
+ js <- valueToJs val
+ return $ JSVariableIntroduction (identToJs ident) (Just js)
--- |
--- Generate code in the simplified Javascript intermediate representation for a variable based on a
--- PureScript identifier.
---
-var :: Ident -> JS
-var = JSVar . identToJs
+ -- |
+ -- Generate code in the simplified Javascript intermediate representation for a variable based on a
+ -- PureScript identifier.
+ --
+ var :: Ident -> JS
+ var = JSVar . identToJs
--- |
--- Generate code in the simplified Javascript intermediate representation for an accessor based on
--- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
--- indexer is returned.
---
-accessor :: Ident -> JS -> JS
-accessor (Ident prop) = accessorString prop
-accessor (Op op) = JSIndexer (JSStringLiteral op)
+ -- |
+ -- Generate code in the simplified Javascript intermediate representation for an accessor based on
+ -- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
+ -- indexer is returned.
+ --
+ accessor :: Ident -> JS -> JS
+ accessor (Ident prop) = accessorString prop
+ accessor (Op op) = JSIndexer (JSStringLiteral op)
-accessorString :: String -> JS -> JS
-accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
- | otherwise = JSAccessor prop
+ accessorString :: String -> JS -> JS
+ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
+ | otherwise = JSAccessor prop
--- |
--- Generate code in the simplified Javascript intermediate representation for a value or expression.
---
-valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => ModuleName -> Expr Ann -> SupplyT m JS
-valueToJs m (Literal _ l) =
- literalToValueJS m l
-valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =
- return $ JSAccessor "value" $ qualifiedToJS m id name
-valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =
- return $ JSAccessor "create" $ qualifiedToJS m id name
-valueToJs m (Accessor _ prop val) =
- accessorString prop <$> valueToJs m val
-valueToJs m (ObjectUpdate _ o ps) = do
- obj <- valueToJs m o
- sts <- mapM (sndM $ valueToJs m) ps
- extendObj obj sts
-valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
- let args = unAbs e
- in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
- where
- unAbs :: Expr Ann -> [Ident]
- unAbs (Abs _ arg val) = arg : unAbs val
- unAbs _ = []
- assign :: Ident -> JS
- assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
- (var name)
-valueToJs m (Abs _ arg val) = do
- ret <- valueToJs m val
- return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
-valueToJs m e@App{} = do
- let (f, args) = unApp e []
- args' <- mapM (valueToJs m) args
- case f of
- Var (_, _, _, Just IsNewtype) _ -> return (head args')
- Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
- return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
- Var (_, _, _, Just IsTypeClassConstructor) name ->
- return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
- _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f
- where
- unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
- unApp (App _ val arg) args = unApp val (arg : args)
- unApp other args = (other, args)
-valueToJs m (Var _ ident) =
- return $ varToJs m ident
-valueToJs m (Case _ values binders) = do
- vals <- mapM (valueToJs m) values
- bindersToJs m binders vals
-valueToJs m (Let _ ds val) = do
- decls <- concat <$> mapM (bindToJs m) ds
- ret <- valueToJs m val
- return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
-valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
- return $ JSVariableIntroduction ctor (Just $
- JSObjectLiteral [("create",
- JSFunction Nothing ["value"]
- (JSBlock [JSReturn $ JSVar "value"]))])
-valueToJs _ (Constructor _ _ (ProperName ctor) []) =
- return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
- , JSAssignment (JSAccessor "value" (JSVar ctor))
- (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
-valueToJs _ (Constructor _ _ (ProperName ctor) fields) =
- let constructor =
- let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
- in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
- createFn =
- let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
- in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
- in return $ iife ctor [ constructor
- , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
- ]
-iife :: String -> [JS] -> JS
-iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
+ -- |
+ -- Generate code in the simplified Javascript intermediate representation for a value or expression.
+ --
+ valueToJs :: Expr Ann -> m JS
+ valueToJs (Literal _ l) =
+ literalToValueJS l
+ valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =
+ return $ JSAccessor "value" $ qualifiedToJS id name
+ valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =
+ return $ JSAccessor "create" $ qualifiedToJS id name
+ valueToJs (Accessor _ prop val) =
+ accessorString prop <$> valueToJs val
+ valueToJs (ObjectUpdate _ o ps) = do
+ obj <- valueToJs o
+ sts <- mapM (sndM valueToJs) ps
+ extendObj obj sts
+ valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
+ let args = unAbs e
+ in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
+ where
+ unAbs :: Expr Ann -> [Ident]
+ unAbs (Abs _ arg val) = arg : unAbs val
+ unAbs _ = []
+ assign :: Ident -> JS
+ assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
+ (var name)
+ valueToJs (Abs _ arg val) = do
+ ret <- valueToJs val
+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
+ valueToJs e@App{} = do
+ let (f, args) = unApp e []
+ args' <- mapM valueToJs args
+ case f of
+ Var (_, _, _, Just IsNewtype) _ -> return (head args')
+ Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
+ return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
+ Var (_, _, _, Just IsTypeClassConstructor) name ->
+ return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f
+ where
+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
+ unApp (App _ val arg) args = unApp val (arg : args)
+ unApp other args = (other, args)
+ valueToJs (Var _ ident) =
+ return $ varToJs ident
+ valueToJs (Case _ values binders) = do
+ vals <- mapM valueToJs values
+ bindersToJs binders vals
+ valueToJs (Let _ ds val) = do
+ ds' <- concat <$> mapM bindToJs ds
+ ret <- valueToJs val
+ return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []
+ valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
+ return $ JSVariableIntroduction ctor (Just $
+ JSObjectLiteral [("create",
+ JSFunction Nothing ["value"]
+ (JSBlock [JSReturn $ JSVar "value"]))])
+ valueToJs (Constructor _ _ (ProperName ctor) []) =
+ return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
+ , JSAssignment (JSAccessor "value" (JSVar ctor))
+ (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
+ valueToJs (Constructor _ _ (ProperName ctor) fields) =
+ let constructor =
+ let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
+ in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
+ createFn =
+ let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
+ in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
+ in return $ iife ctor [ constructor
+ , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
+ ]
-literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => ModuleName -> Literal (Expr Ann) -> SupplyT m JS
-literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
-literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
-literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
-literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs
-literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps
+ iife :: String -> [JS] -> JS
+ iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
--- |
--- Shallow copy an object.
---
-extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS
-extendObj obj sts = do
- newObj <- freshName
- key <- freshName
- let
- jsKey = JSVar key
- jsNewObj = JSVar newObj
- block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
- objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
- copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
- cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
- assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
- stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
- extend = map stToAssign sts
- return $ JSApp (JSFunction Nothing [] block) []
+ literalToValueJS :: Literal (Expr Ann) -> m JS
+ literalToValueJS (NumericLiteral n) = return $ JSNumericLiteral n
+ literalToValueJS (StringLiteral s) = return $ JSStringLiteral s
+ literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b
+ literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs
+ literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps
--- |
--- Generate code in the simplified Javascript intermediate representation for a reference to a
--- variable.
---
-varToJs :: ModuleName -> Qualified Ident -> JS
-varToJs _ (Qualified Nothing ident) = var ident
-varToJs m qual = qualifiedToJS m id qual
+ -- |
+ -- Shallow copy an object.
+ --
+ extendObj :: JS -> [(String, JS)] -> m JS
+ extendObj obj sts = do
+ newObj <- freshName
+ key <- freshName
+ let
+ jsKey = JSVar key
+ jsNewObj = JSVar newObj
+ block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
+ objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
+ copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
+ cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
+ assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
+ stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
+ extend = map stToAssign sts
+ return $ JSApp (JSFunction Nothing [] block) []
--- |
--- Generate code in the simplified Javascript intermediate representation for a reference to a
--- variable that may have a qualified name.
---
-qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
-qualifiedToJS _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = JSVar . runIdent $ f a
-qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
-qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
+ -- |
+ -- Generate code in the simplified Javascript intermediate representation for a reference to a
+ -- variable.
+ --
+ varToJs :: Qualified Ident -> JS
+ varToJs (Qualified Nothing ident) = var ident
+ varToJs qual = qualifiedToJS id qual
--- |
--- Generate code in the simplified Javascript intermediate representation for pattern match binders
--- and guards.
---
-bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS
-bindersToJs m binders vals = do
- valNames <- replicateM (length vals) freshName
- let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
- jss <- forM binders $ \(CaseAlternative bs result) -> do
- ret <- guardsToJs result
- go valNames ret bs
- return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
- []
- where
- go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]
- go _ done [] = return done
- go (v:vs) done' (b:bs) = do
- done'' <- go vs done' bs
- binderToJs m v done'' b
- go _ _ _ = error "Invalid arguments to bindersToJs"
+ -- |
+ -- Generate code in the simplified Javascript intermediate representation for a reference to a
+ -- variable that may have a qualified name.
+ --
+ qualifiedToJS :: (a -> Ident) -> Qualified a -> JS
+ qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a
+ qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))
+ qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)
- guardsToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]
- guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
- cond' <- valueToJs m cond
- done <- valueToJs m val
- return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
- guardsToJs (Right v) = return . JSReturn <$> valueToJs m v
+ -- |
+ -- Generate code in the simplified Javascript intermediate representation for pattern match binders
+ -- and guards.
+ --
+ bindersToJs :: [CaseAlternative Ann] -> [JS] -> m JS
+ bindersToJs binders vals = do
+ valNames <- replicateM (length vals) freshName
+ let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
+ jss <- forM binders $ \(CaseAlternative bs result) -> do
+ ret <- guardsToJs result
+ go valNames ret bs
+ return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
+ []
+ where
+ go :: [String] -> [JS] -> [Binder Ann] -> m [JS]
+ go _ done [] = return done
+ go (v:vs) done' (b:bs) = do
+ done'' <- go vs done' bs
+ binderToJs v done'' b
+ go _ _ _ = error "Invalid arguments to bindersToJs"
--- |
--- Generate code in the simplified Javascript intermediate representation for a pattern match
--- binder.
---
-binderToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]
-binderToJs _ _ done (NullBinder{}) = return done
-binderToJs m varName done (LiteralBinder _ l) =
- literalToBinderJS m varName done l
-binderToJs _ varName done (VarBinder _ ident) =
- return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
-binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
- binderToJs m varName done b
-binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
- js <- go (zip fields bs) done
- return $ case ctorType of
- ProductType -> js
- SumType ->
- [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
- (JSBlock js)
- Nothing]
- where
- go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS]
- go [] done' = return done'
- go ((field, binder) : remain) done' = do
- argVar <- freshName
- done'' <- go remain done'
- js <- binderToJs m argVar done'' binder
- return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
-binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
- let (headBinders, tailBinder) = uncons [] binder
- numberOfHeadBinders = fromIntegral $ length headBinders
- js1 <- foldM (\done' (headBinder, index) -> do
- headVar <- freshName
- jss <- binderToJs m headVar done' headBinder
- return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
- tailVar <- freshName
- js2 <- binderToJs m tailVar js1 tailBinder
- return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
- ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
- js2
- )) Nothing]
- where
- uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
- uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
- uncons acc tailBinder = (reverse acc, tailBinder)
-binderToJs _ _ _ b@(ConstructorBinder{}) =
- error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
-binderToJs m varName done (NamedBinder _ ident binder) = do
- js <- binderToJs m varName done binder
- return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
+ guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
+ guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
+ cond' <- valueToJs cond
+ done <- valueToJs val
+ return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
+ guardsToJs (Right v) = return . JSReturn <$> valueToJs v
-literalToBinderJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]
-literalToBinderJS _ varName done (NumericLiteral num) =
- return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
-literalToBinderJS _ varName done (StringLiteral str) =
- return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
-literalToBinderJS _ varName done (BooleanLiteral True) =
- return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
-literalToBinderJS _ varName done (BooleanLiteral False) =
- return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
-literalToBinderJS m varName done (ObjectLiteral bs) = go done bs
- where
- go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]
- go done' [] = return done'
- go done' ((prop, binder):bs') = do
- propVar <- freshName
- done'' <- go done' bs'
- js <- binderToJs m propVar done'' binder
- return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
-literalToBinderJS m varName done (ArrayLiteral bs) = do
- js <- go done 0 bs
- return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
- where
- go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
- => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]
- go done' _ [] = return done'
- go done' index (binder:bs') = do
- elVar <- freshName
- done'' <- go done' (index + 1) bs'
- js <- binderToJs m elVar done'' binder
- return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
+ -- |
+ -- Generate code in the simplified Javascript intermediate representation for a pattern match
+ -- binder.
+ --
+ binderToJs :: String -> [JS] -> Binder Ann -> m [JS]
+ binderToJs _ done (NullBinder{}) = return done
+ binderToJs varName done (LiteralBinder _ l) =
+ literalToBinderJS varName done l
+ binderToJs varName done (VarBinder _ ident) =
+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
+ binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
+ binderToJs varName done b
+ binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
+ js <- go (zip fields bs) done
+ return $ case ctorType of
+ ProductType -> js
+ SumType ->
+ [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))
+ (JSBlock js)
+ Nothing]
+ where
+ go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
+ go [] done' = return done'
+ go ((field, binder) : remain) done' = do
+ argVar <- freshName
+ done'' <- go remain done'
+ js <- binderToJs argVar done'' binder
+ return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
+ binderToJs varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
+ let (headBinders, tailBinder) = uncons [] binder
+ numberOfHeadBinders = fromIntegral $ length headBinders
+ js1 <- foldM (\done' (headBinder, index) -> do
+ headVar <- freshName
+ jss <- binderToJs headVar done' headBinder
+ return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
+ tailVar <- freshName
+ js2 <- binderToJs tailVar js1 tailBinder
+ return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
+ ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
+ js2
+ )) Nothing]
+ where
+ uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
+ uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
+ uncons acc tailBinder = (reverse acc, tailBinder)
+ binderToJs _ _ b@(ConstructorBinder{}) =
+ error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
+ binderToJs varName done (NamedBinder _ ident binder) = do
+ js <- binderToJs varName done binder
+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
+
+ literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]
+ literalToBinderJS varName done (NumericLiteral num) =
+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
+ literalToBinderJS varName done (StringLiteral str) =
+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
+ literalToBinderJS varName done (BooleanLiteral True) =
+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
+ literalToBinderJS varName done (BooleanLiteral False) =
+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
+ literalToBinderJS varName done (ObjectLiteral bs) = go done bs
+ where
+ go :: [JS] -> [(String, Binder Ann)] -> m [JS]
+ go done' [] = return done'
+ go done' ((prop, binder):bs') = do
+ propVar <- freshName
+ done'' <- go done' bs'
+ js <- binderToJs propVar done'' binder
+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
+ literalToBinderJS varName done (ArrayLiteral bs) = do
+ js <- go done 0 bs
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
+ where
+ go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
+ go done' _ [] = return done'
+ go done' index (binder:bs') = do
+ elVar <- freshName
+ done'' <- go done' (index + 1) bs'
+ js <- binderToJs elVar done'' binder
+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
-isCons :: Qualified ProperName -> Bool
-isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
-isCons name = error $ "Unexpected argument in isCons: " ++ show name
+ isCons :: Qualified ProperName -> Bool
+ isCons (Qualified (Just mn') ctor) = mn' == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
+ isCons name = error $ "Unexpected argument in isCons: " ++ show name
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index cc5e16c..4141352 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -40,14 +40,14 @@ import qualified Language.PureScript.AST as A
-- Desugars a module from AST to CoreFn representation.
--
moduleToCoreFn :: Environment -> A.Module -> Module Ann
-moduleToCoreFn _ (A.Module _ _ Nothing) =
+moduleToCoreFn _ (A.Module _ _ _ Nothing) =
error "Module exports were not elaborated before moduleToCoreFn"
-moduleToCoreFn env (A.Module mn decls (Just exps)) =
+moduleToCoreFn env (A.Module coms mn decls (Just exps)) =
let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
exps' = nub $ concatMap exportToCoreFn exps
externs = nub $ mapMaybe externToCoreFn decls
decls' = concatMap (declToCoreFn Nothing []) decls
- in Module mn imports exps' externs decls'
+ in Module coms mn imports exps' externs decls'
where
@@ -190,12 +190,17 @@ moduleToCoreFn env (A.Module mn decls (Just exps)) =
--
findQualModules :: [A.Declaration] -> [ModuleName]
findQualModules decls =
- let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
+ let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues fqBinders (const []) (const [])
in f `concatMap` decls
where
fqValues :: A.Expr -> [ModuleName]
fqValues (A.Var (Qualified (Just mn) _)) = [mn]
+ fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]
fqValues _ = []
+
+ fqBinders :: A.Binder -> [ModuleName]
+ fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]
+ fqBinders _ = []
-- |
-- Desugars import declarations from AST to CoreFn representation.
diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs
index 9f97ccb..0088ee1 100644
--- a/src/Language/PureScript/CoreFn/Module.hs
+++ b/src/Language/PureScript/CoreFn/Module.hs
@@ -15,12 +15,14 @@
module Language.PureScript.CoreFn.Module where
import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.Comments
import Language.PureScript.CoreFn.Expr
import Language.PureScript.Names
import Language.PureScript.Types
data Module a = Module
- { moduleName :: ModuleName
+ { moduleComments :: [Comment]
+ , moduleName :: ModuleName
, moduleImports :: [ModuleName]
, moduleExports :: [Ident]
, moduleForeign :: [ForeignDecl]
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 3213373..7f576cc 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -29,7 +29,7 @@ import Language.PureScript.Names
eliminateDeadCode :: [ModuleName] -> [Module a] -> [Module a]
eliminateDeadCode entryPoints ms = map go ms
where
- go (Module mn imps exps foreigns ds) = Module mn imps exps' foreigns' ds'
+ go (Module coms mn imps exps foreigns ds) = Module coms mn imps exps' foreigns' ds'
where
ds' = filter (isUsed mn graph vertexFor entryPointVertices) ds
foreigns' = filter (isUsed' mn graph vertexFor entryPointVertices . foreignIdent) foreigns
@@ -61,7 +61,7 @@ type Key = (ModuleName, Ident)
-- Find dependencies for each member in a module.
--
declarationsByModule :: Module a -> [(Key, [Key])]
-declarationsByModule (Module mn _ _ fs ds) =
+declarationsByModule (Module _ mn _ _ fs ds) =
let fs' = map ((\name -> ((mn, name), [])) . foreignIdent) fs
in fs' ++ concatMap go ds
where
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 3ff82ff..07d8b19 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -12,108 +12,486 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
module Language.PureScript.Errors where
import Data.Either (lefts, rights)
-import Data.String (IsString(..))
-import Data.List (intersperse, intercalate)
+import Data.List (intercalate)
import Data.Monoid
+import Data.Foldable (fold, foldMap)
import Control.Monad.Except
+import Control.Monad.Unify
import Control.Applicative ((<$>))
import Language.PureScript.AST
import Language.PureScript.Pretty
import Language.PureScript.Types
+import Language.PureScript.Names
+import Language.PureScript.Kinds
+import Language.PureScript.TypeClassDictionaries
+
+import qualified Text.PrettyPrint.Boxes as Box
+
+-- |
+-- A type of error messages
+--
+data ErrorMessage
+ = InfiniteType Type
+ | InfiniteKind Kind
+ | CannotReorderOperators
+ | MultipleFixities Ident
+ | OrphanTypeDeclaration Ident
+ | OrphanFixityDeclaration String
+ | RedefinedModule ModuleName
+ | RedefinedIdent Ident
+ | OverlappingNamesInLet
+ | UnknownModule ModuleName
+ | UnknownType (Qualified ProperName)
+ | UnknownTypeClass (Qualified ProperName)
+ | UnknownValue (Qualified Ident)
+ | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
+ | UnknownTypeConstructor (Qualified ProperName)
+ | ConflictingImport String ModuleName
+ | ConflictingImports String ModuleName ModuleName
+ | ConflictingTypeDecls ProperName
+ | ConflictingCtorDecls ProperName
+ | TypeConflictsWithClass ProperName
+ | CtorConflictsWithClass ProperName
+ | ClassConflictsWithType ProperName
+ | ClassConflictsWithCtor ProperName
+ | DuplicateClassExport ProperName
+ | DuplicateValueExport Ident
+ | DuplicateTypeArgument String
+ | InvalidDoBind
+ | InvalidDoLet
+ | CycleInDeclaration Ident
+ | CycleInTypeSynonym (Maybe ProperName)
+ | NameIsUndefined Ident
+ | NameNotInScope Ident
+ | UndefinedTypeVariable ProperName
+ | PartiallyAppliedSynonym (Qualified ProperName)
+ | NotYetDefined [Ident] ErrorMessage
+ | EscapedSkolem (Maybe Expr)
+ | UnspecifiedSkolemScope
+ | TypesDoNotUnify Type Type
+ | KindsDoNotUnify Kind Kind
+ | ConstrainedTypeUnified Type Type
+ | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]
+ | NoInstanceFound (Qualified ProperName) [Type]
+ | DuplicateLabel String (Maybe Expr)
+ | DuplicateValueDeclaration Ident
+ | ArgListLengthsDiffer Ident
+ | OverlappingArgNames (Maybe Ident)
+ | MissingClassMember Ident
+ | ExpectedType Kind
+ | IncorrectConstructorArity (Qualified ProperName)
+ | SubsumptionCheckFailed
+ | ExprDoesNotHaveType Expr Type
+ | PropertyIsMissing String Type
+ | ErrorUnifyingTypes Type Type ErrorMessage
+ | CannotApplyFunction Type Expr
+ | TypeSynonymInstance
+ | InvalidNewtype
+ | InvalidInstanceHead Type
+ | TransitiveExportError DeclarationRef [DeclarationRef]
+ | ErrorInExpression Expr ErrorMessage
+ | ErrorInModule ModuleName ErrorMessage
+ | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
+ | ErrorInSubsumption Type Type ErrorMessage
+ | ErrorCheckingType Expr Type ErrorMessage
+ | ErrorCheckingKind Type ErrorMessage
+ | ErrorInferringType Expr ErrorMessage
+ | ErrorInApplication Expr Type Expr ErrorMessage
+ | ErrorInDataConstructor ProperName ErrorMessage
+ | ErrorInTypeConstructor ProperName ErrorMessage
+ | ErrorInBindingGroup [Ident] ErrorMessage
+ | ErrorInDataBindingGroup ErrorMessage
+ | ErrorInTypeSynonym ProperName ErrorMessage
+ | ErrorInValueDeclaration Ident ErrorMessage
+ | ErrorInForeignImport Ident ErrorMessage
+ | PositionedError SourceSpan ErrorMessage
+ deriving (Show)
+
+instance UnificationError Type ErrorMessage where
+ occursCheckFailed = InfiniteType
+
+instance UnificationError Kind ErrorMessage where
+ occursCheckFailed = InfiniteKind
+
+-- |
+-- Get the error code for a particular error type
+--
+errorCode :: ErrorMessage -> String
+errorCode (InfiniteType _) = "InfiniteType"
+errorCode (InfiniteKind _) = "InfiniteKind"
+errorCode CannotReorderOperators = "CannotReorderOperators"
+errorCode (MultipleFixities _) = "MultipleFixities"
+errorCode (OrphanTypeDeclaration _) = "OrphanTypeDeclaration"
+errorCode (OrphanFixityDeclaration _) = "OrphanFixityDeclaration"
+errorCode (RedefinedModule _) = "RedefinedModule"
+errorCode (RedefinedIdent _) = "RedefinedIdent"
+errorCode OverlappingNamesInLet = "OverlappingNamesInLet"
+errorCode (UnknownModule _) = "UnknownModule"
+errorCode (UnknownType _) = "UnknownType"
+errorCode (UnknownTypeClass _) = "UnknownTypeClass"
+errorCode (UnknownValue _) = "UnknownValue"
+errorCode (UnknownDataConstructor _ _) = "UnknownDataConstructor"
+errorCode (UnknownTypeConstructor _) = "UnknownTypeConstructor"
+errorCode (ConflictingImport _ _) = "ConflictingImport"
+errorCode (ConflictingImports _ _ _) = "ConflictingImports"
+errorCode (ConflictingTypeDecls _) = "ConflictingTypeDecls"
+errorCode (ConflictingCtorDecls _) = "ConflictingCtorDecls"
+errorCode (TypeConflictsWithClass _) = "TypeConflictsWithClass"
+errorCode (CtorConflictsWithClass _) = "CtorConflictsWithClass"
+errorCode (ClassConflictsWithType _) = "ClassConflictsWithType"
+errorCode (ClassConflictsWithCtor _) = "ClassConflictsWithCtor"
+errorCode (DuplicateClassExport _) = "DuplicateClassExport"
+errorCode (DuplicateValueExport _) = "DuplicateValueExport"
+errorCode (DuplicateTypeArgument _) = "DuplicateTypeArgument"
+errorCode InvalidDoBind = "InvalidDoBind"
+errorCode InvalidDoLet = "InvalidDoLet"
+errorCode (CycleInDeclaration _) = "CycleInDeclaration"
+errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"
+errorCode (NameIsUndefined _) = "NameIsUndefined"
+errorCode (NameNotInScope _) = "NameNotInScope"
+errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"
+errorCode (PartiallyAppliedSynonym _) = "PartiallyAppliedSynonym"
+errorCode (EscapedSkolem _) = "EscapedSkolem"
+errorCode UnspecifiedSkolemScope = "UnspecifiedSkolemScope"
+errorCode (TypesDoNotUnify _ _) = "TypesDoNotUnify"
+errorCode (KindsDoNotUnify _ _) = "KindsDoNotUnify"
+errorCode (ConstrainedTypeUnified _ _) = "ConstrainedTypeUnified"
+errorCode (OverlappingInstances _ _ _) = "OverlappingInstances"
+errorCode (NoInstanceFound _ _) = "NoInstanceFound"
+errorCode (DuplicateLabel _ _) = "DuplicateLabel"
+errorCode (DuplicateValueDeclaration _) = "DuplicateValueDeclaration"
+errorCode (ArgListLengthsDiffer _) = "ArgListLengthsDiffer"
+errorCode (OverlappingArgNames _) = "OverlappingArgNames"
+errorCode (MissingClassMember _) = "MissingClassMember"
+errorCode (ExpectedType _) = "ExpectedType"
+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 (ErrorInExpression _ e) = errorCode e
+errorCode (ErrorInModule _ e) = errorCode e
+errorCode (ErrorInInstance _ _ e) = errorCode e
+errorCode (ErrorInSubsumption _ _ e) = errorCode e
+errorCode (ErrorCheckingType _ _ e) = errorCode e
+errorCode (ErrorCheckingKind _ e) = errorCode e
+errorCode (ErrorInferringType _ e) = errorCode e
+errorCode (ErrorInApplication _ _ _ e) = errorCode e
+errorCode (ErrorInDataConstructor _ e) = errorCode e
+errorCode (ErrorInTypeConstructor _ e) = errorCode e
+errorCode (ErrorInBindingGroup _ e) = errorCode e
+errorCode (ErrorInDataBindingGroup e) = errorCode e
+errorCode (ErrorInTypeSynonym _ e) = errorCode e
+errorCode (ErrorInValueDeclaration _ e) = errorCode e
+errorCode (ErrorInForeignImport _ e) = errorCode e
+errorCode (PositionedError _ e) = errorCode e
+
+-- |
+-- A stack trace for an error
+--
+newtype MultipleErrors = MultipleErrors
+ { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)
+
+instance UnificationError Type MultipleErrors where
+ occursCheckFailed = errorMessage . occursCheckFailed
+
+instance UnificationError Kind MultipleErrors where
+ occursCheckFailed = errorMessage . occursCheckFailed
+
+-- |
+-- Create an error set from a single error message
+--
+errorMessage :: ErrorMessage -> MultipleErrors
+errorMessage err = MultipleErrors [err]
+
+-- |
+-- Lift a function on ErrorMessage to a function on MultipleErrors
+--
+onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
+onErrorMessages f = MultipleErrors . map f . runMultipleErrors
-- |
--- Type for sources of type checking errors
+-- Pretty print a single error, simplifying if necessary
--
-data ErrorSource
+prettyPrintSingleError :: Bool -> ErrorMessage -> Box.Box
+prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)
+ where
-- |
- -- An error which originated at a Expr
+ -- Pretty print an ErrorMessage
--
- = ExprError Expr
+ prettyPrintErrorMessage :: ErrorMessage -> Box.Box
+ prettyPrintErrorMessage em =
+ paras
+ [ go em
+ , line ("See " ++ wikiUri ++ " for more information, or to contribute content related to this error.")
+ ]
+ where
+ wikiUri :: String
+ wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
+
+ go :: ErrorMessage -> Box.Box
+ 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"
+ go UnspecifiedSkolemScope = line "Skolem variable scope is unspecified"
+ go OverlappingNamesInLet = line "Overlapping names in let binding."
+ go (InfiniteType ty) = paras [ line "Infinite type detected: "
+ , indent $ line $ prettyPrintType ty
+ ]
+ go (InfiniteKind ki) = paras [ line "Infinite kind detected: "
+ , indent $ line $ prettyPrintKind ki
+ ]
+ go (MultipleFixities name) = line $ "Multiple fixity declarations for " ++ show name
+ go (OrphanTypeDeclaration nm) = line $ "Orphan type declaration for " ++ show nm
+ go (OrphanFixityDeclaration op) = line $ "Orphan fixity declaration for " ++ show op
+ go (RedefinedModule name) = line $ "Module " ++ show name ++ " has been defined multiple times"
+ go (RedefinedIdent name) = line $ "Name " ++ show name ++ " has been defined multiple times"
+ go (UnknownModule mn) = line $ "Unknown module " ++ show mn
+ go (UnknownType name) = line $ "Unknown type " ++ show name
+ go (UnknownTypeClass name) = line $ "Unknown type class " ++ show name
+ go (UnknownValue name) = line $ "Unknown value " ++ show name
+ go (UnknownTypeConstructor name) = line $ "Unknown type constructor " ++ show name
+ go (UnknownDataConstructor dc tc) = line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
+ go (ConflictingImport nm mn) = line $ "Declaration " ++ nm ++ " conflicts with import " ++ show mn
+ go (ConflictingImports nm m1 m2) = line $ "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
+ go (ConflictingTypeDecls nm) = line $ "Conflicting type declarations for " ++ show nm
+ go (ConflictingCtorDecls nm) = line $ "Conflicting data constructor declarations for " ++ show nm
+ go (TypeConflictsWithClass nm) = line $ "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
+ go (CtorConflictsWithClass nm) = line $ "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
+ go (ClassConflictsWithType nm) = line $ "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
+ go (ClassConflictsWithCtor nm) = line $ "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
+ 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 (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
+ , indent $ go err
+ ]
+ go (CycleInTypeSynonym pn) = line $ "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
+ go (NameIsUndefined ident) = line $ show ident ++ " is undefined"
+ go (NameNotInScope ident) = line $ show ident ++ " may not be defined in the current scope"
+ go (UndefinedTypeVariable name) = line $ "Type variable " ++ show name ++ " is undefined"
+ go (PartiallyAppliedSynonym name) = line $ "Partially applied type synonym " ++ show name
+ go (EscapedSkolem binding) = paras $ [ line "Rigid/skolem type variable has escaped." ]
+ <> foldMap (\expr -> [ line "Relevant expression: "
+ , indent $ line $ prettyPrintValue expr
+ ]) binding
+ go (TypesDoNotUnify t1 t2) = paras [ line "Cannot unify type"
+ , indent $ line $ prettyPrintType t1
+ , line "with type"
+ , indent $ line $ prettyPrintType t2
+ ]
+ go (KindsDoNotUnify k1 k2) = paras [ line "Cannot unify kind"
+ , indent $ line $ prettyPrintKind k1
+ , line "with kind"
+ , indent $ line $ prettyPrintKind k2
+ ]
+ go (ConstrainedTypeUnified t1 t2) = paras [ line "Cannot unify constrained type"
+ , indent $ line $ prettyPrintType t1
+ , line "with type"
+ , indent $ line $ prettyPrintType t2
+ ]
+ go (OverlappingInstances nm ts ds) = paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
+ , paras $ map prettyPrintDictionaryValue ds
+ ]
+ go (NoInstanceFound nm ts) = line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
+ go (DuplicateLabel l expr) = paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
+ <> foldMap (\expr' -> [ line "Relevant expression: "
+ , indent $ line $ prettyPrintValue expr'
+ ]) expr
+ go (DuplicateTypeArgument name) = line $ "Duplicate type argument " ++ show name
+ go (DuplicateValueDeclaration nm) = line $ "Duplicate value declaration for " ++ show nm
+ go (ArgListLengthsDiffer ident) = line $ "Argument list lengths differ in declaration " ++ show ident
+ go (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
+ go (MissingClassMember ident) = line $ "Member " ++ show ident ++ " has not been implemented"
+ go (ExpectedType kind) = line $ "Expected type of kind *, was " ++ prettyPrintKind kind
+ go (IncorrectConstructorArity nm) = line $ "Wrong number of arguments to constructor " ++ show nm
+ go SubsumptionCheckFailed = line $ "Unable to check type subsumption"
+ go (ExprDoesNotHaveType expr ty) = paras [ line "Expression"
+ , indent $ line $ prettyPrintValue expr
+ , line "does not have type"
+ , indent $ line $ prettyPrintType ty
+ ]
+ go (PropertyIsMissing prop row) = line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
+ go (CannotApplyFunction fn arg) = paras [ line "Cannot apply function of type"
+ , indent $ line $ prettyPrintType fn
+ , line "to argument"
+ , indent $ line $ prettyPrintValue arg
+ ]
+ go TypeSynonymInstance = line "Type synonym instances are disallowed"
+ go InvalidNewtype = line "Newtypes must define a single constructor with a single argument"
+ go (InvalidInstanceHead ty) = paras [ line "Invalid type in class instance head:"
+ , indent $ line $ prettyPrintType ty
+ ]
+ go (TransitiveExportError x ys) = paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
+ : map (line . prettyPrintExport) ys
+ go (ErrorUnifyingTypes t1 t2 err) = paras [ line "Error unifying type "
+ , indent $ line $ prettyPrintType t1
+ , line "with type"
+ , indent $ line $ prettyPrintType t2
+ , go err
+ ]
+ go (ErrorInExpression expr err) = paras [ line "Error in expression:"
+ , indent $ line $ prettyPrintValue expr
+ , go err
+ ]
+ go (ErrorInModule mn err) = paras [ line $ "Error in module " ++ show mn ++ ":"
+ , go err
+ ]
+ go (ErrorInSubsumption t1 t2 err) = paras [ line "Error checking that type "
+ , indent $ line $ prettyPrintType t1
+ , line "subsumes type"
+ , indent $ line $ prettyPrintType t2
+ , go err
+ ]
+ go (ErrorInInstance name ts err) = paras [ line $ "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
+ , go err
+ ]
+ go (ErrorCheckingKind ty err) = paras [ line "Error checking kind of type "
+ , indent $ line $ prettyPrintType ty
+ , go err
+ ]
+ go (ErrorInferringType expr err) = paras [ line "Error inferring type of value "
+ , indent $ line $ prettyPrintValue expr
+ , go err
+ ]
+ go (ErrorCheckingType expr ty err) = paras [ line "Error checking that value "
+ , indent $ line $ prettyPrintValue expr
+ , line "has type"
+ , indent $ line $ prettyPrintType ty
+ , go err
+ ]
+ go (ErrorInApplication f t a err) = paras [ line "Error applying function"
+ , indent $ line $ prettyPrintValue f
+ , line "of type"
+ , indent $ line $ prettyPrintType t
+ , line "to argument"
+ , indent $ line $ prettyPrintValue a
+ , go err
+ ]
+ go (ErrorInDataConstructor nm err) = paras [ line $ "Error in data constructor " ++ show nm ++ ":"
+ , go err
+ ]
+ go (ErrorInTypeConstructor nm err) = paras [ line $ "Error in type constructor " ++ show nm ++ ":"
+ , go err
+ ]
+ go (ErrorInBindingGroup nms err) = paras [ line $ "Error in binding group " ++ intercalate ", " (map show nms) ++ ":"
+ , go err
+ ]
+ go (ErrorInDataBindingGroup err) = paras [ line $ "Error in data binding group:"
+ , go err
+ ]
+ go (ErrorInTypeSynonym name err) = paras [ line $ "Error in type synonym " ++ show name ++ ":"
+ , go err
+ ]
+ go (ErrorInValueDeclaration n err) = paras [ line $ "Error in value declaration " ++ show n ++ ":"
+ , go err
+ ]
+ go (ErrorInForeignImport nm err) = paras [ line $ "Error in foreign import " ++ show nm ++ ":"
+ , go err
+ ]
+ go (PositionedError pos err) = paras [ line $ "Error at " ++ show pos ++ ":"
+ , indent $ go err
+ ]
+
+ line :: String -> Box.Box
+ line = Box.text
+
+ paras :: [Box.Box] -> Box.Box
+ paras = Box.vcat Box.left
+
+ indent :: Box.Box -> Box.Box
+ indent = Box.moveRight 2
+
+ -- |
+ -- Render a DictionaryValue fit for human consumption in error messages
+ --
+ prettyPrintDictionaryValue :: DictionaryValue -> Box.Box
+ prettyPrintDictionaryValue (LocalDictionaryValue _) = line "Dictionary in scope"
+ prettyPrintDictionaryValue (GlobalDictionaryValue nm) = line (show nm)
+ prettyPrintDictionaryValue (DependentDictionaryValue nm args) = paras [ line $ (show nm) ++ " via"
+ , indent $ paras $ map prettyPrintDictionaryValue args
+ ]
+ prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"
+ , indent $ prettyPrintDictionaryValue sup
+ ]
+
+ -- |
+ -- Pretty print and export declaration
+ --
+ prettyPrintExport :: DeclarationRef -> String
+ prettyPrintExport (TypeRef pn _) = show pn
+ prettyPrintExport (ValueRef ident) = show ident
+ prettyPrintExport (TypeClassRef pn) = show pn
+ prettyPrintExport (TypeInstanceRef ident) = show ident
+ prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
+
-- |
- -- An error which originated at a Type
+ -- Simplify an error message
--
- | TypeError Type deriving (Show)
+ simplifyErrorMessage :: ErrorMessage -> ErrorMessage
+ simplifyErrorMessage = unwrap Nothing
+ where
+ unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
+ unwrap pos (ErrorInExpression _ err) = unwrap pos err
+ unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
+ unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
+ unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
+ unwrap pos (ErrorInferringType _ err) = unwrap pos err
+ unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
+ unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
+ unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
+ unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
+ unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
+ unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
+ unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
+ unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
+ unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
+ unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
+ unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
+ unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
+ unwrap _ (PositionedError pos err) = unwrap (Just pos) err
+ unwrap pos other = wrap pos other
+
+ wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
+ wrap Nothing = id
+ wrap (Just pos) = PositionedError pos
-- |
--- Compilation errors
+-- Pretty print multiple errors
--
-data CompileError
- = CompileError
- { -- |
- -- Error message
- --
- compileErrorMessage :: String
- -- |
- -- The value where the error occurred
- --
- , compileErrorValue :: Maybe ErrorSource
- -- |
- -- Optional source position information
- --
- , compileErrorPosition :: Maybe SourceSpan
- }
- deriving (Show)
+prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
+prettyPrintMultipleErrors full (MultipleErrors [e]) = renderBox $
+ prettyPrintSingleError full e
+prettyPrintMultipleErrors full (MultipleErrors es) = renderBox $
+ Box.vcat Box.left [ Box.text "Multiple errors:"
+ , Box.vsep 1 Box.left $ map (Box.moveRight 2 . prettyPrintSingleError full) es
+ ]
+
+renderBox :: Box.Box -> String
+renderBox = unlines . map trimEnd . lines . Box.render
+ where
+ trimEnd = reverse . dropWhile (== ' ') . reverse
-- |
--- A stack trace for an error
+-- Interpret multiple errors in a monad supporting errors
--
-data ErrorStack
- = ErrorStack { runErrorStack :: [CompileError] }
- | MultipleErrors [ErrorStack] deriving (Show)
-
--- TODO: Remove strMsg, the IsString instance, and unnecessary
--- OverloadedStrings pragmas. See #745
--- | Create an ErrorStack from a string
-strMsg :: String -> ErrorStack
-strMsg s = ErrorStack [CompileError s Nothing Nothing]
-
-instance IsString ErrorStack where
- fromString = strMsg
-
-prettyPrintErrorStack :: Bool -> ErrorStack -> String
-prettyPrintErrorStack printFullStack (ErrorStack es) =
- case mconcat $ map (Last . compileErrorPosition) es of
- Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
- _ -> prettyPrintErrorStack'
- where
- prettyPrintErrorStack' :: String
- prettyPrintErrorStack'
- | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))
- | otherwise =
- let
- es' = filter isErrorNonEmpty es
- in case length es' of
- 1 -> showError (head es')
- _ -> showError (head es') ++ "\n" ++ showError (last es')
-prettyPrintErrorStack printFullStack (MultipleErrors es) =
- unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
-
-stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a
-stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return
-
-isErrorNonEmpty :: CompileError -> Bool
-isErrorNonEmpty = not . null . compileErrorMessage
-
-showError :: CompileError -> String
-showError (CompileError msg Nothing _) = msg
-showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg
-showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
-
-mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
-mkErrorStack msg t = ErrorStack [mkCompileError msg t]
-
-mkCompileError :: String -> Maybe ErrorSource -> CompileError
-mkCompileError msg t = CompileError msg t Nothing
-
-positionError :: SourceSpan -> CompileError
-positionError pos = CompileError "" Nothing (Just pos)
+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
@@ -124,30 +502,23 @@ rethrow f = flip catchError $ \e -> throwError (f e)
-- |
-- Rethrow an error with source position information
--
-rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
-rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)
+rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
+rethrowWithPosition pos = rethrow (onErrorMessages withPosition)
+ where
+ withPosition :: ErrorMessage -> ErrorMessage
+ withPosition (PositionedError _ err) = withPosition err
+ withPosition err = PositionedError pos err
-- |
-- Collect errors in in parallel
--
-parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
+parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]
parU xs f = forM xs (withError . f) >>= collectErrors
where
- withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
+ withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)
withError u = catchError (Right <$> u) (return . Left)
- collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
+ collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]
collectErrors es = case lefts es of
- [err] -> throwError err
[] -> return $ rights es
- errs -> throwError $ MultipleErrors errs
-
--- |
--- Add an extra error string onto the top of each error stack in a list of possibly many errors
---
-combineErrors :: CompileError -> ErrorStack -> ErrorStack
-combineErrors ce err = go (ErrorStack [ce]) err
- where
- go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
- go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ]
- go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ]
+ errs -> throwError $ fold errs
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 71e516f..1af1ab4 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -41,7 +41,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]
--
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
+ let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
ms' <- mapM toModule $ stronglyConnComp verts
let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
return (ms', moduleGraph)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 4518aa0..b1afa4c 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -24,6 +24,8 @@ module Language.PureScript.Parser.Declarations (
parseGuard,
parseBinder,
parseBinderNoParens,
+ parseImportDeclaration',
+ parseLocalDeclaration
) where
import Prelude hiding (lex)
@@ -146,6 +148,11 @@ parseFixityDeclaration = do
parseImportDeclaration :: TokenParser Declaration
parseImportDeclaration = do
+ (mn, declType, asQ) <- parseImportDeclaration'
+ return $ ImportDeclaration mn declType asQ
+
+parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, (Maybe ModuleName))
+parseImportDeclaration' = do
reserved "import"
indented
qualImport <|> stdImport
@@ -157,21 +164,21 @@ parseImportDeclaration = do
stdImportHiding mn = do
reserved "hiding"
declType <- importDeclarationType Hiding
- return $ ImportDeclaration mn declType Nothing
+ return (mn, declType, Nothing)
stdImportQualifying mn = do
- declType <- importDeclarationType Qualifying
- return $ ImportDeclaration mn declType Nothing
+ declType <- importDeclarationType Explicit
+ return (mn, declType, Nothing)
qualImport = do
reserved "qualified"
indented
moduleName' <- moduleName
- declType <- importDeclarationType Qualifying
+ declType <- importDeclarationType Explicit
reserved "as"
asQ <- moduleName
- return $ ImportDeclaration moduleName' declType (Just asQ)
+ return (moduleName', declType, Just asQ)
importDeclarationType expectedType = do
idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
- return $ fromMaybe Unqualified (expectedType <$> idents)
+ return $ fromMaybe Implicit (expectedType <$> idents)
parseDeclarationRef :: TokenParser DeclarationRef
@@ -242,13 +249,14 @@ parseLocalDeclaration = positioned (P.choice
--
parseModule :: TokenParser Module
parseModule = do
+ comments <- C.readComments
reserved "module"
indented
name <- moduleName
exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
reserved "where"
decls <- mark (P.many (same *> parseDeclaration))
- return $ Module name decls exports
+ return $ Module comments name decls exports
-- |
-- Parse a collection of modules
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 69d55ba..4223305 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -272,26 +272,26 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
++ fromMaybe "" name
++ "(" ++ intercalate ", " args ++ ") "
++ ret ]
- , [ binary LessThan "<" ]
- , [ binary LessThanOrEqualTo "<=" ]
- , [ binary GreaterThan ">" ]
- , [ binary GreaterThanOrEqualTo ">=" ]
, [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
- , [ AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]
- , [ unary Not "!" ]
- , [ unary BitwiseNot "~" ]
- , [ negateOperator ]
- , [ unary Positive "+" ]
+ , [ unary Not "!"
+ , unary BitwiseNot "~"
+ , unary Positive "+"
+ , negateOperator ]
, [ binary Multiply "*"
, binary Divide "/"
, binary Modulus "%" ]
, [ binary Add "+"
, binary Subtract "-" ]
- , [ binary ShiftLeft "<<" ]
- , [ binary ShiftRight ">>" ]
- , [ binary ZeroFillShiftRight ">>>" ]
- , [ binary EqualTo "===" ]
- , [ binary NotEqualTo "!==" ]
+ , [ binary ShiftLeft "<<"
+ , binary ShiftRight ">>"
+ , binary ZeroFillShiftRight ">>>" ]
+ , [ binary LessThan "<"
+ , binary LessThanOrEqualTo "<="
+ , binary GreaterThan ">"
+ , binary GreaterThanOrEqualTo ">="
+ , AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]
+ , [ binary EqualTo "==="
+ , binary NotEqualTo "!==" ]
, [ binary BitwiseAnd "&" ]
, [ binary BitwiseXor "^" ]
, [ binary BitwiseOr "|" ]
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 568c26e..0f2b4df 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Pretty.Values
--- Copyright : Kinds.hs(c) Phil Freeman 2013
+-- Copyright : (c) Phil Freeman 2013
-- License : MIT
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
@@ -29,7 +29,7 @@ import Control.Applicative
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Pretty.Common
-import Language.PureScript.Pretty.Types (prettyPrintType)
+import Language.PureScript.Pretty.Types (prettyPrintType, prettyPrintTypeAtom)
literals :: Pattern PrinterState Expr String
literals = mkPattern' match
@@ -76,7 +76,7 @@ literals = mkPattern' match
]
match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"
match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"
- match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"
+ match (TypeClassDictionary _ (name, tys) _) = return $ "<<dict " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"
match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
match (TypedValue _ val _) = prettyPrintValue' val
match (PositionedValue _ _ val) = prettyPrintValue' val
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 69e3086..cab0bd0 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -113,7 +113,7 @@ renameInModules :: [Module Ann] -> [Module Ann]
renameInModules = map go
where
go :: Module Ann -> Module Ann
- go m@(Module _ _ _ _ decls) = m { moduleDecls = renameInDecl' (findDeclIdents decls) `map` decls }
+ go m@(Module _ _ _ _ _ decls) = m { moduleDecls = renameInDecl' (findDeclIdents decls) `map` decls }
renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann
renameInDecl' scope = runRename scope . renameInDecl True
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 0a5bc05..31356da 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -13,15 +13,18 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE FlexibleContexts #-}
+
module Language.PureScript.Sugar (desugar, module S) where
import Control.Monad
import Control.Category ((>>>))
-import Control.Monad.Trans.Class
+import Control.Applicative
+import Control.Monad.Error.Class
+import Control.Monad.Supply.Class
import Language.PureScript.AST
import Language.PureScript.Errors
-import Language.PureScript.Supply
import Language.PureScript.Sugar.BindingGroups as S
import Language.PureScript.Sugar.CaseDeclarations as S
@@ -55,14 +58,14 @@ import Language.PureScript.Sugar.TypeDeclarations as S
--
-- * Group mutually recursive value and data declarations into binding groups.
--
-desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
+desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
desugar = map removeSignedLiterals
>>> mapM desugarObjectConstructors
>=> mapM desugarOperatorSections
>=> mapM desugarDoModule
>=> desugarCasesModule
- >=> lift . (desugarTypeDeclarationsModule
- >=> desugarImports
- >=> rebracket)
+ >=> desugarTypeDeclarationsModule
+ >=> desugarImports
+ >=> rebracket
>=> desugarTypeClasses
- >=> lift . createBindingGroupsModule
+ >=> createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index c477180..b5e311b 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -14,6 +14,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE FlexibleContexts #-}
+
module Language.PureScript.Sugar.BindingGroups (
createBindingGroups,
createBindingGroupsModule,
@@ -24,8 +26,9 @@ module Language.PureScript.Sugar.BindingGroups (
import Data.Graph
import Data.List (nub, intersect)
import Data.Maybe (isJust, mapMaybe)
-import Control.Applicative ((<$>), (<*>), pure)
+import Control.Applicative
import Control.Monad ((<=<))
+import Control.Monad.Error.Class
import qualified Data.Set as S
@@ -38,29 +41,29 @@ import Language.PureScript.Errors
-- |
-- Replace all sets of mutually-recursive declarations in a module with binding groups
--
-createBindingGroupsModule :: [Module] -> Either ErrorStack [Module]
-createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps
+createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
+createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms name <$> createBindingGroups name ds <*> pure exps
-- |
-- Collapse all binding groups in a module to individual declarations
--
collapseBindingGroupsModule :: [Module] -> [Module]
-collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps
+collapseBindingGroupsModule = map $ \(Module coms name ds exps) -> Module coms name (collapseBindingGroups ds) exps
-createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]
+createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]
createBindingGroups moduleName = mapM f <=< handleDecls
where
(f, _, _) = everywhereOnValuesTopDownM return handleExprs return
- handleExprs :: Expr -> Either ErrorStack Expr
+ handleExprs :: (Functor m, MonadError MultipleErrors m) => Expr -> m Expr
handleExprs (Let ds val) = flip Let val <$> handleDecls ds
handleExprs other = return other
-- |
-- Replace all sets of mutually-recursive declarations with binding groups
--
- handleDecls :: [Declaration] -> Either ErrorStack [Declaration]
+ handleDecls :: (Functor m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
handleDecls ds = do
let values = filter isValueDecl ds
dataDecls = filter isDataDecl ds
@@ -75,6 +78,7 @@ createBindingGroups moduleName = mapM f <=< handleDecls
filter isExternInstanceDecl ds ++
dataBindingGroupDecls ++
filter isTypeClassDeclaration ds ++
+ filter isTypeClassInstanceDeclaration ds ++
filter isFixityDecl ds ++
filter isExternDecl ds ++
bindingGroupDecls
@@ -151,7 +155,7 @@ getProperName _ = error "Expected DataDeclaration"
-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
--
--
-toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration
+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') =
@@ -172,24 +176,23 @@ toBindingGroup moduleName (CyclicSCC ds') =
valueVerts :: [(Declaration, Ident, [Ident])]
valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
- toBinding :: SCC Declaration -> Either ErrorStack (Ident, NameKind, Expr)
+ toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr)
toBinding (AcyclicSCC d) = return $ fromValueDecl d
toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
- cycleError :: Declaration -> [Declaration] -> Either ErrorStack a
+ cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a
cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
- cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $
- mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))
- cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []
+ cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n
+ cycleError d ds@(_:_) = rethrow (onErrorMessages (NotYetDefined (map getIdent ds))) $ cycleError d []
cycleError _ _ = error "Expected ValueDeclaration"
-toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration
+toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration
toDataBindingGroup (AcyclicSCC d) = return d
toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
- Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
+ Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)
_ -> return d
toDataBindingGroup (CyclicSCC ds')
- | all (isJust . isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing
+ | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing
| otherwise = return $ DataBindingGroupDeclaration ds'
isTypeSynonym :: Declaration -> Maybe ProperName
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index dde2428..3f48f88 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -14,6 +14,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE FlexibleContexts #-}
+
module Language.PureScript.Sugar.CaseDeclarations (
desugarCases,
desugarCasesModule
@@ -24,12 +26,13 @@ import Data.List (nub, groupBy)
import Control.Applicative
import Control.Monad ((<=<), forM, join, unless, replicateM)
import Control.Monad.Except (throwError)
+import Control.Monad.Error.Class (MonadError)
+import Control.Monad.Supply.Class
import Language.PureScript.Names
import Language.PureScript.AST
import Language.PureScript.Environment
import Language.PureScript.Errors
-import Language.PureScript.Supply
import Language.PureScript.Traversals
import Language.PureScript.TypeChecker.Monad (guardWith)
@@ -41,17 +44,17 @@ isLeft (Right _) = False
-- |
-- Replace all top-level binders in a module with case expressions.
--
-desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]
-desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
- rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $
- Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
+desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
+desugarCasesModule ms = forM ms $ \(Module coms name ds exps) ->
+ rethrow (onErrorMessages (ErrorInModule name)) $
+ Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
-desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
+desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarAbs = flip parU f
where
(f, _, _) = everywhereOnValuesM return replace return
- replace :: Expr -> SupplyT (Either ErrorStack) Expr
+ replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr
replace (Abs (Right binder) val) = do
ident <- Ident <$> freshName
return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
@@ -60,10 +63,10 @@ desugarAbs = flip parU f
-- |
-- Replace all top-level binders with case expressions.
--
-desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
+desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
where
- desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
+ desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
(:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
desugarRest (ValueDeclaration name nameKind bs result : rest) =
@@ -86,18 +89,18 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2
inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
inSameGroup _ _ = False
-toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
+toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
let args = map (\(VarBinder arg) -> arg) bs
body = foldr (Abs . Left) val args
- guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args
+ guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (nub args) == length args
return [ValueDeclaration ident nameKind [] (Right body)]
toDecls ds@(ValueDeclaration ident _ bs result : _) = do
let tuples = map toTuple ds
unless (all ((== length bs) . length . fst) tuples) $
- throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
+ throwError . errorMessage $ ArgListLengthsDiffer ident
unless (not (null bs) || isLeft result) $
- throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing
+ throwError . errorMessage $ DuplicateValueDeclaration ident
caseDecl <- makeCaseDeclaration ident tuples
return [caseDecl]
toDecls (PositionedDeclaration pos com d : ds) = do
@@ -114,13 +117,34 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)
toTuple (PositionedDeclaration _ _ d) = toTuple d
toTuple _ = error "Not a value declaration"
-makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration
+makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
makeCaseDeclaration ident alternatives = do
- let argPattern = length . fst . head $ alternatives
- args <- map Ident <$> replicateM argPattern freshName
+ let namedArgs = map findName . fst <$> alternatives
+ args <- mapM argName $ foldl1 resolveNames namedArgs
let
vars = map (Var . Qualified Nothing) args
binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
value = foldr (Abs . Left) (Case vars binders) args
return $ ValueDeclaration ident Value [] (Right value)
+ where
+ findName :: Binder -> Maybe Ident
+ findName (VarBinder name) = Just name
+ findName (PositionedBinder _ _ binder) = findName binder
+ findName _ = Nothing
+
+ argName :: (MonadSupply m) => Maybe Ident -> m Ident
+ argName (Just name) = return name
+ argName Nothing = do
+ name <- freshName
+ return (Ident name)
+
+ resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]
+ resolveNames = zipWith resolveName
+ resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident
+ resolveName (Just a) (Just b)
+ | a == b = Just a
+ | otherwise = Nothing
+ resolveName Nothing Nothing = Nothing
+ resolveName (Just a) Nothing = Just a
+ resolveName Nothing (Just b) = Just b
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index ac30a39..9667655 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -14,6 +14,9 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
module Language.PureScript.Sugar.DoNotation (
desugarDoModule
) where
@@ -21,21 +24,21 @@ module Language.PureScript.Sugar.DoNotation (
import Language.PureScript.Names
import Language.PureScript.AST
import Language.PureScript.Errors
-import Language.PureScript.Supply
import qualified Language.PureScript.Constants as C
import Control.Applicative
-import Control.Monad.Trans.Class
+import Control.Monad.Error.Class
+import Control.Monad.Supply.Class
-- |
-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
-- and all @DoNotationLet@ constructors with let expressions.
--
-desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
-desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts
+desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
+desugarDoModule (Module coms mn ds exts) = Module coms mn <$> parU ds desugarDo <*> pure exts
-desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
+desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
desugarDo d =
let (f, _, _) = everywhereOnValuesM return replace return
@@ -47,18 +50,18 @@ desugarDo d =
bind :: Expr
bind = Var (Qualified (Just prelude) (Op (C.>>=)))
- replace :: Expr -> SupplyT (Either ErrorStack) Expr
+ replace :: Expr -> m Expr
replace (Do els) = go els
replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
replace other = return other
- go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr
+ go :: [DoNotationElement] -> m Expr
go [] = error "The impossible happened in desugarDo"
go [DoNotationValue val] = return val
go (DoNotationValue val : rest) = do
rest' <- go rest
return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
- go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
+ go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind
go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
go (DoNotationBind (VarBinder ident) val : rest) = do
rest' <- go rest
@@ -67,7 +70,7 @@ desugarDo d =
rest' <- go rest
ident <- Ident <$> freshName
return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
- go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
+ go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
go (DoNotationLet ds : rest) = do
rest' <- go rest
return $ Let ds rest'
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index fc22e34..e885f7d 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -12,6 +12,9 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
module Language.PureScript.Sugar.Names (
desugarImports
) where
@@ -84,7 +87,7 @@ data ImportEnvironment = ImportEnvironment
-- Updates the exports for a module from the global environment. If the module was not previously
-- present in the global environment, it is created.
--
-updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either ErrorStack Exports) -> Either ErrorStack ExportEnvironment
+updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment
updateExportedModule env mn update = do
let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
exports' <- update exports
@@ -93,61 +96,61 @@ updateExportedModule env mn update = do
-- |
-- Adds an empty module to an ExportEnvironment.
--
-addEmptyModule :: ExportEnvironment -> ModuleName -> Either ErrorStack ExportEnvironment
+addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment
addEmptyModule env name =
if name `M.member` env
- then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing
+ then throwError . errorMessage $ RedefinedModule name
else return $ M.insert name (Exports [] [] []) env
-- |
-- Adds a type belonging to a module to the export environment.
--
-addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment
+addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment
addType env mn name dctors = updateExportedModule env mn $ \m -> do
let exTypes = exportedTypes m
let exDctors = snd `concatMap` exTypes
let exClasses = exportedTypeClasses m
- when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name
- when (name `elem` exClasses) $ throwConflictingDefError "Type" "type class" name
+ when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
+ when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name
forM_ dctors $ \dctor -> do
- when (dctor `elem` exDctors) $ throwMultipleDefError "data constructor" dctor
- when (dctor `elem` exClasses) $ throwConflictingDefError "Data constructor" "type class" dctor
+ when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
+ when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor
return $ m { exportedTypes = (name, dctors) : exTypes }
-- |
-- Adds a class to the export environment.
--
-addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
+addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment
addTypeClass env mn name = updateExportedModule env mn $ \m -> do
let exTypes = exportedTypes m
let exDctors = snd `concatMap` exTypes
- when (any ((== name) . fst) exTypes) $ throwConflictingDefError "Type class" "type" name
- when (name `elem` exDctors) $ throwConflictingDefError "Type class" "data constructor" name
- classes <- addExport "type class" (exportedTypeClasses m) name
+ when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name
+ when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
+ classes <- addExport DuplicateClassExport (exportedTypeClasses m) name
return $ m { exportedTypeClasses = classes }
-- |
-- Adds a class to the export environment.
--
-addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
+addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment
addValue env mn name = updateExportedModule env mn $ \m -> do
- values <- addExport "value" (exportedValues m) name
+ values <- addExport DuplicateValueExport (exportedValues m) name
return $ m { exportedValues = values }
-- |
-- Adds an entry to a list of exports unless it is already present, in which case an error is
-- returned.
--
-addExport :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack [a]
+addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> ErrorMessage) -> [a] -> a -> m [a]
addExport what exports name =
if name `elem` exports
- then throwMultipleDefError what name
+ then throwConflictError what name
else return $ name : exports
-- |
-- Replaces all local names with qualified names within a set of modules.
--
-desugarImports :: [Module] -> Either ErrorStack [Module]
+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
desugarImports modules = do
unfilteredExports <- findExports modules
exports <- foldM filterModuleExports unfilteredExports modules
@@ -157,15 +160,15 @@ desugarImports modules = do
-- Filters the exports for a module in the global exports environment so that only explicitly
-- exported members remain. If the module does not explicitly export anything, everything is
-- exported.
- filterModuleExports :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
- filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env
+ filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment
+ filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env
filterModuleExports env _ = return env
-- Rename and check all the names within a module. We tweak the global exports environment so
-- the module has access to an unfiltered list of its own members.
- renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
- renameInModule' unfilteredExports exports m@(Module mn _ _) =
- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ do
+ renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module
+ renameInModule' unfilteredExports exports m@(Module _ mn _ _) =
+ rethrow (onErrorMessages (ErrorInModule mn)) $ do
let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
imports <- resolveImports env m
@@ -176,7 +179,7 @@ desugarImports modules = do
-- as it will also make all data constructor exports explicit.
--
elaborateExports :: Exports -> Module -> Module
-elaborateExports exps (Module mn decls _) = Module mn decls (Just $
+elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $
map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
map TypeClassRef (exportedTypeClasses exps) ++
map ValueRef (exportedValues exps))
@@ -186,7 +189,7 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $
-- This ensures transitive instances are included when using a member from a module.
--
elaborateImports :: Module -> Module
-elaborateImports (Module mn decls exps) = Module mn decls' exps
+elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps
where
decls' :: [Declaration]
decls' =
@@ -196,19 +199,19 @@ elaborateImports (Module mn decls exps) = Module mn decls' exps
fqValues (Var (Qualified (Just mn') _)) = [mn']
fqValues _ = []
mkImport :: ModuleName -> Declaration
- mkImport mn' = ImportDeclaration mn' (Qualifying []) Nothing
+ mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing
-- |
-- Replaces all local names with qualified names within a module and checks that all existing
-- qualified names are valid.
--
-renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
-renameInModule imports exports (Module mn decls exps) =
- Module mn <$> parU decls go <*> pure exps
+renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
+renameInModule imports exports (Module coms mn decls exps) =
+ Module coms mn <$> parU decls go <*> pure exps
where
(go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
- updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Declaration)
+ updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)
updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)
updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
(,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
@@ -226,14 +229,14 @@ renameInModule imports exports (Module mn decls exps) =
(,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
updateDecl s d = return (s, d)
- updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)
+ updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)
updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
updateValue (pos, bound) (Let ds val') = do
let args = mapMaybe letBoundVariable ds
unless (length (nub args) == length args) $
- maybe id rethrowWithPosition pos $
- throwError $ mkErrorStack ("Overlapping names in let binding.") Nothing
+ maybe id rethrowWithPosition pos $
+ throwError . errorMessage $ OverlappingNamesInLet
return ((pos, args ++ bound), Let ds val')
where
updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
@@ -244,12 +247,12 @@ renameInModule imports exports (Module mn decls exps) =
updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
updateValue s v = return (s, v)
- updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Binder)
+ updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)
updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)
updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
updateBinder s v = return (s, v)
- updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourceSpan, [Ident]), CaseAlternative)
+ updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
letBoundVariable :: Declaration -> Maybe Ident
@@ -257,10 +260,10 @@ renameInModule imports exports (Module mn decls exps) =
letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d
letBoundVariable _ = Nothing
- updateTypesEverywhere :: Maybe SourceSpan -> Type -> Either ErrorStack Type
+ updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type
updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
where
- updateType :: Maybe SourceSpan -> Type -> Either ErrorStack Type
+ updateType :: Maybe SourceSpan -> Type -> m Type
updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
@@ -268,28 +271,28 @@ renameInModule imports exports (Module mn decls exps) =
updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
- updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
- updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
- updateValueName = update "value" importedValues (flip elem . exportedValues)
- updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
+ updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
+ updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)
+ updateValueName = update UnknownValue importedValues (flip elem . exportedValues)
+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
-- Update names so unqualified references become qualified, and locally qualified references
-- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
- update :: (Ord a, Show a) => String
+ update :: (Ord a, Show a) => (Qualified a -> ErrorMessage)
-> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
-> (Exports -> a -> Bool)
-> Qualified a
-> Maybe SourceSpan
- -> Either ErrorStack (Qualified a)
- update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
+ -> m (Qualified a)
+ update unknown getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
(Just qname', _) -> return qname'
(Nothing, Just mn'') -> do
- when (isExplicitQualModule mn'') $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
+ when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname
modExports <- getExports mn''
if checkE modExports name
then return qname
- else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
- _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
+ else throwError . errorMessage $ unknown qname
+ _ -> throwError . errorMessage $ unknown qname
where
isExplicitQualModule :: ModuleName -> Bool
isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
@@ -299,13 +302,13 @@ renameInModule imports exports (Module mn decls exps) =
Just pos' -> rethrowWithPosition pos' err
-- Gets the exports for a module, or an error message if the module doesn't exist
- getExports :: ModuleName -> Either ErrorStack Exports
- getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports
+ getExports :: ModuleName -> m Exports
+ getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') return $ M.lookup mn' exports
-- |
-- Finds all exported declarations in a set of modules.
--
-findExports :: [Module] -> Either ErrorStack ExportEnvironment
+findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment
findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
where
@@ -315,13 +318,13 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
mkTypeEntry (Qualified _ name) = (name, [])
-- Add all of the exported declarations from a module to the global export environment
- addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
- addModule env (Module mn ds _) = do
+ addModule :: ExportEnvironment -> Module -> m ExportEnvironment
+ addModule env (Module _ mn ds _) = do
env' <- addEmptyModule env mn
- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ foldM (addDecl mn) env' ds
+ rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds
-- Add a declaration from a module to the global export environment
- addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment
+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment
addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
env' <- addTypeClass env mn tcn
foldM go env' ds
@@ -341,15 +344,15 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
-- environment.
--
-filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment
+filterExports :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment
filterExports mn exps env = do
let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
- moduleExports' <- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ filterModule moduleExports
+ moduleExports' <- rethrow (onErrorMessages (ErrorInModule mn)) $ filterModule moduleExports
return $ M.insert mn moduleExports' env
where
-- Filter the exports for the specific module
- filterModule :: Exports -> Either ErrorStack Exports
+ filterModule :: Exports -> m Exports
filterModule exported = do
types' <- foldM (filterTypes $ exportedTypes exported) [] exps
values <- foldM (filterValues $ exportedValues exported) [] exps
@@ -358,37 +361,37 @@ filterExports mn exps env = do
-- Ensure the exported types and data constructors exist in the module and add them to the set of
-- exports
- filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]
+ filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]
filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
filterTypes expTys result (TypeRef name expDcons) = do
- dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys
+ dcons <- maybe (throwError . errorMessage . UnknownType $ Qualified (Just mn) name) return $ name `lookup` expTys
dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
return $ (name, dcons') : result
filterTypes _ result _ = return result
-- Ensure the exported data constructors exists for a type and add them to the list of exports
- filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either ErrorStack [ProperName]
+ filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> m [ProperName]
filterDcons tcon exps' result name =
if name `elem` exps'
then return $ name : result
- else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing
+ else throwError . errorMessage $ UnknownDataConstructor (Qualified (Just mn) name) (Just (Qualified (Just mn) tcon))
-- Ensure the exported classes exist in the module and add them to the set of exports
- filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]
+ filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]
filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r
filterClasses exps' result (TypeClassRef name) =
if name `elem` exps'
then return $ name : result
- else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing
+ else throwError . errorMessage . UnknownTypeClass $ Qualified (Just mn) name
filterClasses _ result _ = return result
-- Ensure the exported values exist in the module and add them to the set of exports
- filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]
+ filterValues :: [Ident] -> [Ident] -> DeclarationRef -> m [Ident]
filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r
filterValues exps' result (ValueRef name) =
if name `elem` exps'
then return $ name : result
- else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing
+ else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name
filterValues _ result _ = return result
-- |
@@ -405,8 +408,8 @@ findImports = foldl (findImports' Nothing) M.empty
-- |
-- Constructs a local environment for a module.
--
-resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnvironment
-resolveImports env (Module currentModule decls _) =
+resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment
+resolveImports env (Module _ currentModule decls _) =
foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
where
@@ -414,11 +417,11 @@ resolveImports env (Module currentModule decls _) =
-- module (where Nothing indicates everything is to be imported), and optionally a qualified name
-- for the module
scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
- scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)
+ scope = M.insert currentModule (Nothing, Implicit, Nothing) (findImports decls)
- resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment
resolveImport' imp (mn, (pos, typ, impQual)) = do
- modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
+ modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) return $ mn `M.lookup` env
positioned $ resolveImport currentModule mn modExports imp impQual typ
where
positioned err = case pos of
@@ -428,19 +431,19 @@ resolveImports env (Module currentModule decls _) =
-- |
-- Extends the local environment for a module by resolving an import of another module.
--
-resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> Either ErrorStack ImportEnvironment
+resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment
resolveImport currentModule importModule exps imps impQual =
resolveByType
where
- resolveByType :: ImportDeclarationType -> Either ErrorStack ImportEnvironment
- resolveByType Unqualified = importAll importExplicit
- resolveByType (Qualifying explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
+ resolveByType :: ImportDeclarationType -> m ImportEnvironment
+ resolveByType Implicit = importAll importExplicit
+ resolveByType (Explicit explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
resolveByType (Hiding hiddenImports) = do
hiddenImports' <- checkedRefs hiddenImports
importAll (importNonHidden hiddenImports')
- importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
+ importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment
importNonHidden hidden m ref =
if isHidden hidden ref
then return m
@@ -459,14 +462,14 @@ resolveImport currentModule importModule exps imps impQual =
isHidden hidden ref = ref `elem` hidden
-- Import all symbols
- importAll :: (ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment) -> Either ErrorStack ImportEnvironment
+ importAll :: (ImportEnvironment -> DeclarationRef -> m ImportEnvironment) -> m ImportEnvironment
importAll importer = do
imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
-- Import something explicitly
- importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
+ importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment
importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r
importExplicit imp (ValueRef name) = do
values' <- updateImports (importedValues imp) name
@@ -483,20 +486,20 @@ resolveImport currentModule importModule exps imps impQual =
importExplicit _ _ = error "Invalid argument to importExplicit"
-- Check if DeclarationRef points to an existent symbol
- checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]
+ checkedRefs :: [DeclarationRef] -> m [DeclarationRef]
checkedRefs = mapM check
where
check (PositionedDeclarationRef pos _ r) =
rethrowWithPosition pos $ check r
check ref@(ValueRef name) =
- checkImportExists "value" values name >> return ref
+ checkImportExists UnknownValue values name >> return ref
check ref@(TypeRef name dctors) = do
- _ <- checkImportExists "type" availableTypes name
+ _ <- checkImportExists UnknownType availableTypes name
let allDctors = allExportedDataConstructors name
_ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
return ref
check ref@(TypeClassRef name) =
- checkImportExists "type class" classes name >> return ref
+ checkImportExists UnknownTypeClass classes name >> return ref
check _ = error "Invalid argument to checkRefIsValid"
-- Find all exported data constructors for a given type
@@ -504,15 +507,15 @@ resolveImport currentModule importModule exps imps impQual =
allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
-- Add something to the ImportEnvironment if it does not already exist there
- updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either ErrorStack (M.Map (Qualified a) (Qualified a))
+ updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> m (M.Map (Qualified a) (Qualified a))
updateImports m name = case M.lookup (Qualified impQual name) m of
Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
Just (Qualified Nothing _) -> error "Invalid state in updateImports"
- Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing
+ Just (Qualified (Just mn) _) -> throwError . errorMessage $ err
where
err = if mn == currentModule || importModule == currentModule
- then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
- else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
+ then ConflictingImport (show name) mn
+ else ConflictingImports (show name) mn importModule
-- The available values, types, and classes in the module being imported
values = exportedValues exps
@@ -521,28 +524,18 @@ resolveImport currentModule importModule exps imps impQual =
-- Ensure that an explicitly imported data constructor exists for the type it is being imported
-- from
- checkDctorExists :: [ProperName] -> ProperName -> Either ErrorStack ProperName
- checkDctorExists = checkImportExists "data constructor"
+ checkDctorExists :: [ProperName] -> ProperName -> m ProperName
+ checkDctorExists = checkImportExists (flip UnknownDataConstructor Nothing)
-- Check that an explicitly imported item exists in the module it is being imported from
- checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack a
- checkImportExists t exports item =
+ checkImportExists :: (Eq a, Show a) => (Qualified a -> ErrorMessage) -> [a] -> a -> m a
+ checkImportExists unknown exports item =
if item `elem` exports
then return item
- else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
+ else throwError . errorMessage . unknown $ Qualified (Just importModule) item
-- |
-- Raises an error for when there is more than one definition for something.
--
-throwMultipleDefError :: (Show a) => String -> a -> Either ErrorStack b
-throwMultipleDefError what name = throwError $
- mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing
-
--- |
--- Raises an error for when there is a conflicting definition for something, for example, a type
--- class and data constructor of the same name.
---
-throwConflictingDefError :: (Show a) => String -> String -> a -> Either ErrorStack b
-throwConflictingDefError what1 what2 name = throwError $
- mkErrorStack (what1 ++ " '" ++ show name ++ "' cannot be defined in the same module as a " ++ what2 ++ " of the same name") Nothing
-
+throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> ErrorMessage) -> a -> m b
+throwConflictError conflict = throwError . errorMessage . conflict
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index 625d4aa..984ce79 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -12,12 +12,17 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
module Language.PureScript.Sugar.ObjectWildcards (
desugarObjectConstructors
) where
import Control.Applicative
import Control.Arrow (second)
+import Control.Monad.Error.Class
+import Control.Monad.Supply.Class
import Data.List (partition)
import Data.Maybe (isJust, fromJust, catMaybes)
@@ -25,16 +30,15 @@ import Data.Maybe (isJust, fromJust, catMaybes)
import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Names
-import Language.PureScript.Supply
-desugarObjectConstructors :: Module -> SupplyT (Either ErrorStack) Module
-desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl ds <*> pure exts
+desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
+desugarObjectConstructors (Module coms mn ds exts) = Module coms mn <$> mapM desugarDecl ds <*> pure exts
where
- desugarDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration
+ desugarDecl :: Declaration -> m Declaration
(desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return
- desugarExpr :: Expr -> SupplyT (Either ErrorStack) Expr
+ desugarExpr :: Expr -> m Expr
desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
desugarExpr (ObjectUpdater Nothing ps) = do
@@ -45,7 +49,7 @@ desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl d
return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
desugarExpr e = return e
- wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> SupplyT (Either ErrorStack) Expr
+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr
wrapLambda mkVal ps =
let (props, args) = partition (isJust . snd) ps
in if null args
@@ -54,7 +58,7 @@ desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl d
(args', ps') <- unzip <$> mapM mkProp ps
return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
- mkProp :: (String, Maybe Expr) -> SupplyT (Either ErrorStack) (Maybe Ident, (String, Expr))
+ mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))
mkProp (name, Just e) = return (Nothing, (name, e))
mkProp (name, Nothing) = do
arg <- Ident <$> freshName
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 9038e63..95fe08e 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -17,7 +17,9 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE Rank2Types, FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Language.PureScript.Sugar.Operators (
rebracket,
@@ -28,11 +30,11 @@ module Language.PureScript.Sugar.Operators (
import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Names
-import Language.PureScript.Supply
import Control.Applicative
import Control.Monad.State
import Control.Monad.Except
+import Control.Monad.Supply.Class
import Data.Function (on)
import Data.Functor.Identity
@@ -47,7 +49,7 @@ import qualified Language.PureScript.Constants as C
-- |
-- Remove explicit parentheses and reorder binary operator applications
--
-rebracket :: [Module] -> Either ErrorStack [Module]
+rebracket :: (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
rebracket ms = do
let fixities = concatMap collectFixities ms
ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
@@ -55,17 +57,17 @@ rebracket ms = do
mapM (rebracketModule opTable) ms
removeSignedLiterals :: Module -> Module
-removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts
+removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts
where
(f', _, _) = everywhereOnValues id go id
go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
go other = other
-rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module
-rebracketModule opTable (Module mn ds exts) =
+rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
+rebracketModule opTable (Module coms mn ds exts) =
let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
- in Module mn <$> (map removeParens <$> parU ds f) <*> pure exts
+ in Module coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
removeParens :: Declaration -> Declaration
removeParens =
@@ -76,22 +78,22 @@ removeParens =
go val = val
collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
-collectFixities (Module moduleName ds _) = concatMap collect ds
+collectFixities (Module _ moduleName ds _) = concatMap collect ds
where
collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
collect FixityDeclaration{} = error "Fixity without srcpos info"
collect _ = []
-ensureNoDuplicates :: [(Qualified Ident, SourceSpan)] -> Either ErrorStack ()
+ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()
ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
where
go [] = return ()
go [_] = return ()
go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $
+ rethrow (onErrorMessages (ErrorInModule mn)) $
rethrowWithPosition pos $
- throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
+ throwError . errorMessage $ MultipleFixities name
go (_ : rest) = go rest
customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
@@ -106,17 +108,17 @@ customOperatorTable fixities =
type Chain = [Either Expr Expr]
-matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr
+matchOperators :: forall m. (MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr
matchOperators ops = parseChains
where
- parseChains :: Expr -> Either ErrorStack Expr
+ parseChains :: Expr -> m Expr
parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
parseChains other = return other
extendChain :: Expr -> Chain
extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
extendChain other = [Left other]
- bracketChain :: Chain -> Either ErrorStack Expr
- bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
+ bracketChain :: Chain -> m Expr
+ bracketChain = either (const . throwError . errorMessage $ CannotReorderOperators) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]
: map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
@@ -149,14 +151,14 @@ matchOp op = do
ident <- parseOp
guard $ ident == op
-desugarOperatorSections :: Module -> SupplyT (Either ErrorStack) Module
-desugarOperatorSections (Module mn ds exts) = Module mn <$> mapM goDecl ds <*> pure exts
+desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
+desugarOperatorSections (Module coms mn ds exts) = Module coms mn <$> mapM goDecl ds <*> pure exts
where
- goDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration
+ goDecl :: Declaration -> m Declaration
(goDecl, _, _) = everywhereOnValuesM return goExpr return
- goExpr :: Expr -> SupplyT (Either ErrorStack) Expr
+ goExpr :: Expr -> m Expr
goExpr (OperatorSection op (Left val)) = return $ App op val
goExpr (OperatorSection op (Right val)) = do
arg <- Ident <$> freshName
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index ed08fc2..ffd6ada 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -14,6 +14,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE FlexibleContexts #-}
+
module Language.PureScript.Sugar.TypeClasses
( desugarTypeClasses
, typeClassMemberName
@@ -25,9 +27,8 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
-import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
import Language.PureScript.Sugar.CaseDeclarations
-import Language.PureScript.Supply
+import Control.Monad.Supply.Class
import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
@@ -36,26 +37,32 @@ import Control.Applicative
import Control.Arrow (first, second)
import Control.Monad.Except
import Control.Monad.State
-import Data.List ((\\), find)
+import Data.List ((\\), find, sortBy)
import Data.Maybe (catMaybes, mapMaybe, isJust)
import qualified Data.Map as M
type MemberMap = M.Map (ModuleName, ProperName) Declaration
-type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))
+type Desugar = StateT MemberMap
-- |
-- Add type synonym declarations for type class dictionary types, and value declarations for type class
-- instance dictionary expressions.
--
-desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
+desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
-desugarModule :: Module -> Desugar Module
-desugarModule (Module name decls (Just exps)) = do
- (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)
- return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
+desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module
+desugarModule (Module coms name decls (Just exps)) = do
+ (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)
+ return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
+ where
+ classesFirst :: Declaration -> Declaration -> Ordering
+ classesFirst d1 d2
+ | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT
+ | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT
+ | otherwise = EQ
desugarModule _ = error "Exports should have been elaborated in name desugaring"
{- Desugar type class and type class instance declarations
@@ -152,7 +159,7 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
-- return new Sub(fooString, "");
-- };
-}
-desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
+desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl mn exps = go
where
go d@(TypeClassDeclaration name args implies members) = do
@@ -160,7 +167,7 @@ desugarDecl mn exps = go
return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
go d@(TypeInstanceDeclaration name deps className tys members) = do
- desugared <- lift $ desugarCases members
+ desugared <- desugarCases members
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
return (expRef name className tys, [d, dictDecl])
go (PositionedDeclaration pos com d) = do
@@ -222,18 +229,18 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type
unit :: Type
unit = TypeApp tyObject REmpty
-typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
+typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
typeInstanceDictionaryDeclaration name mn deps className tys decls =
- rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do
+ rethrow (onErrorMessages (ErrorInInstance className tys)) $ do
m <- get
-- Lookup the type arguments and member types for the type class
- (TypeClassDeclaration _ args implies tyDecls) <- lift . lift $
- maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
+ (TypeClassDeclaration _ args implies tyDecls) <-
+ maybe (throwError . errorMessage $ UnknownTypeClass className) return $
M.lookup (qualify mn className) m
case mapMaybe declName tyDecls \\ mapMaybe declName decls of
- x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
+ member : _ -> throwError . errorMessage $ MissingClassMember member
[] -> do
let instanceTys = map memberToNameAndType tyDecls
@@ -268,9 +275,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
declName (TypeDeclaration ident _) = Just ident
declName _ = Nothing
- memberToValue :: [(Ident, Type)] -> Declaration -> Desugar Expr
+ memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr
memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
- _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
+ _ <- maybe (throwError . errorMessage $ MissingClassMember ident) return $ lookup ident tys'
return val
memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do
val <- memberToValue tys' d
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 7779fd1..95ecedd 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -14,6 +14,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE FlexibleContexts #-}
+
module Language.PureScript.Sugar.TypeDeclarations (
desugarTypeDeclarations,
desugarTypeDeclarationsModule
@@ -22,6 +24,7 @@ module Language.PureScript.Sugar.TypeDeclarations (
import Control.Applicative
import Control.Monad (forM)
import Control.Monad.Except (throwError)
+import Control.Monad.Error.Class (MonadError)
import Language.PureScript.AST
import Language.PureScript.Names
@@ -32,15 +35,15 @@ import Language.PureScript.Traversals
-- |
-- Replace all top level type declarations in a module with type annotations
--
-desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]
-desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->
- rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $
- Module name <$> desugarTypeDeclarations ds <*> pure exps
+desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
+desugarTypeDeclarationsModule ms = forM ms $ \(Module coms name ds exps) ->
+ rethrow (onErrorMessages (ErrorInModule name)) $
+ Module coms name <$> desugarTypeDeclarations ds <*> pure exps
-- |
-- Replace all top level type declarations with type annotations
--
-desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]
+desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
(d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
return (PositionedDeclaration pos com d' : ds')
@@ -48,13 +51,13 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
(_, nameKind, val) <- fromValueDeclaration d
desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
where
- fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)
+ fromValueDeclaration :: (Functor m, Applicative m, MonadError MultipleErrors m) => Declaration -> m (Ident, NameKind, Expr)
fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
fromValueDeclaration (PositionedDeclaration pos com d') = do
(ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
return (ident, nameKind, PositionedValue pos com val)
- fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
-desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
+ fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name
+desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError . errorMessage $ OrphanTypeDeclaration name
desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
let (_, f, _) = everywhereOnValuesTopDownM return go return
f' (Left gs) = Left <$> mapM (pairM return f) gs
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index bc5c64d..4a50a12 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -26,8 +26,9 @@ import Language.PureScript.TypeChecker.Types as T
import Language.PureScript.TypeChecker.Synonyms as T
import Data.Maybe
-import Data.List (nub, (\\), find, intercalate)
+import Data.List (nub, (\\))
import Data.Foldable (for_)
+
import qualified Data.Map as M
import Control.Monad.State
@@ -46,7 +47,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
forM_ dctors $ \(dctor, tys) ->
- rethrow (mkCompileError ("Error in data constructor " ++ show dctor) Nothing `combineErrors`) $
+ rethrow (onErrorMessages (ErrorInDataConstructor dctor)) $
addDataConstructor moduleName dtype name (map fst args) dctor tys
addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -70,7 +71,7 @@ valueIsNotDefined :: ModuleName -> Ident -> Check ()
valueIsNotDefined moduleName name = do
env <- getEnv
case M.lookup (moduleName, name) (names env) of
- Just _ -> throwError . strMsg $ show name ++ " is already defined"
+ Just _ -> throwError . errorMessage $ RedefinedIdent name
Nothing -> return ()
addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
@@ -94,7 +95,7 @@ addTypeClassDictionaries entries =
checkDuplicateTypeArguments :: [String] -> Check ()
checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
- throwError . strMsg $ "Duplicate type argument '" ++ dup ++ "'"
+ throwError . errorMessage $ DuplicateTypeArgument dup
where
firstDup :: Maybe String
firstDup = listToMaybe $ args \\ nub args
@@ -103,10 +104,10 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()
checkTypeClassInstance _ (TypeVar _) = return ()
checkTypeClassInstance _ (TypeConstructor ctor) = do
env <- getEnv
- when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
+ when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance
return ()
checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
-checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))
+checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
-- |
-- Check that type synonyms are fully-applied in a type
@@ -133,7 +134,7 @@ typeCheckAll mainModuleName moduleName exps = go
go :: [Declaration] -> Check [Declaration]
go [] = return []
go (DataDeclaration dtype name args dctors : rest) = do
- rethrow (mkCompileError ("Error in type constructor " ++ show name) Nothing `combineErrors`) $ do
+ rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
when (dtype == Newtype) $ checkNewtype dctors
checkDuplicateTypeArguments $ map fst args
ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
@@ -144,10 +145,10 @@ typeCheckAll mainModuleName moduleName exps = go
where
checkNewtype :: [(ProperName, [Type])] -> Check ()
checkNewtype [(_, [_])] = return ()
- checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"
- checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"
+ checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
+ checkNewtype _ = throwError . errorMessage $ InvalidNewtype
go (d@(DataBindingGroupDeclaration tys) : rest) = do
- rethrow (mkCompileError "Error in data binding group" Nothing `combineErrors`) $ do
+ rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
let syns = mapMaybe toTypeSynonym tys
let dataDecls = mapMaybe toDataDecl tys
(syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
@@ -169,7 +170,7 @@ typeCheckAll mainModuleName moduleName exps = go
toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
toDataDecl _ = Nothing
go (TypeSynonymDeclaration name args ty : rest) = do
- rethrow (mkCompileError ("Error in type synonym " ++ show name) Nothing `combineErrors`) $ do
+ rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
checkDuplicateTypeArguments $ map fst args
kind <- kindsOf False moduleName name args [ty]
let args' = args `withKinds` kind
@@ -178,7 +179,7 @@ typeCheckAll mainModuleName moduleName exps = go
return $ TypeSynonymDeclaration name args ty : ds
go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
go (ValueDeclaration name nameKind [] (Right val) : rest) = do
- d <- rethrow (mkCompileError ("Error in declaration " ++ show name) Nothing `combineErrors`) $ do
+ d <- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
valueIsNotDefined moduleName name
[(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
addValue moduleName name ty nameKind
@@ -187,7 +188,7 @@ typeCheckAll mainModuleName moduleName exps = go
return $ d : ds
go (ValueDeclaration{} : _) = error "Binders were not desugared"
go (BindingGroupDeclaration vals : rest) = do
- d <- rethrow (mkCompileError ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) Nothing `combineErrors`) $ do
+ d <- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
valueIsNotDefined moduleName name
tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -207,19 +208,19 @@ typeCheckAll mainModuleName moduleName exps = go
ds <- go rest
return $ d : ds
go (d@(ExternDeclaration importTy name _ ty) : rest) = do
- rethrow (mkCompileError ("Error in foreign import declaration " ++ show name) Nothing `combineErrors`) $ do
+ rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
env <- getEnv
kind <- kindOf moduleName ty
- guardWith (strMsg "Expected kind *") $ kind == Star
+ guardWith (errorMessage (ExpectedType kind)) $ kind == Star
case M.lookup (moduleName, name) (names env) of
- Just _ -> throwError . strMsg $ show name ++ " is already defined"
+ Just _ -> throwError . errorMessage $ RedefinedIdent name
Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
ds <- go rest
return $ d : ds
go (d@(FixityDeclaration _ name) : rest) = do
ds <- go rest
env <- getEnv
- guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
+ guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
return $ d : ds
go (d@(ImportDeclaration importedModule _ _) : rest) = do
tcds <- getTypeClassDictionaries
@@ -276,74 +277,65 @@ typeCheckAll mainModuleName moduleName exps = go
-- required by exported members are also exported.
--
typeCheckModule :: Maybe ModuleName -> Module -> Check Module
-typeCheckModule _ (Module _ _ Nothing) = error "exports should have been elaborated"
-typeCheckModule mainModuleName (Module mn decls (Just exps)) = do
+typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"
+typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do
modify (\s -> s { checkCurrentModule = Just mn })
decls' <- typeCheckAll mainModuleName mn exps decls
forM_ exps $ \e -> do
checkTypesAreExported e
checkClassMembersAreExported e
checkClassesAreExported e
- return $ Module mn decls' (Just exps)
+ return $ Module coms mn decls' (Just exps)
where
- checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()
- checkMemberExport thing extract test (ValueRef name) = do
+ checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()
+ checkMemberExport extract dr@(ValueRef name) = do
ty <- lookupVariable mn (Qualified (Just mn) name)
- case find test (extract ty) of
- Just hiddenType -> throwError . strMsg $
- "Error in module '" ++ show mn ++ "':\n\
- \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"
- Nothing -> return ()
- checkMemberExport _ _ _ _ = return ()
+ case filter (not . exported) (extract ty) of
+ [] -> return ()
+ hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
+ where
+ exported e = any (exports e) exps
+ exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
+ exports (ValueRef id1) (ValueRef id2) = id1 == id2
+ exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
+ exports (TypeInstanceRef id1) (TypeInstanceRef id2) = id1 == id2
+ exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
+ exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
+ exports _ _ = False
+ checkMemberExport _ _ = return ()
-- Check that all the type constructors defined in the current module that appear in member types
-- have also been exported from the module
checkTypesAreExported :: DeclarationRef -> Check ()
- checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden
+ checkTypesAreExported = checkMemberExport findTcons
where
- findTcons :: Type -> [ProperName]
+ findTcons :: Type -> [DeclarationRef]
findTcons = everythingOnTypes (++) go
where
- go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")]
go _ = []
- isTconHidden :: ProperName -> Bool
- isTconHidden tyName = all go exps
- where
- go (TypeRef tyName' _) = tyName' /= tyName
- go _ = True
-- Check that all the classes defined in the current module that appear in member types have also
-- been exported from the module
checkClassesAreExported :: DeclarationRef -> Check ()
- checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden
+ checkClassesAreExported = checkMemberExport findClasses
where
- findClasses :: Type -> [ProperName]
+ findClasses :: Type -> [DeclarationRef]
findClasses = everythingOnTypes (++) go
where
- go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs
+ go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
go _ = []
extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
extractCurrentModuleClass _ = Nothing
- isClassHidden :: ProperName -> Bool
- isClassHidden clsName = all go exps
- where
- go (TypeClassRef clsName') = clsName' /= clsName
- go _ = True
checkClassMembersAreExported :: DeclarationRef -> Check ()
- checkClassMembersAreExported (TypeClassRef name) = do
+ checkClassMembersAreExported dr@(TypeClassRef name) = do
let members = ValueRef `map` head (mapMaybe findClassMembers decls)
let missingMembers = members \\ exps
- unless (null missingMembers) $
- throwError . strMsg $
- "Error in module '" ++ show mn ++ "':\n\
- \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"
+ unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
where
- runValueRef :: DeclarationRef -> Ident
- runValueRef (ValueRef refName) = refName
- runValueRef _ = error "non-ValueRef passed to runValueRef"
findClassMembers :: Declaration -> Maybe [Ident]
findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index c86f979..75b9b42 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -31,7 +31,6 @@ import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Environment
import Language.PureScript.Names
-import Language.PureScript.Pretty
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.TypeChecker.Unify
@@ -40,29 +39,6 @@ import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
-- |
--- A simplified representation of expressions which are used to represent type
--- class dictionaries at runtime, which can be compared for equality
---
-data DictionaryValue
- -- |
- -- A dictionary which is brought into scope by a local constraint
- --
- = LocalDictionaryValue (Qualified Ident)
- -- |
- -- A dictionary which is brought into scope by an instance declaration
- --
- | GlobalDictionaryValue (Qualified Ident)
- -- |
- -- A dictionary which depends on other dictionaries
- --
- | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
- -- |
- -- A subclass dictionary
- --
- | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
- deriving (Show, Ord, Eq)
-
--- |
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
-- return a type class dictionary reference.
--
@@ -140,16 +116,9 @@ 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
- (d1, d2) : _ -> throwError . strMsg $ unlines
- [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."
- , "For example:"
- , prettyPrintDictionaryValue d1
- , "and:"
- , prettyPrintDictionaryValue d2
- ]
+ ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys (map fst ds)
_ -> case chooseSimplestDictionaries dicts of
- [] -> throwError . strMsg $
- "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
+ [] -> throwError . errorMessage $ NoInstanceFound className tys
d : _ -> return $ dictionaryValueToValue d
-- Choose the simplest DictionaryValues from a list of candidates
-- The reason for this function is as follows:
@@ -180,18 +149,6 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
overlapping SubclassDictionaryValue{} _ = False
overlapping _ SubclassDictionaryValue{} = False
overlapping _ _ = True
- -- |
- -- Render a DictionaryValue fit for human consumption in error messages
- --
- prettyPrintDictionaryValue :: DictionaryValue -> String
- prettyPrintDictionaryValue = unlines . indented 0
- where
- indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]
- indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]
- indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args
- indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup
-
- spaces n = replicate n ' ' ++ "- "
valUndefined :: Expr
valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index fa3d630..19d8769 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -38,7 +38,6 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
-import Language.PureScript.Pretty
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Types
@@ -65,7 +64,7 @@ instance Unifiable Check Kind where
FunKind k1 k2 =?= FunKind k3 k4 = do
k1 =?= k3
k2 =?= k4
- k1 =?= k2 = UnifyT . lift . throwError . strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
+ k1 =?= k2 = UnifyT . lift . throwError . errorMessage $ KindsDoNotUnify k1 k2
-- |
-- Infer the kind of a single type
@@ -78,7 +77,7 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty
--
kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])
kindOfWithScopedVars ty =
- rethrow (mkCompileError "Error checking kind" (Just (TypeError ty)) `combineErrors`) $
+ rethrow (onErrorMessages (ErrorCheckingKind ty)) $
fmap tidyUp . liftUnify $ infer ty
where
tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)
@@ -156,7 +155,7 @@ starIfUnknown k = k
-- Infer a kind for a type
--
infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])
-infer ty = rethrow (mkCompileError "Error inferring type of value" (Just (TypeError ty)) `combineErrors`) $ infer' ty
+infer ty = rethrow (onErrorMessages (ErrorCheckingKind ty)) $ infer' ty
infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])
infer' (ForAll ident ty _) = do
@@ -189,10 +188,10 @@ infer' other = (, []) <$> go other
go (Skolem v _ _) = do
Just moduleName <- checkCurrentModule <$> get
UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
- go c@(TypeConstructor v) = do
+ go (TypeConstructor v) = do
env <- liftCheck getEnv
case M.lookup v (types env) of
- Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))
+ Nothing -> UnifyT . lift . throwError . errorMessage $ UnknownTypeConstructor v
Just (kind, _) -> return kind
go (TypeApp t1 t2) = do
k0 <- fresh
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 7abb0ac..84aab4a 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -109,41 +109,41 @@ makeBindingGroupVisible action = do
-- |
-- Lookup the type of a value by name in the @Environment@
--
-lookupVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
+lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
lookupVariable currentModule (Qualified moduleName var) = do
env <- getEnv
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
- Nothing -> throwError . strMsg $ show var ++ " is undefined"
+ Nothing -> throwError . errorMessage $ NameIsUndefined var
Just (ty, _, _) -> return ty
-- |
-- Lookup the visibility of a value by name in the @Environment@
--
-getVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
+getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
getVisibility currentModule (Qualified moduleName var) = do
env <- getEnv
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
- Nothing -> throwError . strMsg $ show var ++ " is undefined"
+ Nothing -> throwError . errorMessage $ NameIsUndefined var
Just (_, _, vis) -> return vis
-- |
-- Assert that a name is visible
--
-checkVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
+checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
checkVisibility currentModule name@(Qualified _ var) = do
vis <- getVisibility currentModule name
case vis of
- Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."
+ Undefined -> throwError . errorMessage $ NameNotInScope var
_ -> return ()
-- |
-- Lookup the kind of a type by name in the @Environment@
--
-lookupTypeVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
+lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
lookupTypeVariable currentModule (Qualified moduleName name) = do
env <- getEnv
case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
- Nothing -> throwError . strMsg $ "Type variable " ++ show name ++ " is undefined"
+ Nothing -> throwError . errorMessage $ UndefinedTypeVariable name
Just (k, _) -> return k
-- |
@@ -171,8 +171,8 @@ data CheckState = CheckState {
-- |
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
--
-newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }
- deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError ErrorStack)
+newtype Check a = Check { unCheck :: StateT CheckState (Either MultipleErrors) a }
+ deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError MultipleErrors)
-- |
-- Get the current @Environment@
@@ -204,9 +204,9 @@ runCheck = runCheck' initEnvironment
runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)
runCheck' env c = do
verbose <- asks optionsVerboseErrors
- stringifyErrorStack verbose $ do
- (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
- return (a, checkEnv s)
+ 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/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs
index f1fec1b..ebd0846 100644
--- a/src/Language/PureScript/TypeChecker/Rows.hs
+++ b/src/Language/PureScript/TypeChecker/Rows.hs
@@ -53,7 +53,7 @@ checkDuplicateLabels =
checkDups r@RCons{} =
let (ls, _) = rowToList r in
case firstDup . sort . map fst $ ls of
- Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)
+ Just l -> throwError . errorMessage $ DuplicateLabel l (Just val)
Nothing -> return ()
checkDups _ = return ()
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index 221cb1a..bb64df0 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -31,7 +31,6 @@ import Control.Monad.Unify
import Language.PureScript.AST
import Language.PureScript.Errors
-import Language.PureScript.Pretty
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Types
@@ -89,7 +88,7 @@ skolemEscapeCheck root@TypedValue{} =
let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
in case f root of
[] -> return ()
- ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))
+ ((binding, val) : _) -> throwError . errorMessage . ErrorInExpression val $ EscapedSkolem binding
where
def s _ = (s, [])
@@ -112,4 +111,4 @@ skolemEscapeCheck root@TypedValue{} =
where
go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)
go' _ = mempty
-skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
+skolemEscapeCheck _ = error "Untyped value passed to skolemEscapeCheck"
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index e9a7ac2..612d47c 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -20,14 +20,12 @@ module Language.PureScript.TypeChecker.Subsumption (
import Data.List (sortBy)
import Data.Ord (comparing)
-import Control.Applicative
import Control.Monad.Except
import Control.Monad.Unify
import Language.PureScript.AST
import Language.PureScript.Environment
import Language.PureScript.Errors
-import Language.PureScript.Pretty
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Skolems
import Language.PureScript.TypeChecker.Synonyms
@@ -38,12 +36,7 @@ import Language.PureScript.Types
-- Check whether one type subsumes another, rethrowing errors to provide a better error message
--
subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
-subsumes val ty1 ty2 = rethrow (mkCompileError errorMessage (ExprError <$> val) `combineErrors`) $ subsumes' val ty1 ty2
- where
- errorMessage = "Error checking that type "
- ++ prettyPrintType ty1
- ++ " subsumes type "
- ++ prettyPrintType ty2
+subsumes val ty1 ty2 = rethrow (onErrorMessages (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2
-- |
-- Check whether one type subsumes another
@@ -58,7 +51,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =
sko <- newSkolemConstant
let sk = skolemize ident sko sco' ty2
subsumes val ty1 sk
- Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"
+ Nothing -> throwError . errorMessage $ UnspecifiedSkolemScope
subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
_ <- subsumes Nothing arg2 arg1
_ <- subsumes Nothing ret1 ret2
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 1457a8c..11a2915 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -40,19 +40,19 @@ import Language.PureScript.Types
-- |
-- Build a type substitution for a type synonym
--
-buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either ErrorMessage (Maybe Type)
buildTypeSubstitution name n = go n []
where
- go :: Int -> [Type] -> Type -> Either String (Maybe Type)
+ go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)
go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
- go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
+ go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ PartiallyAppliedSynonym name
go m args (TypeApp f arg) = go (m - 1) (arg:args) f
go _ _ _ = return Nothing
-- |
-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
--
-saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either String Type
+saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either ErrorMessage Type
saturateTypeSynonym name n = everywhereOnTypesTopDownM replace
where
replace t = fromMaybe t <$> buildTypeSubstitution name n t
@@ -60,7 +60,7 @@ saturateTypeSynonym name n = everywhereOnTypesTopDownM replace
-- |
-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
--
-saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type
+saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either ErrorMessage Type
saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns
-- |
@@ -76,22 +76,22 @@ desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym
-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
-- better error messages during unification.
--
-replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type
+replaceAllTypeSynonyms' :: Environment -> Type -> Either ErrorMessage Type
replaceAllTypeSynonyms' env d =
let
syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
in
saturateAllTypeSynonyms syns d
-replaceAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
+replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
replaceAllTypeSynonyms d = do
env <- getEnv
- either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d
+ either (throwError . errorMessage) return $ replaceAllTypeSynonyms' env d
-- |
-- Replace a type synonym and its arguments with the aliased type
--
-expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type
+expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either ErrorMessage Type
expandTypeSynonym' env name args =
case M.lookup name (typeSynonyms env) of
Just (synArgs, body) -> do
@@ -99,12 +99,12 @@ expandTypeSynonym' env name args =
replaceAllTypeSynonyms' env repl
Nothing -> error "Type synonym was not defined"
-expandTypeSynonym :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
+expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
expandTypeSynonym name args = do
env <- getEnv
- either (throwError . strMsg) return $ expandTypeSynonym' env name args
+ either (throwError . errorMessage) return $ expandTypeSynonym' env name args
-expandAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
+expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
expandAllTypeSynonyms = everywhereOnTypesTopDownM go
where
go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 7ad5a97..b83d80f 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -39,7 +39,6 @@ import Data.Either (lefts, rights)
import Data.List
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
-import Data.String (IsString)
import Control.Applicative
import Control.Monad.Except
@@ -51,7 +50,6 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
-import Language.PureScript.Pretty
import Language.PureScript.Traversals
import Language.PureScript.TypeChecker.Entailment
import Language.PureScript.TypeChecker.Kinds
@@ -184,7 +182,7 @@ replaceTypeClassDictionaries mn =
-- Check the kind of a type, failing if it is not of kind *.
--
checkTypeKind :: Kind -> UnifyT t Check ()
-checkTypeKind kind = guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
+checkTypeKind kind = guardWith (errorMessage (ExpectedType kind)) $ kind == Star
-- |
-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
@@ -207,7 +205,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- Infer a type for a value, rethrowing any error to provide a more useful error message
--
infer :: Expr -> UnifyT Type Check Expr
-infer val = rethrow (mkCompileError "Error inferring type of value" (Just (ExprError val)) `combineErrors`) $ infer' val
+infer val = rethrow (onErrorMessages (ErrorInferringType val)) $ infer' val
-- |
-- Infer a type for a value
@@ -269,7 +267,7 @@ infer' (Var var) = do
infer' v@(Constructor c) = do
env <- getEnv
case M.lookup c (dataConstructors env) of
- Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
+ Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing
Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty
return $ TypedValue True v' ty'
infer' (Case vals binders) = do
@@ -365,8 +363,8 @@ inferBinder val (ConstructorBinder ctor binders) = do
return M.empty
go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
M.union <$> inferBinder obj binder <*> go binders' ret
- go _ _ = throwError . strMsg $ "Wrong number of arguments to constructor " ++ show ctor
- _ -> throwError . strMsg $ "Constructor " ++ show ctor ++ " is not defined"
+ go _ _ = throwError . errorMessage $ IncorrectConstructorArity ctor
+ _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing
inferBinder val (ObjectBinder props) = do
row <- fresh
rest <- fresh
@@ -404,7 +402,7 @@ inferBinder val (PositionedBinder pos _ binder) =
checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]
checkBinders _ _ [] = return []
checkBinders nvals ret (CaseAlternative binders result : bs) = do
- guardWith (strMsg "Overlapping binders in case statement") $
+ guardWith (errorMessage $ OverlappingArgNames Nothing) $
let ns = concatMap binderNames binders in length (nub ns) == length ns
Just moduleName <- checkCurrentModule <$> get
m1 <- M.unions <$> zipWithM inferBinder nvals binders
@@ -427,13 +425,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
-- Check the type of a value, rethrowing errors to provide a better error message
--
check :: Expr -> Type -> UnifyT Type Check Expr
-check val ty = rethrow (mkCompileError errorMessage (Just (ExprError val)) `combineErrors`) $ check' val ty
- where
- errorMessage =
- "Error checking type of term " ++
- prettyPrintValue val ++
- " against type " ++
- prettyPrintType ty
+check val ty = rethrow (onErrorMessages (ErrorCheckingType val ty)) $ check' val ty
-- |
-- Check the type of a value
@@ -490,7 +482,7 @@ check' v@(Var var) ty = do
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
v' <- subsumes (Just v) repl ty'
case v' of
- Nothing -> throwError . strMsg $ "Unable to check type subsumption"
+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed
Just v'' -> return $ TypedValue True v'' ty'
check' (SuperClassDictionary className tys) _ = do
{-
@@ -513,10 +505,10 @@ check' (TypedValue checkType val ty1) ty2 = do
ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2
val' <- subsumes (Just val) ty1' ty2'
case val' of
- Nothing -> throwError . strMsg $ "Unable to check type subsumption"
- Just val'' -> do
- val''' <- if checkType then withScopedTypeVars moduleName args (check val'' ty2') else return val''
- return $ TypedValue checkType (TypedValue True val''' ty1') ty2'
+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed
+ Just _ -> do
+ val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val
+ return $ TypedValue checkType val''' ty2'
check' (Case vals binders) ret = do
vals' <- mapM infer vals
let ts = map (\(TypedValue _ _ t) -> t) vals'
@@ -551,7 +543,7 @@ check' (Accessor prop val) ty = do
check' (Constructor c) ty = do
env <- getEnv
case M.lookup c (dataConstructors env) of
- Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
+ Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing
Just (_, _, ty1, _) -> do
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
_ <- subsumes Nothing repl ty
@@ -568,7 +560,7 @@ check' val kt@(KindedType ty kind) = do
return $ TypedValue True val' kt
check' (PositionedValue pos _ val) ty =
rethrowWithPosition pos $ check' val ty
-check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))
+check' val ty = throwError . errorMessage $ ExprDoesNotHaveType val ty
containsTypeSynonyms :: Type -> Bool
containsTypeSynonyms = everythingOnTypes (||) go where
@@ -589,8 +581,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
return []
go [] [] Skolem{} | lax = return []
go [] ((p, _): _) _ | lax = return []
- | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))
- go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))
+ | otherwise = throwError . errorMessage $ PropertyIsMissing p row
+ go ((p,_):_) [] REmpty = throwError . errorMessage $ PropertyIsMissing p row
go ((p,v):ps') ts r =
case lookup p ts of
Nothing -> do
@@ -603,19 +595,15 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
v' <- check v ty
ps'' <- go ps' (delete (p, ty) ts) r
return $ (p, v') : ps''
- go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ExprError (ObjectLiteral ps)))
+ go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType (ObjectLiteral ps) (TypeApp tyObject row)
-- |
-- Check the type of a function application, rethrowing errors to provide a better error message
--
checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
-checkFunctionApplication fn fnTy arg ret = rethrow (mkCompileError errorMessage (Just (ExprError fn)) `combineErrors`) $ do
+checkFunctionApplication fn fnTy arg ret = rethrow (onErrorMessages (ErrorInApplication fn fnTy arg)) $ do
subst <- unifyCurrentSubstitution <$> UnifyT get
checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)
- where
- errorMessage = "Error applying function of type "
- ++ prettyPrintType fnTy
- ++ " to argument " ++ prettyPrintValue arg
-- |
-- Check the type of a function application
@@ -651,9 +639,7 @@ checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret
checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
return (fnTy, App fn dict)
-checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
- ++ prettyPrintType fnTy
- ++ " to argument " ++ prettyPrintValue arg
+checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg
-- |
-- Compute the meet of two types, i.e. the most general type which both types subsume.
@@ -673,5 +659,9 @@ meet e1 e2 t1 t2 = do
-- |
-- Ensure a set of property names and value does not contain duplicate labels
--
-ensureNoDuplicateProperties :: (IsString e, MonadError e m) => [(String, Expr)] -> m ()
-ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
+ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(String, Expr)] -> m ()
+ensureNoDuplicateProperties ps =
+ let ls = map fst ps in
+ case ls \\ nub ls of
+ l : _ -> throwError . errorMessage $ DuplicateLabel l Nothing
+ _ -> return ()
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 48381a2..13faf00 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -34,7 +34,6 @@ import Control.Monad.Unify
import Language.PureScript.Environment
import Language.PureScript.Errors
-import Language.PureScript.Pretty
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Skolems
import Language.PureScript.TypeChecker.Synonyms
@@ -60,7 +59,7 @@ instance Unifiable Check Type where
-- Unify two types, updating the current substitution
--
unifyTypes :: Type -> Type -> UnifyT Type Check ()
-unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing `combineErrors`) $
+unifyTypes t1 t2 = rethrow (onErrorMessages (ErrorUnifyingTypes t1 t2)) $
unifyTypes' t1 t2
where
unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
@@ -82,11 +81,11 @@ unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrin
sko <- newSkolemConstant
let sk = skolemize ident sko sc ty1
sk `unifyTypes` ty2
- unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"
+ unifyTypes' ForAll{} _ = throwError . errorMessage $ UnspecifiedSkolemScope
unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
- unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =
- guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2)
+ unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =
+ guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2)
unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
t3 `unifyTypes` t5
t4 `unifyTypes` t6
@@ -97,9 +96,9 @@ unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrin
unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
unifyTypes' r1@REmpty r2 = unifyRows r1 r2
unifyTypes' r1 r2@REmpty = unifyRows r1 r2
- unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type."
+ unifyTypes' ty1@(ConstrainedType _ _) ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2
unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3
- unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
+ unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4
-- |
-- Unify two rows, updating the current substitution
@@ -136,7 +135,7 @@ unifyRows r1 r2 =
unifyRows' [] REmpty [] REmpty = return ()
unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
- unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"
+ unifyRows' sd3 r3 sd4 r4 = throwError . errorMessage $ TypesDoNotUnify (rowFromList (sd3, r3)) (rowFromList (sd4, r4))
-- |
-- Check that two types unify
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 1cf5bba..e0780dd 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -66,6 +66,29 @@ data TypeClassDictionaryType
| TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
-- |
+-- A simplified representation of expressions which are used to represent type
+-- class dictionaries at runtime, which can be compared for equality
+--
+data DictionaryValue
+ -- |
+ -- A dictionary which is brought into scope by a local constraint
+ --
+ = LocalDictionaryValue (Qualified Ident)
+ -- |
+ -- A dictionary which is brought into scope by an instance declaration
+ --
+ | GlobalDictionaryValue (Qualified Ident)
+ -- |
+ -- A dictionary which depends on other dictionaries
+ --
+ | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
+ -- |
+ -- A subclass dictionary
+ --
+ | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
+ deriving (Show, Ord, Eq)
+
+-- |
-- Find the original dictionary which a type class dictionary in scope refers to
--
canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
diff --git a/tests/Main.hs b/tests/Main.hs
index 47922b0..e7ac794 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -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 _ -> return Nothing
+ Left err -> putStrLn err >> return Nothing
Right _ -> return $ Just "Should not have compiled"
findNodeProcess :: IO (Maybe String)