purescript 0.6.9.3 → 0.6.9.4

raw patch · 44 files changed

+2386/−1518 lines, 44 filesdep +HUnitdep ~basedep ~directorydep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: HUnit

Dependency ranges changed: base, directory, mtl, transformers

API changes (from Hackage documentation)

Files

• examples/failing/365.purs +11/−0
• examples/failing/RowConstructors1.purs +6/−0
• examples/failing/RowConstructors2.purs +6/−0
• examples/failing/RowConstructors3.purs +6/−0
• examples/failing/TypeSynonyms5.purs +3/−0
• examples/passing/CaseStatement.purs +19/−0
• examples/passing/Collatz.purs +12/−1
• examples/passing/Guards.purs +31/−21
• examples/passing/Let2.purs +15/−0
• examples/passing/OperatorAssociativity.purs +0/−8
• examples/passing/OperatorInlining.purs +46/−0
• examples/passing/Operators.purs +0/−4
• examples/passing/RebindableSyntax.purs +37/−0
• examples/passing/RowConstructors.purs +40/−0
• examples/passing/TopLevelCase.purs +21/−11
• prelude/prelude.purs +531/−458
• psc-make/Main.hs +14/−12
• psc/Main.hs +2/−2
• psci/Commands.hs +0/−78
• psci/Completion.hs +232/−0
• psci/Directive.hs +74/−40
• psci/Main.hs +0/−702
• psci/PSCi.hs +543/−0
• psci/Parser.hs +41/−27
• psci/Types.hs +167/−0
• psci/main/Main.hs +6/−0
• psci/tests/Main.hs +137/−0
• purescript.cabal +16/−3
• src/Language/PureScript.hs +11/−11
• src/Language/PureScript/AST/Declarations.hs +3/−3
• src/Language/PureScript/AST/SourcePos.hs +11/−6
• src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +139/−46
• src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +30/−5
• src/Language/PureScript/Constants.hs +58/−19
• src/Language/PureScript/Errors.hs +40/−5
• src/Language/PureScript/ModuleDependencies.hs +4/−3
• src/Language/PureScript/Parser/Types.hs +1/−3
• src/Language/PureScript/Sugar/BindingGroups.hs +0/−1
• src/Language/PureScript/Sugar/CaseDeclarations.hs +39/−16
• src/Language/PureScript/Sugar/DoNotation.hs +1/−4
• src/Language/PureScript/TypeChecker/Entailment.hs +1/−1
• src/Language/PureScript/TypeChecker/Monad.hs +17/−14
• src/Language/PureScript/TypeChecker/Types.hs +7/−5
• tests/Main.hs +8/−9

@@ -0,0 +1,11 @@+module Main where++class C a where+  f :: a -> a+  g :: a -> a++instance cS :: C String where+  f s = s+  g = f++main = g "Done"

@@ -0,0 +1,6 @@+module Main where++data Foo = Bar+type Baz = { | Foo }++main = Debug.Trace.trace "Done"

@@ -0,0 +1,6 @@+module Main where++type Foo r = (x :: Number | r)+type Bar = { | Foo }++main = Debug.Trace.trace "Done"

@@ -0,0 +1,6 @@+module Main where++type Foo = { x :: Number }+type Bar = { | Foo }++main = Debug.Trace.trace "Done"

@@ -0,0 +1,3 @@+module Main where++type T = T

@@ -0,0 +1,19 @@+module Main where++data A = A | B | C++f a _ A = a+f _ a B = a+f _ _ C = "Done"++g a _ A = a+g _ b B = b+g _ _ C = C++data M a = N | J a++h f N a = a+h f a N = a+h f (J a) (J b) = J (f a b)++main = Debug.Trace.trace $ f "Done" "Failed" A

