packages feed

purescript 0.6.8 → 0.6.9

raw patch · 52 files changed

+2102/−1058 lines, 52 filesdep +boxesdep ~base

Dependencies added: boxes

Dependency ranges changed: base

Files

LICENSE view
@@ -37,6 +37,8 @@   transformers   unordered-containers   utf8-string+  split+  boxes  base LICENSE file: @@ -620,3 +622,63 @@   * 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.
+ examples/passing/InstanceBeforeClass.purs view
@@ -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"
examples/passing/OperatorAssociativity.purs view
@@ -40,3 +40,19 @@      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!"
+ examples/passing/SequenceDesugared.purs view
@@ -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"]
hierarchy/Main.hs view
@@ -64,7 +64,7 @@   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
prelude/prelude.purs view
@@ -20,7 +20,7 @@   , negate   , DivisionRing   , Num-  , Eq, (==), (/=), refEq, refIneq+  , Eq, (==), (/=)   , Ord, Ordering(..), compare, (<), (>), (<=), (>=)   , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement   , BoolLike, (&&), (||)@@ -31,27 +31,38 @@    -- | 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 @@   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 @@   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 @@     }     """ :: 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 @@   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 @@   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 @@    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 @@     (==) 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 @@     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 @@    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 @@    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 @@    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 @@   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 @@   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 @@    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 @@    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 @@     }     """ :: forall a. (Unit -> a) -> Fn0 a +  -- | Create a function of one argument   foreign import mkFn1     """     function mkFn1(fn) {@@ -636,6 +930,7 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: forall a. Fn0 a -> a +  -- | Apply a function of one argument   foreign import runFn1     """     function runFn1(fn) {@@ -733,6 +1038,7 @@     }     """ :: forall a b. Fn1 a b -> a -> b +  -- | Apply a function of two arguments   foreign import runFn2     """     function runFn2(fn) {@@ -744,6 +1050,7 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 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 @@     }     """ :: 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 @@     }     """ :: 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 @@    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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@    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 @@    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 @@     }     """ :: 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 @@    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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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 @@     }     """ :: 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)
psc-docs/Main.hs view
@@ -30,21 +30,37 @@ 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 @@   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 @@      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
psc-make/Main.hs view
@@ -155,7 +155,7 @@                     <*> noMagicDo                     <*> pure Nothing                     <*> noOpts-                    <*> comments+                    <*> (not <$> comments)                     <*> verboseErrors                     <*> pure P.MakeOptions
psc/Main.hs view
@@ -180,7 +180,7 @@                     <*> runMain                     <*> noOpts                     <*> verboseErrors-                    <*> comments+                    <*> (not <$> comments)                     <*> additionalOptions   where   additionalOptions =
psci/Commands.hs view
@@ -32,7 +32,7 @@   -- |   -- Import a module from a loaded file   ---  | Import ModuleName+  | Import ImportedModule   -- |   -- Browse a module   --@@ -50,9 +50,9 @@   --   | 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 @@   --   | 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)
psci/Main.hs view
@@ -54,12 +54,14 @@ 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 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 @@ -- | -- 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 @@ -- | -- 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 @@ -- 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 @@ -- 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 @@     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 @@             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 @@           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 @@ -- 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,32 +383,33 @@     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 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 @@   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 @@   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 @@           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 @@ -- | -- 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 @@ -- | -- 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 @@       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 @@     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 @@           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 @@      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
psci/Parser.hs view
@@ -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 @@ -- | -- 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+  parsers =+    [ psciLet+    , psciImport+    , psciOtherDeclaration+    , psciExpression+    ] -  trimEnd :: String -> String-  trimEnd = reverse . dropWhile isSpace . reverse+trim :: String -> String+trim = trimEnd . trimStart -  -- |-  -- 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+trimStart :: String -> String+trimStart = dropWhile isSpace -  -- |-  -- Parses expressions entered at the PSCI repl.-  ---  psciExpression :: P.TokenParser Command-  psciExpression = Expression <$> P.parseValue+trimEnd :: String -> String+trimEnd = reverse . trimStart . reverse -  -- |-  -- 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))+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
purescript.cabal view
@@ -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 @@                    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 @@                      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 @@                      Language.PureScript.Types                       Control.Monad.Unify+                     Control.Monad.Supply+                     Control.Monad.Supply.Class     exposed: True     buildable: True     hs-source-dirs: src
+ src/Control/Monad/Supply.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+--+-- Module      :  Control.Monad.Supply+-- Copyright   :  (c) Phil Freeman 2014+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Fresh variable supply+--+-----------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++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, MonadError e, MonadWriter w, MonadReader r)++runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)+runSupplyT n = flip runStateT n . unSupplyT++evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a+evalSupplyT n = fmap fst . runSupplyT n++type Supply = SupplyT Identity++runSupply :: Integer -> Supply a -> (a, Integer)+runSupply n = runIdentity . runSupplyT n++evalSupply :: Integer -> Supply a -> a+evalSupply n = runIdentity . evalSupplyT n
+ src/Control/Monad/Supply/Class.hs view
@@ -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
src/Control/Monad/Unify.hs view
@@ -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 = 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 @@ -- | -- 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 @@ -- | -- 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 ()  -- |
src/Language/PureScript.hs view
@@ -13,15 +13,29 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell, FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} -module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where+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.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 @@   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 @@ -- 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 @@    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 @@      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 @@ -- 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 @@  prelude :: String prelude = BU.toString $(embedFile "prelude/prelude.purs")++version :: Version+version = Paths.version
src/Language/PureScript/AST/Declarations.hs view
@@ -30,14 +30,15 @@ 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 @@   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 @@ -- 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 @@ -- 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 _ = 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
src/Language/PureScript/AST/SourcePos.hs view
@@ -30,7 +30,7 @@     -- 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 @@     -- 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)
src/Language/PureScript/CodeGen/Externs.hs view
@@ -36,8 +36,8 @@ -- 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
src/Language/PureScript/CodeGen/JS.hs view
@@ -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 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.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 @@ -- 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) -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+  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
src/Language/PureScript/CoreFn/Desugar.hs view
@@ -40,14 +40,14 @@ -- 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 @@ -- 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.
src/Language/PureScript/CoreFn/Module.hs view
@@ -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]
src/Language/PureScript/DeadCodeElimination.hs view
@@ -29,7 +29,7 @@ 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 @@ -- 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
src/Language/PureScript/Errors.hs view
@@ -12,110 +12,488 @@ -- ----------------------------------------------------------------------------- -{-# 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 --- |--- Type for sources of type checking errors----data ErrorSource-  -- |-  -- An error which originated at a Expr-  ---  = ExprError Expr-  -- |-  -- An error which originated at a Type-  ---  | TypeError Type deriving (Show)+import qualified Text.PrettyPrint.Boxes as Box  -- |--- Compilation errors+-- A type of error messages ---data CompileError-  = CompileError-      { -- |-        -- Error message-        ---        compileErrorMessage :: String-        -- |-        -- The value where the error occurred-        ---      , compileErrorValue :: Maybe ErrorSource-        -- |-        -- Optional source position information-        ---      , compileErrorPosition :: Maybe SourceSpan-      }+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 ---data ErrorStack-  = ErrorStack { runErrorStack :: [CompileError] }-  | MultipleErrors [ErrorStack] deriving (Show)+newtype MultipleErrors = MultipleErrors +  { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)+  +instance UnificationError Type MultipleErrors where+  occursCheckFailed = errorMessage . occursCheckFailed+  +instance UnificationError Kind MultipleErrors where+  occursCheckFailed = errorMessage . occursCheckFailed --- 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]+-- |+-- Create an error set from a single error message+--+errorMessage :: ErrorMessage -> MultipleErrors+errorMessage err = MultipleErrors [err] -instance IsString ErrorStack where-  fromString = strMsg+-- |+-- Lift a function on ErrorMessage to a function on MultipleErrors+--+onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors+onErrorMessages f = MultipleErrors . map f . runMultipleErrors -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'+-- |+-- Pretty print a single error, simplifying if necessary+--+prettyPrintSingleError :: Bool -> ErrorMessage -> Box.Box+prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)   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+  -- |+  -- Pretty print an ErrorMessage+  --+  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+                                               ] -stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a-stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return+  line :: String -> Box.Box+  line = Box.text -isErrorNonEmpty :: CompileError -> Bool-isErrorNonEmpty = not . null . compileErrorMessage+  paras :: [Box.Box] -> Box.Box+  paras = Box.vcat Box.left -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+  indent :: Box.Box -> Box.Box+  indent = Box.moveRight 2 -mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack-mkErrorStack msg t = ErrorStack [mkCompileError msg t]+  -- |+  -- 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 -mkCompileError :: String -> Maybe ErrorSource -> CompileError-mkCompileError msg t = CompileError msg t Nothing+  -- |+  -- Simplify an error message+  --+  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 -positionError :: SourceSpan -> CompileError-positionError pos = CompileError "" Nothing (Just pos)+-- |+-- Pretty print multiple errors+--+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+ -- |+-- Interpret multiple errors in a monad supporting errors+--+interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a+interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return++-- | -- Rethrow an error with a more detailed error message in the case of failure -- rethrow :: (MonadError e m) => (e -> e) -> m a -> m a@@ -124,30 +502,23 @@ -- | -- 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
src/Language/PureScript/ModuleDependencies.hs view
@@ -41,7 +41,7 @@ -- 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)
src/Language/PureScript/Parser/Declarations.hs view
@@ -24,6 +24,8 @@     parseGuard,     parseBinder,     parseBinderNoParens,+    parseImportDeclaration',+    parseLocalDeclaration ) where  import Prelude hiding (lex)@@ -146,6 +148,11 @@  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 @@     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 @@ -- 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
src/Language/PureScript/Pretty/JS.hs view
@@ -272,26 +272,26 @@                         ++ 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            "|" ]
src/Language/PureScript/Pretty/Values.hs view
@@ -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 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 @@     ]   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
src/Language/PureScript/Renamer.hs view
@@ -113,7 +113,7 @@ 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
src/Language/PureScript/Sugar.hs view
@@ -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 @@ -- --  * 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
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -14,6 +14,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-}+ module Language.PureScript.Sugar.BindingGroups (     createBindingGroups,     createBindingGroupsModule,@@ -24,8 +26,9 @@ 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 @@ -- | -- 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 @@              filter isExternInstanceDecl ds ++              dataBindingGroupDecls ++              filter isTypeClassDeclaration ds +++             filter isTypeClassInstanceDeclaration ds ++              filter isFixityDecl ds ++              filter isExternDecl ds ++              bindingGroupDecls@@ -151,7 +155,7 @@ -- 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 @@   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
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -14,6 +14,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-}+ module Language.PureScript.Sugar.CaseDeclarations (     desugarCases,     desugarCasesModule@@ -24,12 +26,13 @@ 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 @@ -- | -- 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 @@ -- | -- 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 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 (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
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -14,6 +14,9 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Language.PureScript.Sugar.DoNotation (     desugarDoModule ) where@@ -21,21 +24,21 @@ 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 @@   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 @@     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'
src/Language/PureScript/Sugar/Names.hs view
@@ -12,6 +12,9 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Language.PureScript.Sugar.Names (   desugarImports ) where@@ -84,7 +87,7 @@ -- 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 @@ -- | -- 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 @@   -- 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 @@ -- 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 @@ -- 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 @@   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 @@     (,) (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 @@   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 @@   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 @@    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 @@       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 @@     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 @@ -- 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 @@    -- 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 @@ -- | -- 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 @@   -- 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 @@ -- | -- 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 @@   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 @@   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 @@   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 @@    -- 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
src/Language/PureScript/Sugar/ObjectWildcards.hs view
@@ -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 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 @@     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 @@         (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
src/Language/PureScript/Sugar/Operators.hs view
@@ -17,7 +17,9 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types, FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Language.PureScript.Sugar.Operators (   rebracket,@@ -28,11 +30,11 @@ 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 @@ -- | -- 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 @@   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 @@   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 @@  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 @@   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
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -14,6 +14,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-}+ module Language.PureScript.Sugar.TypeClasses   ( desugarTypeClasses   , typeClassMemberName@@ -25,9 +27,8 @@ 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.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 @@ --       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 @@     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 @@ 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 @@   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
src/Language/PureScript/Sugar/TypeDeclarations.hs view
@@ -14,6 +14,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-}+ module Language.PureScript.Sugar.TypeDeclarations (     desugarTypeDeclarations,     desugarTypeDeclarationsModule@@ -22,6 +24,7 @@ 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 @@ -- | -- 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 @@   (_, 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
− src/Language/PureScript/Supply.hs 
@@ -1,56 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Supply--- Copyright   :  (c) Phil Freeman 2014--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Fresh variable supply-----------------------------------------------------------------------------------{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}--module Language.PureScript.Supply where--import Data.Functor.Identity--import Control.Applicative-import Control.Monad.State-import Control.Monad.Except--newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)--runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)-runSupplyT n = flip runStateT n . unSupplyT--evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a-evalSupplyT n = fmap fst . runSupplyT n--type Supply = SupplyT Identity--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)
src/Language/PureScript/TypeChecker.hs view
@@ -26,8 +26,9 @@ 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 @@   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 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 @@  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 _ (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 @@   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 @@     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 @@     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 @@     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 @@     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 @@     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 @@ -- 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
src/Language/PureScript/TypeChecker/Entailment.hs view
@@ -31,7 +31,6 @@ 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 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 @@       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 @@       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))
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -38,7 +38,6 @@ 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 @@   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 @@ -- 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 @@ -- 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 @@   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
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -109,41 +109,41 @@ -- | -- 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 @@ -- | -- 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' :: (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
src/Language/PureScript/TypeChecker/Rows.hs view
@@ -53,7 +53,7 @@     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 ()
src/Language/PureScript/TypeChecker/Skolems.hs view
@@ -31,7 +31,6 @@  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 @@   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 @@     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"
src/Language/PureScript/TypeChecker/Subsumption.hs view
@@ -20,14 +20,12 @@ 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 @@ -- 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 @@       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
src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -40,19 +40,19 @@ -- | -- 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 @@ -- | -- 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 @@ -- 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 @@       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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -39,7 +39,6 @@ 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.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 @@ -- 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 @@ -- 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' 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 @@           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 @@ 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 @@ -- 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 @@   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 @@   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' (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 @@   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 @@                      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 @@         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' (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 @@ -- | -- 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 ()
src/Language/PureScript/TypeChecker/Unify.hs view
@@ -34,7 +34,6 @@  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 @@ -- 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 @@     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' 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' [] 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
src/Language/PureScript/TypeClassDictionaries.hs view
@@ -66,6 +66,29 @@   | 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
tests/Main.hs view
@@ -77,7 +77,7 @@   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)