purescript 0.6.9.4 → 0.6.9.5

raw patch · 43 files changed

+1502/−2340 lines, 43 filesdep −HUnitdep ~basedep ~directorydep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: HUnit

Dependency ranges changed: base, directory, mtl, transformers

API changes (from Hackage documentation)

Files

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

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

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

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

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

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

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

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

@@ -35,13 +35,21 @@     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"

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

@@ -61,6 +61,9 @@   test15 :: Number -> Number -> Boolean   test15 a b = const false $ a `test14` b +  test16 :: Number -> Number -> Number+  test16 x y = x .|. y .&. y+   test17 :: Number   test17 = negate (-1) @@ -91,6 +94,7 @@     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

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

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

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

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

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

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

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

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

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

@@ -0,0 +1,702 @@+-----------------------------------------------------------------------------+--+-- 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

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

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

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

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

@@ -1,5 +1,5 @@ name: purescript-version: 0.6.9.4+version: 0.6.9.5 cabal-version: >=1.8 build-type: Simple license: MIT@@ -148,12 +148,10 @@      main-is: Main.hs     buildable: True-    hs-source-dirs: psci psci/main-    other-modules: Types+    hs-source-dirs: psci+    other-modules: Commands                    Parser                    Directive-                   Completion-                   PSCi     ghc-options: -Wall -O2  executable psc-docs@@ -184,14 +182,3 @@     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 MultipleErrors m, MonadReader (Options Compile) m)+compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)         => [Module] -> [String] -> m (String, String, Environment) compile = compile' initEnvironment -compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)+compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)          => Environment -> [Module] -> [String] -> m (String, String, Environment) compile' env ms prefix = do   noPrelude <- asks optionsNoPrelude   additional <- asks optionsAdditional   mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)   (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms-  (desugared, nextVar) <- runSupplyT 0 $ desugar sorted+  (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted   (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent-  regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated+  regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated   let corefn = map (CoreFn.moduleToCoreFn env') regrouped   let entryPoints = moduleNameFromString `map` entryPointModules additional   let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn@@ -115,21 +115,21 @@   let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']   return (pjs, exts, env') -generateMain :: (MonadError MultipleErrors m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]+generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS] generateMain env js = do   main <- asks optionsMain   additional <- asks optionsAdditional   case moduleNameFromString <$> main of     Just mmi -> do       when ((mmi, Ident C.main) `M.notMember` names env) $-        throwError . errorMessage $ NameIsUndefined (Ident C.main)+        throwError $ show mmi ++ "." ++ C.main ++ " is undefined"       return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]     _ -> return js  -- | -- A type class which collects the IO actions we need to be able to run in "make" mode ---class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m) => MonadMake m where+class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where   -- |   -- Get a file timestamp   --@@ -196,7 +196,7 @@    marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted -  (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)+  (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)    evalSupplyT nextVar $ go initEnvironment desugared @@ -216,7 +216,7 @@      (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m -    regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated+    regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated      let mod' = Module coms moduleName' regrouped exps     let corefn = CoreFn.moduleToCoreFn env' mod'@@ -240,10 +240,10 @@   rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do     let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"     externs <- readTextFile externsFile-    externsModules <- fmap (map snd) . either (throwError . errorMessage . ErrorParsingExterns) return $ P.parseModulesFromFiles id [(externsFile, externs)]+    externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]     case externsModules of       [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'-      _ -> throwError . errorMessage . InvalidExternsFile $ externsFile+      _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"  reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName] reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

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

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

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

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

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

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

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

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

@@ -157,6 +157,7 @@ -- 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

@@ -25,7 +25,7 @@ import Data.List (nub, groupBy)  import Control.Applicative-import Control.Monad ((<=<), forM, replicateM, join, unless)+import Control.Monad ((<=<), forM, join, unless, replicateM) import Control.Monad.Except (throwError) import Control.Monad.Error.Class (MonadError) import Control.Monad.Supply.Class@@ -130,20 +130,12 @@       value = foldr (Abs . Left) (Case vars binders) args   return $ ValueDeclaration ident Value [] (Right value)   where-  -- We will construct a table of potential names.-  -- VarBinders will become Just (Just _) which is a potential name.-  -- NullBinder will become Just Nothing, which indicates that we may -  -- have to generate a name.-  -- Everything else becomes Nothing, which indicates that we definitely-  --have to generate a name.   findName :: Binder -> Maybe (Maybe Ident)   findName NullBinder = Just Nothing   findName (VarBinder name) = Just (Just name)   findName (PositionedBinder _ _ binder) = findName binder   findName _ = Nothing -  -- We still have to make sure the generated names are unique, or else-  -- we will end up constructing an invalid function.   allUnique :: (Eq a) => [a] -> Bool   allUnique xs = length xs == length (nub xs) @@ -153,15 +145,11 @@     name <- freshName     return (Ident name) -  -- Combine two lists of potential names from two case alternatives-  -- by zipping correspoding columns.   resolveNames :: [Maybe (Maybe Ident)] ->                    [Maybe (Maybe Ident)] ->                    [Maybe (Maybe Ident)]   resolveNames = zipWith resolveName -  -- Resolve a pair of names. VarBinder beats NullBinder, and everything-  -- else results in Nothing.   resolveName :: Maybe (Maybe Ident) ->                   Maybe (Maybe Ident) ->                   Maybe (Maybe Ident)

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

@@ -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 $ nub (map fst ds)+          ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys (map fst ds)           _ -> case chooseSimplestDictionaries dicts of                  [] -> throwError . errorMessage $ NoInstanceFound className tys                  d : _ -> return $ dictionaryValueToValue d

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

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

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