@@ -1,8 +1,19 @@ module Main where -import Prelude import Control.Monad.Eff import Control.Monad.ST++foreign import jsMod+  """+  function jsMod(x) {+    return function (y) {+      return x % y;+    };+  }+  """ :: Number -> Number -> Number++infixl 7 %+(%) = jsMod  collatz :: Number -> Number collatz n = runPure (runST (do

@@ -1,29 +1,39 @@ module Main where -  import Prelude+foreign import jsMod+  """+  function jsMod(x) {+    return function (y) {+      return x % y;+    };+  }+  """ :: Number -> Number -> Number -  collatz = \x -> case x of-    y | y % 2 == 0 -> y / 2-    y -> y * 3 + 1+infixl 7 %+(%) = jsMod -  -- Guards have access to current scope-  collatz2 = \x y -> case x of-    z | y > 0 -> z / 2-    z -> z * 3 + 1+collatz = \x -> case x of+  y | y % 2 == 0 -> y / 2+  y -> y * 3 + 1 -  min :: forall a. (Ord a) => a -> a -> a-  min n m | n < m     = n-          | otherwise = m+-- Guards have access to current scope+collatz2 = \x y -> case x of+  z | y > 0 -> z / 2+  z -> z * 3 + 1 -  max :: forall a. (Ord a) => a -> a -> a-  max n m = case unit of-    _ | m < n     -> n-      | otherwise -> m+min :: forall a. (Ord a) => a -> a -> a+min n m | n < m     = n+        | otherwise = m -  testIndentation :: Number -> Number -> Number-  testIndentation x y | x > 0-    = x + y-                      | otherwise-    = y - x+max :: forall a. (Ord a) => a -> a -> a+max n m = case unit of+  _ | m < n     -> n+    | otherwise -> m -  main = Debug.Trace.trace $ min "Done" "ZZZZ"+testIndentation :: Number -> Number -> Number+testIndentation x y | x > 0+  = x + y+                    | otherwise+  = y - x++main = Debug.Trace.trace $ min "Done" "ZZZZ"

@@ -0,0 +1,15 @@+module Main where++test = +  let f :: Number -> Boolean+      f 0 = false+      f n = g (n - 1)++      g :: Number -> Boolean+      g 0 = true+      g n = f (n - 1)++      x = f 1+  in not x++main = Debug.Trace.print test

@@ -35,21 +35,13 @@     assert (6 / (3 * 2) == 1)   "6 / (3 * 2) == 1"     assert ((6 / 3) * 2 == 4)   "(6 / 3) * 2 == 4" -    assert (6 % (2 * 2) == 2)   "6 % (2 * 2) == 2"-    assert ((6 % 2) * 2 == 0)   "(6 % 2) * 2 == 0"--    assert (4 % (9 / 3) == 1)   "4 % (9 / 3) == 1"-    assert ((4 % 9) / 2 == 2)   "(4 % 9) / 2 == 2"-     assert (not (1 < 0) == true) "not (1 < 0) == true"-    assert (not (complement (1 + 10) == 8) == true) "not (complement (1 + 10) == 8) == true"     assert (not ((negate 1) < 0) == false) "not ((negate 1) < 0) == false"      assert (negate (1 + 10) == -11) "negate (1 + 10) == -11"      assert (2 * 3 / 4 == 1.5) "2 * 3 / 4 == 1.5"     assert (1 * 2 * 3 * 4 * 5 / 6 == 20) "1 * 2 * 3 * 4 * 5 / 6 == 20"-    assert (complement (2 / 3 * 4) == -3) "complement (2 / 3 * 4) == -3"      assert (1 + 10 - 5 == 6) "1 + 10 - 5 == 6"     assert (1 + 10 * 5 == 51) "1 + 10 * 5 == 51"

@@ -0,0 +1,46 @@+module Main where++import Debug.Trace++main = do++  -- semiringNumber+  print (1 + 2)+  print (1 * 2)++  -- ringNumber+  print (1 - 2)+  print (negate 1)++  -- moduleSemiringNumber+  print (1 / 2)++  -- ordNumber+  print (1 > 2)+  print (1 < 2)+  print (1 <= 2)+  print (1 >= 2)+  print (1 == 2)++  -- eqNumber+  print (1 == 2)+  print (1 /= 2)++  -- eqString+  print ("foo" == "bar")+  print ("foo" /= "bar")++  -- eqBoolean+  print (true == false)+  print (true /= false)++  -- semigroupString+  print ("foo" ++ "bar")+  print ("foo" <> "bar")++  -- latticeBoolean+  print (top && true)+  print (bottom || false)++  -- complementedLatticeBoolean+  print (not true)

@@ -61,9 +61,6 @@   test15 :: Number -> Number -> Boolean   test15 a b = const false $ a `test14` b -  test16 :: Number -> Number -> Number-  test16 x y = x .|. y .&. y-   test17 :: Number   test17 = negate (-1) @@ -94,7 +91,6 @@     let t13 = test13 k 1 2     let t14 = test14 1 2     let t15 = test15 1 2-    let t16 = test16 1 2     let t17 = test17     let t18 = test18     let t19 = test19

@@ -0,0 +1,37 @@+module Main where++example1 :: String+example1 = do+  "Do"+  " notation"+  " for"+  " Semigroup"+  where+  (>>=) x f = x <> f unit++(*>) :: forall f a b. (Apply f) => f a -> f b -> f b+(*>) fa fb = const id <$> fa <*> fb++newtype Const a b = Const a++runConst :: forall a b. Const a b -> a+runConst (Const a) = a++instance functorConst :: Functor (Const a) where+  (<$>) _ (Const a) = Const a++instance applyConst :: (Semigroup a) => Apply (Const a) where+  (<*>) (Const a1) (Const a2) = Const (a1 <> a2)++example2 :: Const String Unit+example2 = do+  Const "Do"+  Const " notation"+  Const " for"+  Const " Apply"+  where+  (>>=) x f = x *> f unit++main = do+  Debug.Trace.trace example1+  Debug.Trace.trace $ runConst example2

@@ -0,0 +1,40 @@+module Main where++type Foo = (x :: Number | (y :: Number | (z :: Number)))+type Bar = (x :: Number, y :: Number, z :: Number)+type Baz = { w :: Number | Bar }++foo :: { | Foo }+foo = { x: 0, y: 0, z: 0 }++bar :: { | Bar }+bar = { x: 0, y: 0, z: 0 }++id' :: Object Foo -> Object Bar+id' = id++foo' :: { | Foo }+foo' = id' foo++bar' :: { | Bar }+bar' = id' bar++baz :: Baz+baz = { x: 0, y: 0, z: 0, w: 0 }++type Quux r = (q :: Number | r)+type Norf r = (q' :: Number | Quux r)++quux :: { f :: { | Foo } | Quux Bar }+quux = { f: foo', x: 0, y: 0, z: 0, q: 0 }++quux' :: { | Norf Bar }+quux' = { x: 0, y: 0, z: 0, q: 0, q': 0 }++wildcard :: { w :: Number | _ } -> Baz+wildcard { w: w } = { x: w, y: w, z: w, w: w }++wildcard' :: { | Quux _ } -> Number+wildcard' { q: q } = q++main = Debug.Trace.trace "Done"

@@ -1,18 +1,28 @@ module Main where -  import Prelude+foreign import jsMod+  """+  function jsMod(x) {+    return function (y) {+      return x % y;+    };+  }+  """ :: Number -> Number -> Number -  gcd :: Number -> Number -> Number-  gcd 0 x = x-  gcd x 0 = x-  gcd x y | x > y = gcd (x % y) y-  gcd x y = gcd (y % x) x+infixl 7 %+(%) = jsMod -  guardsTest (x:xs) | x > 0 = guardsTest xs-  guardsTest xs = xs+gcd :: Number -> Number -> Number+gcd 0 x = x+gcd x 0 = x+gcd x y | x > y = gcd (x % y) y+gcd x y = gcd (y % x) x -  data A = A+guardsTest (x:xs) | x > 0 = guardsTest xs+guardsTest xs = xs -  parseTest A 0 = 0+data A = A -  main = Debug.Trace.trace "Done"+parseTest A 0 = 0++main = Debug.Trace.trace "Done"

@@ -1,156 +1,120 @@ module Prelude-  ( otherwise+  ( Unit(..), unit+  , ($), (#)   , flip   , const   , asTypeOf+  , otherwise+  , (:), cons   , Semigroupoid, (<<<), (>>>)   , Category, id-  , ($), (#)-  , (:), cons-  , Show, show   , Functor, (<$>), (<#>), void   , Apply, (<*>)   , Applicative, pure, liftA1   , Bind, (>>=)   , Monad, return, liftM1, ap+  , Semigroup, (<>), (++)   , Semiring, (+), zero, (*), one   , ModuloSemiring, (/), mod-  , Ring, (-)-  , (%)-  , negate-  , DivisionRing+  , Ring, (-), negate   , Num+  , DivisionRing   , Eq, (==), (/=)-  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)-  , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement-  , BoolLike, (&&), (||)-  , not-  , Semigroup, (<>), (++)-  , Unit(..), unit+  , Ordering(..), Ord, compare, (<), (>), (<=), (>=)+  , Bounded, top, bottom+  , Lattice, sup, inf, (||), (&&)+  , BoundedLattice+  , ComplementedLattice, not+  , DistributiveLattice+  , BooleanAlgebra+  , Show, show   ) where -  -- | An alias for `true`, which can be useful in guard clauses:-  -- |-  -- | ```purescript-  -- | max x y | x >= y = x-  -- |         | otherwise = y-  -- | ```+  -- | The `Unit` type has a single inhabitant, called `unit`. It represents+  -- | values with no computational content.   -- |-  otherwise :: Boolean-  otherwise = true+  -- | `Unit` is often used, wrapped in a monadic type constructor, as the+  -- | return type of a computation where only+  -- | the _effects_ are important.+  newtype Unit = Unit {} -  -- | Flips the order of the arguments to a function of two arguments.+  -- | `unit` is the sole inhabitant of the `Unit` type.+  unit :: Unit+  unit = Unit {}++  infixr 0 $+  infixl 0 #++  -- | Applies a function to its argument.   -- |   -- | ```purescript-  -- | flip const 1 2 = const 2 1 = 2+  -- | length $ groupBy productCategory $ filter isInStock $ products   -- | ```   -- |-  flip :: forall a b c. (a -> b -> c) -> b -> a -> c-  flip f b a = f a b--  -- | Returns its first argument and ignores its second.+  -- | is equivalent to:   -- |   -- | ```purescript-  -- | const 1 "hello" = 1+  -- | length (groupBy productCategory (filter isInStock products))   -- | ```   -- |-  const :: forall a b. a -> b -> a-  const a _ = a+  -- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of+  -- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))`+  ($) :: forall a b. (a -> b) -> a -> b+  ($) f x = f x -  -- | This function returns its first argument, and can be used to assert type equalities.-  -- | This can be useful when types are otherwise ambiguous.+  -- | Applies an argument to a function.   -- |   -- | ```purescript-  -- | main = print $ [] `asTypeOf` [0]+  -- | products # filter isInStock # groupBy productCategory # length   -- | ```   -- |-  -- | If instead, we had written `main = print []`, the type of the argument `[]` would have-  -- | been ambiguous, resulting in a compile-time error.-  asTypeOf :: forall a. a -> a -> a-  asTypeOf x _ = x--  infixr 9 >>>-  infixr 9 <<<--  -- | A `Semigroupoid` is similar to a [`Category`](#category) but does not require an identity-  -- | element `id`, just composable morphisms.-  -- |-  -- | `Semigroupoid`s should obey the following rule:-  -- |-  -- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`-  -- |-  -- | One example of a `Semigroupoid` is the function type constructor `(->)`, with `(<<<)` defined-  -- | as function composition.-  class Semigroupoid a where-    (<<<) :: forall b c d. a c d -> a b c -> a b d--  instance semigroupoidArr :: Semigroupoid (->) where-    (<<<) f g x = f (g x)--  -- | Forwards composition, or `(<<<)` with its arguments reversed.-  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d-  (>>>) f g = g <<< f--  -- | `Category`s consist of objects and composable morphisms between them, and as such are-  -- | [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids` must have an identity element.-  -- |-  -- | `Category`s should obey the following rules.-  -- |-  -- | - Left Identity: `id <<< p = p`-  -- | - Right Identity: `p <<< id = p`-  -- |-  class (Semigroupoid a) <= Category a where-    id :: forall t. a t t--  instance categoryArr :: Category (->) where-    id x = x--  infixr 0 $-  infixl 0 #--  -- | Applies a function to its argument+  -- | is equivalent to:   -- |   -- | ```purescript-  -- | length $ groupBy productCategory $ filter isInStock products+  -- | length (groupBy productCategory (filter isInStock products))   -- | ```   -- |-  -- | is equivalent to+  -- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of+  -- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))`+  (#) :: forall a b. a -> (a -> b) -> b+  (#) x f = f x++  -- | Flips the order of the arguments to a function of two arguments.   -- |   -- | ```purescript-  -- | length (groupBy productCategory (filter isInStock (products)))+  -- | flip const 1 2 = const 2 1 = 2   -- | ```-  -- |-  -- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of left, so-  -- | `a $ b $ c $ d x` = `a $ (b $ (c $ (d $ x)))` = `a (b (c (d x)))`-  -- |-  ($) :: forall a b. (a -> b) -> a -> b-  ($) f x = f x+  flip :: forall a b c. (a -> b -> c) -> b -> a -> c+  flip f b a = f a b -  -- | Applies a function to its argument+  -- | Returns its first argument and ignores its second.   -- |   -- | ```purescript-  -- | products # groupBy productCategory # filter isInStock # length+  -- | const 1 "hello" = 1   -- | ```-  -- |-  -- | is equivalent to+  const :: forall a b. a -> b -> a+  const a _ = a++  -- | This function returns its first argument, and can be used to assert type+  -- | equalities. This can be useful when types are otherwise ambiguous.   -- |   -- | ```purescript-  -- | length (groupBy productCategory (filter isInStock (products)))+  -- | main = print $ [] `asTypeOf` [0]   -- | ```   -- |-  -- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of right, so-  -- | `x # a # b # c # d` = `(((x # a) # b) # c) # d` = `d (c (b (a x)))`-  -- |-  (#) :: forall a b. a -> (a -> b) -> b-  (#) x f = f x--  infixr 6 :+  -- | If instead, we had written `main = print []`, the type of the argument+  -- | `[]` would have been ambiguous, resulting in a compile-time error.+  asTypeOf :: forall a. a -> a -> a+  asTypeOf x _ = x -  -- | An infix alias for `cons`.+  -- | An alias for `true`, which can be useful in guard clauses:   -- |-  -- | Note, the running time of this function is `O(n)`.-  (:) :: forall a. a -> [a] -> [a]-  (:) = cons+  -- | ```purescript+  -- | max x y | x >= y    = x+  -- |         | otherwise = y+  -- | ```+  otherwise :: Boolean+  otherwise = true    -- | Attaches an element to the front of an array, creating a new array.   -- |@@ -168,72 +132,70 @@     }     """ :: forall a. a -> [a] -> [a] -  -- | The `Show` type class represents those types which can be converted into a human-readable `String` representation.-  -- |-  -- | While not required, it is recommended that for any expression `x`, the string `show x` be executable PureScript code-  -- | which evaluates to the same value as the expression `x`.-  class Show a where-    show :: a -> String--  foreign import showStringImpl-    """-    function showStringImpl(s) {-      return JSON.stringify(s);-    }-    """ :: String -> String+  infixr 6 : -  instance showUnit :: Show Unit where-    show (Unit {}) = "Unit {}"+  -- | An infix alias for `cons`.+  -- |+  -- | Note, the running time of this function is `O(n)`.+  (:) :: forall a. a -> [a] -> [a]+  (:) = cons -  instance showString :: Show String where-    show = showStringImpl+  infixr 9 >>>+  infixr 9 <<< -  instance showBoolean :: Show Boolean where-    show true = "true"-    show false = "false"+  -- | A `Semigroupoid` is similar to a [`Category`](#category) but does not+  -- | require an identity element `id`, just composable morphisms.+  -- |+  -- | `Semigroupoid`s must satisfy the following law:+  -- |+  -- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`+  -- |+  -- | One example of a `Semigroupoid` is the function type constructor `(->)`,+  -- | with `(<<<)` defined as function composition.+  class Semigroupoid a where+    (<<<) :: forall b c d. a c d -> a b c -> a b d -  foreign import showNumberImpl-    """-    function showNumberImpl(n) {-      return n.toString();-    }-    """ :: Number -> String+  instance semigroupoidArr :: Semigroupoid (->) where+    (<<<) f g x = f (g x) -  instance showNumber :: Show Number where-    show = showNumberImpl+  -- | Forwards composition, or `(<<<)` with its arguments reversed.+  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d+  (>>>) f g = g <<< f -  foreign import showArrayImpl-    """-    function showArrayImpl(f) {-      return function(xs) {-        var ss = [];-        for (var i = 0, l = xs.length; i < l; i++) {-          ss[i] = f(xs[i]);-        }-        return '[' + ss.join(',') + ']';-      };-    }-    """ :: forall a. (a -> String) -> [a] -> String+  -- | `Category`s consist of objects and composable morphisms between them, and+  -- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids`+  -- | must have an identity element.+  -- |+  -- | Instances must satisfy the following law in addition to the+  -- | `Semigroupoid` law:+  -- |+  -- | - Identity: `id <<< p = p <<< id = p`+  class (Semigroupoid a) <= Category a where+    id :: forall t. a t t -  instance showArray :: (Show a) => Show [a] where-    show = showArrayImpl show+  instance categoryArr :: Category (->) where+    id x = x    infixl 4 <$>   infixl 1 <#> -  -- | A `Functor` is a type constructor which supports a mapping operation `(<$>)`.+  -- | A `Functor` is a type constructor which supports a mapping operation+  -- | `(<$>)`.   -- |-  -- | `(<$>)` can be used to turn functions `a -> b` into functions `f a -> f b` whose argument and return-  -- | types use the type constructor `f` to represent some computational context.+  -- | `(<$>)` can be used to turn functions `a -> b` into functions+  -- | `f a -> f b` whose argument and return types use the type constructor `f`+  -- | to represent some computational context.   -- |-  -- | `Functor` instances should satisfy the following laws:+  -- | Instances must satisfy the following laws:   -- |   -- | - Identity: `(<$>) id = id`   -- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`-  -- |   class Functor f where     (<$>) :: forall a b. (a -> b) -> f a -> f b +  instance functorArr :: Functor ((->) r) where+    (<$>) = (<<<)+   -- | `(<#>)` is `(<$>)` with its arguments reversed. For example:   -- |   -- | ```purescript@@ -242,10 +204,12 @@   (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b   (<#>) fa f = f <$> fa -  -- | The `void` function is used to ignore the type wrapped by a [`Functor`](#functor), replacing it with `Unit` and-  -- | keeping only the type information provided by the type constructor itself.+  -- | The `void` function is used to ignore the type wrapped by a+  -- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type+  -- | information provided by the type constructor itself.   -- |-  -- | `void` is often useful when using `do` notation to change the return type of a monadic computation:+  -- | `void` is often useful when using `do` notation to change the return type+  -- | of a monadic computation:   -- |   -- | ```purescript   -- | main = forE 1 10 \n -> void do@@ -257,48 +221,69 @@    infixl 4 <*> -  -- | The `Apply` class provides the `(<*>)` which is used to apply a function to an argument under a type constructor.+  -- | The `Apply` class provides the `(<*>)` which is used to apply a function+  -- | to an argument under a type constructor.   -- |-  -- | `Apply` can be used to lift functions of two or more arguments to work on values wrapped with the type constructor `f`.-  -- | It might also be understood in terms of the `lift2` function:+  -- | `Apply` can be used to lift functions of two or more arguments to work on+  -- | values wrapped with the type constructor `f`. It might also be understood+  -- | in terms of the `lift2` function:   -- |   -- | ```purescript   -- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c   -- | lift2 f a b = f <$> a <*> b   -- | ```   -- |-  -- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts the function application operator `($)` to arguments-  -- | wrapped with the type constructor `f`.+  -- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts+  -- | the function application operator `($)` to arguments wrapped with the+  -- | type constructor `f`.   -- |-  -- | `Apply` instances should satisfy the following law:+  -- | Instances must satisfy the following law in addition to the `Functor`+  -- | laws:   -- |-  -- | - Associative Composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`+  -- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`   -- |   -- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.   class (Functor f) <= Apply f where     (<*>) :: forall a b. f (a -> b) -> f a -> f b -  -- | The `Applicative` type class extends the [`Apply`](#apply) type class with a `pure` function, which can be used to-  -- | create values of type `f a` from values of type `a`.+  instance applyArr :: Apply ((->) r) where+    (<*>) f g x = f x (g x)++  -- | The `Applicative` type class extends the [`Apply`](#apply) type class+  -- | with a `pure` function, which can be used to create values of type `f a`+  -- | from values of type `a`.   -- |-  -- | Where [`Apply`](#apply) provides the ability to lift functions of two or more arguments to functions whose arguments are wrapped using `f`,-  -- | and [`Functor`](#functor) provides the ability to lift functions of one argument, `pure` can be seen as the function which lifts functions of-  -- | _zero_ arguments. That is, `Applicative` functors support a lifting operation for any number of function arguments.+  -- | Where [`Apply`](#apply) provides the ability to lift functions of two or+  -- | more arguments to functions whose arguments are wrapped using `f`, and+  -- | [`Functor`](#functor) provides the ability to lift functions of one+  -- | argument, `pure` can be seen as the function which lifts functions of+  -- | _zero_ arguments. That is, `Applicative` functors support a lifting+  -- | operation for any number of function arguments.   -- |-  -- | `Applicative` instances should satisfy the following laws:+  -- | Instances must satisfy the following laws in addition to the `Apply`+  -- | laws:   -- |   -- | - Identity: `(pure id) <*> v = v`   -- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`   -- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`   -- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`-  -- |   class (Apply f) <= Applicative f where     pure :: forall a. a -> f a -  -- | `liftA1` provides a default implementation of `(<$>)` for any [`Applicative`](#applicative) functor,-  -- | without using `(<$>)` as provided by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass relationship.+  instance applicativeArr :: Applicative ((->) r) where+    pure = const++  -- | `return` is an alias for `pure`.+  return :: forall m a. (Applicative m) => a -> m a+  return = pure++  -- | `liftA1` provides a default implementation of `(<$>)` for any+  -- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided+  -- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass+  -- | relationship.   -- |-  -- | `liftA1` can therefore be used to write [`Functor`](#functor) instances as follows:+  -- | `liftA1` can therefore be used to write [`Functor`](#functor) instances+  -- | as follows:   -- |   -- | ```purescript   -- | instance functorF :: Functor F where@@ -309,8 +294,9 @@    infixl 1 >>= -  -- | The `Bind` type class extends the [`Apply`](#apply) type class with a "bind" operation `(>>=)` which composes computations-  -- | in sequence, using the return value of one computation to determine the next computation.+  -- | The `Bind` type class extends the [`Apply`](#apply) type class with a+  -- | "bind" operation `(>>=)` which composes computations in sequence, using+  -- | the return value of one computation to determine the next computation.   -- |   -- | The `>>=` operator can also be expressed using `do` notation, as follows:   -- |@@ -321,15 +307,13 @@   -- |   -- | where the function argument of `f` is given the name `y`.   -- |-  -- | `Bind` instances should satisfy the following law:+  -- | Instances must satisfy the following law in addition to the `Apply`+  -- | laws:   -- |   -- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`   -- |-  -- | Or, expressed using `do` notation:-  -- |-  -- | - Associativity: `do { z <- do { y <- x ; f y } ; g z } = do { k <- x ; do { y <- f k ; g y } }`-  -- |-  -- | Associativity tells us that we can regroup operations which use do-notation, so that we can unambiguously write, for example:+  -- | Associativity tells us that we can regroup operations which use `do`+  -- | notation so that we can unambiguously write, for example:   -- |   -- | ```purescript   -- | do x <- m1@@ -339,29 +323,29 @@   class (Apply m) <= Bind m where     (>>=) :: forall a b. m a -> (a -> m b) -> m b -  -- | The `Monad` type class combines the operations of the `Bind` and `Applicative` type classes. Therefore, `Monad` instances-  -- | represent type constructors which support sequential composition, and also lifting of functions of arbitrary arity.+  instance bindArr :: Bind ((->) r) where+    (>>=) m f x = f (m x) x++  -- | The `Monad` type class combines the operations of the `Bind` and+  -- | `Applicative` type classes. Therefore, `Monad` instances represent type+  -- | constructors which support sequential composition, and also lifting of+  -- | functions of arbitrary arity.   -- |-  -- | `Monad` instances should satisfy the following laws:+  -- | Instances must satisfy the following laws in addition to the+  -- | `Applicative` and `Bind` laws:   -- |   -- | - Left Identity: `pure x >>= f = f x`   -- | - Right Identity: `x >>= pure = x`-  -- |-  -- | Or, expressed using `do` notation:-  -- |-  -- | - Left Identity: `do { y <- pure x ; f y } = f x`-  -- | - Right Identity: `do { y <- x ; pure y } = x`-  -- |   class (Applicative m, Bind m) <= Monad m -  -- | `return` is an alias for `pure`.-  return :: forall m a. (Monad m) => a -> m a-  return = pure+  instance monadArr :: Monad ((->) r) -  -- | `liftM1` provides a default implementation of `(<$>)` for any [`Monad`](#monad),-  -- | without using `(<$>)` as provided by the [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.+  -- | `liftM1` provides a default implementation of `(<$>)` for any+  -- | [`Monad`](#monad), without using `(<$>)` as provided by the+  -- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.   -- |-  -- | `liftM1` can therefore be used to write [`Functor`](#functor) instances as follows:+  -- | `liftM1` can therefore be used to write [`Functor`](#functor) instances+  -- | as follows:   -- |   -- | ```purescript   -- | instance functorF :: Functor F where@@ -372,10 +356,12 @@     a' <- a     return (f a') -  -- | `ap` provides a default implementation of `(<*>)` for any [`Monad`](#monad),-  -- | without using `(<*>)` as provided by the [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.+  -- | `ap` provides a default implementation of `(<*>)` for any+  -- | [`Monad`](#monad), without using `(<*>)` as provided by the+  -- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.   -- |-  -- | `ap` can therefore be used to write [`Apply`](#apply) instances as follows:+  -- | `ap` can therefore be used to write [`Apply`](#apply) instances as+  -- | follows:   -- |   -- | ```purescript   -- | instance applyF :: Apply F where@@ -387,69 +373,153 @@     a' <- a     return (f' a') -  instance functorArr :: Functor ((->) r) where-    (<$>) = (<<<)+  infixr 5 <>+  infixr 5 ++ -  instance applyArr :: Apply ((->) r) where-    (<*>) f g x = f x (g x)+  -- | The `Semigroup` type class identifies an associative operation on a type.+  -- |+  -- | Instances are required to satisfy the following law:+  -- |+  -- | - Associativity: `(x <> y) <> z = x <> (y <> z)`+  -- |+  -- | One example of a `Semigroup` is `String`, with `(<>)` defined as string+  -- | concatenation.+  class Semigroup a where+    (<>) :: a -> a -> a -  instance applicativeArr :: Applicative ((->) r) where-    pure = const+  -- | `(++)` is an alias for `(<>)`.+  (++) :: forall s. (Semigroup s) => s -> s -> s+  (++) = (<>) -  instance bindArr :: Bind ((->) r) where-    (>>=) m f x = f (m x) x+  instance semigroupString :: Semigroup String where+    (<>) = concatString -  instance monadArr :: Monad ((->) r)+  instance semigroupUnit :: Semigroup Unit where+    (<>) _ _ = unit -  infixl 7 *-  infixl 7 /-  infixl 7 %+  instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where+    (<>) f g = \x -> f x <> g x -  infixl 6 -+  instance semigroupOrdering :: Semigroup Ordering where+    (<>) LT _ = LT+    (<>) GT _ = GT+    (<>) EQ y = y++  foreign import concatString+    """+    function concatString(s1) {+      return function(s2) {+        return s1 + s2;+      };+    }+    """ :: String -> String -> String+   infixl 6 ++  infixl 7 * -  -- | Addition and multiplication, satisfying the following laws:+  -- | The `Semiring` class is for types that support an addition and+  -- | multiplication operation.   -- |-  -- | - `a` is a commutative monoid under addition-  -- | - `a` is a monoid under multiplication-  -- | - multiplication distributes over addition-  -- | - multiplication by `zero` annihilates `a`+  -- | Instances must satisfy the following laws:   -- |+  -- | - Commutative monoid under addition:+  -- |   - Associativity: `(a + b) + c = a + (b + c)`+  -- |   - Identity: `zero + a = a + zero = a`+  -- |   - Commutative: `a + b = b + a`+  -- | - Monoid under multiplication:+  -- |   - Associativity: `(a * b) * c = a * (b * c)`+  -- |   - Identity: `one * a = a * one = a`+  -- | - Multiplication distributes over addition:+  -- |   - Left distributivity: `a * (b + c) = (a * b) + (a * c)`+  -- |   - Right distributivity: `(a + b) * c = (a * c) + (b * c)`+  -- | - Annihiliation: `zero * a = a * zero = zero`   class Semiring a where     (+)  :: a -> a -> a     zero :: a     (*)  :: a -> a -> a     one  :: a -  -- | Addition, multiplication, modulo operation and division, satisfying:-  -- |-  -- | - ```a / b * b + (a `mod` b) = a```-  -- |-  class (Semiring a) <= ModuloSemiring a where-    (/) :: a -> a -> a-    mod :: a -> a -> a+  instance semiringNumber :: Semiring Number where+    (+) = numAdd+    zero = 0+    (*) = numMul+    one = 1 -  -- | Addition, multiplication, and subtraction.-  -- |-  -- | Has the same laws as `Semiring` but additionally satisfying:+  instance semiringUnit :: Semiring Unit where+    (+) _ _ = unit+    zero = unit+    (*) _ _ = unit+    one = unit++  infixl 6 -++  -- | The `Ring` class is for types that support addition, multiplication,+  -- | and subtraction operations.   -- |-  -- | - `a` is an abelian group under addition+  -- | Instances must satisfy the following law in addition to the `Semiring`+  -- | laws:   -- |+  -- | - Additive inverse: `a + (-a) = (-a) + a = zero`   class (Semiring a) <= Ring a where     (-) :: a -> a -> a +  instance ringNumber :: Ring Number where+    (-) = numSub++  instance ringUnit :: Ring Unit where+    (-) _ _ = unit+   negate :: forall a. (Ring a) => a -> a   negate a = zero - a -  -- | Ring where every nonzero element has a multiplicative inverse so that:+  infixl 7 /++  -- | The `ModuloSemiring` class is for types that support addition,+  -- | multiplication, division, and modulo (division remainder) operations.   -- |-  -- | - ```a `mod` b = zero```+  -- | Instances must satisfy the following law in addition to the `Semiring`+  -- | laws:   -- |+  -- | - Remainder: `a / b * b + (a `mod` b) = a`+  class (Semiring a) <= ModuloSemiring a where+    (/) :: a -> a -> a+    mod :: a -> a -> a++  instance moduloSemiringNumber :: ModuloSemiring Number where+    (/) = numDiv+    mod _ _ = 0++  instance moduloSemiringUnit :: ModuloSemiring Unit where+    (/) _ _ = unit+    mod _ _ = unit++  -- | A `Ring` where every nonzero element has a multiplicative inverse.+  -- |+  -- | Instances must satisfy the following law in addition to the `Ring` and+  -- | `ModuloSemiring` laws:+  -- |+  -- | - Multiplicative inverse: `(one / x) * x = one`+  -- |+  -- | As a consequence of this ```a `mod` b = zero``` as no divide operation+  -- | will have a remainder.   class (Ring a, ModuloSemiring a) <= DivisionRing a -  -- | A commutative field+  instance divisionRingNumber :: DivisionRing Number++  instance divisionRingUnit :: DivisionRing Unit++  -- | The `Num` class is for types that are commutative fields.+  -- |+  -- | Instances must satisfy the following law in addition to the+  -- | `DivisionRing` laws:+  -- |+  -- | - Commutative multiplication: `a * b = b * a`   class (DivisionRing a) <= Num a +  instance numNumber :: Num Number++  instance numUnit :: Num Unit+   foreign import numAdd     """     function numAdd(n1) {@@ -459,15 +529,6 @@     }     """ :: Number -> Number -> Number -  foreign import numSub-    """-    function numSub(n1) {-      return function(n2) {-        return n1 - n2;-      };-    }-    """ :: Number -> Number -> Number-   foreign import numMul     """     function numMul(n1) {@@ -486,44 +547,15 @@     }     """ :: Number -> Number -> Number -  foreign import numMod+  foreign import numSub     """-    function numMod(n1) {+    function numSub(n1) {       return function(n2) {-        return n1 % n2;+        return n1 - n2;       };     }     """ :: Number -> Number -> Number -  (%) = numMod--  instance semiringNumber :: Semiring Number where-    (+) = numAdd-    zero = 0-    (*) = numMul-    one = 1--  instance ringNumber :: Ring Number where-    (-) = numSub--  instance moduloSemiringNumber :: ModuloSemiring Number where-    (/) = numDiv-    mod _ _ = 0--  instance divisionRingNumber :: DivisionRing Number--  instance numNumber :: Num Number--  -- | The `Unit` type has a single inhabitant, called `unit`. It represents values with no computational content.-  -- |-  -- | `Unit` is often used, wrapped in a monadic type constructor, as the return type of a computation where only-  -- | the _effects_ are important.-  newtype Unit = Unit {}--  -- | `unit` is the sole inhabitant of the `Unit` type.-  unit :: Unit-  unit = Unit {}-   infix 4 ==   infix 4 /= @@ -541,6 +573,33 @@     (==) :: a -> a -> Boolean     (/=) :: a -> a -> Boolean +  instance eqBoolean :: Eq Boolean where+    (==) = refEq+    (/=) = refIneq++  instance eqNumber :: Eq Number where+    (==) = refEq+    (/=) = refIneq++  instance eqString :: Eq String where+    (==) = refEq+    (/=) = refIneq++  instance eqUnit :: Eq Unit where+    (==) _ _ = true+    (/=) _ _ = false++  instance eqArray :: (Eq a) => Eq [a] where+    (==) = eqArrayImpl (==)+    (/=) xs ys = not (xs == ys)++  instance eqOrdering :: Eq Ordering where+    (==) LT LT = true+    (==) GT GT = true+    (==) EQ EQ = true+    (==) _  _  = false+    (/=) x y = not (x == y)+   foreign import refEq     """     function refEq(r1) {@@ -559,22 +618,6 @@     }     """ :: forall a. a -> a -> Boolean -  instance eqUnit :: Eq Unit where-    (==) (Unit {}) (Unit {}) = true-    (/=) (Unit {}) (Unit {}) = false--  instance eqString :: Eq String where-    (==) = refEq-    (/=) = refIneq--  instance eqNumber :: Eq Number where-    (==) = refEq-    (/=) = refIneq--  instance eqBoolean :: Eq Boolean where-    (==) = refEq-    (/=) = refIneq-   foreign import eqArrayImpl     """     function eqArrayImpl(f) {@@ -590,34 +633,14 @@     }     """ :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean -  instance eqArray :: (Eq a) => Eq [a] where-    (==) xs ys = eqArrayImpl (==) xs ys-    (/=) xs ys = not (xs == ys)--  -- | The `Ordering` data type represents the three possible outcomes of comparing two values:+  -- | The `Ordering` data type represents the three possible outcomes of+  -- | comparing two values:   -- |   -- | `LT` - The first value is _less than_ the second.   -- | `GT` - The first value is _greater than_ the second.   -- | `EQ` - The first value is _equal to_ or _incomparable to_ the second.   data Ordering = LT | GT | EQ -  instance eqOrdering :: Eq Ordering where-    (==) LT LT = true-    (==) GT GT = true-    (==) EQ EQ = true-    (==) _  _  = false-    (/=) x y = not (x == y)--  instance showOrdering :: Show Ordering where-    show LT = "LT"-    show GT = "GT"-    show EQ = "EQ"--  instance semigroupOrdering :: Semigroup Ordering where-    (<>) LT _ = LT-    (<>) GT _ = GT-    (<>) EQ y = y-   -- | The `Ord` type class represents types which support comparisons.   -- |   -- | `Ord` instances should satisfy the laws of _partially orderings_:@@ -625,11 +648,45 @@   -- | - Reflexivity: `a <= a`   -- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b`   -- | - Transitivity: if `a <= b` and `b <= c` then `a <= c`-  -- |   class (Eq a) <= Ord a where     compare :: a -> a -> Ordering +  instance ordBoolean :: Ord Boolean where+    compare false false = EQ+    compare false true  = LT+    compare true  true  = EQ+    compare true  false = GT++  instance ordNumber :: Ord Number where+    compare = unsafeCompare++  instance ordString :: Ord String where+    compare = unsafeCompare++  instance ordUnit :: Ord Unit where+    compare _ _ = EQ++  instance ordArray :: (Ord a) => Ord [a] where+    compare [] [] = EQ+    compare [] _ = LT+    compare _ [] = GT+    compare (x:xs) (y:ys) = case compare x y of+      EQ -> compare xs ys+      other -> other++  instance ordOrdering :: Ord Ordering where+    compare LT LT = EQ+    compare EQ EQ = EQ+    compare GT GT = EQ+    compare LT _  = LT+    compare EQ LT = GT+    compare EQ GT = LT+    compare GT _  = GT+   infixl 4 <+  infixl 4 >+  infixl 4 <=+  infixl 4 >=    -- | Test whether one value is _strictly less than_ another.   (<) :: forall a. (Ord a) => a -> a -> Boolean@@ -637,30 +694,27 @@     LT -> true     _ -> false -  infixl 4 >-   -- | Test whether one value is _strictly greater than_ another.   (>) :: forall a. (Ord a) => a -> a -> Boolean   (>) a1 a2 = case a1 `compare` a2 of     GT -> true     _ -> false -  infixl 4 <=-   -- | Test whether one value is _non-strictly less than_ another.   (<=) :: forall a. (Ord a) => a -> a -> Boolean   (<=) a1 a2 = case a1 `compare` a2 of     GT -> false     _ -> true -  infixl 4 >=-   -- | Test whether one value is _non-strictly greater than_ another.   (>=) :: forall a. (Ord a) => a -> a -> Boolean   (>=) a1 a2 = case a1 `compare` a2 of     LT -> false     _ -> true +  unsafeCompare :: forall a. a -> a -> Ordering+  unsafeCompare = unsafeCompareImpl LT EQ GT+   foreign import unsafeCompareImpl     """     function unsafeCompareImpl(lt) {@@ -676,137 +730,131 @@     }     """ :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering -  unsafeCompare :: forall a. a -> a -> Ordering-  unsafeCompare = unsafeCompareImpl LT EQ GT--  instance ordUnit :: Ord Unit where-    compare (Unit {}) (Unit {}) = EQ+  -- | The `Bounded` type class represents types that are finite partially+  -- | ordered sets.+  -- |+  -- | Instances should satisfy the following law in addition to the `Ord` laws:+  -- |+  -- | - Ordering: `bottom <= a <= top`+  class (Ord a) <= Bounded a where+    top :: a+    bottom :: a -  instance ordBoolean :: Ord Boolean where-    compare false false = EQ-    compare false true  = LT-    compare true  true  = EQ-    compare true  false = GT+  instance boundedBoolean :: Bounded Boolean where+    top = true+    bottom = false -  instance ordNumber :: Ord Number where-    compare = unsafeCompare+  instance boundedUnit :: Bounded Unit where+    top = unit+    bottom = unit -  instance ordString :: Ord String where-    compare = unsafeCompare+  instance boundedOrdering :: Bounded Ordering where+    top = GT+    bottom = LT -  instance ordArray :: (Ord a) => Ord [a] where-    compare [] [] = EQ-    compare [] _ = LT-    compare _ [] = GT-    compare (x:xs) (y:ys) = case compare x y of-      EQ -> compare xs ys-      other -> other+  -- | The `Lattice` type class represents types that are partially ordered+  -- | sets with a supremum (`sup` or `||`) and infimum (`inf` or `&&`).+  -- |+  -- | Instances should satisfy the following laws in addition to the `Ord`+  -- | laws:+  -- |+  -- | - Associativity:+  -- |   - `a || (b || c) = (a || b) || c`+  -- |   - `a && (b && c) = (a && b) && c`+  -- | - Commutativity:+  -- |   - `a || b = b || a`+  -- |   - `a && b = b && a`+  -- | - Absorption:+  -- |   - `a || (a && b) = a`+  -- |   - `a && (a || b) = a`+  -- | - Idempotent:+  -- |   - `a || a = a`+  -- |   - `a && a = a`+  class (Ord a) <= Lattice a where+    sup :: a -> a -> a+    inf :: a -> a -> a -  infixl 10 .&.-  infixl 10 .|.-  infixl 10 .^.+  instance latticeBoolean :: Lattice Boolean where+    sup = boolOr+    inf = boolAnd -  -- | The `Bits` type class identifies types which support bitwise operations.-  class Bits b where-    (.&.) :: b -> b -> b-    (.|.) :: b -> b -> b-    (.^.) :: b -> b -> b-    shl :: b -> Number -> b-    shr :: b -> Number -> b-    zshr :: b -> Number -> b-    complement :: b -> b+  instance latticeUnit :: Lattice Unit where+    sup _ _ = unit+    inf _ _ = unit -  foreign import numShl-    """-    function numShl(n1) {-      return function(n2) {-        return n1 << n2;-      };-    }-    """ :: Number -> Number -> Number+  infixr 2 ||+  infixr 3 && -  foreign import numShr-    """-    function numShr(n1) {-      return function(n2) {-        return n1 >> n2;-      };-    }-    """ :: Number -> Number -> Number+  -- | The `sup` operator.+  (||) :: forall a. (Lattice a) => a -> a -> a+  (||) = sup -  foreign import numZshr-    """-    function numZshr(n1) {-      return function(n2) {-        return n1 >>> n2;-      };-    }-    """ :: Number -> Number -> Number+  -- | The `inf` operator.+  (&&) :: forall a. (Lattice a) => a -> a -> a+  (&&) = inf -  foreign import numAnd-    """-    function numAnd(n1) {-      return function(n2) {-        return n1 & n2;-      };-    }-    """ :: Number -> Number -> Number+  -- | The `BoundedLattice` type class represents types that are finite+  -- | lattices.+  -- |+  -- | Instances should satisfy the following law in addition to the `Lattice`+  -- | and `Bounded` laws:+  -- |+  -- | - Identity:+  -- |   - `a || bottom = a`+  -- |   - `a && top = a`+  -- | - Annihiliation:+  -- |   - `a || top = top`+  -- |   - `a && bottom = bottom`+  class (Bounded a, Lattice a) <= BoundedLattice a -  foreign import numOr-    """-    function numOr(n1) {-      return function(n2) {-        return n1 | n2;-      };-    }-    """ :: Number -> Number -> Number+  instance boundedLatticeBoolean :: BoundedLattice Boolean -  foreign import numXor-    """-    function numXor(n1) {-      return function(n2) {-        return n1 ^ n2;-      };-    }-    """ :: Number -> Number -> Number+  instance boundedLatticeUnit :: BoundedLattice Unit -  foreign import numComplement-    """-    function numComplement(n) {-      return ~n;-    }-    """ :: Number -> Number+  -- | The `ComplementedLattice` type class represents types that are lattices+  -- | where every member is also uniquely complemented.+  -- |+  -- | Instances should satisfy the following law in addition to the+  -- | `BoundedLattice` laws:+  -- |+  -- | - Complemented:+  -- |   - `not a || a == top`+  -- |   - `not a && a == bottom`+  -- | - Double negation:+  -- |   - `not <<< not == id`+  class (BoundedLattice a) <= ComplementedLattice a where+    not :: a -> a -  instance bitsNumber :: Bits Number where-    (.&.) = numAnd-    (.|.) = numOr-    (.^.) = numXor-    shl = numShl-    shr = numShr-    zshr = numZshr-    complement = numComplement+  instance complementedLatticeBoolean :: ComplementedLattice Boolean where+    not = boolNot -  infixr 2 ||-  infixr 3 &&+  instance complementedLatticeUnit :: ComplementedLattice Unit where+    not _ = unit -  -- | The `BoolLike` type class identifies types which support Boolean operations.+  -- | The `DistributiveLattice` type class represents types that are lattices+  -- | where the `&&` and `||` distribute over each other.   -- |-  -- | `BoolLike` instances are required to satisfy the laws of a _Boolean algebra_.+  -- | Instances should satisfy the following law in addition to the `Lattice`+  -- | laws:   -- |-  class BoolLike b where-    (&&) :: b -> b -> b-    (||) :: b -> b -> b-    not :: b -> b+  -- | - Distributivity: `x && (y || z) = (x && y) || (x && z)`+  class (Lattice a) <= DistributiveLattice a -  foreign import boolAnd-    """-    function boolAnd(b1) {-      return function(b2) {-        return b1 && b2;-      };-    }-    """  :: Boolean -> Boolean -> Boolean+  instance distributiveLatticeBoolean :: DistributiveLattice Boolean +  instance distributiveLatticeUnit :: DistributiveLattice Unit++  -- | The `BooleanAlgebra` type class represents types that are Boolean+  -- | algebras, also known as Boolean lattices.+  -- |+  -- | Instances should satisfy the `ComplementedLattice` and+  -- | `DistributiveLattice` laws.+  class (ComplementedLattice a, DistributiveLattice a) <= BooleanAlgebra a++  instance booleanAlgebraBoolean :: BooleanAlgebra Boolean++  instance booleanAlgebraUnit :: BooleanAlgebra Unit+   foreign import boolOr     """     function boolOr(b1) {@@ -816,6 +864,15 @@     }     """ :: Boolean -> Boolean -> Boolean +  foreign import boolAnd+    """+    function boolAnd(b1) {+      return function(b2) {+        return b1 && b2;+      };+    }+    """  :: Boolean -> Boolean -> Boolean+   foreign import boolNot     """     function boolNot(b) {@@ -823,46 +880,62 @@     }     """ :: Boolean -> Boolean -  instance boolLikeBoolean :: BoolLike Boolean where-    (&&) = boolAnd-    (||) = boolOr-    not = boolNot+  -- | The `Show` type class represents those types which can be converted into+  -- | a human-readable `String` representation.+  -- |+  -- | While not required, it is recommended that for any expression `x`, the+  -- | string `show x` be executable PureScript code which evaluates to the same+  -- | value as the expression `x`.+  class Show a where+    show :: a -> String -  infixr 5 <>+  instance showBoolean :: Show Boolean where+    show true = "true"+    show false = "false" -  -- | The `Semigroup` type class identifies an associative operation on a type.-  -- |-  -- | `Semigroup` instances are required to satisfy the following law:-  -- |-  -- | - Associativity: `(x <> y) <> z = x <> (y <> z)`-  -- |-  -- | For example, the `String` type is an instance of `Semigroup`, where `(<>)` is defined to be string concatenation.-  class Semigroup a where-    (<>) :: a -> a -> a+  instance showNumber :: Show Number where+    show = showNumberImpl -  foreign import concatString-    """-    function concatString(s1) {-      return function(s2) {-        return s1 + s2;-      };-    }-    """ :: String -> String -> String+  instance showString :: Show String where+    show = showStringImpl -  instance semigroupUnit :: Semigroup Unit where-    (<>) (Unit {}) (Unit {}) = Unit {}+  instance showUnit :: Show Unit where+    show _ = "unit" -  instance semigroupString :: Semigroup String where-    (<>) = concatString+  instance showArray :: (Show a) => Show [a] where+    show = showArrayImpl show -  instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where-    (<>) f g = \x -> f x <> g x+  instance showOrdering :: Show Ordering where+    show LT = "LT"+    show GT = "GT"+    show EQ = "EQ" -  infixr 5 +++  foreign import showNumberImpl+    """+    function showNumberImpl(n) {+      return n.toString();+    }+    """ :: Number -> String -  -- | `(++)` is an alias for `(<>)`.-  (++) :: forall s. (Semigroup s) => s -> s -> s-  (++) = (<>)+  foreign import showStringImpl+    """+    function showStringImpl(s) {+      return JSON.stringify(s);+    }+    """ :: String -> String++  foreign import showArrayImpl+    """+    function showArrayImpl(f) {+      return function(xs) {+        var ss = [];+        for (var i = 0, l = xs.length; i < l; i++) {+          ss[i] = f(xs[i]);+        }+        return '[' + ss.join(',') + ']';+      };+    }+    """ :: forall a. (a -> String) -> [a] -> String  module Data.Function where 

@@ -52,27 +52,29 @@   content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile   return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content) -newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }-  deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make))+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make)) -runMake :: P.Options P.Make -> Make a -> IO (Either String a)+runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors a) runMake opts = runExceptT . flip runReaderT opts . unMake -makeIO :: IO a -> Make a-makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a+makeIO f io = do+  e <- liftIO $ tryIOError io+  either (throwError . P.errorMessage . f) return e  instance P.MonadMake Make where-  getTimestamp path = makeIO $ do+  getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do     exists <- doesFileExist path     traverse (const $ getModificationTime path) $ guard exists-  readTextFile path = makeIO $ do+  readTextFile path = makeIO (const (P.CannotReadFile path))$ do     putStrLn $ "Reading " ++ path     readFile path-  writeTextFile path text = makeIO $ do+  writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do     mkdirp path     putStrLn $ "Writing " ++ path     writeFile path text-  progress = makeIO . putStrLn+  progress = liftIO . putStrLn  compile :: PSCMakeOptions -> IO () compile (PSCMakeOptions input outputDir opts usePrefix) = do@@ -84,8 +86,8 @@     Right ms -> do       e <- runMake opts $ P.make outputDir ms prefix       case e of-        Left err -> do-          putStrLn err+        Left errs -> do+          putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)           exitFailure         Right _ -> do           exitSuccess@@ -155,8 +157,8 @@                     <*> noMagicDo                     <*> pure Nothing                     <*> noOpts-                    <*> (not <$> comments)                     <*> verboseErrors+                    <*> (not <$> comments)                     <*> pure P.MakeOptions  pscMakeOptions :: Parser PSCMakeOptions

@@ -63,8 +63,8 @@       exitFailure     Right ms -> do       case P.compile (map snd ms) prefix `runReaderT` opts of-        Left err -> do-          hPutStrLn stderr err+        Left errs -> do+          hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)           exitFailure         Right (js, exts, _) -> do           case output of

@@ -1,78 +0,0 @@------------------------------------------------------------------------------------ Module      :  Commands--- Copyright   :  (c) Phil Freeman 2014--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Commands for PSCI.-----------------------------------------------------------------------------------module Commands where--import Language.PureScript---- |--- Valid Meta-commands for PSCI----data Command-  -- |-  -- A purescript expression-  ---  = Expression Expr-  -- |-  -- Show the help command-  ---  | Help-  -- |-  -- Import a module from a loaded file-  ---  | Import ImportedModule-  -- |-  -- Browse a module-  ---  | Browse ModuleName-  -- |-  -- Load a file for use with importing-  ---  | LoadFile FilePath-  -- |-  -- Exit PSCI-  ---  | Quit-  -- |-  -- Reset the state of the REPL-  ---  | Reset-  -- |-  -- Add some declarations to the current evaluation context.-  ---  | Decls [Declaration]-  -- |-  -- Find the type of an expression-  ---  | TypeOf Expr-  -- |-  -- Find the kind of an expression-  ---  | KindOf Type-  -- |-  -- Show command-  ---  | Show String---- | All of the data that is contained by an ImportDeclaration in the AST.--- That is:------ * A module name, the name of the module which is being imported--- * An ImportDeclarationType which specifies whether there is an explicit---   import list, a hiding list, or neither.--- * If the module is imported qualified, its qualified name in the importing---   module. Otherwise, Nothing.----type ImportedModule = (ModuleName, ImportDeclarationType, Maybe ModuleName)

@@ -0,0 +1,232 @@+module Completion where++import Data.Maybe (mapMaybe)+import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix)+import Data.Char (isUpper)+import Data.Function (on)+import Data.Traversable (traverse)++import Control.Applicative ((<$>), (<*>))+import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)+import Control.Monad.Trans.State.Strict++import System.Console.Haskeline++import qualified Language.PureScript as P+import qualified Language.PureScript.Names as N++import qualified Directive as D+import Types++-- Completions may read the state, but not modify it.+type CompletionM = ReaderT PSCiState IO++-- Lift a `CompletionM` action to a `StateT PSCiState IO` one.+liftCompletionM :: CompletionM a -> StateT PSCiState IO a+liftCompletionM act = StateT (\s -> (\a -> (a, s)) <$> runReaderT act s)++-- Haskeline completions++data CompletionContext+  = CtxDirective String+  | CtxFilePath String+  | CtxModule+  | CtxIdentifier+  | CtxType+  | CtxFixed String+  deriving (Show)++-- |+-- Loads module, function, and file completions.+--+completion :: CompletionFunc (StateT PSCiState IO)+completion = liftCompletionM . completion'++completion' :: CompletionFunc CompletionM+completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions++-- |+-- Decide what kind of completion we need based on input. This function expects+-- a list of complete words (to the left of the cursor) as the first argument,+-- and the current word as the second argument.+completionContext :: [String] -> String -> [CompletionContext]+completionContext [] _ = [CtxDirective "", CtxIdentifier, CtxFixed "import"]+completionContext ws w | headSatisfies (":" `isPrefixOf`) ws = completeDirective ws w+completionContext ws w | headSatisfies (== "import") ws = completeImport ws w+completionContext _ _ = [CtxIdentifier]++completeDirective :: [String] -> String -> [CompletionContext]+completeDirective ws w =+  case ws of+    []    -> [CtxDirective w]+    [dir] -> case D.directivesFor <$> stripPrefix ":" dir of+                -- only offer completions if the directive is unambiguous+                Just [dir'] -> directiveArg w dir'+                _           -> []++    -- All directives take exactly one argument. If we haven't yet matched,+    -- that means one argument has already been supplied. So don't complete+    -- any others.+    _     -> []++directiveArg :: String -> Directive -> [CompletionContext]+directiveArg _ Browse = [CtxModule]+directiveArg w Load   = [CtxFilePath w]+directiveArg _ Quit   = []+directiveArg _ Reset  = []+directiveArg _ Help   = []+directiveArg _ Show   = map CtxFixed replQueryStrings+directiveArg _ Type   = [CtxIdentifier]+directiveArg _ Kind   = [CtxType]++completeImport :: [String] -> String -> [CompletionContext]+completeImport ws w' =+  case (ws, w') of+    (["import"], w) | headSatisfies isUpper w -> [CtxModule]+    (["import"], _)                           -> [CtxModule, CtxFixed "qualified"]+    (["import", "qualified"], _)              -> [CtxModule]+    _                                         -> []++headSatisfies :: (a -> Bool) -> [a] -> Bool+headSatisfies p str =+  case str of+    (c:_)  -> p c+    _     -> False++-- | Callback for Haskeline's `completeWordWithPrev`.+-- Expects:+--   * Line contents to the left of the word, reversed+--   * Word to be completed+findCompletions :: String -> String -> CompletionM [Completion]+findCompletions prev word = do+  let ctx = completionContext (words (reverse prev)) word+  completions <- concat <$> traverse getCompletions ctx+  return $ sortBy directivesFirst completions+  where+  getCompletions :: CompletionContext -> CompletionM [Completion]+  getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion++  prefixedBy :: String -> String -> Maybe Completion+  prefixedBy w cand = if w `isPrefixOf` cand+                        then Just (simpleCompletion cand)+                        else Nothing++getCompletion :: CompletionContext -> CompletionM [Either String Completion]+getCompletion ctx =+  case ctx of+    CtxFilePath f        -> map Right <$> listFiles f+    CtxModule            -> map Left <$> getModuleNames+    CtxIdentifier        -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames)+    CtxType              -> map Left <$> getTypeNames+    CtxFixed str         -> return [Left str]+    CtxDirective d       -> return (map Left (completeDirectives d))++  where+  completeDirectives :: String -> [String]+  completeDirectives = map (':' :) . D.directiveStringsFor+++getLoadedModules :: CompletionM [P.Module]+getLoadedModules = asks (map snd . psciLoadedModules)++getImportedModules :: CompletionM [ImportedModule]+getImportedModules = asks psciImportedModules++getModuleNames :: CompletionM [String]+getModuleNames = moduleNames <$> getLoadedModules++mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]+mapLoadedModulesAndQualify f = do+  ms <- getLoadedModules+  let argPairs = do m <- ms+                    fm <- f m+                    return (m, fm)+  concat <$> traverse (uncurry getAllQualifications) argPairs++getIdentNames :: CompletionM [String]+getIdentNames = mapLoadedModulesAndQualify identNames++getDctorNames :: CompletionM [String]+getDctorNames = mapLoadedModulesAndQualify dctorNames++getTypeNames :: CompletionM [String]+getTypeNames = mapLoadedModulesAndQualify typeDecls++-- | Given a module and a declaration in that module, return all possible ways+-- it could have been referenced given the current PSCiState - including fully+-- qualified, qualified using an alias, and unqualified.+getAllQualifications :: (Show a) => P.Module -> (a, P.Declaration) -> CompletionM [String]+getAllQualifications m (declName, decl) = do+  imports <- getAllImportsOf m+  let fullyQualified = qualifyWith (Just (P.getModuleName m))+  let otherQuals = nub (concatMap qualificationsUsing imports)+  return $ fullyQualified : otherQuals+  where+  qualifyWith mMod = show (P.Qualified mMod declName)+  referencedBy refs = P.isExported (Just refs) decl++  qualificationsUsing (_, importType, asQ') =+    let q = qualifyWith asQ'+    in case importType of+          P.Implicit      -> [q]+          P.Explicit refs -> if referencedBy refs+                               then [q]+                               else []+          P.Hiding refs   -> if referencedBy refs+                               then []+                               else [q]+++-- | Returns all the ImportedModule values referring to imports of a particular+-- module.+getAllImportsOf :: P.Module -> CompletionM [ImportedModule]+getAllImportsOf = asks . allImportsOf++nubOnFst :: Eq a => [(a, b)] -> [(a, b)]+nubOnFst = nubBy ((==) `on` fst)++typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]+typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations+  where+  getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)+  getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)+  getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)+  getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d+  getTypeName _ = Nothing++identNames :: P.Module -> [(N.Ident, P.Declaration)]+identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations+  where+  getDeclName :: P.Declaration -> Maybe (P.Ident, P.Declaration)+  getDeclName d@(P.ValueDeclaration ident _ _ _)  = Just (ident, d)+  getDeclName d@(P.ExternDeclaration _ ident _ _) = Just (ident, d)+  getDeclName (P.PositionedDeclaration _ _ d) = getDeclName d+  getDeclName _ = Nothing++dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]+dctorNames m = nubOnFst $ concatMap dctors dnames+  where+  getDataDeclName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)+  getDataDeclName d@(P.DataDeclaration _ name _ _) = Just (name, d)+  getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d+  getDataDeclName _ = Nothing++  dnames :: [(N.ProperName, P.Declaration)]+  dnames = (mapMaybe getDataDeclName onlyDataDecls)++  onlyDataDecls :: [P.Declaration]+  onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))++  dctors :: (N.ProperName, P.Declaration) -> [(N.ProperName, P.Declaration)]+  dctors (name, decl) = map (\n -> (n, decl)) (map fst (P.exportedDctors m name))++moduleNames :: [P.Module] -> [String]+moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]++directivesFirst :: Completion -> Completion -> Ordering+directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2+  where+  go (':' : xs) (':' : ys) = compare xs ys+  go (':' : _) _ = LT+  go _ (':' : _) = GT+  go xs ys = compare xs ys

@@ -15,65 +15,99 @@  module Directive where -import Data.List (nub, isPrefixOf)+import Data.Maybe (fromJust, listToMaybe)+import Data.List (isPrefixOf)+import Data.Tuple (swap) -data Directive-  = Help-  | Quit-  | Reset-  | Browse-  | Load-  | Type-  | Kind-  | Show-  deriving Eq+import Types  -- |--- Maps given directive to relating command strings.+-- List of all avaliable directives. ---commands :: Directive -> [String]-commands Help = ["?", "help"]-commands Quit = ["quit"]-commands Reset = ["reset"]-commands Browse = ["browse"]-commands Load = ["load", "module"]-commands Type = ["type"]-commands Kind = ["kind"]-commands Show = ["show"]+directives :: [Directive]+directives = map fst directiveStrings  -- |--- Tries to parse given string into a directive.+-- A mapping of directives to the different strings that can be used to invoke+-- them. ---parseDirective :: String -> Maybe Directive-parseDirective cmd =-  case filter (matches . snd) mapping of-    [directive] -> Just $ fst directive-    _ -> Nothing+directiveStrings :: [(Directive, [String])]+directiveStrings =+    [ (Help   , ["?", "help"])+    , (Quit   , ["quit"])+    , (Reset  , ["reset"])+    , (Browse , ["browse"])+    , (Load   , ["load", "module"])+    , (Type   , ["type"])+    , (Kind   , ["kind"])+    , (Show   , ["show"])+    ]++-- |+-- Like directiveStrings, but the other way around.+--+directiveStrings' :: [(String, Directive)]+directiveStrings' = concatMap go directiveStrings   where-  mapping :: [(Directive, [String])]-  mapping = zip directives (map commands directives)+  go (dir, strs) = map (\s -> (s, dir)) strs -  matches :: [String] -> Bool-  matches = any (cmd `isPrefixOf`)+-- |+-- List of all directive strings.+--+strings :: [String]+strings = concatMap snd directiveStrings  -- |+-- Returns all possible string representations of a directive.+--+stringsFor :: Directive -> [String]+stringsFor d = fromJust (lookup d directiveStrings)++-- |+-- Returns the default string representation of a directive.+--+stringFor :: Directive -> String+stringFor = head . stringsFor++-- |+-- Returns the list of directives which could be expanded from the string+-- argument, together with the string alias that matched.+--+directivesFor' :: String -> [(Directive, String)]+directivesFor' str = go directiveStrings'+  where+  go = map swap . filter ((str `isPrefixOf`) . fst)++directivesFor :: String -> [Directive]+directivesFor = map fst . directivesFor'++directiveStringsFor :: String -> [String]+directiveStringsFor = map snd . directivesFor'++parseDirective :: String -> Maybe Directive+parseDirective = listToMaybe . directivesFor++-- |+-- True if the given directive takes an argument, false otherwise.+hasArgument :: Directive -> Bool+hasArgument Help = False+hasArgument Quit = False+hasArgument Reset = False+hasArgument _ = True++-- | -- The help menu. -- help :: [(Directive, String, String)] help =   [ (Help,   "",         "Show this help menu")   , (Quit,   "",         "Quit PSCi")-  , (Reset,  "",         "Reset")-  , (Browse, "<module>", "Browse <module>")+  , (Reset,  "",         "Discard all imported modules and declared bindings")+  , (Browse, "<module>", "See all functions in <module>")   , (Load,   "<file>",   "Load <file> for importing")   , (Type,   "<expr>",   "Show the type of <expr>")   , (Kind,   "<type>",   "Show the kind of <type>")-  , (Show,   "import",   "Show imported modules")-  , (Show,   "loaded",   "Show loaded modules")+  , (Show,   "import",   "Show all imported modules")+  , (Show,   "loaded",   "Show all loaded modules")   ] --- |--- List of all avaliable directives.----directives :: [Directive]-directives = nub . map (\(dir, _, _) -> dir) $ help

@@ -1,702 +0,0 @@------------------------------------------------------------------------------------ Module      :  Main--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- PureScript Compiler Interactive.-----------------------------------------------------------------------------------{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}--module Main where--import Data.Foldable (traverse_)-import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)-import Data.Maybe (mapMaybe)-import Data.Traversable (traverse)-import Data.Version (showVersion)-import Data.Char (isSpace)-import qualified Data.Map as M--import Control.Applicative-import Control.Monad-import Control.Monad.Except (ExceptT(..), MonadError, runExceptT)-import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)-import Control.Monad.Trans.Class-import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)-import Control.Monad.Trans.State.Strict-import qualified Control.Monad.Trans.State.Lazy as L--import Options.Applicative as Opts--import System.Console.Haskeline-import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)-import System.Exit-import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)-import System.IO.Error (tryIOError)-import System.Process (readProcessWithExitCode)--import qualified Text.Parsec as Par (ParseError)--import qualified Language.PureScript as P-import qualified Language.PureScript.AST as D-import qualified Language.PureScript.Names as N-import qualified Paths_purescript as Paths--import qualified Commands as C-import qualified Directive as D-import Parser--data PSCiOptions = PSCiOptions-  { psciMultiLineMode  :: Bool-  , psciInputFile      :: [FilePath]-  , psciInputNodeFlags :: [String]-  }---- |--- The PSCI state.--- Holds a list of imported modules, loaded files, and partial let bindings.--- The let bindings are partial,--- because it makes more sense to apply the binding to the final evaluated expression.----data PSCiState = PSCiState-  { psciImportedFilenames   :: [FilePath]-  , psciImportedModules     :: [C.ImportedModule]-  , psciLoadedModules       :: [(Either P.RebuildPolicy FilePath, P.Module)]-  , psciLetBindings         :: [P.Declaration]-  , psciNodeFlags           :: [String]-  }--psciImportedModuleNames :: PSCiState -> [P.ModuleName]-psciImportedModuleNames (PSCiState{psciImportedModules = is}) =-  map (\(mn, _, _) -> mn) is---- State helpers---- |--- Updates the state to have more imported modules.----updateImportedFiles :: FilePath -> PSCiState -> PSCiState-updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }---- |--- Updates the state to have more imported modules.----updateImportedModules :: C.ImportedModule -> PSCiState -> PSCiState-updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }---- |--- Updates the state to have more loaded files.----updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState-updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }---- |--- Updates the state to have more let bindings.----updateLets :: [P.Declaration] -> PSCiState -> PSCiState-updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }---- File helpers--- |--- Load the necessary modules.----defaultImports :: [C.ImportedModule]-defaultImports = [(P.ModuleName [P.ProperName "Prelude"], D.Implicit, Nothing)]---- |--- Locates the node executable.--- Checks for either @nodejs@ or @node@.----findNodeProcess :: IO (Maybe String)-findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names-  where names = ["nodejs", "node"]---- |--- Grabs the filename where the history is stored.----getHistoryFilename :: IO FilePath-getHistoryFilename = do-  home <- getHomeDirectory-  let filename = home </> ".purescript" </> "psci_history"-  mkdirp filename-  return filename---- |--- Loads a file for use with imports.----loadModule :: FilePath -> IO (Either String [P.Module])-loadModule filename = do-  content <- readFile filename-  return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]---- |--- Load all modules, including the Prelude----loadAllModules :: [FilePath] -> IO (Either Par.ParseError [(Either P.RebuildPolicy FilePath, P.Module)])-loadAllModules files = do-  filesAndContent <- forM files $ \filename -> do-    content <- readFile filename-    return (Right filename, content)-  return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent---- |--- Load all modules, updating the application state----loadAllImportedModules :: PSCI ()-loadAllImportedModules = do-  files <- PSCI . lift $ fmap psciImportedFilenames get-  modulesOrFirstError <- psciIO $ loadAllModules files-  case modulesOrFirstError of-    Left err -> psciIO $ print err-    Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }---- |--- Expands tilde in path.----expandTilde :: FilePath -> IO FilePath-expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory-expandTilde p = return p--- Messages---- |--- The help message.----helpMessage :: String-helpMessage = "The following commands are available:\n\n    " ++-  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.----prologueMessage :: String-prologueMessage = intercalate "\n"-  [ " ____                 ____            _       _   "-  , "|  _ \\ _   _ _ __ ___/ ___|  ___ _ __(_)_ __ | |_ "-  , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"-  , "|  __/| |_| | | |  __/___) | (__| |  | | |_) | |_ "-  , "|_|    \\__,_|_|  \\___|____/ \\___|_|  |_| .__/ \\__|"-  , "                                       |_|        "-  , ""-  , ":? shows help"-  ]---- |--- The quit message.----quitMessage :: String-quitMessage = "See ya!"---- Haskeline completions--data CompletionContext = Command String | FilePath String | Module | Identifier-                       | Type | Fixed [String] | Multiple [CompletionContext]-                         deriving (Show)---- |--- Decide what kind of completion we need based on input.-completionContext :: String -> String -> Maybe CompletionContext-completionContext cmd@"" _ = Just $ Multiple [Command cmd, Identifier]-completionContext (':' : cmd) word =-  case D.parseDirective dstr of-    Just directive | dstr `elem` D.commands directive -> context directive-    _ -> Just $ Command cmd-  where-  dstr :: String-  dstr = takeWhile (not . isSpace) cmd--  context :: D.Directive -> Maybe CompletionContext-  context D.Browse = Just Module-  context D.Load = Just $ FilePath word-  context D.Quit = Nothing-  context D.Reset = Nothing-  context D.Help = Nothing-  context D.Show = Just $ Fixed ["import", "loaded"]-  context D.Type = Just Identifier-  context D.Kind = Just Type-completionContext _ _ = Just Identifier---- |--- Loads module, function, and file completions.----completion :: CompletionFunc (StateT PSCiState IO)-completion = completeWordWithPrev Nothing " \t\n\r" findCompletions-  where-  findCompletions :: String -> String -> StateT PSCiState IO [Completion]-  findCompletions prev word = do-    let ctx = completionContext ((dropWhile isSpace (reverse prev)) ++ word) word-    completions <- case ctx of-      Nothing -> return []-      (Just c) -> (mapMaybe $ either (\cand -> if word `isPrefixOf` cand-                                               then Just $ simpleCompletion cand-                                               else Nothing) Just)-                  <$> getCompletion c-    return $ sortBy sorter completions--  getCompletion :: CompletionContext -> StateT PSCiState IO [Either String Completion]-  getCompletion (FilePath f) = (map Right) <$> listFiles f-  getCompletion Module = (map Left) <$> getModuleNames-  getCompletion Identifier = (map Left) <$> ((++) <$> getIdentNames <*> getDctorNames)-  getCompletion Type = (map Left) <$> getTypeNames-  getCompletion (Fixed list) = return $ (map Left) list-  getCompletion (Multiple contexts) = concat <$> mapM getCompletion contexts-  getCompletion (Command cmd) = return . map (Left . (":" ++)) . nub $ matching-    where-    matching :: [String]-    matching = filter (isPrefixOf cmd) . concatMap (D.commands) $ D.directives--  getLoadedModules :: StateT PSCiState IO [P.Module]-  getLoadedModules = map snd . psciLoadedModules <$> get--  getModuleNames :: StateT PSCiState IO [String]-  getModuleNames = moduleNames <$> getLoadedModules--  mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [a]) -> StateT PSCiState IO [String]-  mapLoadedModulesAndQualify f = do-    ms <- getLoadedModules-    q <- sequence [qualifyIfNeeded m (f m) | m <- ms]-    return $ concat q--  getIdentNames :: StateT PSCiState IO [String]-  getIdentNames = mapLoadedModulesAndQualify identNames--  getDctorNames :: StateT PSCiState IO [String]-  getDctorNames = mapLoadedModulesAndQualify dctorNames--  getTypeNames :: StateT PSCiState IO [String]-  getTypeNames = mapLoadedModulesAndQualify typeDecls--  qualifyIfNeeded :: (Show a) => P.Module -> [a] -> StateT PSCiState IO [String]-  qualifyIfNeeded m decls = do-    let name = P.getModuleName m-    imported <- psciImportedModuleNames <$> get-    let qualified = map (P.Qualified $ Just name) decls-    if name `elem` imported then-        return $ map show $ qualified ++ (map (P.Qualified Nothing) decls)-    else-        return $ map show qualified--  typeDecls :: P.Module -> [N.ProperName]-  typeDecls m = mapMaybe getTypeName $ filter P.isDataDecl (P.exportedDeclarations m)-      where getTypeName :: P.Declaration -> Maybe N.ProperName-            getTypeName (P.TypeSynonymDeclaration name _ _) = Just name-            getTypeName (P.DataDeclaration _ name _ _) = Just name-            getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d-            getTypeName _ = Nothing--  identNames :: P.Module -> [N.Ident]-  identNames (P.Module _ _ ds exports) = nub [ ident | ident <- mapMaybe (getDeclName exports) (D.flattenDecls ds) ]-    where getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident-          getDeclName exts decl@(P.ValueDeclaration ident _ _ _)  | P.isExported exts decl = Just ident-          getDeclName exts decl@(P.ExternDeclaration _ ident _ _) | P.isExported exts decl = Just ident-          getDeclName exts (P.PositionedDeclaration _ _ d) = getDeclName exts d-          getDeclName _ _ = Nothing--  dctorNames :: P.Module -> [N.ProperName]-  dctorNames m = nub $ concat $ map (P.exportedDctors m) dnames-    where getDataDeclName :: P.Declaration -> Maybe N.ProperName-          getDataDeclName (P.DataDeclaration _ name _ _) = Just name-          getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d-          getDataDeclName _ = Nothing--          dnames :: [N.ProperName]-          dnames = (mapMaybe getDataDeclName onlyDataDecls)--          onlyDataDecls :: [P.Declaration]-          onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))--  moduleNames :: [P.Module] -> [String]-  moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]--  sorter :: Completion -> Completion -> Ordering-  sorter (Completion _ d1 _) (Completion _ d2 _) = if ":" `isPrefixOf` d1 then LT else compare d1 d2---- Compilation---- | Compilation options.----options :: P.Options P.Make-options = P.Options False False False Nothing False False False P.MakeOptions---- |--- PSCI monad----newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)--psciIO :: IO a -> PSCI a-psciIO io = PSCI . lift $ lift io--newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }-  deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))--runMake :: Make a -> IO (Either String a)-runMake = runExceptT . flip runReaderT options . unMake--makeIO :: IO a -> Make a-makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError--instance P.MonadMake Make where-  getTimestamp path = makeIO $ do-    exists <- doesFileExist path-    traverse (const $ getModificationTime path) $ guard exists-  readTextFile path = makeIO $ readFile path-  writeTextFile path text = makeIO $ do-    mkdirp path-    writeFile path text-  progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s--mkdirp :: FilePath -> IO ()-mkdirp = createDirectoryIfMissing True . takeDirectory---- |--- Makes a volatile module to execute the current expression.----createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module-createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =-  let-    moduleName = P.ModuleName [P.ProperName "$PSCI"]-    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")))-    itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right val-    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----- |--- 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{psciImportedModules = imports} typ =-  let-    moduleName = P.ModuleName [P.ProperName "$PSCI"]-    itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ-  in-    P.Module [] moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing---- |--- Makes a volatile module to execute the current imports.----createTemporaryModuleForImports :: PSCiState -> P.Module-createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =-  let-    moduleName = P.ModuleName [P.ProperName "$PSCI"]-  in-    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"--indexFile :: FilePath-indexFile = ".psci_modules" ++ pathSeparator : "index.js"---- |--- Takes a value declaration and evaluates it with the current state.----handleDeclaration :: P.Expr -> PSCI ()-handleDeclaration val = do-  st <- PSCI $ lift get-  let m = createTemporaryModule True st val-  let nodeArgs = psciNodeFlags st ++ [indexFile]-  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []-  case e of-    Left err -> PSCI $ outputStrLn err-    Right _ -> do-      psciIO $ writeFile indexFile "require('$PSCI').main();"-      process <- psciIO findNodeProcess-      result  <- psciIO $ traverse (\node -> readProcessWithExitCode node 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 list of declarations and updates the environment, then run a make. If the declaration fails,--- restore the original environment.----handleDecls :: [P.Declaration] -> PSCI ()-handleDecls ds = do-  st <- PSCI $ lift get-  let st' = updateLets ds st-  let m = createTemporaryModule False st' (P.ObjectLiteral [])-  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []-  case e of-    Left err -> PSCI $ outputStrLn err-    Right _ -> PSCI $ lift (put st')---- |--- Show actual loaded modules in psci.----handleShowLoadedModules :: PSCI ()-handleShowLoadedModules = do-  PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get-  psciIO $ readModules loadedModules >>= putStrLn-  return ()-  where readModules = return . unlines . sort . nub . map toModuleName-        toModuleName =  N.runModuleName . (\ (D.Module _ mdName _ _) -> mdName) . snd---- |--- Show the imported modules in psci.----handleShowImportedModules :: PSCI ()-handleShowImportedModules = do-  PSCiState { psciImportedModules = importedModules } <- PSCI $ lift get-  psciIO $ showModules importedModules >>= putStrLn-  return ()-  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 :: C.ImportedModule -> PSCI ()-handleImport im = do-   st <- updateImportedModules im <$> PSCI (lift get)-   let m = createTemporaryModuleForImports st-   e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []-   case e of-     Left err -> PSCI $ outputStrLn err-     Right _  -> do-       PSCI $ lift $ put st-       return ()---- |--- Takes a value and prints its type----handleTypeOf :: P.Expr -> PSCI ()-handleTypeOf val = do-  st <- PSCI $ lift get-  let m = createTemporaryModule False st val-  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []-  case e of-    Left err -> PSCI $ outputStrLn err-    Right env' ->-      case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of-        Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty-        Nothing -> PSCI $ outputStrLn "Could not find type"---- |--- Pretty print a module's signatures----printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()-printModuleSignatures moduleName env =-  PSCI $ let namesEnv = P.names env-             moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv-             in case moduleNamesIdent of-                  [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."-                  _ -> ( outputStrLn-                       . unlines-                       . sort-                       . map (showType . findType namesEnv)) moduleNamesIdent-  where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))-        findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)-        showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String-        showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType-        showType _ = error "The impossible happened in printModuleSignatures."---- |--- Browse a module and displays its signature (if module exists).----handleBrowse :: P.ModuleName -> PSCI ()-handleBrowse moduleName = do-  st <- PSCI $ lift get-  let loadedModules = psciLoadedModules st-  env <- psciIO . runMake $ P.make modulesDir loadedModules []-  case env of-    Left err -> PSCI $ outputStrLn err-    Right env' ->-      if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules-        then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."-        else printModuleSignatures moduleName env'---- |--- Takes a value and prints its kind----handleKindOf :: P.Type -> PSCI ()-handleKindOf typ = do-  st <- PSCI $ lift get-  let m = createTemporaryModuleForKind st typ-      mName = P.ModuleName [P.ProperName "$PSCI"]-  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []-  case e of-    Left err -> PSCI $ outputStrLn err-    Right env' ->-      case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of-        Just (_, typ') -> do-          let chk = P.CheckState env' 0 0 (Just mName)-              k   = L.runStateT (P.unCheck (P.kindOf mName typ')) chk-          case k of-            Left errStack   -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack-            Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind-        Nothing -> PSCI $ outputStrLn "Could not find kind"---- Commands---- |--- Parses the input and returns either a Metacommand or an expression.----getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe C.Command))-getCommand singleLineMode = do-  firstLine <- getInputLine "> "-  case firstLine of-    Nothing -> return (Right Nothing)-    Just "" -> return (Right Nothing)-    Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s-    Just s -> either Left (Right . Just) . parseCommand <$> go [s]-  where-    go :: [String] -> InputT (StateT PSCiState IO) String-    go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine "  "---- |--- Performs an action for each meta-command given, and also for expressions..----handleCommand :: C.Command -> PSCI ()-handleCommand (C.Expression val) = handleDeclaration val-handleCommand C.Help = PSCI $ outputStrLn helpMessage-handleCommand (C.Import im) = handleImport im-handleCommand (C.Decls l) = handleDecls l-handleCommand (C.LoadFile filePath) = do-  absPath <- psciIO $ expandTilde filePath-  exists <- psciIO $ doesFileExist absPath-  if exists then do-    PSCI . lift $ modify (updateImportedFiles absPath)-    m <- psciIO $ loadModule absPath-    case m of-      Left err -> PSCI $ outputStrLn err-      Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))-  else-    PSCI . outputStrLn $ "Couldn't locate: " ++ filePath-handleCommand C.Reset = do-  files <- psciImportedFilenames <$> PSCI (lift get)-  PSCI . lift . modify $ \st -> st-    { psciImportedFilenames   = files-    , psciImportedModules     = defaultImports-    , psciLetBindings         = []-    }-  loadAllImportedModules-handleCommand (C.TypeOf val) = handleTypeOf val-handleCommand (C.KindOf typ) = handleKindOf typ-handleCommand (C.Browse moduleName) = handleBrowse moduleName-handleCommand (C.Show "loaded") = handleShowLoadedModules-handleCommand (C.Show "import") = handleShowImportedModules-handleCommand _ = PSCI $ outputStrLn "Unknown command"--loadUserConfig :: IO (Maybe [C.Command])-loadUserConfig = do-  configFile <- (</> ".psci") <$> getCurrentDirectory-  exists <- doesFileExist configFile-  if exists-  then do-    ls <- lines <$> readFile configFile-    case mapM parseCommand ls of-      Left err -> print err >> exitFailure-      Right cs -> return $ Just cs-  else-    return Nothing---- |--- The PSCI main loop.----loop :: PSCiOptions -> IO ()-loop PSCiOptions{..} = do-  config <- loadUserConfig-  modulesOrFirstError <- loadAllModules psciInputFile-  case modulesOrFirstError of-    Left err -> print err >> exitFailure-    Right modules -> do-      historyFilename <- getHistoryFilename-      let settings = defaultSettings { historyFile = Just historyFilename }-      flip evalStateT (PSCiState psciInputFile defaultImports modules [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do-        outputStrLn prologueMessage-        traverse_ (mapM_ (runPSCI . handleCommand)) config-        go-      where-        go :: InputT (StateT PSCiState IO) ()-        go = do-          c <- getCommand (not psciMultiLineMode)-          case c of-            Left err -> outputStrLn err >> go-            Right Nothing -> go-            Right (Just C.Quit) -> outputStrLn quitMessage-            Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go--multiLineMode :: Parser Bool-multiLineMode = switch $-     long "multi-line-mode"-  <> short 'm'-  <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"--inputFile :: Parser FilePath-inputFile = strArgument $-     metavar "FILE"-  <> Opts.help "Optional .purs files to load on start"--nodeFlagsFlag :: Parser [String]-nodeFlagsFlag = option parser $-     long "node-opts"-  <> metavar "NODE_OPTS"-  <> value []-  <> Opts.help "Flags to pass to node, separated by spaces"-  where-    parser = words <$> str--psciOptions :: Parser PSCiOptions-psciOptions = PSCiOptions <$> multiLineMode-                          <*> many inputFile-                          <*> nodeFlagsFlag--main :: IO ()-main = execParser opts >>= loop-  where-  opts        = info (version <*> helper <*> psciOptions) infoModList-  infoModList = fullDesc <> headerInfo <> footerInfo-  headerInfo  = header   "psci - Interactive mode for PureScript"-  footerInfo  = footer $ "psci " ++ showVersion Paths.version--  version :: Parser (a -> a)-  version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden

@@ -0,0 +1,543 @@+-----------------------------------------------------------------------------+--+-- Module      :  PSCi+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- PureScript Compiler Interactive.+--+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++module PSCi where++import Data.Foldable (traverse_)+import Data.List (intercalate, nub, sort)+import Data.Traversable (traverse)+import Data.Version (showVersion)+import qualified Data.Map as M++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Error.Class (throwError)+import Control.Monad.Except (ExceptT(..), MonadError, runExceptT)+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.Trans.State.Strict+import qualified Control.Monad.Trans.State.Lazy as L++import Options.Applicative as Opts++import System.Console.Haskeline+import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)+import System.Exit+import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)+import System.IO.Error (tryIOError)+import System.Process (readProcessWithExitCode)++import qualified Text.Parsec as Par (ParseError)++import qualified Language.PureScript as P+import qualified Language.PureScript.Names as N+import qualified Paths_purescript as Paths++import qualified Directive as D+import Parser (parseCommand)+import Completion (completion)+import Types+++-- File helpers+-- |+-- Load the necessary modules.+--+defaultImports :: [ImportedModule]+defaultImports = [(P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]++-- |+-- Locates the node executable.+-- Checks for either @nodejs@ or @node@.+--+findNodeProcess :: IO (Maybe String)+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names+  where names = ["nodejs", "node"]++-- |+-- Grabs the filename where the history is stored.+--+getHistoryFilename :: IO FilePath+getHistoryFilename = do+  home <- getHomeDirectory+  let filename = home </> ".purescript" </> "psci_history"+  mkdirp filename+  return filename++-- |+-- Loads a file for use with imports.+--+loadModule :: FilePath -> IO (Either String [P.Module])+loadModule filename = do+  content <- readFile filename+  return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]++-- |+-- Load all modules, including the Prelude+--+loadAllModules :: [FilePath] -> IO (Either Par.ParseError [(Either P.RebuildPolicy FilePath, P.Module)])+loadAllModules files = do+  filesAndContent <- forM files $ \filename -> do+    content <- readFile filename+    return (Right filename, content)+  return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent++-- |+-- Load all modules, updating the application state+--+loadAllImportedModules :: PSCI ()+loadAllImportedModules = do+  files <- PSCI . lift $ fmap psciImportedFilenames get+  modulesOrFirstError <- psciIO $ loadAllModules files+  case modulesOrFirstError of+    Left err -> psciIO $ print err+    Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }++-- |+-- Expands tilde in path.+--+expandTilde :: FilePath -> IO FilePath+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory+expandTilde p = return p+-- Messages++-- |+-- The help message.+--+helpMessage :: String+helpMessage = "The following commands are available:\n\n    " +++  intercalate "\n    " (map line D.help) +++  "\n\n" ++ extraHelp+  where+  line :: (Directive, String, String) -> String+  line (dir, arg, desc) =+    let cmd = ':' : D.stringFor dir+    in intercalate " "+        [ cmd+        , replicate (11 - length cmd) ' '+        , arg+        , replicate (11 - length arg) ' '+        , desc+        ]++  extraHelp =+    "Further information is available on the PureScript wiki:\n" +++    " --> https://github.com/purescript/purescript/wiki/psci"+++-- |+-- The welcome prologue.+--+prologueMessage :: String+prologueMessage = intercalate "\n"+  [ " ____                 ____            _       _   "+  , "|  _ \\ _   _ _ __ ___/ ___|  ___ _ __(_)_ __ | |_ "+  , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"+  , "|  __/| |_| | | |  __/___) | (__| |  | | |_) | |_ "+  , "|_|    \\__,_|_|  \\___|____/ \\___|_|  |_| .__/ \\__|"+  , "                                       |_|        "+  , ""+  , ":? shows help"+  ]++-- |+-- The quit message.+--+quitMessage :: String+quitMessage = "See ya!"+++-- Compilation++-- | Compilation options.+--+options :: P.Options P.Make+options = P.Options False False False Nothing False False False P.MakeOptions++-- |+-- PSCI monad+--+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)++psciIO :: IO a -> PSCI a+psciIO io = PSCI . lift $ lift io++newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make))++runMake :: Make a -> IO (Either P.MultipleErrors a)+runMake = runExceptT . flip runReaderT options . unMake++makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a+makeIO f io = do+  e <- liftIO $ tryIOError io+  either (throwError . P.errorMessage . f) return e++instance P.MonadMake Make where+  getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do+    exists <- doesFileExist path+    traverse (const $ getModificationTime path) $ guard exists+  readTextFile path = makeIO (const (P.CannotReadFile path)) $ readFile path+  writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do+    mkdirp path+    writeFile path text+  progress s = unless (s == "Compiling $PSCI") $ liftIO . putStrLn $ s++mkdirp :: FilePath -> IO ()+mkdirp = createDirectoryIfMissing True . takeDirectory++-- |+-- Makes a volatile module to execute the current expression.+--+createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module+createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =+  let+    moduleName = P.ModuleName [P.ProperName "$PSCI"]+    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")))+    itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right val+    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+++-- |+-- 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{psciImportedModules = imports} typ =+  let+    moduleName = P.ModuleName [P.ProperName "$PSCI"]+    itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ+  in+    P.Module [] moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing++-- |+-- Makes a volatile module to execute the current imports.+--+createTemporaryModuleForImports :: PSCiState -> P.Module+createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =+  let+    moduleName = P.ModuleName [P.ProperName "$PSCI"]+  in+    P.Module [] moduleName (importDecl `map` imports) Nothing++importDecl :: ImportedModule -> P.Declaration+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ++modulesDir :: FilePath+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"++indexFile :: FilePath+indexFile = ".psci_modules" ++ pathSeparator : "index.js"++-- |+-- Takes a value declaration and evaluates it with the current state.+--+handleDeclaration :: P.Expr -> PSCI ()+handleDeclaration val = do+  st <- PSCI $ lift get+  let m = createTemporaryModule True st val+  let nodeArgs = psciNodeFlags st ++ [indexFile]+  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []+  case e of+    Left errs -> printErrors errs+    Right _ -> do+      psciIO $ writeFile indexFile "require('$PSCI').main();"+      process <- psciIO findNodeProcess+      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 list of declarations and updates the environment, then run a make. If the declaration fails,+-- restore the original environment.+--+handleDecls :: [P.Declaration] -> PSCI ()+handleDecls ds = do+  st <- PSCI $ lift get+  let st' = updateLets ds st+  let m = createTemporaryModule False st' (P.ObjectLiteral [])+  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []+  case e of+    Left err -> printErrors err+    Right _ -> PSCI $ lift (put st')++-- |+-- Show actual loaded modules in psci.+--+handleShowLoadedModules :: PSCI ()+handleShowLoadedModules = do+  PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get+  psciIO $ readModules loadedModules >>= putStrLn+  return ()+  where readModules = return . unlines . sort . nub . map toModuleName+        toModuleName =  N.runModuleName . (\ (P.Module _ mdName _ _) -> mdName) . snd++-- |+-- Show the imported modules in psci.+--+handleShowImportedModules :: PSCI ()+handleShowImportedModules = do+  PSCiState { psciImportedModules = importedModules } <- PSCI $ lift get+  psciIO $ showModules importedModules >>= putStrLn+  return ()+  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 P.Implicit = ""+  showDeclType (P.Explicit refs) = refsList refs+  showDeclType (P.Hiding refs) = "hiding " ++ refsList refs+  refsList refs = "(" ++ commaList (map showRef refs) ++ ")"++  showRef :: P.DeclarationRef -> String+  showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"+  showRef (P.ValueRef ident) = show ident+  showRef (P.TypeClassRef pn) = show pn+  showRef (P.TypeInstanceRef ident) = show ident+  showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref++  commaList :: [String] -> String+  commaList = intercalate ", "++-- |+-- Imports a module, preserving the initial state on failure.+--+handleImport :: ImportedModule -> PSCI ()+handleImport im = do+   st <- updateImportedModules im <$> PSCI (lift get)+   let m = createTemporaryModuleForImports st+   e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []+   case e of+     Left errs -> printErrors errs+     Right _  -> do+       PSCI $ lift $ put st+       return ()++-- |+-- Takes a value and prints its type+--+handleTypeOf :: P.Expr -> PSCI ()+handleTypeOf val = do+  st <- PSCI $ lift get+  let m = createTemporaryModule False st val+  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []+  case e of+    Left errs -> printErrors errs+    Right env' ->+      case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of+        Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty+        Nothing -> PSCI $ outputStrLn "Could not find type"++-- |+-- Pretty print a module's signatures+--+printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()+printModuleSignatures moduleName env =+  PSCI $ let namesEnv = P.names env+             moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv+             in case moduleNamesIdent of+                  [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."+                  _ -> ( outputStrLn+                       . unlines+                       . sort+                       . map (showType . findType namesEnv)) moduleNamesIdent+  where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))+        findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)+        showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String+        showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType+        showType _ = error "The impossible happened in printModuleSignatures."++-- |+-- Browse a module and displays its signature (if module exists).+--+handleBrowse :: P.ModuleName -> PSCI ()+handleBrowse moduleName = do+  st <- PSCI $ lift get+  let loadedModules = psciLoadedModules st+  env <- psciIO . runMake $ P.make modulesDir loadedModules []+  case env of+    Left errs -> printErrors errs+    Right env' ->+      if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules+        then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."+        else printModuleSignatures moduleName env'++-- | Pretty-print errors+printErrors :: P.MultipleErrors -> PSCI ()+printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False++-- |+-- Takes a value and prints its kind+--+handleKindOf :: P.Type -> PSCI ()+handleKindOf typ = do+  st <- PSCI $ lift get+  let m = createTemporaryModuleForKind st typ+      mName = P.ModuleName [P.ProperName "$PSCI"]+  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []+  case e of+    Left errs -> printErrors errs+    Right env' ->+      case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of+        Just (_, typ') -> do+          let chk = P.CheckState env' 0 0 (Just mName)+              k   = L.runStateT (P.unCheck (P.kindOf mName typ')) chk+          case k of+            Left errStack   -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack+            Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind+        Nothing -> PSCI $ outputStrLn "Could not find kind"++-- Commands++-- |+-- Parses the input and returns either a Metacommand, or an error as a string.+--+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))+getCommand singleLineMode = do+  firstLine <- getInputLine "> "+  case firstLine of+    Nothing -> return (Right Nothing)+    Just "" -> return (Right Nothing)+    Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s+    Just s -> either Left (Right . Just) . parseCommand <$> go [s]+  where+    go :: [String] -> InputT (StateT PSCiState IO) String+    go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine "  "++-- |+-- Performs an action for each meta-command given, and also for expressions.+--+handleCommand :: Command -> PSCI ()+handleCommand (Expression val) = handleDeclaration val+handleCommand ShowHelp = PSCI $ outputStrLn helpMessage+handleCommand (Import im) = handleImport im+handleCommand (Decls l) = handleDecls l+handleCommand (LoadFile filePath) = do+  absPath <- psciIO $ expandTilde filePath+  exists <- psciIO $ doesFileExist absPath+  if exists then do+    PSCI . lift $ modify (updateImportedFiles absPath)+    m <- psciIO $ loadModule absPath+    case m of+      Left err -> PSCI $ outputStrLn err+      Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))+  else+    PSCI . outputStrLn $ "Couldn't locate: " ++ filePath+handleCommand ResetState = do+  files <- psciImportedFilenames <$> PSCI (lift get)+  PSCI . lift . modify $ \st -> st+    { psciImportedFilenames   = files+    , psciImportedModules     = defaultImports+    , psciLetBindings         = []+    }+  loadAllImportedModules+handleCommand (TypeOf val) = handleTypeOf val+handleCommand (KindOf typ) = handleKindOf typ+handleCommand (BrowseModule moduleName) = handleBrowse moduleName+handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules+handleCommand (ShowInfo QueryImport) = handleShowImportedModules+handleCommand QuitPSCi = error "`handleCommand QuitPSCi` was called. This is a bug."++loadUserConfig :: IO (Maybe [Command])+loadUserConfig = do+  configFile <- (</> ".psci") <$> getCurrentDirectory+  exists <- doesFileExist configFile+  if exists+  then do+    ls <- lines <$> readFile configFile+    case mapM parseCommand ls of+      Left err -> print err >> exitFailure+      Right cs -> return $ Just cs+  else+    return Nothing++-- |+-- The PSCI main loop.+--+loop :: PSCiOptions -> IO ()+loop PSCiOptions{..} = do+  config <- loadUserConfig+  modulesOrFirstError <- loadAllModules psciInputFile+  case modulesOrFirstError of+    Left err -> print err >> exitFailure+    Right modules -> do+      historyFilename <- getHistoryFilename+      let settings = defaultSettings { historyFile = Just historyFilename }+      flip evalStateT (PSCiState psciInputFile defaultImports modules [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do+        outputStrLn prologueMessage+        traverse_ (mapM_ (runPSCI . handleCommand)) config+        go+      where+        go :: InputT (StateT PSCiState IO) ()+        go = do+          c <- getCommand (not psciMultiLineMode)+          case c of+            Left err -> outputStrLn err >> go+            Right Nothing -> go+            Right (Just QuitPSCi) -> outputStrLn quitMessage+            Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go++multiLineMode :: Parser Bool+multiLineMode = switch $+     long "multi-line-mode"+  <> short 'm'+  <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"++inputFile :: Parser FilePath+inputFile = strArgument $+     metavar "FILE"+  <> Opts.help "Optional .purs files to load on start"++nodeFlagsFlag :: Parser [String]+nodeFlagsFlag = option parser $+     long "node-opts"+  <> metavar "NODE_OPTS"+  <> value []+  <> Opts.help "Flags to pass to node, separated by spaces"+  where+    parser = words <$> str++psciOptions :: Parser PSCiOptions+psciOptions = PSCiOptions <$> multiLineMode+                          <*> many inputFile+                          <*> nodeFlagsFlag++runPSCi :: IO ()+runPSCi = execParser opts >>= loop+  where+  opts        = info (version <*> helper <*> psciOptions) infoModList+  infoModList = fullDesc <> headerInfo <> footerInfo+  headerInfo  = header   "psci - Interactive mode for PureScript"+  footerInfo  = footer $ "psci " ++ showVersion Paths.version++  version :: Parser (a -> a)+  version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden

@@ -19,22 +19,23 @@  import Prelude hiding (lex) -import qualified Commands as C-import qualified Directive as D- import Data.Char (isSpace)+import Data.List (intercalate)  import Control.Applicative hiding (many)  import Text.Parsec hiding ((<|>))  import qualified Language.PureScript as P-import qualified Language.PureScript.Parser.Common as C (mark, same)+import Language.PureScript.Parser.Common (mark, same) +import qualified Directive as D+import Types+ -- | -- Parses PSCI metacommands or expressions input from the user. ---parseCommand :: String -> Either String C.Command+parseCommand :: String -> Either String Command parseCommand cmdString =   case cmdString of     (':' : cmd) -> parseDirective cmd@@ -45,7 +46,7 @@   ts <- P.lex "" s   P.runTokenParser "" (p <* eof) ts -psciCommand :: P.TokenParser C.Command+psciCommand :: P.TokenParser Command psciCommand = choice (map try parsers)   where   parsers =@@ -64,25 +65,31 @@ trimEnd :: String -> String trimEnd = reverse . trimStart . reverse -parseDirective :: String -> Either String C.Command+parseDirective :: String -> Either String Command parseDirective cmd =-  case D.parseDirective dstr of-    Just D.Help -> return C.Help-    Just D.Quit -> return C.Quit-    Just D.Reset -> return C.Reset-    Just D.Browse -> C.Browse <$> parseRest P.moduleName arg-    Just D.Load -> return $ C.LoadFile (trim arg)-    Just D.Show -> return $ C.Show (trim arg)-    Just D.Type -> C.TypeOf <$> parseRest P.parseValue arg-    Just D.Kind -> C.KindOf <$> parseRest P.parseType arg-    Nothing -> Left $ "Unrecognized command. Type :? for help."-  where (dstr, arg) = break isSpace cmd+  case D.directivesFor' dstr of+    [(d, _)] -> commandFor d+    []       -> Left "Unrecognized directive. Type :? for help."+    ds       -> Left ("Ambiguous directive. Possible matches: " +++                  intercalate ", " (map snd ds) ++ ". Type :? for help.")+  where+  (dstr, arg) = break isSpace cmd +  commandFor d = case d of+    Help   -> return ShowHelp+    Quit   -> return QuitPSCi+    Reset  -> return ResetState+    Browse -> BrowseModule <$> parseRest P.moduleName arg+    Load   -> return $ LoadFile (trim arg)+    Show   -> ShowInfo <$> parseReplQuery' (trim arg)+    Type   -> TypeOf <$> parseRest P.parseValue arg+    Kind   -> KindOf <$> parseRest P.parseType arg+ -- | -- Parses expressions entered at the PSCI repl. ---psciExpression :: P.TokenParser C.Command-psciExpression = C.Expression <$> P.parseValue+psciExpression :: P.TokenParser Command+psciExpression = Expression <$> P.parseValue  -- | -- PSCI version of @let@.@@ -90,21 +97,21 @@ -- However, since we don't support the @Eff@ monad, -- we actually want the normal @let@. ---psciLet :: P.TokenParser C.Command-psciLet = C.Decls <$> (P.reserved "let" *> P.indented *> manyDecls)+psciLet :: P.TokenParser Command+psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)   where   manyDecls :: P.TokenParser [P.Declaration]-  manyDecls = C.mark (many1 (C.same *> P.parseLocalDeclaration))+  manyDecls = mark (many1 (same *> P.parseLocalDeclaration))  -- | Imports must be handled separately from other declarations, so that -- :show import works, for example.-psciImport :: P.TokenParser C.Command-psciImport = C.Import <$> P.parseImportDeclaration'+psciImport :: P.TokenParser Command+psciImport = Import <$> P.parseImportDeclaration'  -- | Any other declaration that we don't need a 'special case' parser for -- (like let or import declarations).-psciOtherDeclaration :: P.TokenParser C.Command-psciOtherDeclaration = C.Decls . (:[]) <$> do+psciOtherDeclaration :: P.TokenParser Command+psciOtherDeclaration = Decls . (:[]) <$> do   decl <- discardPositionInfo <$> P.parseDeclaration   if acceptable decl     then return decl@@ -123,3 +130,10 @@ acceptable (P.TypeClassDeclaration _ _ _ _) = True acceptable (P.TypeInstanceDeclaration _ _ _ _ _) = True acceptable _ = False++parseReplQuery' :: String -> Either String ReplQuery+parseReplQuery' str =+  case parseReplQuery str of+    Nothing -> Left ("Don't know how to show " ++ str ++ ". Try one of: " +++                      intercalate ", " replQueryStrings ++ ".")+    Just query -> Right query

@@ -0,0 +1,167 @@+-----------------------------------------------------------------------------+--+-- Module      :  Types+-- Copyright   :  (c) Phil Freeman 2014+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Type declarations and associated basic functions for PSCI.+--+-----------------------------------------------------------------------------++module Types where++import qualified Language.PureScript as P++data PSCiOptions = PSCiOptions+  { psciMultiLineMode  :: Bool+  , psciInputFile      :: [FilePath]+  , psciInputNodeFlags :: [String]+  }++-- |+-- The PSCI state.+-- Holds a list of imported modules, loaded files, and partial let bindings.+-- The let bindings are partial,+-- because it makes more sense to apply the binding to the final evaluated expression.+--+data PSCiState = PSCiState+  { psciImportedFilenames   :: [FilePath]+  , psciImportedModules     :: [ImportedModule]+  , psciLoadedModules       :: [(Either P.RebuildPolicy FilePath, P.Module)]+  , psciLetBindings         :: [P.Declaration]+  , psciNodeFlags           :: [String]+  }++-- | All of the data that is contained by an ImportDeclaration in the AST.+-- That is:+--+-- * A module name, the name of the module which is being imported+-- * An ImportDeclarationType which specifies whether there is an explicit+--   import list, a hiding list, or neither.+-- * If the module is imported qualified, its qualified name in the importing+--   module. Otherwise, Nothing.+--+type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)++psciImportedModuleNames :: PSCiState -> [P.ModuleName]+psciImportedModuleNames (PSCiState{psciImportedModules = is}) =+  map (\(mn, _, _) -> mn) is++allImportsOf :: P.Module -> PSCiState -> [ImportedModule]+allImportsOf m (PSCiState{psciImportedModules = is}) =+  filter isImportOfThis is+  where+  name = P.getModuleName m+  isImportOfThis (name', _, _) = name == name'++-- State helpers++-- |+-- Updates the state to have more imported modules.+--+updateImportedFiles :: FilePath -> PSCiState -> PSCiState+updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }++-- |+-- Updates the state to have more imported modules.+--+updateImportedModules :: ImportedModule -> PSCiState -> PSCiState+updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }++-- |+-- Updates the state to have more loaded files.+--+updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState+updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }++-- |+-- Updates the state to have more let bindings.+--+updateLets :: [P.Declaration] -> PSCiState -> PSCiState+updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }++-- |+-- Valid Meta-commands for PSCI+--+data Command+  -- |+  -- A purescript expression+  --+  = Expression P.Expr+  -- |+  -- Show the help (ie, list of directives)+  --+  | ShowHelp+  -- |+  -- Import a module from a loaded file+  --+  | Import ImportedModule+  -- |+  -- Browse a module+  --+  | BrowseModule P.ModuleName+  -- |+  -- Load a file for use with importing+  --+  | LoadFile FilePath+  -- |+  -- Exit PSCI+  --+  | QuitPSCi+  -- |+  -- Reset the state of the REPL+  --+  | ResetState+  -- |+  -- Add some declarations to the current evaluation context.+  --+  | Decls [P.Declaration]+  -- |+  -- Find the type of an expression+  --+  | TypeOf P.Expr+  -- |+  -- Find the kind of an expression+  --+  | KindOf P.Type+  -- |+  -- Shows information about the current state of the REPL+  --+  | ShowInfo ReplQuery++data ReplQuery+  = QueryLoaded+  | QueryImport+  deriving (Eq, Show)++-- | A list of all ReplQuery values.+replQueries :: [ReplQuery]+replQueries = [QueryLoaded, QueryImport]++replQueryStrings :: [String]+replQueryStrings = map showReplQuery replQueries++showReplQuery :: ReplQuery -> String+showReplQuery QueryLoaded = "loaded"+showReplQuery QueryImport = "import"++parseReplQuery :: String -> Maybe ReplQuery+parseReplQuery "loaded" = Just QueryLoaded+parseReplQuery "import" = Just QueryImport+parseReplQuery _ = Nothing++data Directive+  = Help+  | Quit+  | Reset+  | Browse+  | Load+  | Type+  | Kind+  | Show+  deriving (Eq, Show)

@@ -0,0 +1,6 @@+module Main where++import PSCi++main :: IO ()+main = runPSCi

@@ -0,0 +1,137 @@+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Monad.Trans.State.Strict (runStateT)+import Control.Monad (when)++import System.Exit (exitFailure)+import System.Console.Haskeline++import Test.HUnit++import qualified Language.PureScript as P++import PSCi+import Completion+import Types++main :: IO ()+main = do+  Counts{..} <- runTestTT allTests+  when (errors + failures > 0) exitFailure++allTests :: Test+allTests = completionTests++completionTests :: Test+completionTests =+  TestLabel "completionTests"+    (TestList (map (TestCase . assertCompletedOk) completionTestData))++-- If the cursor is at the right end of the line, with the 1st element of the+-- pair as the text in the line, then pressing tab should offer all the+-- elements of the list (which is the 2nd element) as completions.+completionTestData :: [(String, [String])]+completionTestData =+  -- basic directives+  [ (":h", [":help"])+  , (":re", [":reset"])+  , (":q", [":quit"])+  , (":mo", [":module"])+  , (":b", [":browse"])++  -- :browse should complete modules+  , (":b Prel", [":b Prelude", ":b Prelude.Unsafe"])+  , (":b Prelude.", [":b Prelude.Unsafe"])++  -- :load, :module should complete file paths+  , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"])+  , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"])++  -- :quit, :help, :reset should not complete+  , (":help ", [])+  , (":quit ", [])+  , (":reset ", [])++  -- :show should complete to "loaded" and "import"+  , (":show ", [":show import", ":show loaded"])+  , (":show a", [])++  -- :type should complete values and data constructors in scope+  , (":type Prelude.Unsafe.un", [":type Prelude.Unsafe.unsafeIndex"])+  , (":type un", [":type unit"])+  , (":type E", [":type EQ"])++  -- :kind should complete types in scope+  , (":kind C", [":kind Control.Monad.Eff.Pure"])+  , (":kind O", [":kind Ordering"])++  -- Only one argument for directives should be completed+  , (":show import ", [])+  , (":type EQ ", [])+  , (":kind Ordering ", [])++  -- import should complete module names+  , ("import Control.Monad.S", ["import Control.Monad.ST"])+  , ("import qualified Control.Monad.S", ["import qualified Control.Monad.ST"])+  , ("import Control.Monad.", map ("import Control.Monad." ++)+                                  ["Eff", "Eff.Unsafe", "ST"])++  -- a few other import tests+  , ("impor", ["import"])+  , ("import q", ["import qualified"])+  , ("import ", map ("import " ++) allModuleNames ++ ["import qualified"])+  , ("import Prelude.Unsafe ", [])++  -- String and number literals should not be completed+  , ("\"hi", [])+  , ("34", [])++  -- Identifiers and data constructors should be completed+  , ("un", ["unit"])+  , ("Debug.Trace.", map ("Debug.Trace." ++) ["print", "trace"])+  , ("G", ["GT"])+  , ("Prelude.L", ["Prelude.LT"])++  -- if a module is imported qualified, values should complete under the+  -- qualified name, as well as the original name.+  , ("ST.new", ["ST.newSTRef"])+  , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])+  ]+  where+  allModuleNames = [ "Control.Monad.Eff"+                   , "Control.Monad.Eff.Unsafe"+                   , "Control.Monad.ST"+                   , "Data.Function"+                   , "Debug.Trace"+                   , "Prelude"+                   , "Prelude.Unsafe"+                   ]++assertCompletedOk :: (String, [String]) -> Assertion+assertCompletedOk (line, expecteds) = do+  (unusedR, completions) <- runCM (completion' (reverse line, ""))+  let unused = reverse unusedR+  let actuals = map ((unused ++) . replacement) completions+  expecteds @=? actuals++runCM :: CompletionM a -> IO a+runCM act = do+  psciState <- getPSCiState+  fmap fst (runStateT (liftCompletionM act) psciState)++getPSCiState :: IO PSCiState+getPSCiState = do+  modulesOrFirstError <- loadAllModules []+  case modulesOrFirstError of+    Left err ->+      print err >> exitFailure+    Right modules ->+      let imports = controlMonadSTasST : defaultImports+      in  return (PSCiState [] imports modules [] [])++controlMonadSTasST :: ImportedModule+controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))+  where+  s = P.moduleNameFromString

@@ -1,5 +1,5 @@ name: purescript-version: 0.6.9.3+version: 0.6.9.4 cabal-version: >=1.8 build-type: Simple license: MIT@@ -148,10 +148,12 @@      main-is: Main.hs     buildable: True-    hs-source-dirs: psci-    other-modules: Commands+    hs-source-dirs: psci psci/main+    other-modules: Types                    Parser                    Directive+                   Completion+                   PSCi     ghc-options: -Wall -O2  executable psc-docs@@ -182,3 +184,14 @@     main-is: Main.hs     buildable: True     hs-source-dirs: tests++test-suite psci-tests+    build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,+                   mtl -any, optparse-applicative >= 0.10.0, parsec -any,+                   haskeline >= 0.7.0.0, purescript -any, transformers -any,+                   process -any, HUnit -any+    type: exitcode-stdio-1.0+    main-is: Main.hs+    buildable: True+    hs-source-dirs: psci psci/tests+    ghc-options: -Wall

@@ -89,20 +89,20 @@ -- --  * Pretty-print the generated Javascript ---compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)+compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)         => [Module] -> [String] -> m (String, String, Environment) compile = compile' initEnvironment -compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)+compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)          => Environment -> [Module] -> [String] -> m (String, String, Environment) compile' env ms prefix = do   noPrelude <- asks optionsNoPrelude   additional <- asks optionsAdditional   mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)   (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms-  (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted+  (desugared, nextVar) <- runSupplyT 0 $ desugar sorted   (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent-  regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated+  regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated   let corefn = map (CoreFn.moduleToCoreFn env') regrouped   let entryPoints = moduleNameFromString `map` entryPointModules additional   let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn@@ -115,21 +115,21 @@   let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']   return (pjs, exts, env') -generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]+generateMain :: (MonadError MultipleErrors m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS] generateMain env js = do   main <- asks optionsMain   additional <- asks optionsAdditional   case moduleNameFromString <$> main of     Just mmi -> do       when ((mmi, Ident C.main) `M.notMember` names env) $-        throwError $ show mmi ++ "." ++ C.main ++ " is undefined"+        throwError . errorMessage $ NameIsUndefined (Ident C.main)       return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]     _ -> return js  -- | -- A type class which collects the IO actions we need to be able to run in "make" mode ---class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where+class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m) => MonadMake m where   -- |   -- Get a file timestamp   --@@ -196,7 +196,7 @@    marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted -  (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)+  (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)    evalSupplyT nextVar $ go initEnvironment desugared @@ -216,7 +216,7 @@      (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m -    regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated+    regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated      let mod' = Module coms moduleName' regrouped exps     let corefn = CoreFn.moduleToCoreFn env' mod'@@ -240,10 +240,10 @@   rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do     let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"     externs <- readTextFile externsFile-    externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]+    externsModules <- fmap (map snd) . either (throwError . errorMessage . ErrorParsingExterns) return $ P.parseModulesFromFiles id [(externsFile, externs)]     case externsModules of       [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'-      _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"+      _ -> throwError . errorMessage . InvalidExternsFile $ externsFile  reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName] reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

@@ -78,12 +78,12 @@ -- | -- Return the exported data constructors for a given type. ---exportedDctors :: Module -> ProperName -> [ProperName]+exportedDctors :: Module -> ProperName -> [(ProperName, [Type])] exportedDctors (Module _ _ decls exps) ident =-  filter (isDctorExported ident exps) dctors+  filter (isDctorExported ident exps . fst) dctors   where   dctors = concatMap getDctors (flattenDecls decls)-  getDctors (DataDeclaration _ _ _ ctors) = map fst ctors+  getDctors (DataDeclaration _ _ _ ctors) = ctors   getDctors (PositionedDeclaration _ _ d) = getDctors d   getDctors _ = [] 

@@ -30,10 +30,12 @@     -- Column number     --   , sourcePosColumn :: Int-  } deriving (Eq, D.Data, D.Typeable)+  } deriving (Eq, Show, D.Data, D.Typeable) -instance Show SourcePos where-  show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)+displaySourcePos :: SourcePos -> String+displaySourcePos sp =+  "line " ++ show (sourcePosLine sp) +++    ", column " ++ show (sourcePosColumn sp)  data SourceSpan = SourceSpan   { -- |@@ -47,7 +49,10 @@     -- End of the span     --   , spanEnd :: SourcePos-  } deriving (Eq, D.Data, D.Typeable)+  } deriving (Eq, Show, D.Data, D.Typeable) -instance Show SourceSpan where-  show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)+displaySourceSpan :: SourceSpan -> String+displaySourceSpan sp =+  spanName sp ++ " " +++    displaySourcePos (spanStart sp) ++ " - " +++    displaySourcePos (spanEnd sp)

@@ -84,10 +84,28 @@ inlineValues = everywhereOnJS convert   where   convert :: JS -> JS-  convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.zero fn = JSNumericLiteral (Left 0)-  convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.one fn = JSNumericLiteral (Left 1)-  convert (JSApp (JSApp fn [x]) [y]) | isPreludeFn (C.%) fn = JSBinary Modulus x y+  convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0)+                            | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1)+                            | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0)+                            | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1)+                            | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False+                            | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True+  convert (JSApp fn [value]) | isFn fromNumber fn = JSBinary BitwiseOr value (JSNumericLiteral (Left 0))+  convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])+    | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0))+    | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0))+    | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0))+    | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0))   convert other = other+  fnZero = (C.prelude, C.zero)+  fnOne = (C.prelude, C.one)+  fnBottom = (C.prelude, C.bottom)+  fnTop = (C.prelude, C.top)+  fromNumber = (C.dataInt, C.fromNumber)+  fnAdd = (C.prelude, (C.+))+  fnDivide = (C.prelude, (C./))+  fnMultiply = (C.prelude, (C.*))+  fnSubtract = (C.prelude, (C.-))  inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS inlineOperator (m, op) f = everywhereOnJS convert@@ -101,59 +119,84 @@  inlineCommonOperators :: JS -> JS inlineCommonOperators = applyAll $-  [ binary C.semiringNumber (C.+) Add-  , binary C.semiringNumber (C.*) Multiply-  , binary C.ringNumber (C.-) Subtract-  , unary  C.ringNumber C.negate Negate-  , binary C.moduloSemiringNumber (C./) Divide+  [ binary semiringNumber (C.+) Add+  , binary semiringNumber (C.*) Multiply -  , binary C.ordNumber (C.<) LessThan-  , binary C.ordNumber (C.>) GreaterThan-  , binary C.ordNumber (C.<=) LessThanOrEqualTo-  , binary C.ordNumber (C.>=) GreaterThanOrEqualTo+  , binary ringNumber (C.-) Subtract+  , unary  ringNumber C.negate Negate+  , binary ringInt (C.-) Subtract+  , unary  ringInt C.negate Negate -  , binary C.eqNumber (C.==) EqualTo-  , binary C.eqNumber (C./=) NotEqualTo-  , binary C.eqString (C.==) EqualTo-  , binary C.eqString (C./=) NotEqualTo-  , binary C.eqBoolean (C.==) EqualTo-  , binary C.eqBoolean (C./=) NotEqualTo+  , binary moduloSemiringNumber (C./) Divide+  , binary moduloSemiringInt C.mod Modulus -  , binary C.semigroupString (C.<>) Add-  , binary C.semigroupString (C.++) Add+  , binary eqNumber (C.==) EqualTo+  , binary eqNumber (C./=) NotEqualTo+  , binary eqInt (C.==) EqualTo+  , binary eqInt (C./=) NotEqualTo+  , binary eqString (C.==) EqualTo+  , binary eqString (C./=) NotEqualTo+  , binary eqBoolean (C.==) EqualTo+  , binary eqBoolean (C./=) NotEqualTo -  , binaryFunction C.bitsNumber C.shl ShiftLeft-  , binaryFunction C.bitsNumber C.shr ShiftRight-  , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight-  , binary         C.bitsNumber (C..&.) BitwiseAnd-  , binary         C.bitsNumber (C..|.) BitwiseOr-  , binary         C.bitsNumber (C..^.) BitwiseXor-  , unary          C.bitsNumber C.complement BitwiseNot+  , binary ordNumber (C.<) LessThan+  , binary ordNumber (C.>) GreaterThan+  , binary ordNumber (C.<=) LessThanOrEqualTo+  , binary ordNumber (C.>=) GreaterThanOrEqualTo+  , binary ordInt (C.<) LessThan+  , binary ordInt (C.>) GreaterThan+  , binary ordInt (C.<=) LessThanOrEqualTo+  , binary ordInt (C.>=) GreaterThanOrEqualTo -  , binary C.boolLikeBoolean (C.&&) And-  , binary C.boolLikeBoolean (C.||) Or-  , unary  C.boolLikeBoolean C.not Not+  , binary semigroupString (C.<>) Add+  , binary semigroupString (C.++) Add++  , binary latticeBoolean (C.&&) And+  , binary latticeBoolean (C.||) Or+  , binaryFunction latticeBoolean C.inf And+  , binaryFunction latticeBoolean C.sup Or+  , unary complementedLatticeBoolean C.not Not++  , binary' C.dataIntBits (C..|.) BitwiseOr+  , binary' C.dataIntBits (C..&.) BitwiseAnd+  , binary' C.dataIntBits (C..^.) BitwiseXor+  , binary' C.dataIntBits C.shl ShiftLeft+  , binary' C.dataIntBits C.shr ShiftRight+  , binary' C.dataIntBits C.zshr ZeroFillShiftRight+  , unary'  C.dataIntBits C.complement BitwiseNot   ] ++   [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]   where-  binary :: String -> String -> BinaryOperator -> JS -> JS-  binary dictName opString op = everywhereOnJS convert+  binary :: (String, String) -> String -> BinaryOperator -> JS -> JS+  binary dict opString op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y+    convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y     convert other = other-  binaryFunction :: String -> String -> BinaryOperator -> JS -> JS-  binaryFunction dictName fnName op = everywhereOnJS convert+  binary' :: String -> String -> BinaryOperator -> JS -> JS+  binary' moduleName opString op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y+    convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y     convert other = other-  unary :: String -> String -> UnaryOperator -> JS -> JS-  unary dictName fnName op = everywhereOnJS convert+  binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS+  binaryFunction dict fnName op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x+    convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y     convert other = other+  unary :: (String, String) -> String -> UnaryOperator -> JS -> JS+  unary dict fnName op = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x+    convert other = other+  unary' :: String -> String -> UnaryOperator -> JS -> JS+  unary' moduleName fnName op = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x+    convert other = other   mkFn :: Int -> JS -> JS   mkFn 0 = everywhereOnJS convert     where@@ -190,12 +233,62 @@     go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs     go _ _   _ = Nothing -isPreludeDict :: String -> JS -> Bool-isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName-isPreludeDict _ _ = False+isDict :: (String, String) -> JS -> Bool+isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName+isDict _ _ = False +isFn :: (String, String) -> JS -> Bool+isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName+isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName+isFn _ _ = False+ isPreludeFn :: String -> JS -> Bool-isPreludeFn fnName (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName-isPreludeFn fnName (JSIndexer (JSStringLiteral fnName') (JSVar prelude)) = prelude == C.prelude && fnName' == fnName-isPreludeFn fnName (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op fnName)-isPreludeFn _ _ = False+isPreludeFn fnName = isFn (C.prelude, fnName)++semiringNumber :: (String, String)+semiringNumber = (C.prelude, C.semiringNumber)++semiringInt :: (String, String)+semiringInt = (C.dataInt, C.semiringInt)++ringNumber :: (String, String)+ringNumber = (C.prelude, C.ringNumber)++ringInt :: (String, String)+ringInt = (C.dataInt, C.ringInt)++moduloSemiringNumber :: (String, String)+moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)++moduloSemiringInt :: (String, String)+moduloSemiringInt = (C.dataInt, C.moduloSemiringInt)++eqNumber :: (String, String)+eqNumber = (C.prelude, C.eqNumber)++eqInt :: (String, String)+eqInt = (C.dataInt, C.eqInt)++eqString :: (String, String)+eqString = (C.prelude, C.eqNumber)++eqBoolean :: (String, String)+eqBoolean = (C.prelude, C.eqNumber)++ordNumber :: (String, String)+ordNumber = (C.prelude, C.ordNumber)++ordInt :: (String, String)+ordInt = (C.dataInt, C.ordInt)++semigroupString :: (String, String)+semigroupString = (C.prelude, C.semigroupString)++boundedBoolean :: (String, String)+boundedBoolean = (C.prelude, C.boundedBoolean)++latticeBoolean :: (String, String)+latticeBoolean = (C.prelude, C.latticeBoolean)++complementedLatticeBoolean :: (String, String)+complementedLatticeBoolean = (C.prelude, C.complementedLatticeBoolean)

@@ -15,6 +15,8 @@  module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where +import Data.Monoid+ import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST @@ -30,10 +32,13 @@   where   tcoLabel :: String   tcoLabel = "tco"+   tcoVar :: String -> String   tcoVar arg = "__tco_" ++ arg+   copyVar :: String -> String   copyVar arg = "__copy_" ++ arg+   convert :: JS -> JS   convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =     let@@ -46,6 +51,7 @@               JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))         | otherwise -> js   convert js = js+   collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)   collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =     collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body@@ -56,25 +62,35 @@   collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =     (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))   collectAllFunctionArgs allArgs f body = (allArgs, body, f)+   isTailCall :: String -> JS -> Bool   isTailCall ident js =     let       numSelfCalls = everythingOnJS (+) countSelfCalls js       numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js       numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js+      numSelfCallWithFnArgs = everythingOnJS (+) countSelfCallsWithFnArgs js     in       numSelfCalls > 0       && numSelfCalls == numSelfCallsInTailPosition       && numSelfCallsUnderFunctions == 0+      && numSelfCallWithFnArgs == 0     where     countSelfCalls :: JS -> Int     countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1     countSelfCalls _ = 0+         countSelfCallsInTailPosition :: JS -> Int     countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1     countSelfCallsInTailPosition _ = 0+    +    countSelfCallsUnderFunctions :: JS -> Int     countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'     countSelfCallsUnderFunctions _ = 0+    +    countSelfCallsWithFnArgs :: JS -> Int+    countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0+   toLoop :: String -> [String] -> JS -> JS   toLoop ident allArgs js = JSBlock $         map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++@@ -94,10 +110,19 @@     collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]     collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn     collectSelfCallArgs allArgumentValues _ = allArgumentValues+   isSelfCall :: String -> JS -> Bool-  isSelfCall ident (JSApp (JSVar ident') args) | ident == ident' && not (any isFunction args) = True-  isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn+  isSelfCall ident (JSApp (JSVar ident') _) = ident == ident'+  isSelfCall ident (JSApp fn _) = isSelfCall ident fn   isSelfCall _ _ = False-  isFunction :: JS -> Bool-  isFunction (JSFunction _ _ _) = True-  isFunction _ = False++  isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool+  isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True+  isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)+  isSelfCallWithFnArgs _ _ _ = False+    +  hasFunction :: JS -> Bool +  hasFunction = getAny . everythingOnJS mappend (Any . isFunction)+    where+    isFunction (JSFunction _ _ _) = True+    isFunction _ = False

@@ -15,7 +15,7 @@  module Language.PureScript.Constants where --- Prelude Operators+-- Operators  ($) :: String ($) = "$"@@ -65,15 +65,6 @@ (/=) :: String (/=) = "/=" -(.&.) :: String-(.&.) = ".&."--(.|.) :: String-(.|.) = ".|."--(.^.) :: String-(.^.) = ".^."- (&&) :: String (&&) = "&&" @@ -83,11 +74,32 @@ unsafeIndex :: String unsafeIndex = "unsafeIndex" --- Prelude Operator Functions+(.|.) :: String+(.|.) = ".|." +(.&.) :: String+(.&.) = ".&."++(.^.) :: String+(.^.) = ".^."++-- Functions+ negate :: String negate = "negate" +not :: String+not = "not"++sup :: String+sup = "sup"++inf :: String+inf = "inf"++mod :: String+mod = "mod"+ shl :: String shl = "shl" @@ -100,8 +112,8 @@ complement :: String complement = "complement" -not :: String-not = "not"+fromNumber :: String+fromNumber = "fromNumber"  -- Prelude Values @@ -111,6 +123,12 @@ one :: String one = "one" +bottom :: String+bottom = "bottom"++top :: String+top = "top"+ return :: String return = "return" @@ -172,33 +190,48 @@ semiringNumber :: String semiringNumber = "semiringNumber" +semiringInt :: String+semiringInt = "semiringInt"+ ringNumber :: String ringNumber = "ringNumber" +ringInt :: String+ringInt = "ringInt"+ moduloSemiringNumber :: String moduloSemiringNumber = "moduloSemiringNumber" -numNumber :: String-numNumber = "numNumber"+moduloSemiringInt :: String+moduloSemiringInt = "moduloSemiringInt"  ordNumber :: String ordNumber = "ordNumber" +ordInt :: String+ordInt = "ordInt"+ eqNumber :: String eqNumber = "eqNumber" +eqInt :: String+eqInt = "eqInt"+ eqString :: String eqString = "eqString"  eqBoolean :: String eqBoolean = "eqBoolean" -bitsNumber :: String-bitsNumber = "bitsNumber"+boundedBoolean :: String+boundedBoolean = "boundedBoolean" -boolLikeBoolean :: String-boolLikeBoolean = "boolLikeBoolean"+latticeBoolean :: String+latticeBoolean = "latticeBoolean" +complementedLatticeBoolean :: String+complementedLatticeBoolean = "complementedLatticeBoolean"+ semigroupString :: String semigroupString = "semigroupString" @@ -237,3 +270,9 @@  dataFunction :: String dataFunction = "Data_Function"++dataInt :: String+dataInt = "Data_Int"++dataIntBits :: String+dataIntBits = "Data_Int_Bits"

@@ -36,11 +36,19 @@  import qualified Text.PrettyPrint.Boxes as Box +import qualified Text.Parsec as P+ -- | -- A type of error messages -- data ErrorMessage -  = InfiniteType Type+  = ErrorParsingExterns P.ParseError+  | ErrorParsingPrelude P.ParseError+  | InvalidExternsFile FilePath+  | CannotGetFileInfo FilePath+  | CannotReadFile FilePath+  | CannotWriteFile FilePath+  | InfiniteType Type   | InfiniteKind Kind   | CannotReorderOperators   | MultipleFixities Ident@@ -70,6 +78,7 @@   | InvalidDoLet   | CycleInDeclaration Ident   | CycleInTypeSynonym (Maybe ProperName)+  | CycleInModules [ModuleName]   | NameIsUndefined Ident   | NameNotInScope Ident   | UndefinedTypeVariable ProperName@@ -126,6 +135,12 @@ -- Get the error code for a particular error type -- errorCode :: ErrorMessage -> String+errorCode (ErrorParsingExterns _)       = "ErrorParsingExterns"+errorCode (ErrorParsingPrelude _)       = "ErrorParsingPrelude"+errorCode (InvalidExternsFile _)        = "InvalidExternsFile"+errorCode (CannotGetFileInfo _)         = "CannotGetFileInfo"+errorCode (CannotReadFile _)            = "CannotReadFile"+errorCode (CannotWriteFile _)           = "CannotWriteFile" errorCode (InfiniteType _)              = "InfiniteType" errorCode (InfiniteKind _)              = "InfiniteKind" errorCode CannotReorderOperators        = "CannotReorderOperators"@@ -156,6 +171,7 @@ errorCode InvalidDoLet                  = "InvalidDoLet" errorCode (CycleInDeclaration _)        = "CycleInDeclaration" errorCode (CycleInTypeSynonym _)        = "CycleInTypeSynonym"+errorCode (CycleInModules _)            = "CycleInModules" errorCode (NameIsUndefined _)           = "NameIsUndefined" errorCode (NameNotInScope _)            = "NameNotInScope" errorCode (UndefinedTypeVariable _)     = "UndefinedTypeVariable"@@ -177,13 +193,13 @@ errorCode SubsumptionCheckFailed        = "SubsumptionCheckFailed" errorCode (ExprDoesNotHaveType _ _)     = "ExprDoesNotHaveType" errorCode (PropertyIsMissing _ _)       = "PropertyIsMissing"-errorCode (ErrorUnifyingTypes _ _ _)    = "ErrorUnifyingTypes" errorCode (CannotApplyFunction _ _)     = "CannotApplyFunction" errorCode TypeSynonymInstance           = "TypeSynonymInstance" errorCode InvalidNewtype                = "InvalidNewtype" errorCode (InvalidInstanceHead _)       = "InvalidInstanceHead" errorCode (TransitiveExportError _ _)   = "TransitiveExportError" errorCode (NotYetDefined _ e)           = errorCode e+errorCode (ErrorUnifyingTypes _ _ e)    = errorCode e errorCode (ErrorInExpression _ e)       = errorCode e errorCode (ErrorInModule _ e)           = errorCode e errorCode (ErrorInInstance _ _ e)       = errorCode e@@ -245,6 +261,24 @@     wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e            go :: ErrorMessage -> Box.Box+    go (CannotGetFileInfo path)        = paras [ line "Unable to read file info: "+                                               , indent . line $ path+                                               ]+    go (CannotReadFile path)           = paras [ line "Unable to read file: "+                                               , indent . line $ path+                                               ]+    go (CannotWriteFile path)          = paras [ line "Unable to write file: "+                                               , indent . line $ path+                                               ]+    go (ErrorParsingExterns err)       = paras [ line "Error parsing externs files: "+                                               , indent . line . show $ err+                                               ]+    go (ErrorParsingPrelude err)       = paras [ line "Error parsing prelude: "+                                               , indent . line . show $ err+                                               ]+    go (InvalidExternsFile path)       = paras [ line "Externs file is invalid: "+                                               , indent . line $ path+                                               ]     go InvalidDoBind                   = line "Bind statement cannot be the last statement in a do block"     go InvalidDoLet                    = line "Let statement cannot be the last statement in a do block"     go CannotReorderOperators          = line "Unable to reorder operators"@@ -278,6 +312,7 @@     go (DuplicateClassExport nm)       = line $ "Duplicate export declaration for type class " ++ show nm     go (DuplicateValueExport nm)       = line $ "Duplicate export declaration for value " ++ show nm     go (CycleInDeclaration nm)         = line $ "Cycle in declaration of " ++ show nm+    go (CycleInModules mns)            = line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns)     go (NotYetDefined names err)       = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"                                                , indent $ go err                                                ]@@ -404,7 +439,7 @@     go (ErrorInForeignImport nm err)   = paras [ line $ "Error in foreign import " ++ show nm ++ ":"                                                , go err                                                ]-    go (PositionedError pos err)       = paras [ line $ "Error at " ++ show pos ++ ":"+    go (PositionedError srcSpan err)   = paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":"                                                , indent $ go err                                                ] @@ -490,8 +525,8 @@ -- | -- Interpret multiple errors in a monad supporting errors ---interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a-interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return+interpretMultipleErrors :: (MonadError MultipleErrors m) => Either MultipleErrors a -> m a+interpretMultipleErrors = either throwError return  -- | -- Rethrow an error with a more detailed error message in the case of failure

@@ -28,6 +28,7 @@ import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types+import Language.PureScript.Errors  -- | -- A list of modules with their dependencies@@ -39,7 +40,7 @@ -- -- Reports an error if the module graph contains a cycle. ---sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph)+sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph) sortModules ms = do   let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms   ms' <- mapM toModule $ stronglyConnComp verts@@ -70,7 +71,7 @@ -- | -- Convert a strongly connected component of the module graph to a module ---toModule :: (MonadError String m) => SCC Module -> m Module+toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m-toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms)+toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)

@@ -126,9 +126,7 @@ parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p  parseRowEnding :: TokenParser Type-parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> P.choice  (map P.try-            [ parseTypeWildcard-            , TypeVar <$> identifier ])+parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType  parseRow :: TokenParser Type parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"

@@ -157,7 +157,6 @@ -- toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration toBindingGroup _ (AcyclicSCC d) = return d-toBindingGroup _ (CyclicSCC [d]) = return d toBindingGroup moduleName (CyclicSCC ds') =   -- Once we have a mutually-recursive group of declarations, we need to sort   -- them further by their immediate dependencies (those outside function

@@ -21,10 +21,11 @@     desugarCasesModule ) where +import Data.Maybe (catMaybes) import Data.List (nub, groupBy)  import Control.Applicative-import Control.Monad ((<=<), forM, join, unless, replicateM)+import Control.Monad ((<=<), forM, replicateM, join, unless) import Control.Monad.Except (throwError) import Control.Monad.Error.Class (MonadError) import Control.Monad.Supply.Class@@ -120,31 +121,53 @@ makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration makeCaseDeclaration ident alternatives = do   let namedArgs = map findName . fst <$> alternatives-  args <- mapM argName $ foldl1 resolveNames namedArgs-  let-    vars = map (Var . Qualified Nothing) args-    binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]-    value = foldr (Abs . Left) (Case vars binders) args+      argNames = map join $ foldl1 resolveNames namedArgs+  args <- if allUnique (catMaybes argNames) +            then mapM argName argNames +            else replicateM (length argNames) (Ident <$> freshName)+  let vars = map (Var . Qualified Nothing) args+      binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]+      value = foldr (Abs . Left) (Case vars binders) args   return $ ValueDeclaration ident Value [] (Right value)   where-  findName :: Binder -> Maybe Ident-  findName (VarBinder name) = Just name+  -- We will construct a table of potential names.+  -- VarBinders will become Just (Just _) which is a potential name.+  -- NullBinder will become Just Nothing, which indicates that we may +  -- have to generate a name.+  -- Everything else becomes Nothing, which indicates that we definitely+  --have to generate a name.+  findName :: Binder -> Maybe (Maybe Ident)+  findName NullBinder = Just Nothing+  findName (VarBinder name) = Just (Just name)   findName (PositionedBinder _ _ binder) = findName binder   findName _ = Nothing +  -- We still have to make sure the generated names are unique, or else+  -- we will end up constructing an invalid function.+  allUnique :: (Eq a) => [a] -> Bool+  allUnique xs = length xs == length (nub xs)+   argName :: (MonadSupply m) => Maybe Ident -> m Ident   argName (Just name) = return name-  argName Nothing = do+  argName _ = do     name <- freshName     return (Ident name) -  resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]+  -- Combine two lists of potential names from two case alternatives+  -- by zipping correspoding columns.+  resolveNames :: [Maybe (Maybe Ident)] -> +                  [Maybe (Maybe Ident)] -> +                  [Maybe (Maybe Ident)]   resolveNames = zipWith resolveName -  resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident-  resolveName (Just a) (Just b)-    | a == b = Just a+  -- Resolve a pair of names. VarBinder beats NullBinder, and everything+  -- else results in Nothing.+  resolveName :: Maybe (Maybe Ident) -> +                 Maybe (Maybe Ident) -> +                 Maybe (Maybe Ident)+  resolveName (Just (Just a)) (Just (Just b))+    | a == b = Just (Just a)     | otherwise = Nothing-  resolveName Nothing Nothing = Nothing-  resolveName (Just a) Nothing = Just a-  resolveName Nothing (Just b) = Just b+  resolveName (Just Nothing) a = a+  resolveName a (Just Nothing) = a+  resolveName _ _ = Nothing

@@ -44,11 +44,8 @@   let (f, _, _) = everywhereOnValuesM return replace return   in f d   where-  prelude :: ModuleName-  prelude = ModuleName [ProperName C.prelude]-   bind :: Expr-  bind = Var (Qualified (Just prelude) (Op (C.>>=)))+  bind = Var (Qualified Nothing (Op (C.>>=)))    replace :: Expr -> m Expr   replace (Do els) = go els

@@ -116,7 +116,7 @@       checkOverlaps :: [DictionaryValue] -> Check Expr       checkOverlaps dicts =         case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of-          ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys (map fst ds)+          ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys $ nub (map fst ds)           _ -> case chooseSimplestDictionaries dicts of                  [] -> throwError . errorMessage $ NoInstanceFound className tys                  d : _ -> return $ dictionaryValueToValue d

@@ -23,7 +23,6 @@  import Control.Applicative import Control.Monad.Except-import Control.Monad.Reader.Class import Control.Monad.State import Control.Monad.Unify @@ -31,7 +30,6 @@ import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Names-import Language.PureScript.Options import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -98,12 +96,19 @@ -- | -- Update the visibility of all names to Defined ---makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a-makeBindingGroupVisible action = do-  orig <- get-  modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } }+makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m () +makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }++-- | Update the visibility of all names to Defined in the scope of the provided action+withBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a+withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action++-- | Perform an action while preserving the names from the @Environment@.+preservingNames :: (Functor m, MonadState CheckState m) => m a -> m a+preservingNames action = do+  orig <- gets (names . checkEnv)   a <- action-  modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }+  modifyEnv $ \e -> e { names = orig }   return a  -- |@@ -195,18 +200,16 @@ -- | -- Run a computation in the Check monad, starting with an empty @Environment@ ---runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment)+runCheck :: (MonadError MultipleErrors m) => Check a -> m (a, Environment) runCheck = runCheck' initEnvironment  -- | -- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@. ---runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)-runCheck' env c = do-  verbose <- asks optionsVerboseErrors-  interpretMultipleErrors verbose $ do-    (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c-    return (a, checkEnv s)+runCheck' :: (MonadError MultipleErrors m) => Environment -> Check a -> m (a, Environment)+runCheck' env c = interpretMultipleErrors $ do+  (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c+  return (a, checkEnv s)  -- | -- Make an assertion, failing with an error message

@@ -247,7 +247,7 @@ infer' (Abs (Left arg) ret) = do   ty <- fresh   Just moduleName <- checkCurrentModule <$> get-  makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do+  withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do     body@(TypedValue _ _ bodyTy) <- infer' ret     return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy infer' (Abs (Right _) _) = error "Binder was not desugared"@@ -298,7 +298,7 @@ infer' _ = error "Invalid argument to infer"  inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)-inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)+inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do   Just moduleName <- checkCurrentModule <$> get   (kind, args) <- liftCheck $ kindOfWithScopedVars ty@@ -320,7 +320,9 @@   ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict   ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict   let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']-  makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j+  bindNames dict $ do+    makeBindingGroupVisible+    inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do   (d' : ds', val') <- inferLetBinding seen (d : ds) ret j   return (PositionedDeclaration pos com d' : ds', val')@@ -442,7 +444,7 @@   dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do     n <- liftCheck freshDictionaryName     return $ Ident $ "__dict_" ++ className ++ "_" ++ show n-  val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->+  val' <- withBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->     TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)       constraints) $ check val ty   return $ TypedValue True (foldr (Abs . Left) val' dictNames) t@@ -468,7 +470,7 @@ check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do   t =?= tyFunction   Just moduleName <- checkCurrentModule <$> get-  ret' <- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy+  ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy   return $ TypedValue True (Abs (Left arg) ret') ty check' (Abs (Right _) _) _ = error "Binder was not desugared" check' (App f arg) ret = do

@@ -35,21 +35,21 @@   text <- readFile inputFile   return (inputFile, text) -loadPrelude :: Either String (String, String, P.Environment)+loadPrelude :: Either P.MultipleErrors (String, String, P.Environment) loadPrelude =   case P.parseModulesFromFiles id [("", P.prelude)] of-    Left parseError -> Left (show parseError)+    Left parseError -> Left . P.errorMessage . P.ErrorParsingPrelude $ parseError     Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] } -compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))+compile :: P.Options P.Compile -> [FilePath] -> IO (Either P.MultipleErrors (String, String, P.Environment)) compile opts inputFiles = do   modules <- P.parseModulesFromFiles id <$> readInput inputFiles   case modules of     Left parseError ->-      return (Left $ show parseError)+      return . Left . P.errorMessage . P.ErrorParsingPrelude $ parseError     Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts -assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()+assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO () assert preludeExterns opts inputFile f = do   e <- compile opts [preludeExterns, inputFile]   maybeErr <- f e@@ -64,7 +64,7 @@                               { P.optionsMain = Just "Main"                               , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]                               }-  assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do+  assert preludeExterns options inputFile $ either (return . Just . P.prettyPrintMultipleErrors False) $ \(js, _, _) -> do     process <- findNodeProcess     result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process     case result of@@ -77,7 +77,7 @@   putStrLn $ "Assert " ++ inputFile ++ " does not compile"   assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->     case e of-      Left err -> putStrLn err >> return Nothing+      Left errs -> putStrLn  (P.prettyPrintMultipleErrors False errs) >> return Nothing       Right _ -> return $ Just "Should not have compiled"  findNodeProcess :: IO (Maybe String)@@ -88,7 +88,7 @@ main = do   putStrLn "Compiling Prelude"   case loadPrelude of-    Left err -> putStrLn err >> exitFailure+    Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure     Right (preludeJs, exts, _) -> do       tmp <- getTemporaryDirectory       let preludeExterns = tmp ++ pathSeparator : "prelude.externs"@@ -105,4 +105,3 @@       forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $         assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)       exitSuccess-