purescript 0.8.0.0 → 0.8.1.0

raw patch · 140 files changed

+8669/−2784 lines, 140 filesdep +edit-distancedep +fsnotifydep +hspecdep ~Globdep ~aesondep ~basenew-component:exe:psc-ide-clientnew-component:exe:psc-ide-serverPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: edit-distance, fsnotify, hspec, hspec-discover, http-types, monad-logger, network, pipes, pipes-http, regex-tdfa, sourcemap, stm

Dependency ranges changed: Glob, aeson, base, boxes, mtl, optparse-applicative, process, transformers

API changes (from Hackage documentation)

Files

• CONTRIBUTORS.md +8/−7
• LICENSE +34/−0
• examples/docs/src/ExplicitTypeSignatures.purs +16/−0
• examples/failing/AnonArgument1.purs +5/−0
• examples/failing/AnonArgument2.purs +7/−0
• examples/failing/AnonArgument3.purs +5/−0
• examples/failing/ConflictingExports2.purs +0/−13
• examples/failing/ConflictingImports2.purs +8/−4
• examples/failing/DctorOperatorAliasExport.purs +6/−0
• examples/failing/InvalidOperatorInBinder.purs +12/−0
• examples/passing/DctorOperatorAlias.purs +35/−0
• examples/passing/Deriving.purs +31/−0
• examples/passing/ExplicitOperatorSections.purs +14/−0
• examples/passing/ResolvableScopeConflict.purs +25/−0
• examples/passing/ResolvableScopeConflict2.purs +22/−0
• examples/passing/ResolvableScopeConflict3.purs +15/−0
• psc-docs/Main.hs +6/−6
• psc-ide-client/Main.hs +57/−0
• psc-ide-server/Main.hs +135/−0
• psc/Main.hs +6/−0
• psci/Completion.hs +0/−226
• psci/Directive.hs +0/−115
• psci/IO.hs +0/−21
• psci/PSCi.hs +122/−452
• psci/PSCi/Completion.hs +226/−0
• psci/PSCi/Directive.hs +119/−0
• psci/PSCi/IO.hs +68/−0
• psci/PSCi/Message.hs +53/−0
• psci/PSCi/Module.hs +106/−0
• psci/PSCi/Option.hs +57/−0
• psci/PSCi/Parser.hs +140/−0
• psci/PSCi/Printer.hs +131/−0
• psci/PSCi/Types.hs +218/−0
• psci/Parser.hs +0/−140
• psci/Types.hs +0/−215
• psci/tests/Main.hs +0/−162
• psci/tests/data/Sample.purs +0/−0
• purescript.cabal +104/−35
• src/Language/PureScript/AST/Binders.hs +20/−0
• src/Language/PureScript/AST/Declarations.hs +8/−11
• src/Language/PureScript/AST/Traversals.hs +16/−18
• src/Language/PureScript/CodeGen/JS.hs +140/−123
• src/Language/PureScript/CodeGen/JS/AST.hs +168/−97
• src/Language/PureScript/CodeGen/JS/Optimizer.hs +5/−5
• src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs +4/−4
• src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +18/−18
• src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +50/−50
• src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +34/−34
• src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +33/−31
• src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs +3/−3
• src/Language/PureScript/Constants.hs +3/−0
• src/Language/PureScript/CoreFn/Binders.hs +9/−2
• src/Language/PureScript/CoreFn/Desugar.hs +51/−20
• src/Language/PureScript/CoreFn/Expr.hs +3/−5
• src/Language/PureScript/CoreFn/Meta.hs +2/−4
• src/Language/PureScript/CoreFn/Module.hs +1/−1
• src/Language/PureScript/CoreFn/Traversals.hs +2/−2
• src/Language/PureScript/Docs.hs +1/−1
• src/Language/PureScript/Docs/AsMarkdown.hs +7/−9
• src/Language/PureScript/Docs/Convert.hs +139/−30
• src/Language/PureScript/Docs/Convert/ReExports.hs +3/−3
• src/Language/PureScript/Docs/Convert/Single.hs +7/−3
• src/Language/PureScript/Docs/ParseAndBookmark.hs +100/−0
• src/Language/PureScript/Docs/ParseAndDesugar.hs +0/−137
• src/Language/PureScript/Docs/Render.hs +5/−1
• src/Language/PureScript/Docs/Types.hs +8/−5
• src/Language/PureScript/Errors.hs +75/−20
• src/Language/PureScript/Externs.hs +3/−2
• src/Language/PureScript/Ide.hs +199/−0
• src/Language/PureScript/Ide/CaseSplit.hs +157/−0
• src/Language/PureScript/Ide/CodecJSON.hs +13/−0
• src/Language/PureScript/Ide/Command.hs +101/−0
• src/Language/PureScript/Ide/Completion.hs +35/−0
• src/Language/PureScript/Ide/Error.hs +43/−0
• src/Language/PureScript/Ide/Externs.hs +102/−0
• src/Language/PureScript/Ide/Filter.hs +110/−0
• src/Language/PureScript/Ide/Matcher.hs +100/−0
• src/Language/PureScript/Ide/Pursuit.hs +65/−0
• src/Language/PureScript/Ide/Reexports.hs +73/−0
• src/Language/PureScript/Ide/SourceFile.hs +106/−0
• src/Language/PureScript/Ide/State.hs +80/−0
• src/Language/PureScript/Ide/Types.hs +240/−0
• src/Language/PureScript/Ide/Watcher.hs +40/−0
• src/Language/PureScript/Linter.hs +1/−0
• src/Language/PureScript/Linter/Imports.hs +14/−5
• src/Language/PureScript/Make.hs +41/−6
• src/Language/PureScript/ModuleDependencies.hs +2/−1
• src/Language/PureScript/Options.hs +4/−1
• src/Language/PureScript/Parser/Declarations.hs +34/−23
• src/Language/PureScript/Pretty.hs +0/−3
• src/Language/PureScript/Pretty/Common.hs +96/−9
• src/Language/PureScript/Pretty/JS.hs +118/−105
• src/Language/PureScript/Pretty/Values.hs +1/−5
• src/Language/PureScript/Publish.hs +4/−4
• src/Language/PureScript/Renamer.hs +9/−9
• src/Language/PureScript/Sugar/Names.hs +10/−6
• src/Language/PureScript/Sugar/Names/Env.hs +55/−15
• src/Language/PureScript/Sugar/Names/Exports.hs +5/−5
• src/Language/PureScript/Sugar/Names/Imports.hs +36/−27
• src/Language/PureScript/Sugar/ObjectWildcards.hs +36/−15
• src/Language/PureScript/Sugar/Operators.hs +92/−79
• src/Language/PureScript/Sugar/Operators/Binders.hs +43/−0
• src/Language/PureScript/Sugar/Operators/Common.hs +53/−0
• src/Language/PureScript/Sugar/Operators/Expr.hs +52/−0
• src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +274/−127
• src/Language/PureScript/TypeChecker.hs +45/−22
• src/Language/PureScript/TypeChecker/Types.hs +12/−3
• stack-lts-2.yaml +6/−2
• stack-lts-3.yaml +3/−2
• stack-nightly.yaml +2/−2
• stack.yaml +3/−3
• tests/Main.hs +11/−204
• tests/PscIdeSpec.hs +1/−0
• tests/TestCompiler.hs +194/−0
• tests/TestDocs.hs +50/−13
• tests/TestPscIde.hs +7/−0
• tests/TestPscPublish.hs +9/−8
• tests/TestPsci.hs +159/−0
• tests/TestUtils.hs +65/−0
• tests/common/TestsSetup.hs +0/−45
• tests/support/flattened/Control-Monad-Eff-Class.purs +24/−0
• tests/support/flattened/Control-Monad-Eff-Console.js +18/−0
• tests/support/flattened/Control-Monad-Eff-Console.purs +18/−0
• tests/support/flattened/Control-Monad-Eff-Unsafe.js +8/−0
• tests/support/flattened/Control-Monad-Eff-Unsafe.purs +10/−0
• tests/support/flattened/Control-Monad-Eff.js +62/−0
• tests/support/flattened/Control-Monad-Eff.purs +67/−0
• tests/support/flattened/Control-Monad-ST.js +38/−0
• tests/support/flattened/Control-Monad-ST.purs +42/−0
• tests/support/flattened/Data-Function.js +233/−0
• tests/support/flattened/Data-Function.purs +113/−0
• tests/support/flattened/Prelude.js +228/−0
• tests/support/flattened/Prelude.purs +872/−0
• tests/support/flattened/Test-Assert.js +27/−0
• tests/support/flattened/Test-Assert.purs +46/−0
• tests/support/prelude/LICENSE +20/−0
• tests/support/prelude/bower.json +23/−0
• tests/support/prelude/src/Prelude.js +228/−0
• tests/support/prelude/src/Prelude.purs +872/−0
• tests/support/psci/Sample.purs +0/−0

@@ -13,7 +13,10 @@ - [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dckc](https://github.com/dckc) (Dan Connolly) My existing contributions and all future contributions until further notice are Copyright Dan Connolly, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dylex](https://github.com/dylex) (Dylan Simon) My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@eamelink](https://github.com/eamelink) (Erik Bakker) - My existing contributions and all future contributions until further notice are Copyright Erik Bakker, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.@@ -22,6 +25,7 @@ - [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.@@ -42,6 +46,7 @@ - [@nwolverson](https://github.com/nwolverson) (Nicholas Wolverson) My existing contributions and all future contributions until further notice are Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@osa1](https://github.com/osa1) (Ömer Sinan Ağacan) - My existing contributions and all future contributions until further notice are Copyright Ömer Sinan Ağacan, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@paf31](https://github.com/paf31) (Phil Freeman) My existing contributions and all future contributions until further notice are Copyright Phil Freeman, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@pelotom](https://github.com/pelotom) (Thomas Crockett) My existing contributions and all future contributions until further notice are Copyright Thomas Crockett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@phadej](https://github.com/phadej) (Oleg Grenrus) My existing contributions and all future contributions until further notice are Copyright Oleg Grenrus, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).@@ -51,20 +56,16 @@ - [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.+- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).-- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).-<http://opensource.org/licenses/MIT>.-- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).-- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).-- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).-- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).-- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).  ### Companies 

@@ -63,6 +63,7 @@   safe   scientific   semigroups+  sourcemap   split   stm   syb@@ -1588,6 +1589,39 @@   STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN   ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE   POSSIBILITY OF SUCH DAMAGE.++sourcemap LICENSE file:++  Copyright (c) 2012, Chris Done++  All rights reserved.++  Redistribution and use in source and binary forms, with or without+  modification, are permitted provided that the following conditions are met:++      * Redistributions of source code must retain the above copyright+        notice, this list of conditions and the following disclaimer.++      * Redistributions in binary form must reproduce the above+        copyright notice, this list of conditions and the following+        disclaimer in the documentation and/or other materials provided+        with the distribution.++      * Neither the name of Chris Done nor the names of other+        contributors may be used to endorse or promote products derived+        from this software without specific prior written permission.++  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+  OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+  DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+  THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+  OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  split LICENSE file: 

@@ -0,0 +1,16 @@++module ExplicitTypeSignatures where++-- This should use the explicit type signature so that the type variable name+-- is preserved.+explicit :: forall something. something -> something+explicit x+  | true = x+  | false = x++-- This should use the inferred type.+anInt :: _+anInt = 0++-- This should infer a type.+aNumber = 1.0

@@ -0,0 +1,5 @@+-- @shouldFailWith IncorrectAnonymousArgument+module Main where++test :: Int -> Int+test = _

@@ -0,0 +1,7 @@+-- @shouldFailWith IncorrectAnonymousArgument+module Main where++import Prelude++test :: Int -> Int+test = 1 + 2 * _

@@ -0,0 +1,5 @@+-- @shouldFailWith IncorrectAnonymousArgument+module Main where++test :: Int -> Int+test = 1 + _

@@ -1,13 +0,0 @@--- @shouldFailWith ScopeConflict-module A where--  thing :: Int-  thing = 1---- Fails here because re-exporting forces any scope conflicts to be resolved-module Main (thing, module A) where--  import A--  thing :: Int-  thing = 2

@@ -4,13 +4,17 @@   thing :: Int   thing = 1 -module Main where--  import A+module B where    thing :: Int   thing = 2 -  -- Error due to referencing `thing` which is in scope as A.thing and Main.thing+module Main where++  import A (thing)+  import B (thing)++  -- Error due to referencing `thing` which is explicitly in scope as A.thing+  -- and B.thing   what :: Int   what = thing

@@ -0,0 +1,6 @@+-- @shouldFailWith TransitiveDctorExportError+module Data.List (List, (:)) where++  data List a = Cons a (List a) | Nil++  infixr 6 Cons as :

@@ -0,0 +1,12 @@+-- @shouldFailWith InvalidOperatorInBinder+module Main where++data List a = Cons a (List a) | Nil++cons ∷ ∀ a. a → List a → List a+cons = Cons++infixl 6 cons as :++get ∷ ∀ a. List a → a+get (_ : x : _) = x

@@ -0,0 +1,35 @@+module Data.List where++  data List a = Cons a (List a) | Nil++  infixr 6 Cons as :++module Main where++  import Prelude (Unit, bind, (==))+  import Control.Monad.Eff (Eff)+  import Control.Monad.Eff.Console (CONSOLE, log)+  import Test.Assert (ASSERT, assert')+  import Data.List (List(..), (:))++  infixl 6 Cons as !++  get1 ∷ ∀ a. a → List a → a+  get1 y xs = case xs of+    _ : x : _ → x+    _ → y++  get2 ∷ ∀ a. a → List a → a+  get2 _ (_ : x : _) = x+  get2 y _ = y++  get3 ∷ ∀ a. a → List a → a+  get3 _ (_ ! (x ! _)) = x+  get3 y _ = y++  main ∷ Eff (assert ∷ ASSERT, console ∷ CONSOLE) Unit+  main = do+    assert' "Incorrect result!" (get1 0 (1 : 2 : 3 : Nil) == 2)+    assert' "Incorrect result!" (get2 0 (1 ! (2 ! (3 ! Nil))) == 2)+    assert' "Incorrect result!" (get3 0.0 (1.0 : 2.0 : (3.0 ! Nil)) == 2.0)+    log "Done"

@@ -0,0 +1,31 @@+module Main where++import Prelude+import Test.Assert++data V++derive instance eqV :: Eq V++derive instance ordV :: Ord V++data X = X Int | Y String++derive instance eqX :: Eq X++derive instance ordX :: Ord X++newtype Z = Z { left :: X, right :: X }++derive instance eqZ :: Eq Z++main = do+  assert $ X 0 == X 0+  assert $ X 0 /= X 1+  assert $ Y "Foo" == Y "Foo"+  assert $ Y "Foo" /= Y "Bar"+  assert $ X 0 < X 1+  assert $ X 0 < Y "Foo"+  assert $ Y "Bar" < Y "Baz"+  assert $ z == z where+    z = Z { left: X 0, right: Y "Foo" }

@@ -0,0 +1,14 @@+module Main where++import Prelude++subtractOne :: Int -> Int+subtractOne = (_ - 1)++addOne :: Int -> Int+addOne = (1 + _)++named :: Int -> Int+named = (_ `sub` 1)++main = Control.Monad.Eff.Console.log "Done"

@@ -0,0 +1,25 @@+module A where++  thing :: Int+  thing = 1++module B where++  thing :: Int+  thing = 2++  zing :: Int+  zing = 3++module Main where++  import A (thing)+  import B++  -- Not an error as although we have `thing` in scope from both A and B, it is+  -- imported explicitly from A, giving it a resolvable solution.+  what :: Boolean -> Int+  what true = thing+  what false = zing++  main = Control.Monad.Eff.Console.log "Done"

@@ -0,0 +1,22 @@+module A where++  thing :: Int+  thing = 2++  zing :: Int+  zing = 3++module Main where++  import A++  thing :: Int+  thing = 1++  -- Not an error as although we have `thing` in scope from both Main and A,+  -- as the local declaration takes precedence over the implicit import+  what :: Boolean -> Int+  what true = thing+  what false = zing++  main = Control.Monad.Eff.Console.log "Done"

@@ -0,0 +1,15 @@+module A where++  thing :: Int+  thing = 1++module Main (thing, main, module A) where++  import A++  thing :: Int+  thing = 2++  main = Control.Monad.Eff.Console.log "Done"++

@@ -69,19 +69,19 @@     Etags -> dumpTags input dumpEtags     Ctags -> dumpTags input dumpCtags     Markdown -> do-      ms <- runExceptT (D.parseAndDesugar input []-                           >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))+      ms <- runExceptT (D.parseAndBookmark input []+                           >>= (fst >>> D.convertModulesInPackage))                >>= successOrExit        case output of         EverythingToStdOut ->           putStrLn (D.runDocs (D.modulesAsMarkdown ms))         ToStdOut names -> do-          let (ms', missing) = takeByName ms (map P.runModuleName names)+          let (ms', missing) = takeByName ms names           guardMissing missing           putStrLn (D.runDocs (D.modulesAsMarkdown ms'))         ToFiles names -> do-          let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)+          let (ms', missing) = takeByName' ms names           guardMissing missing            let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'@@ -93,12 +93,12 @@   where   guardMissing [] = return ()   guardMissing [mn] = do-    hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")+    hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ P.runModuleName mn ++ "\"")     exitFailure   guardMissing mns = do     hPutStrLn stderr "psc-docs: error: unknown modules:"     forM_ mns $ \mn ->-      hPutStrLn stderr ("  * " ++ mn)+      hPutStrLn stderr ("  * " ++ P.runModuleName mn)     exitFailure    successOrExit :: Either P.MultipleErrors a -> IO a

@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import           Prelude             ()+import           Prelude.Compat++import           Control.Exception+import           Data.Maybe          (fromMaybe)+import           Data.Text           (Text)+import qualified Data.Text           as T+import qualified Data.Text.IO        as T+import           Data.Version        (showVersion)+import           Network+import           Options.Applicative+import           System.Exit+import           System.IO++import qualified Paths_purescript    as Paths++data Options = Options+    { optionsPort :: Maybe Int+    }++main :: IO ()+main = do+    Options port <- execParser opts+    let port' = PortNumber . fromIntegral $ fromMaybe 4242 port+    client port'+  where+    parser =+        Options <$>+          optional (option auto (long "port" <> short 'p'))+    opts = info (version <*> parser) mempty+    version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden++client :: PortID -> IO ()+client port = do+    h <-+        connectTo "localhost" port `catch`+        (\(SomeException e) ->+              putStrLn+                  ("Couldn't connect to psc-ide-server on port: " +++                   show port ++ " Error: " ++ show e) >>+              exitFailure)+    cmd <- T.getLine+    -- Temporary fix for emacs windows bug+    let cleanedCmd = removeSurroundingTicks cmd+    --+    T.hPutStrLn h cleanedCmd+    res <- T.hGetLine h+    putStrLn (T.unpack res)+    hFlush stdout+    hClose h++-- TODO: Fix this in the emacs plugin by using a real process over shellcommands+removeSurroundingTicks :: Text -> Text+removeSurroundingTicks = T.dropWhile (== '\'') . T.dropWhileEnd (== '\'')

@@ -0,0 +1,135 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PackageImports        #-}+{-# LANGUAGE TemplateHaskell       #-}+module Main where++import           Prelude                           ()+import           Prelude.Compat++import           Control.Concurrent                (forkFinally)+import           Control.Concurrent.STM+import           Control.Exception                 (bracketOnError)+import           Control.Monad+import           "monad-logger" Control.Monad.Logger+import           Control.Monad.Reader+import           Control.Monad.Trans.Except+import qualified Data.Text                         as T+import qualified Data.Text.IO                      as T+import           Data.Version                      (showVersion)+import           Language.PureScript.Ide+import           Language.PureScript.Ide.CodecJSON+import           Language.PureScript.Ide.Error+import           Language.PureScript.Ide.Types+import           Language.PureScript.Ide.Watcher+import           Network                           hiding (socketPort)+import           Network.BSD                       (getProtocolNumber)+import           Network.Socket                    hiding (PortNumber, Type,+                                                    accept, sClose)+import           Options.Applicative+import           System.Directory+import           System.FilePath+import           System.IO++import qualified Paths_purescript                  as Paths++-- "Borrowed" from the Idris Compiler+-- Copied from upstream impl of listenOn+-- bound to localhost interface instead of iNADDR_ANY+listenOnLocalhost :: PortID -> IO Socket+listenOnLocalhost (PortNumber port) = do+  proto <- getProtocolNumber "tcp"+  localhost <- inet_addr "127.0.0.1"+  bracketOnError+    (socket AF_INET Stream proto)+    sClose+    (\sock -> do+      setSocketOption sock ReuseAddr 1+      bindSocket sock (SockAddrInet port localhost)+      listen sock maxListenQueue+      pure sock)+listenOnLocalhost _ = error "Wrong Porttype"++data Options = Options+  { optionsDirectory  :: Maybe FilePath+  , optionsOutputPath :: FilePath+  , optionsPort       :: PortID+  , optionsDebug      :: Bool+  }++main :: IO ()+main = do+  Options dir outputPath port debug  <- execParser opts+  maybe (pure ()) setCurrentDirectory dir+  serverState <- newTVarIO emptyPscIdeState+  cwd <- getCurrentDirectory+  _ <- forkFinally (watcher serverState (cwd </> outputPath)) print+  let conf =+        Configuration+        {+          confDebug = debug+        , confOutputPath = outputPath+        }+  let env =+        PscIdeEnvironment+        {+          envStateVar = serverState+        , envConfiguration = conf+        }+  startServer port env+  where+    parser =+      Options <$>+        optional (strOption (long "directory" <> short 'd')) <*>+        strOption (long "output-directory" <> value "output/") <*>+        (PortNumber . fromIntegral <$>+         option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*>+        switch (long "debug")+    opts = info (version <*> parser) mempty+    version = abortOption+      (InfoMsg (showVersion Paths.version))+      (long "version" <> help "Show the version number")++startServer :: PortID -> PscIdeEnvironment -> IO ()+startServer port env = withSocketsDo $ do+  sock <- listenOnLocalhost port+  runLogger (runReaderT (forever (loop sock)) env)+  where+    runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (envConfiguration env))++    loop :: (PscIde m, MonadLogger m) => Socket -> m ()+    loop sock = do+      (cmd,h) <- acceptCommand sock+      case decodeT cmd of+        Just cmd' -> do+          result <- runExceptT (handleCommand cmd')+          $(logDebug) ("Answer was: " <> T.pack (show result))+          liftIO (hFlush stdout)+          case result of+            -- What function can I use to clean this up?+            Right r  -> liftIO $ T.hPutStrLn h (encodeT r)+            Left err -> liftIO $ T.hPutStrLn h (encodeT err)+        Nothing -> do+          $(logDebug) ("Parsing the command failed. Command: " <> cmd)+          liftIO $ do+            T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))+            hFlush stdout+      liftIO (hClose h)+++acceptCommand :: (Applicative m, MonadIO m, MonadLogger m)+                 => Socket -> m (T.Text, Handle)+acceptCommand sock = do+  h <- acceptConnection+  $(logDebug) "Accepted a connection"+  cmd <- liftIO (T.hGetLine h)+  $(logDebug) cmd+  pure (cmd, h)+  where+   acceptConnection = liftIO $ do+     (h,_,_) <- accept sock+     hSetEncoding h utf8+     hSetBuffering h LineBuffering+     pure h

@@ -177,7 +177,12 @@ jsonErrors = switch $      long "json-errors"   <> help "Print errors to stderr as JSON"+sourceMaps :: Parser Bool+sourceMaps = switch $+     long "source-maps"+  <> help "Generate source maps" + options :: Parser P.Options options = P.Options <$> noTco                     <*> noMagicDo@@ -186,6 +191,7 @@                     <*> verboseErrors                     <*> (not <$> comments)                     <*> requirePath+                    <*> sourceMaps  pscMakeOptions :: Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile

@@ -1,226 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Completion where--import Prelude ()-import Prelude.Compat--import Data.Maybe (mapMaybe)-import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix)-import Data.Char (isUpper)-import Data.Function (on)--import Control.Arrow (second)-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, Read)---- |--- 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 w Foreign     = [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 :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]-mapLoadedModulesAndQualify sho f = do-  ms <- getLoadedModules-  let argPairs = do m <- ms-                    fm <- f m-                    return (m, fm)-  concat <$> traverse (uncurry (getAllQualifications sho)) argPairs--getIdentNames :: CompletionM [String]-getIdentNames = mapLoadedModulesAndQualify P.showIdent identNames--getDctorNames :: CompletionM [String]-getDctorNames = mapLoadedModulesAndQualify P.runProperName dctorNames--getTypeNames :: CompletionM [String]-getTypeNames = mapLoadedModulesAndQualify P.runProperName 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 :: (a -> String) -> P.Module -> (a, P.Declaration) -> CompletionM [String]-getAllQualifications sho 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 = P.showQualified sho (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 -> [q | referencedBy refs]-          P.Hiding refs   -> [q | not $ referencedBy refs]----- | 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 'N.TypeName, P.Declaration)]-typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations-  where-  getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, 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 . concatMap getDeclNames . P.exportedDeclarations-  where-  getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)]-  getDeclNames d@(P.ValueDeclaration ident _ _ _)  = [(ident, d)]-  getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)]-  getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)]-  getDeclNames d@(P.TypeClassDeclaration _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds-  getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d-  getDeclNames _ = []--dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]-dctorNames = nubOnFst . concatMap go . P.exportedDeclarations-  where-  go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]-  go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)-  go (P.PositionedDeclaration _ _ d) = go d-  go _ = []--moduleNames :: [P.Module] -> [String]-moduleNames ms = nub [P.runModuleName 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

@@ -1,115 +0,0 @@------------------------------------------------------------------------------------ Module      :  Directive--- Copyright   :--- License     :  MIT------ Maintainer  :--- Stability   :  experimental--- Portability :------ |--- Directives for PSCI.-----------------------------------------------------------------------------------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"])-    , (Foreign, ["foreign"])-    , (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---- |--- Returns all possible string representations of a directive.----stringsFor :: Directive -> [String]-stringsFor d = fromJust (lookup d directiveStrings)---- |--- Returns the default string representation of a directive.----stringFor :: Directive -> String-stringFor = head . stringsFor---- |--- Returns the list of directives which could be expanded from the string--- argument, together with the string alias that matched.----directivesFor' :: String -> [(Directive, String)]-directivesFor' str = go directiveStrings'-  where-  go = map swap . filter ((str `isPrefixOf`) . fst)--directivesFor :: String -> [Directive]-directivesFor = map fst . directivesFor'--directiveStringsFor :: String -> [String]-directiveStringsFor = map snd . directivesFor'--parseDirective :: String -> Maybe Directive-parseDirective = listToMaybe . directivesFor---- |--- True if the given directive takes an argument, false otherwise.-hasArgument :: Directive -> Bool-hasArgument Help = False-hasArgument Quit = False-hasArgument Reset = False-hasArgument _ = True---- |--- The help menu.----help :: [(Directive, String, String)]-help =-  [ (Help,    "",         "Show this help menu")-  , (Quit,    "",         "Quit PSCi")-  , (Reset,   "",         "Discard all imported modules and declared bindings")-  , (Browse,  "<module>", "See all functions in <module>")-  , (Load,    "<file>",   "Load <file> for importing")-  , (Foreign, "<file>",   "Load foreign module <file>")-  , (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")-  ]-

@@ -1,21 +0,0 @@------------------------------------------------------------------------------------ Module      :  IO--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |-----------------------------------------------------------------------------------module IO where--import System.Directory (createDirectoryIfMissing)-import System.FilePath (takeDirectory)--mkdirp :: FilePath -> IO ()-mkdirp = createDirectoryIfMissing True . takeDirectory

@@ -7,16 +7,14 @@ -- | -- PureScript Compiler Interactive. ---module PSCi where+module PSCi (runPSCi) where  import Prelude () import Prelude.Compat  import Data.Foldable (traverse_)-import Data.Maybe (mapMaybe)-import Data.List (intersperse, intercalate, nub, sort, find)+import Data.List (intercalate, nub, sort, find) import Data.Tuple (swap)-import Data.Version (showVersion) import qualified Data.Map as M  import Control.Arrow (first)@@ -24,103 +22,88 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Class import Control.Monad.Trans.Except (ExceptT(), runExceptT)-import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.State.Strict import Control.Monad.IO.Class (liftIO) import Control.Monad.Writer.Strict (Writer(), runWriter) -import Options.Applicative as Opts- import System.Console.Haskeline-import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)+import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory) import System.Exit-import System.FilePath (pathSeparator, (</>), isPathSeparator)+import System.FilePath ((</>)) import System.FilePath.Glob (glob) import System.Process (readProcessWithExitCode) import System.IO.Error (tryIOError)-import qualified Text.PrettyPrint.Boxes as Box  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 Completion (completion)-import IO (mkdirp)-import Parser (parseCommand)-import Types---- | The name of the PSCI support module-supportModuleName :: P.ModuleName-supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]---- | Support module, contains code to evaluate terms-supportModule :: P.Module-supportModule =-  case P.parseModulesFromFiles id [("", code)] of-    Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps-    _ -> P.internalError "Support module could not be parsed"-  where-  code :: String-  code = unlines-    [ "module S where"-    , ""-    , "import Prelude"-    , "import Control.Monad.Eff"-    , "import Control.Monad.Eff.Console"-    , "import Control.Monad.Eff.Unsafe"-    , ""-    , "class Eval a where"-    , "  eval :: a -> Eff (console :: CONSOLE) Unit"-    , ""-    , "instance evalShow :: (Show a) => Eval a where"-    , "  eval = print"-    , ""-    , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"-    , "  eval x = unsafeInterleaveEff x >>= eval"-    ]---- File helpers--onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)-onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants+import PSCi.Completion (completion)+import PSCi.Parser (parseCommand)+import PSCi.Option+import PSCi.Types+import PSCi.Message+import PSCi.IO+import PSCi.Printer+import PSCi.Module  -- |--- Locates the node executable.--- Checks for either @nodejs@ or @node@.+-- PSCI monad ---findNodeProcess :: IO (Maybe String)-findNodeProcess = onFirstFileMatching findExecutable names-  where names = ["nodejs", "node"]+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad) --- |--- 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+psciIO :: IO a -> PSCI a+psciIO io = PSCI . lift $ lift io  -- |--- Loads a file for use with imports.+-- The runner ---loadModule :: FilePath -> IO (Either String [P.Module])-loadModule filename = do-  content <- readFile filename-  return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]+runPSCi :: IO ()+runPSCi = getOpt >>= loop  -- |--- Load all modules.+-- The PSCI main loop. ---loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])-loadAllModules files = do-  filesAndContent <- forM files $ \filename -> do-    content <- readFile filename-    return (filename, content)-  return $ P.parseModulesFromFiles id filesAndContent+loop :: PSCiOptions -> IO ()+loop PSCiOptions{..} = do+  config <- loadUserConfig+  inputFiles <- concat <$> traverse glob psciInputFile+  foreignFiles <- concat <$> traverse glob psciForeignInputFiles+  modulesOrFirstError <- loadAllModules inputFiles+  case modulesOrFirstError of+    Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure+    Right modules -> do+      historyFilename <- getHistoryFilename+      let settings = defaultSettings { historyFile = Just historyFilename }+      foreignsOrError <- runMake $ do+        foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))+        P.parseForeignModulesFromFiles foreignFilesContent+      case foreignsOrError of+        Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure+        Right foreigns ->+          flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do+            outputStrLn prologueMessage+            traverse_ (traverse_ (runPSCI . handleCommand)) config+            modules' <- lift $ gets psciLoadedModules+            unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines+              [ "PSCi requires the purescript-console module to be installed."+              , "For help getting started, visit http://wiki.purescript.org/PSCi"+              ]+            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') -> do+              handleInterrupt (outputStrLn "Interrupted.")+                              (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))+              go +-- Compile the module+ -- | -- Load all modules, updating the application state --@@ -129,116 +112,9 @@   files <- PSCI . lift $ fmap psciImportedFilenames get   modulesOrFirstError <- psciIO $ loadAllModules files   case modulesOrFirstError of-    Left errs -> printErrors errs+    Left errs -> PSCI $ printErrors errs     Right modules -> PSCI . lift . modify $ updateModules 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 unwords [ 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!"---- |--- 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---- |--- 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"]-    trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))-    mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))-    itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val-    mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue-    decls = if exec then [itDecl, mainDecl] else [itDecl]-  in-    P.Module (P.internalModuleSourceSpan "<internal>") [] 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, psciLetBindings = lets} typ =-  let-    moduleName = P.ModuleName [P.ProperName "$PSCI"]-    itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ-  in-    P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [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 (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing--importDecl :: ImportedModule -> P.Declaration-importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False--indexFile :: FilePath-indexFile = ".psci_modules" ++ pathSeparator : "index.js"--modulesDir :: FilePath-modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"- -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the -- options and ignores the warning messages. runMake :: P.Make a -> IO (Either P.MultipleErrors a)@@ -258,7 +134,59 @@   loadedModules = psciLoadedModules st   allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms ++-- 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 = handleInterrupt (return (Right Nothing)) $ do+  firstLine <- withInterrupt $ getInputLine "> "+  case firstLine of+    Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty+    Just "" -> return (Right Nothing)+    Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s+    Just s -> fmap 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) = handleExpression val+handleCommand ShowHelp = PSCI $ outputStrLn helpMessage+handleCommand (Import im) = handleImport im+handleCommand (Decls l) = handleDecls l+handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do+  m <- lift . lift $ loadModule absPath+  case m of+    Left err -> outputStrLn err+    Right mods -> lift $ modify (updateModules (map (absPath,) mods))+handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do+  foreignsOrError <- lift . lift . runMake $ do+    foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)+    P.parseForeignModulesFromFiles [(absPath, foreignFile)]+  case foreignsOrError of+    Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err+    Right foreigns -> lift $ modify (updateForeignFiles foreigns)+handleCommand ResetState = do+  PSCI . lift . modify $ \st ->+    st { psciImportedModules = []+       , 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 = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."+++-- | -- Takes a value expression and evaluates it with the current state. -- handleExpression :: P.Expr -> PSCI ()@@ -268,7 +196,7 @@   let nodeArgs = psciNodeFlags st ++ [indexFile]   e <- psciIO . runMake $ make st [supportModule, m]   case e of-    Left errs -> printErrors errs+    Left errs -> PSCI $ printErrors errs     Right _ -> do       psciIO $ writeFile indexFile "require('$PSCI')['$main']();"       process <- psciIO findNodeProcess@@ -289,7 +217,7 @@   let m = createTemporaryModule False st' (P.ObjectLiteral [])   e <- psciIO . runMake $ make st' [m]   case e of-    Left err -> printErrors err+    Left err -> PSCI $ printErrors err     Right _ -> PSCI $ lift (put st')  -- |@@ -344,7 +272,7 @@    let m = createTemporaryModuleForImports st    e <- psciIO . runMake $ make st [m]    case e of-     Left errs -> printErrors errs+     Left errs -> PSCI $ printErrors errs      Right _  -> do        PSCI $ lift $ put st        return ()@@ -358,125 +286,13 @@   let m = createTemporaryModule False st val   e <- psciIO . runMake $ make st [m]   case e of-    Left errs -> printErrors errs+    Left errs -> PSCI $ 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 (P.Environment {..}) =-  PSCI $-    -- get relevant components of a module from environment-    let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names-        moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses-        moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types--  in-    -- print each component-    (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)-      [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses-      , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types-      , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions-      ]--  where printModule's showF = Box.vsep 1 Box.left . showF--        findNameType :: 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))-        findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)--        showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box-        showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType-        showNameType _ = P.internalError "The impossible happened in printModuleSignatures."--        findTypeClass-          :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])-          -> P.Qualified (P.ProperName 'P.ClassName)-          -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))-        findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)--        showTypeClass-          :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))-          -> Maybe Box.Box-        showTypeClass (_, Nothing) = Nothing-        showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =-            let constraints =-                    if null constrs-                    then Box.text ""-                    else Box.text "("-                         Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)-                         Box.<> Box.text ") <= "-                className =-                    Box.text (P.runProperName name)-                    Box.<> Box.text (concatMap ((' ':) . fst) vars)-                classBody =-                    Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)--            in-              Just $-                (Box.text "class "-                Box.<> constraints-                Box.<> className-                Box.<+> if null body then Box.text "" else Box.text "where")-                Box.// Box.moveRight 2 classBody---        findType-          :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)-          -> P.Qualified (P.ProperName 'P.TypeName)-          -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))-        findType envTypes name = (name, M.lookup name envTypes)--        showType-          :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])-          -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])-          -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)-          -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))-          -> Maybe Box.Box-        showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =-          case (typ, M.lookup n typeSynonymsEnv) of-            (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->-                if M.member (fmap P.coerceProperName n) typeClassesEnv-                then-                  Nothing-                else-                  Just $-                    Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)-                    Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)--            (Just (_, P.DataType typevars pt), _) ->-              let prefix =-                    case pt of-                      [(dtProperName,_)] ->-                        case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of-                          Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType-                          _ -> "data"-                      _ -> "data"--              in-                Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt--            _ ->-              Nothing--          where printCons pt =-                    Box.moveRight 2 $-                    Box.vcat Box.left $-                    mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $-                    map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt--                prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t--                mapFirstRest _ _ [] = []-                mapFirstRest f g (x:xs) = f x : map g xs--        trimEnd = reverse . dropWhile (== ' ') . reverse----- | -- Browse a module and displays its signature (if module exists). -- handleBrowse :: P.ModuleName -> PSCI ()@@ -484,14 +300,14 @@   st <- PSCI $ lift get   env <- psciIO . runMake $ make st []   case env of-    Left errs -> printErrors errs+    Left errs -> PSCI $ printErrors errs     Right env' ->       if isModInEnv moduleName st-        then printModuleSignatures moduleName env'+        then PSCI $ printModuleSignatures moduleName env'         else case lookupUnQualifiedModName moduleName st of           Just unQualifiedName ->             if isModInEnv unQualifiedName st-              then printModuleSignatures unQualifiedName env'+              then PSCI $ printModuleSignatures unQualifiedName env'               else failNotInEnv moduleName           Nothing ->             failNotInEnv moduleName@@ -503,10 +319,6 @@     lookupUnQualifiedModName quaModName st =         (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) --- | Pretty-print errors-printErrors :: P.MultipleErrors -> PSCI ()-printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False- -- | -- Takes a value and prints its kind --@@ -517,7 +329,7 @@       mName = P.ModuleName [P.ProperName "$PSCI"]   e <- psciIO . runMake $ make st [m]   case e of-    Left errs -> printErrors errs+    Left errs -> PSCI $ printErrors errs     Right env' ->       case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of         Just (_, typ') -> do@@ -531,63 +343,7 @@             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 = handleInterrupt (return (Right Nothing)) $ do-  firstLine <- withInterrupt $ getInputLine "> "-  case firstLine of-    Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty-    Just "" -> return (Right Nothing)-    Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s-    Just s -> fmap 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) = handleExpression val-handleCommand ShowHelp = PSCI $ outputStrLn helpMessage-handleCommand (Import im) = handleImport im-handleCommand (Decls l) = handleDecls l-handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do-  m <- psciIO $ loadModule absPath-  case m of-    Left err -> PSCI $ outputStrLn err-    Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods))-handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do-  foreignsOrError <- psciIO . runMake $ do-    foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)-    P.parseForeignModulesFromFiles [(absPath, foreignFile)]-  case foreignsOrError of-    Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err-    Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)-handleCommand ResetState = do-  PSCI . lift . modify $ \st ->-    st { psciImportedModules = []-       , 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 = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."--whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()-whenFileExists filePath f = do-  absPath <- psciIO $ expandTilde filePath-  exists <- psciIO $ doesFileExist absPath-  if exists-    then f absPath-    else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath+-- Misc  -- | -- Attempts to read initial commands from '.psci' in the present working@@ -610,92 +366,6 @@     else       return Nothing - -- | Checks if the Console module is defined consoleIsDefined :: [P.Module] -> Bool consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)---- |--- The PSCI main loop.----loop :: PSCiOptions -> IO ()-loop PSCiOptions{..} = do-  config <- loadUserConfig-  inputFiles <- concat <$> traverse glob psciInputFile-  foreignFiles <- concat <$> traverse glob psciForeignInputFiles-  modulesOrFirstError <- loadAllModules inputFiles-  case modulesOrFirstError of-    Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure-    Right modules -> do-      historyFilename <- getHistoryFilename-      let settings = defaultSettings { historyFile = Just historyFilename }-      foreignsOrError <- runMake $ do-        foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))-        P.parseForeignModulesFromFiles foreignFilesContent-      case foreignsOrError of-        Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure-        Right foreigns ->-          flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do-            outputStrLn prologueMessage-            traverse_ (traverse_ (runPSCI . handleCommand)) config-            modules' <- lift $ gets psciLoadedModules-            unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines-              [ "PSCi requires the purescript-console module to be installed."-              , "For help getting started, visit http://wiki.purescript.org/PSCi"-              ]-            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') -> do-              handleInterrupt (outputStrLn "Interrupted.")-                              (withInterrupt (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"--inputForeignFile :: Parser FilePath-inputForeignFile = strOption $-     short 'f'-  <> long "ffi"-  <> help "The input .js file(s) providing foreign import implementations"--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-                          <*> many inputForeignFile-                          <*> 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

@@ -0,0 +1,226 @@+{-# LANGUAGE DataKinds #-}++module PSCi.Completion where++import Prelude ()+import Prelude.Compat++import Data.Maybe (mapMaybe)+import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix)+import Data.Char (isUpper)+import Data.Function (on)++import Control.Arrow (second)+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 PSCi.Directive as D+import PSCi.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, Read)++-- |+-- 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 w Foreign     = [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 :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]+mapLoadedModulesAndQualify sho f = do+  ms <- getLoadedModules+  let argPairs = do m <- ms+                    fm <- f m+                    return (m, fm)+  concat <$> traverse (uncurry (getAllQualifications sho)) argPairs++getIdentNames :: CompletionM [String]+getIdentNames = mapLoadedModulesAndQualify P.showIdent identNames++getDctorNames :: CompletionM [String]+getDctorNames = mapLoadedModulesAndQualify P.runProperName dctorNames++getTypeNames :: CompletionM [String]+getTypeNames = mapLoadedModulesAndQualify P.runProperName 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 :: (a -> String) -> P.Module -> (a, P.Declaration) -> CompletionM [String]+getAllQualifications sho 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 = P.showQualified sho (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 -> [q | referencedBy refs]+          P.Hiding refs   -> [q | not $ referencedBy refs]+++-- | 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 'N.TypeName, P.Declaration)]+typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations+  where+  getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, 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 . concatMap getDeclNames . P.exportedDeclarations+  where+  getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)]+  getDeclNames d@(P.ValueDeclaration ident _ _ _)  = [(ident, d)]+  getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)]+  getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)]+  getDeclNames d@(P.TypeClassDeclaration _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds+  getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d+  getDeclNames _ = []++dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]+dctorNames = nubOnFst . concatMap go . P.exportedDeclarations+  where+  go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]+  go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)+  go (P.PositionedDeclaration _ _ d) = go d+  go _ = []++moduleNames :: [P.Module] -> [String]+moduleNames ms = nub [P.runModuleName 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

@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+--+-- Module      :  Directive+-- Copyright   :+-- License     :  MIT+--+-- Maintainer  :+-- Stability   :  experimental+-- Portability :+--+-- |+-- Directives for PSCI.+--+-----------------------------------------------------------------------------++module PSCi.Directive where++import Prelude ()+import Prelude.Compat+++import Data.Maybe (fromJust, listToMaybe)+import Data.List (isPrefixOf)+import Data.Tuple (swap)++import PSCi.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"])+    , (Foreign, ["foreign"])+    , (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++-- |+-- Returns all possible string representations of a directive.+--+stringsFor :: Directive -> [String]+stringsFor d = fromJust (lookup d directiveStrings)++-- |+-- Returns the default string representation of a directive.+--+stringFor :: Directive -> String+stringFor = head . stringsFor++-- |+-- Returns the list of directives which could be expanded from the string+-- argument, together with the string alias that matched.+--+directivesFor' :: String -> [(Directive, String)]+directivesFor' str = go directiveStrings'+  where+  go = map swap . filter ((str `isPrefixOf`) . fst)++directivesFor :: String -> [Directive]+directivesFor = map fst . directivesFor'++directiveStringsFor :: String -> [String]+directiveStringsFor = map snd . directivesFor'++parseDirective :: String -> Maybe Directive+parseDirective = listToMaybe . directivesFor++-- |+-- True if the given directive takes an argument, false otherwise.+hasArgument :: Directive -> Bool+hasArgument Help = False+hasArgument Quit = False+hasArgument Reset = False+hasArgument _ = True++-- |+-- The help menu.+--+help :: [(Directive, String, String)]+help =+  [ (Help,    "",         "Show this help menu")+  , (Quit,    "",         "Quit PSCi")+  , (Reset,   "",         "Discard all imported modules and declared bindings")+  , (Browse,  "<module>", "See all functions in <module>")+  , (Load,    "<file>",   "Load <file> for importing")+  , (Foreign, "<file>",   "Load foreign module <file>")+  , (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")+  ]+

@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+--+-- Module      :  IO+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module PSCi.IO where++import Prelude ()+import Prelude.Compat++import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable, doesFileExist)+import System.FilePath (takeDirectory, (</>), isPathSeparator)+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad (msum)+import Control.Monad.IO.Class (MonadIO, liftIO)+import System.Console.Haskeline (outputStrLn, InputT)++mkdirp :: FilePath -> IO ()+mkdirp = createDirectoryIfMissing True . takeDirectory++-- File helpers++onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)+onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants++-- |+-- Locates the node executable.+-- Checks for either @nodejs@ or @node@.+--+findNodeProcess :: IO (Maybe String)+findNodeProcess = onFirstFileMatching 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+++-- |+-- Expands tilde in path.+--+expandTilde :: FilePath -> IO FilePath+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory+expandTilde p = return p+++whenFileExists :: MonadIO m => FilePath -> (FilePath -> InputT m ()) -> InputT m ()+whenFileExists filePath f = do+  absPath <- liftIO $ expandTilde filePath+  exists <- liftIO $ doesFileExist absPath+  if exists+    then f absPath+    else outputStrLn $ "Couldn't locate: " ++ filePath

@@ -0,0 +1,53 @@+module PSCi.Message where+++import Data.List (intercalate)+import qualified PSCi.Directive as D+import PSCi.Types++-- 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 unwords [ 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!"+

@@ -0,0 +1,106 @@+module PSCi.Module where++import Prelude ()+import Prelude.Compat++import qualified Language.PureScript as P+import PSCi.Types+import System.FilePath (pathSeparator)+import Control.Monad++-- | The name of the PSCI support module+supportModuleName :: P.ModuleName+supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]++-- | Support module, contains code to evaluate terms+supportModule :: P.Module+supportModule =+  case P.parseModulesFromFiles id [("", code)] of+    Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps+    _ -> P.internalError "Support module could not be parsed"+  where+  code :: String+  code = unlines+    [ "module S where"+    , ""+    , "import Prelude"+    , "import Control.Monad.Eff"+    , "import Control.Monad.Eff.Console"+    , "import Control.Monad.Eff.Unsafe"+    , ""+    , "class Eval a where"+    , "  eval :: a -> Eff (console :: CONSOLE) Unit"+    , ""+    , "instance evalShow :: (Show a) => Eval a where"+    , "  eval = print"+    , ""+    , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"+    , "  eval x = unsafeInterleaveEff x >>= eval"+    ]++-- Module Management++-- |+-- Loads a file for use with imports.+--+loadModule :: FilePath -> IO (Either String [P.Module])+loadModule filename = do+  content <- readFile filename+  return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]++-- |+-- Load all modules.+--+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])+loadAllModules files = do+  filesAndContent <- forM files $ \filename -> do+    content <- readFile filename+    return (filename, content)+  return $ P.parseModulesFromFiles id filesAndContent+++-- |+-- 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"]+    trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))+    mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))+    itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val+    mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue+    decls = if exec then [itDecl, mainDecl] else [itDecl]+  in+    P.Module (P.internalModuleSourceSpan "<internal>") [] 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, psciLetBindings = lets} typ =+  let+    moduleName = P.ModuleName [P.ProperName "$PSCI"]+    itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ+  in+    P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [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 (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing++importDecl :: ImportedModule -> P.Declaration+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False++indexFile :: FilePath+indexFile = ".psci_modules" ++ pathSeparator : "index.js"++modulesDir :: FilePath+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"

@@ -0,0 +1,57 @@+module PSCi.Option (+  getOpt+) where++import Prelude ()+import Prelude.Compat++import Options.Applicative as Opts+import Data.Version (showVersion)++import PSCi.Types+import qualified Paths_purescript as Paths++-- Parse Command line option++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"++inputForeignFile :: Parser FilePath+inputForeignFile = strOption $+     short 'f'+  <> long "ffi"+  <> help "The input .js file(s) providing foreign import implementations"++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+                          <*> many inputForeignFile+                          <*> nodeFlagsFlag++version :: Parser (a -> a)+version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden++getOpt :: IO PSCiOptions+getOpt = execParser opts+    where+      opts        = info (version <*> helper <*> psciOptions) infoModList+      infoModList = fullDesc <> headerInfo <> footerInfo+      headerInfo  = header   "psci - Interactive mode for PureScript"+      footerInfo  = footer $ "psci " ++ showVersion Paths.version

@@ -0,0 +1,140 @@+-----------------------------------------------------------------------------+--+-- Module      :  Parser+-- Copyright   :  (c) Phil Freeman 2014+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Parser for PSCI.+--+-----------------------------------------------------------------------------++module PSCi.Parser+  ( parseCommand+  ) where++import Prelude ()+import Prelude.Compat hiding (lex)++import Data.Char (isSpace)+import Data.List (intercalate)++import Text.Parsec hiding ((<|>))++import qualified Language.PureScript as P+import Language.PureScript.Parser.Common (mark, same)++import qualified PSCi.Directive as D+import PSCi.Types++-- |+-- Parses PSCI metacommands or expressions input from the user.+--+parseCommand :: String -> Either String Command+parseCommand cmdString =+  case cmdString of+    (':' : cmd) -> parseDirective cmd+    _ -> parseRest psciCommand cmdString++parseRest :: P.TokenParser a -> String -> Either String a+parseRest p s = either (Left . show) Right $ do+  ts <- P.lex "" s+  P.runTokenParser "" (p <* eof) ts++psciCommand :: P.TokenParser Command+psciCommand = choice (map try parsers)+  where+  parsers =+    [ psciLet+    , psciImport+    , psciOtherDeclaration+    , psciExpression+    ]++trim :: String -> String+trim = trimEnd . trimStart++trimStart :: String -> String+trimStart = dropWhile isSpace++trimEnd :: String -> String+trimEnd = reverse . trimStart . reverse++parseDirective :: String -> Either String 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)+    Foreign -> return $ LoadForeign (trim arg)+    Show    -> ShowInfo <$> parseReplQuery' (trim arg)+    Type    -> TypeOf <$> parseRest P.parseValue arg+    Kind    -> KindOf <$> parseRest P.parseType arg++-- |+-- Parses expressions entered at the PSCI repl.+--+psciExpression :: P.TokenParser Command+psciExpression = Expression <$> P.parseValue++-- |+-- PSCI version of @let@.+-- This is essentially let from do-notation.+-- However, since we don't support the @Eff@ monad,+-- we actually want the normal @let@.+--+psciLet :: P.TokenParser Command+psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)+  where+  manyDecls :: P.TokenParser [P.Declaration]+  manyDecls = mark (many1 (same *> P.parseLocalDeclaration))++-- | Imports must be handled separately from other declarations, so that+-- :show import works, for example.+psciImport :: P.TokenParser Command+psciImport = do+  (mn, declType, asQ, _) <- P.parseImportDeclaration'+  return $ Import (mn, declType, asQ)++-- | 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+  decl <- discardPositionInfo <$> P.parseDeclaration+  if acceptable decl+    then return decl+    else fail "this kind of declaration is not supported in psci"++discardPositionInfo :: P.Declaration -> P.Declaration+discardPositionInfo (P.PositionedDeclaration _ _ d) = d+discardPositionInfo d = d++acceptable :: P.Declaration -> Bool+acceptable P.DataDeclaration{} = True+acceptable P.TypeSynonymDeclaration{} = True+acceptable P.ExternDeclaration{} = True+acceptable P.ExternDataDeclaration{} = True+acceptable P.TypeClassDeclaration{} = True+acceptable P.TypeInstanceDeclaration{} = True+acceptable _ = False++parseReplQuery' :: String -> Either String ReplQuery+parseReplQuery' str =+  case parseReplQuery str of+    Nothing -> Left ("Don't know how to show " ++ str ++ ". Try one of: " +++                      intercalate ", " replQueryStrings ++ ".")+    Just query -> Right query

@@ -0,0 +1,131 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}++module PSCi.Printer where++import Prelude ()+import Prelude.Compat++import qualified Language.PureScript as P+import qualified Text.PrettyPrint.Boxes as Box+import qualified Data.Map as M+import System.Console.Haskeline+import Data.Maybe (mapMaybe)+import Data.List (intersperse)+import Control.Monad.IO.Class (MonadIO)++-- Printers++-- |+-- Pretty print a module's signatures+--+printModuleSignatures :: MonadIO m => P.ModuleName -> P.Environment -> InputT m ()+printModuleSignatures moduleName (P.Environment {..}) =+    -- get relevant components of a module from environment+    let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names+        moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses+        moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types++  in+    -- print each component+    (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)+      [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses+      , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types+      , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions+      ]++  where printModule's showF = Box.vsep 1 Box.left . showF++        findNameType :: 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))+        findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)++        showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box+        showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType+        showNameType _ = P.internalError "The impossible happened in printModuleSignatures."++        findTypeClass+          :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])+          -> P.Qualified (P.ProperName 'P.ClassName)+          -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))+        findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)++        showTypeClass+          :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))+          -> Maybe Box.Box+        showTypeClass (_, Nothing) = Nothing+        showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =+            let constraints =+                    if null constrs+                    then Box.text ""+                    else Box.text "("+                         Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)+                         Box.<> Box.text ") <= "+                className =+                    Box.text (P.runProperName name)+                    Box.<> Box.text (concatMap ((' ':) . fst) vars)+                classBody =+                    Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)++            in+              Just $+                (Box.text "class "+                Box.<> constraints+                Box.<> className+                Box.<+> if null body then Box.text "" else Box.text "where")+                Box.// Box.moveRight 2 classBody+++        findType+          :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)+          -> P.Qualified (P.ProperName 'P.TypeName)+          -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))+        findType envTypes name = (name, M.lookup name envTypes)++        showType+          :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])+          -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])+          -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)+          -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))+          -> Maybe Box.Box+        showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =+          case (typ, M.lookup n typeSynonymsEnv) of+            (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->+                if M.member (fmap P.coerceProperName n) typeClassesEnv+                then+                  Nothing+                else+                  Just $+                    Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)+                    Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)++            (Just (_, P.DataType typevars pt), _) ->+              let prefix =+                    case pt of+                      [(dtProperName,_)] ->+                        case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of+                          Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType+                          _ -> "data"+                      _ -> "data"++              in+                Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt++            _ ->+              Nothing++          where printCons pt =+                    Box.moveRight 2 $+                    Box.vcat Box.left $+                    mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $+                    map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt++                prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t++                mapFirstRest _ _ [] = []+                mapFirstRest f g (x:xs) = f x : map g xs++        trimEnd = reverse . dropWhile (== ' ') . reverse++-- | Pretty-print errors+printErrors :: MonadIO m => P.MultipleErrors -> InputT m ()+printErrors = outputStrLn . P.prettyPrintMultipleErrors False

@@ -0,0 +1,218 @@+-----------------------------------------------------------------------------+--+-- 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 PSCi.Types where++import Prelude ()+import Prelude.Compat++import Control.Arrow (second)+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Language.PureScript as P++data PSCiOptions = PSCiOptions+  { psciMultiLineMode     :: Bool+  , psciInputFile         :: [FilePath]+  , psciForeignInputFiles :: [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+  { psciImportedModules     :: [ImportedModule]+  , _psciLoadedModules      :: Map FilePath [P.Module]+  , psciForeignFiles        :: Map P.ModuleName FilePath+  , psciLetBindings         :: [P.Declaration]+  , psciNodeFlags           :: [String]+  }++initialPSCiState :: PSCiState+initialPSCiState =+  PSCiState [] Map.empty Map.empty [] []++mkPSCiState :: [ImportedModule]+            -> [(FilePath, P.Module)]+            -> Map P.ModuleName FilePath+            -> [P.Declaration]+            -> [String]+            -> PSCiState+mkPSCiState imported loaded foreigns lets nodeFlags =+  (initialPSCiState+    |> each imported updateImportedModules+    |> updateModules loaded)+    { psciForeignFiles = foreigns+    , psciLetBindings = lets+    , psciNodeFlags = nodeFlags+    }+  where+  x |> f = f x+  each xs f st = foldl (flip f) st xs++--  Public psci state accessors++-- | Get the imported filenames as a list.+psciImportedFilenames :: PSCiState -> [FilePath]+psciImportedFilenames = Map.keys . _psciLoadedModules++-- | Get the loaded modules as a list.+psciLoadedModules :: PSCiState -> [(FilePath, P.Module)]+psciLoadedModules = collect . Map.toList . _psciLoadedModules+  where+  collect :: [(k, [v])] -> [(k, v)]+  collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]++-- | 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.+--+updateImportedModules :: ImportedModule -> PSCiState -> PSCiState+updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }++-- |+-- Updates the state to have more loaded modules (available for import, but+-- not necessarily imported).+--+updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState+updateModules modules st =+  st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) }+  where+  go = Map.fromListWith (++) . map (second (:[]))++-- |+-- Updates the state to have more let bindings.+--+updateLets :: [P.Declaration] -> PSCiState -> PSCiState+updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }++-- |+-- Updates the state to have more let bindings.+--+updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState+updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs }++-- |+-- 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+  -- |+  -- Load a foreign module+  --+  | LoadForeign 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+  | Foreign+  | Type+  | Kind+  | Show+  deriving (Eq, Show)

@@ -1,140 +0,0 @@------------------------------------------------------------------------------------ Module      :  Parser--- Copyright   :  (c) Phil Freeman 2014--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Parser for PSCI.-----------------------------------------------------------------------------------module Parser-  ( parseCommand-  ) where--import Prelude ()-import Prelude.Compat hiding (lex)--import Data.Char (isSpace)-import Data.List (intercalate)--import Text.Parsec hiding ((<|>))--import qualified Language.PureScript as P-import Language.PureScript.Parser.Common (mark, same)--import qualified Directive as D-import Types---- |--- Parses PSCI metacommands or expressions input from the user.----parseCommand :: String -> Either String Command-parseCommand cmdString =-  case cmdString of-    (':' : cmd) -> parseDirective cmd-    _ -> parseRest psciCommand cmdString--parseRest :: P.TokenParser a -> String -> Either String a-parseRest p s = either (Left . show) Right $ do-  ts <- P.lex "" s-  P.runTokenParser "" (p <* eof) ts--psciCommand :: P.TokenParser Command-psciCommand = choice (map try parsers)-  where-  parsers =-    [ psciLet-    , psciImport-    , psciOtherDeclaration-    , psciExpression-    ]--trim :: String -> String-trim = trimEnd . trimStart--trimStart :: String -> String-trimStart = dropWhile isSpace--trimEnd :: String -> String-trimEnd = reverse . trimStart . reverse--parseDirective :: String -> Either String 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)-    Foreign -> return $ LoadForeign (trim arg)-    Show    -> ShowInfo <$> parseReplQuery' (trim arg)-    Type    -> TypeOf <$> parseRest P.parseValue arg-    Kind    -> KindOf <$> parseRest P.parseType arg---- |--- Parses expressions entered at the PSCI repl.----psciExpression :: P.TokenParser Command-psciExpression = Expression <$> P.parseValue---- |--- PSCI version of @let@.--- This is essentially let from do-notation.--- However, since we don't support the @Eff@ monad,--- we actually want the normal @let@.----psciLet :: P.TokenParser Command-psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)-  where-  manyDecls :: P.TokenParser [P.Declaration]-  manyDecls = mark (many1 (same *> P.parseLocalDeclaration))---- | Imports must be handled separately from other declarations, so that--- :show import works, for example.-psciImport :: P.TokenParser Command-psciImport = do-  (mn, declType, asQ, _) <- P.parseImportDeclaration'-  return $ Import (mn, declType, asQ)---- | 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-  decl <- discardPositionInfo <$> P.parseDeclaration-  if acceptable decl-    then return decl-    else fail "this kind of declaration is not supported in psci"--discardPositionInfo :: P.Declaration -> P.Declaration-discardPositionInfo (P.PositionedDeclaration _ _ d) = d-discardPositionInfo d = d--acceptable :: P.Declaration -> Bool-acceptable P.DataDeclaration{} = True-acceptable P.TypeSynonymDeclaration{} = True-acceptable P.ExternDeclaration{} = True-acceptable P.ExternDataDeclaration{} = True-acceptable P.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,215 +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 Control.Arrow (second)-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Language.PureScript as P--data PSCiOptions = PSCiOptions-  { psciMultiLineMode     :: Bool-  , psciInputFile         :: [FilePath]-  , psciForeignInputFiles :: [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-  { psciImportedModules     :: [ImportedModule]-  , _psciLoadedModules      :: Map FilePath [P.Module]-  , psciForeignFiles        :: Map P.ModuleName FilePath-  , psciLetBindings         :: [P.Declaration]-  , psciNodeFlags           :: [String]-  }--initialPSCiState :: PSCiState-initialPSCiState =-  PSCiState [] Map.empty Map.empty [] []--mkPSCiState :: [ImportedModule]-            -> [(FilePath, P.Module)]-            -> Map P.ModuleName FilePath-            -> [P.Declaration]-            -> [String]-            -> PSCiState-mkPSCiState imported loaded foreigns lets nodeFlags =-  (initialPSCiState-    |> each imported updateImportedModules-    |> updateModules loaded)-    { psciForeignFiles = foreigns-    , psciLetBindings = lets-    , psciNodeFlags = nodeFlags-    }-  where-  x |> f = f x-  each xs f st = foldl (flip f) st xs----  Public psci state accessors---- | Get the imported filenames as a list.-psciImportedFilenames :: PSCiState -> [FilePath]-psciImportedFilenames = Map.keys . _psciLoadedModules---- | Get the loaded modules as a list.-psciLoadedModules :: PSCiState -> [(FilePath, P.Module)]-psciLoadedModules = collect . Map.toList . _psciLoadedModules-  where-  collect :: [(k, [v])] -> [(k, v)]-  collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]---- | 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.----updateImportedModules :: ImportedModule -> PSCiState -> PSCiState-updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }---- |--- Updates the state to have more loaded modules (available for import, but--- not necessarily imported).----updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState-updateModules modules st =-  st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) }-  where-  go = Map.fromListWith (++) . map (second (:[]))---- |--- Updates the state to have more let bindings.----updateLets :: [P.Declaration] -> PSCiState -> PSCiState-updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }---- |--- Updates the state to have more let bindings.----updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState-updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs }---- |--- 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-  -- |-  -- Load a foreign module-  ---  | LoadForeign 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-  | Foreign-  | Type-  | Kind-  | Show-  deriving (Eq, Show)

@@ -1,162 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}--module Main where--import Prelude ()-import Prelude.Compat--import Control.Monad.Trans.State.Strict (runStateT)-import Control.Monad (when, forM)-import Control.Monad.Writer.Strict (runWriterT)-import Control.Monad.Trans.Except (runExceptT)--import Data.List (sort)--import System.Exit (exitFailure)-import System.Console.Haskeline-import System.FilePath ((</>))-import System.Directory (getCurrentDirectory)-import qualified System.FilePath.Glob as Glob--import Test.HUnit--import qualified Language.PureScript as P--import PSCi-import Completion-import Types--import TestsSetup--main :: IO ()-main = do-  fetchSupportCode-  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 module names-  , (":b Control.Monad.E",    map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])-  , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])--  -- import should complete module names-  , ("import Control.Monad.E",    map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])-  , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])-  , ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])--  -- :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 Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log"])-  , (":type uni", [":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 ", [])--  -- a few other import tests-  , ("impor", ["import"])-  , ("import q", ["import qualified"])-  , ("import ", map ("import " ++) supportModules ++ ["import qualified"])-  , ("import Prelude ", [])--  -- String and number literals should not be completed-  , ("\"hi", [])-  , ("34", [])--  -- Identifiers and data constructors should be completed-  , ("uni", ["unit"])-  , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"])-  , ("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--assertCompletedOk :: (String, [String]) -> Assertion-assertCompletedOk (line, expecteds) = do-  (unusedR, completions) <- runCM (completion' (reverse line, ""))-  let unused = reverse unusedR-  let actuals = map ((unused ++) . replacement) completions-  sort expecteds @=? sort actuals--runCM :: CompletionM a -> IO a-runCM act = do-  psciState <- getPSCiState-  fmap fst (runStateT (liftCompletionM act) psciState)--getPSCiState :: IO PSCiState-getPSCiState = do-  cwd <- getCurrentDirectory-  let supportDir = cwd </> "tests" </> "support" </> "flattened"-  let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir-  pursFiles <- supportFiles "purs"-  jsFiles   <- supportFiles "js"--  modulesOrFirstError <- loadAllModules pursFiles-  foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f)-  Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles-  case modulesOrFirstError of-    Left err ->-      print err >> exitFailure-    Right modules ->-      let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]-      in  return (mkPSCiState imports modules foreigns [] [])--controlMonadSTasST :: ImportedModule-controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))-  where-  s = P.moduleNameFromString--supportModules :: [String]-supportModules =-  [ "Control.Monad.Eff.Class"-  , "Control.Monad.Eff.Console"-  , "Control.Monad.Eff"-  , "Control.Monad.Eff.Unsafe"-  , "Control.Monad.ST"-  , "Data.Function"-  , "Prelude"-  , "Test.Assert"-  ]

@@ -1,5 +1,5 @@ name: purescript-version: 0.8.0.0+version: 0.8.1.0 cabal-version: >=1.8 build-type: Simple license: MIT@@ -14,9 +14,10 @@ author: Phil Freeman <paf31@cantab.net>,         Gary Burgess <gary.burgess@gmail.com>,         Hardy Jones <jones3.hardy@gmail.com>,-        Harry Garrood <harry@garrood.me>+        Harry Garrood <harry@garrood.me>,+        Christoph Hegemann <christoph.hegemann1337@gmail.com> -tested-with: GHC==7.8+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1  extra-source-files: examples/passing/*.purs                   , examples/failing/*.purs@@ -25,9 +26,15 @@                   , examples/docs/src/*.purs                   , tests/support/setup.js                   , tests/support/package.json+                  , tests/support/prelude/bower.json+                  , tests/support/prelude/src/*.purs+                  , tests/support/prelude/src/*.js+                  , tests/support/prelude/LICENSE                   , tests/support/bower.json                   , tests/support/setup-win.cmd-                  , psci/tests/data/Sample.purs+                  , tests/support/flattened/*.purs+                  , tests/support/flattened/*.js+                  , tests/support/psci/*.purs                   , stack.yaml                   , stack-lts-2.yaml                   , stack-lts-3.yaml@@ -54,13 +61,13 @@                    filepath -any,                    mtl >= 2.1.0 && < 2.3.0,                    parsec -any,-                   transformers >= 0.3.0 && < 0.5,+                   transformers >= 0.3.0 && < 0.6,                    transformers-compat >= 0.3.0,                    utf8-string >= 1 && < 2,                    pattern-arrows >= 0.0.2 && < 0.1,                    time -any,                    boxes >= 0.1.4 && < 0.2.0,-                   aeson >= 0.8 && < 0.11,+                   aeson >= 0.8 && < 0.12,                    vector -any,                    bower-json >= 0.7,                    aeson-better-errors >= 0.8,@@ -70,10 +77,19 @@                    language-javascript == 0.5.*,                    syb -any,                    Glob >= 0.7 && < 0.8,-                   process >= 1.2.0 && < 1.4,+                   process >= 1.2.0 && < 1.5,                    safe >= 0.3.9 && < 0.4,                    semigroups >= 0.16.2 && < 0.19,-                   parallel >= 3.2 && < 3.3+                   parallel >= 3.2 && < 3.3,+                   sourcemap >= 0.1.6,+                   stm >= 0.2.4.0,+                   regex-tdfa -any,+                   edit-distance -any,+                   fsnotify >= 0.2.1,+                   monad-logger >= 0.3 && < 0.4,+                   pipes >= 4.0.0 && < 4.2.0 ,+                   pipes-http -any,+                   http-types -any      exposed-modules: Language.PureScript                      Language.PureScript.AST@@ -143,6 +159,9 @@                      Language.PureScript.Sugar.Names.Exports                      Language.PureScript.Sugar.ObjectWildcards                      Language.PureScript.Sugar.Operators+                     Language.PureScript.Sugar.Operators.Common+                     Language.PureScript.Sugar.Operators.Expr+                     Language.PureScript.Sugar.Operators.Binders                      Language.PureScript.Sugar.TypeClasses                      Language.PureScript.Sugar.TypeClasses.Deriving                      Language.PureScript.Sugar.TypeDeclarations@@ -170,7 +189,7 @@                      Language.PureScript.Docs.RenderedCode.Types                      Language.PureScript.Docs.RenderedCode.Render                      Language.PureScript.Docs.AsMarkdown-                     Language.PureScript.Docs.ParseAndDesugar+                     Language.PureScript.Docs.ParseAndBookmark                      Language.PureScript.Docs.Utils.MonoidExtras                       Language.PureScript.Publish@@ -178,6 +197,22 @@                      Language.PureScript.Publish.ErrorsWarnings                      Language.PureScript.Publish.BoxesHelpers +                     Language.PureScript.Ide+                     Language.PureScript.Ide.Command+                     Language.PureScript.Ide.Externs+                     Language.PureScript.Ide.Error+                     Language.PureScript.Ide.CodecJSON+                     Language.PureScript.Ide.Pursuit+                     Language.PureScript.Ide.Completion+                     Language.PureScript.Ide.Matcher+                     Language.PureScript.Ide.Filter+                     Language.PureScript.Ide.Types+                     Language.PureScript.Ide.State+                     Language.PureScript.Ide.CaseSplit+                     Language.PureScript.Ide.SourceFile+                     Language.PureScript.Ide.Watcher+                     Language.PureScript.Ide.Reexports+                      Control.Monad.Logger                      Control.Monad.Supply                      Control.Monad.Supply.Class@@ -196,11 +231,11 @@                    containers -any, directory -any, filepath -any,                    mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,                    time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,-                   aeson >= 0.8 && < 0.11, bytestring -any, utf8-string >= 1 && < 2+                   aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2     main-is: Main.hs     buildable: True     hs-source-dirs: psc-    other-modules: JSON+    other-modules: JSON, Paths_purescript     ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"  executable psci@@ -213,12 +248,17 @@     main-is: Main.hs     buildable: True     hs-source-dirs: psci psci/main-    other-modules: Types-                   Parser-                   Directive-                   Completion-                   PSCi-                   IO+    other-modules: PSCi+                   PSCi.Types+                   PSCi.Parser+                   PSCi.Directive+                   PSCi.Completion+                   PSCi.IO+                   PSCi.Message+                   PSCi.Option+                   PSCi.Module+                   PSCi.Printer+                   Paths_purescript     ghc-options: -Wall -O2  executable psc-docs@@ -228,6 +268,7 @@                    filepath -any, Glob -any, transformers -any,                    transformers-compat -any     main-is: Main.hs+    other-modules: Paths_purescript     buildable: True     hs-source-dirs: psc-docs     other-modules: Ctags@@ -238,6 +279,7 @@ executable psc-publish     build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any     main-is: Main.hs+    other-modules: Paths_purescript     buildable: True     hs-source-dirs: psc-publish     ghc-options: -Wall -O2@@ -247,6 +289,7 @@                    process -any, mtl -any, parsec -any, filepath -any, directory -any,                    Glob -any     main-is: Main.hs+    other-modules: Paths_purescript     buildable: True     hs-source-dirs: hierarchy     other-modules:@@ -254,7 +297,7 @@  executable psc-bundle   main-is:             Main.hs-  other-modules:+  other-modules:       Paths_purescript   other-extensions:   build-depends:       base >=4 && <5,                        purescript -any,@@ -268,29 +311,55 @@   ghc-options:         -Wall -O2   hs-source-dirs:      psc-bundle +executable psc-ide-server+  main-is:             Main.hs+  other-modules:+  other-extensions:+  build-depends:       base >=4 && <5+                     , purescript -any+                     , directory -any+                     , filepath -any+                     , monad-logger -any+                     , mtl -any+                     , transformers -any+                     , transformers-compat -any+                     , network -any+                     , optparse-applicative >= 0.10.0+                     , stm -any+                     , text -any+                     , base-compat >=0.6.0+  ghc-options:         -Wall -O2 -threaded+  hs-source-dirs:      psc-ide-server++executable psc-ide-client+  main-is:             Main.hs+  other-modules:+  other-extensions:+  build-depends:       base >=4 && <5+                     , mtl -any+                     , text -any+                     , optparse-applicative >= 0.10.0+                     , network -any+                     , base-compat >=0.6.0+  ghc-options:         -Wall -O2+  hs-source-dirs:      psc-ide-client+ test-suite tests     build-depends: base >=4 && <5, containers -any, directory -any,                    filepath -any, mtl -any, parsec -any, purescript -any,                    transformers -any, process -any, transformers-compat -any, time -any,                    Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,-                   base-compat -any+                   base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any,+                   boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any+    ghc-options: -Wall     type: exitcode-stdio-1.0     main-is: Main.hs-    other-modules: TestsSetup-                   TestPscPublish+    other-modules: TestUtils+                   TestCompiler                    TestDocs-    buildable: True-    hs-source-dirs: tests tests/common--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,-                   transformers-compat -any, process -any, HUnit -any, time -any,-                   Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0-    type: exitcode-stdio-1.0-    main-is: Main.hs-    other-modules: TestsSetup+                   TestPscPublish+                   TestPsci+                   TestPscIde+                   PscIdeSpec     buildable: True-    hs-source-dirs: psci psci/tests tests/common-    ghc-options: -Wall+    hs-source-dirs: tests psci

@@ -41,6 +41,24 @@   --   | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]   -- |+  -- A operator alias binder. During the rebracketing phase of desugaring,+  -- this data constructor will be removed.+  --+  | OpBinder (Qualified Ident)+  -- |+  -- Binary operator application. During the rebracketing phase of desugaring,+  -- this data constructor will be removed.+  --+  | BinaryNoParensBinder Binder Binder Binder+  -- |+  -- Explicit parentheses. During the rebracketing phase of desugaring, this+  -- data constructor will be removed.+  --+  -- Note: although it seems this constructor is not used, it _is_ useful,+  -- since it prevents certain traversals from matching.+  --+  | ParensInBinder Binder+  -- |   -- A binder which matches a record and binds its properties   --   | ObjectBinder [(String, Binder)]@@ -70,6 +88,8 @@   where   go ns (VarBinder name) = name : ns   go ns (ConstructorBinder _ bs) = foldl go ns bs+  go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]+  go ns (ParensInBinder b) = go ns b   go ns (ObjectBinder bs) = foldl go ns (map snd bs)   go ns (ArrayBinder bs) = foldl go ns bs   go ns (NamedBinder name b) = go (name : ns) b

@@ -189,7 +189,7 @@   -- |   -- A fixity declaration (fixity data, operator name, value the operator is an alias for)   ---  | FixityDeclaration Fixity String (Maybe (Qualified Ident))+  | FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))))   -- |   -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)   -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)@@ -337,6 +337,9 @@   -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor   -- will be removed.   --+  -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents+  -- certain traversals from matching.+  --   | Parens Expr   -- |   -- Operator section. This will be removed during desugaring and replaced with a partially applied@@ -352,11 +355,6 @@   --   | ObjectLiteral [(String, Expr)]   -- |-  -- An object constructor (object literal with underscores). This will be removed during-  -- desugaring and expanded into a lambda that returns an object literal.-  ---  | ObjectConstructor [(String, Maybe Expr)]-  -- |   -- An object property getter (e.g. `_.x`). This will be removed during   -- desugaring and expanded into a lambda that reads a property from an object.   --@@ -370,11 +368,6 @@   --   | ObjectUpdate Expr [(String, Expr)]   -- |-  -- Partial record updater. This will be removed during desugaring and-  -- expanded into a lambda that returns an object update.-  ---  | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]-  -- |   -- Function introduction   --   | Abs (Either Ident Binder) Expr@@ -432,6 +425,10 @@   -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking   --   | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]+  -- |+  -- A placeholder for an anonymous function argument+  --+  | AnonymousArgument   -- |   -- A value with source position information   --

@@ -23,7 +23,7 @@ import qualified Data.Set as S  import Control.Monad-import Control.Arrow ((***), (+++), second)+import Control.Arrow ((***), (+++))  import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations@@ -54,11 +54,9 @@   g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))   g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))   g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))-  g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))   g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))   g' (Accessor prop v) = g (Accessor prop (g' v))   g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))-  g' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (fmap g')) vs))   g' (Abs name v) = g (Abs name (g' v))   g' (App v1 v2) = g (App (g' v1) (g' v2))   g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))@@ -71,6 +69,8 @@    h' :: Binder -> Binder   h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))+  h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))+  h' (ParensInBinder b) = h (ParensInBinder (h' b))   h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))   h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))   h' (NamedBinder name b) = h (NamedBinder name (h' b))@@ -112,11 +112,9 @@   g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))   g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs   g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs-  g' (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g' <=< g)) vs   g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')   g' (Accessor prop v) = Accessor prop <$> (g v >>= g')   g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs-  g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> traverse (sndM $ maybeM (g' <=< g)) vs   g' (Abs name v) = Abs name <$> (g v >>= g')   g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')   g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')@@ -128,6 +126,8 @@   g' other = g other    h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs+  h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')+  h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')   h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs   h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs   h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')@@ -165,11 +165,9 @@   g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g   g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g   g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g-  g' (ObjectConstructor vs) = (ObjectConstructor <$> traverse (sndM $ maybeM g') vs) >>= g   g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g   g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g   g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g-  g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> traverse (sndM $ maybeM g') vs) >>= g   g' (Abs name v) = (Abs name <$> g' v) >>= g   g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g   g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g@@ -181,6 +179,8 @@   g' other = g other    h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h+  h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h+  h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h   h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h   h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h   h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h@@ -221,11 +221,9 @@   g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1   g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)   g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)-  g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))   g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1   g' v@(Accessor _ v1) = g v <> g' v1   g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)-  g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs))   g' v@(Abs _ v1) = g v <> g' v1   g' v@(App v1 v2) = g v <> g' v1 <> g' v2   g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3@@ -237,6 +235,8 @@   g' v = g v    h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)+  h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3+  h' b@(ParensInBinder b1) = h b <> h' b1   h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)   h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)   h' b@(NamedBinder _ b1) = h b <> h' b1@@ -288,11 +288,9 @@   g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v   g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)   g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)-  g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))   g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1   g' s (Accessor _ v1) = g'' s v1   g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)-  g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs))   g' s (Abs _ v1) = g'' s v1   g' s (App v1 v2) = g'' s v1 <> g'' s v2   g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3@@ -306,6 +304,8 @@   h'' s b = let (s', r) = h s b in r <> h' s' b    h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)+  h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3+  h' s (ParensInBinder b) = h'' s b   h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)   h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)   h' s (NamedBinder _ b1) = h'' s b1@@ -358,11 +358,9 @@   g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)   g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs   g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs-  g' s (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g'' s)) vs   g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v   g' s (Accessor prop v) = Accessor prop <$> g'' s v   g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs-  g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> traverse (sndM $ maybeM (g'' s)) vs   g' s (Abs name v) = Abs name <$> g'' s v   g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2   g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3@@ -376,6 +374,8 @@   h'' s = uncurry h' <=< h s    h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs+  h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3+  h' s (ParensInBinder b) = ParensInBinder <$> h'' s b   h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs   h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs   h' s (NamedBinder name b) = NamedBinder name <$> h'' s b@@ -440,11 +440,9 @@   g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v   g' s (ArrayLiteral vs) = foldMap (g'' s) vs   g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs-  g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs)   g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1   g' s (Accessor _ v1) = g'' s v1   g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs-  g' s (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs)   g' s (Abs (Left name) v1) =     let s' = S.insert name s     in g'' s' v1@@ -465,11 +463,11 @@   h'' s a = h s a <> h' s a    h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs+  h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]+  h' s (ParensInBinder b) = h'' s b   h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs   h' s (ArrayBinder bs) = foldMap (h'' s) bs-  h' s (NamedBinder name b1) =-    let s' = S.insert name s-    in h'' s' b1+  h' s (NamedBinder name b1) = h'' (S.insert name s) b1   h' s (PositionedBinder _ _ b1) = h'' s b1   h' s (TypedBinder _ b1) = h'' s b1   h' _ _ = mempty

@@ -55,21 +55,21 @@   rethrow (addHint (ErrorInModule mn)) $ do     let usedNames = concatMap getNames decls     let mnLookup = renameImports usedNames imps-    jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps+    jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd $ imps     let decls' = renameModules mnLookup decls     jsDecls <- mapM bindToJs decls'     optimized <- T.traverse (T.traverse optimize) jsDecls     F.traverse_ (F.traverse_ checkIntegers) optimized     comments <- not <$> asks optionsNoComments-    let strict = JSStringLiteral "use strict"-    let header = if comments && not (null coms) then JSComment coms strict else strict-    let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]+    let strict = JSStringLiteral Nothing "use strict"+    let header = if comments && not (null coms) then JSComment Nothing coms strict else strict+    let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]     let moduleBody = header : foreign' ++ jsImports ++ concat optimized     let foreignExps = exps `intersect` (fst `map` foreigns)     let standardExps = exps \\ foreignExps-    let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps+    let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps                                ++ map (runIdent &&& foreignIdent) foreignExps-    return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']+    return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']    where @@ -77,23 +77,23 @@   -- Extracts all declaration names from a binding group.   --   getNames :: Bind Ann -> [Ident]-  getNames (NonRec ident _) = [ident]-  getNames (Rec vals) = map fst vals+  getNames (NonRec _ ident _) = [ident]+  getNames (Rec vals) = map (snd . fst) vals    -- |   -- Creates alternative names for each module to ensure they don't collide   -- with declaration names.   ---  renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName+  renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)   renameImports ids mns = go M.empty ids mns     where-    go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName-    go acc used (mn' : mns') =+    go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)+    go acc used ((ann, mn') : mns') =       let mni = Ident $ runModuleName mn'       in if mn' /= mn && mni `elem` used          then let newName = freshModuleName 1 mn' used-              in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'-         else go (M.insert mn' mn' acc) (mni : used) mns'+              in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'+         else go (M.insert mn' (ann, mn') acc) (mni : used) mns'     go acc _ [] = acc      freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName@@ -107,18 +107,18 @@   -- Generates Javascript code for a module import, binding the required module   -- to the alternative   ---  importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS+  importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS   importToJs mnLookup mn' = do     path <- asks optionsRequirePath-    let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup-    let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]-    return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody)+    let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup+    let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id (</>) path $ runModuleName mn')]+    withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)    -- |   -- Replaces the `ModuleName`s in the AST so that the generated code refers to   -- the collision-avoiding renamed module imports.   ---  renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann]+  renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]   renameModules mnLookup binds =     let (f, _, _) = everywhereOnValues id goExpr goBinder     in map f binds@@ -131,7 +131,7 @@     goBinder b = b     renameQual :: Qualified a -> Qualified a     renameQual (Qualified (Just mn') a) =-      let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup+      let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup       in Qualified (Just mnSafe) a     renameQual q = q @@ -139,8 +139,8 @@   -- Generate code in the simplified Javascript intermediate representation for a declaration   --   bindToJs :: Bind Ann -> m [JS]-  bindToJs (NonRec ident val) = return <$> nonRecToJS ident val-  bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)+  bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val+  bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)    -- |   -- Generate code in the simplified Javascript intermediate representation for a single non-recursive@@ -148,22 +148,30 @@   --   -- The main purpose of this function is to handle code generation for comments.   ---  nonRecToJS :: Ident -> Expr Ann -> m JS-  nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do+  nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS+  nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do     withoutComment <- asks optionsNoComments     if withoutComment-       then nonRecToJS i (modifyAnn removeComments e)-       else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)-  nonRecToJS ident val = do+       then nonRecToJS a i (modifyAnn removeComments e)+       else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)+  nonRecToJS (ss, _, _, _) ident val = do     js <- valueToJs val-    return $ JSVariableIntroduction (identToJs ident) (Just js)+    withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js) +  withPos :: Maybe SourceSpan -> JS -> m JS+  withPos (Just ss) js = do+    withSM <- asks optionsSourceMaps+    return $ if withSM+      then withSourceSpan ss js+      else js+  withPos Nothing js = return js+   -- |   -- Generate code in the simplified Javascript intermediate representation for a variable based on a   -- PureScript identifier.   --   var :: Ident -> JS-  var = JSVar . identToJs+  var = JSVar Nothing . identToJs    -- |   -- Generate code in the simplified Javascript intermediate representation for an accessor based on@@ -172,102 +180,106 @@   --   accessor :: Ident -> JS -> JS   accessor (Ident prop) = accessorString prop-  accessor (Op op) = JSIndexer (JSStringLiteral op)+  accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op)   accessor (GenIdent _ _) = internalError "GenIdent in accessor"    accessorString :: String -> JS -> JS-  accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)-                      | otherwise = JSAccessor prop+  accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)+                      | otherwise = JSAccessor Nothing prop    -- |   -- Generate code in the simplified Javascript intermediate representation for a value or expression.   --   valueToJs :: Expr Ann -> m JS-  valueToJs (Literal (pos, _, _, _) l) =+  valueToJs e =+    let (ss, _, _, _) = extractAnn e in+    withPos ss =<< valueToJs' e++  valueToJs' :: Expr Ann -> m JS+  valueToJs' (Literal (pos, _, _, _) l) =     maybe id rethrowWithPosition pos $ literalToValueJS l-  valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =-    return $ JSAccessor "value" $ qualifiedToJS id name-  valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =-    return $ JSAccessor "create" $ qualifiedToJS id name-  valueToJs (Accessor _ prop val) =+  valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =+    return $ JSAccessor Nothing "value" $ qualifiedToJS id name+  valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =+    return $ JSAccessor Nothing "create" $ qualifiedToJS id name+  valueToJs' (Accessor _ prop val) =     accessorString prop <$> valueToJs val-  valueToJs (ObjectUpdate _ o ps) = do+  valueToJs' (ObjectUpdate _ o ps) = do     obj <- valueToJs o     sts <- mapM (sndM valueToJs) ps     extendObj obj sts-  valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =+  valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =     let args = unAbs e-    in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)+    in return $ JSFunction Nothing Nothing (map identToJs args) (JSBlock Nothing $ map assign args)     where     unAbs :: Expr Ann -> [Ident]     unAbs (Abs _ arg val) = arg : unAbs val     unAbs _ = []     assign :: Ident -> JS-    assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))+    assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this"))                                (var name)-  valueToJs (Abs _ arg val) = do+  valueToJs' (Abs _ arg val) = do     ret <- valueToJs val-    return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])-  valueToJs e@App{} = do+    return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret])+  valueToJs' e@App{} = do     let (f, args) = unApp e []     args' <- mapM valueToJs args     case f of       Var (_, _, _, Just IsNewtype) _ -> return (head args')       Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->-        return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'+        return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'       Var (_, _, _, Just IsTypeClassConstructor) name ->-        return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'-      _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f+        return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'+      _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f     where     unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])     unApp (App _ val arg) args = unApp val (arg : args)     unApp other args = (other, args)-  valueToJs (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =+  valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =     return $ if mn' == mn              then foreignIdent ident              else varToJs qi-  valueToJs (Var (_, _, _, Just IsForeign) ident) =+  valueToJs' (Var (_, _, _, Just IsForeign) ident) =     error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident-  valueToJs (Var _ ident) =-    return $ varToJs ident-  valueToJs (Case (maybeSpan, _, _, _) values binders) = do+  valueToJs' (Var _ ident) = return $ varToJs ident+  valueToJs' (Case (maybeSpan, _, _, _) values binders) = do     vals <- mapM valueToJs values     bindersToJs maybeSpan binders vals-  valueToJs (Let _ ds val) = do+  valueToJs' (Let _ ds val) = do     ds' <- concat <$> mapM bindToJs ds     ret <- valueToJs val-    return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []-  valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =-    return $ JSVariableIntroduction ctor (Just $-                JSObjectLiteral [("create",-                  JSFunction Nothing ["value"]-                    (JSBlock [JSReturn $ JSVar "value"]))])-  valueToJs (Constructor _ _ (ProperName ctor) []) =-    return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])-           , JSAssignment (JSAccessor "value" (JSVar ctor))-                (JSUnary JSNew $ JSApp (JSVar ctor) []) ]-  valueToJs (Constructor _ _ (ProperName ctor) fields) =+    return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []+  valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =+    return $ JSVariableIntroduction Nothing ctor (Just $+                JSObjectLiteral Nothing [("create",+                  JSFunction Nothing Nothing ["value"]+                    (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])+  valueToJs' (Constructor _ _ (ProperName ctor) []) =+    return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])+           , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))+                (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]+  valueToJs' (Constructor _ _ (ProperName ctor) fields) =     let constructor =-          let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]-          in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)+          let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]+          in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)         createFn =-          let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)-          in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields+          let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)+          in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields     in return $ iife ctor [ constructor-                          , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn+                          , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn                           ]    iife :: String -> [JS] -> JS-  iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []+  iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []    literalToValueJS :: Literal (Expr Ann) -> m JS-  literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral (Left i)-  literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n)-  literalToValueJS (StringLiteral s) = return $ JSStringLiteral s-  literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c]-  literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b-  literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs-  literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps+  literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)+  literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)+  literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s+  literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c]+  literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b+  literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs+  literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps    -- |   -- Shallow copy an object.@@ -277,16 +289,16 @@     newObj <- freshName     key <- freshName     let-      jsKey = JSVar key-      jsNewObj = JSVar newObj-      block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])-      objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])-      copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]-      cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]-      assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]-      stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js+      jsKey = JSVar Nothing key+      jsNewObj = JSVar Nothing newObj+      block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])+      objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])+      copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]+      cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey]+      assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)]+      stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js       extend = map stToAssign sts-    return $ JSApp (JSFunction Nothing [] block) []+    return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []    -- |   -- Generate code in the simplified Javascript intermediate representation for a reference to a@@ -301,12 +313,12 @@   -- variable that may have a qualified name.   --   qualifiedToJS :: (a -> Ident) -> Qualified a -> JS-  qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a-  qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))-  qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)+  qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar Nothing . runIdent $ f a+  qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar Nothing (moduleNameToJs mn'))+  qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a)    foreignIdent :: Ident -> JS-  foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign")+  foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign")    -- |   -- Generate code in the simplified Javascript intermediate representation for pattern match binders@@ -315,11 +327,11 @@   bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS   bindersToJs maybeSpan binders vals = do     valNames <- replicateM (length vals) freshName-    let assignments = zipWith JSVariableIntroduction valNames (map Just vals)+    let assignments = zipWith (JSVariableIntroduction Nothing) valNames (map Just vals)     jss <- forM binders $ \(CaseAlternative bs result) -> do       ret <- guardsToJs result       go valNames ret bs-    return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ failedPatternError valNames])))+    return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames])))                    []     where       go :: [String] -> [JS] -> [Binder Ann] -> m [JS]@@ -330,43 +342,48 @@       go _ _ _ = internalError "Invalid arguments to bindersToJs"        failedPatternError :: [String] -> JS-      failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)]+      failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]        failedPatternMessage :: String       failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "        valueError :: String -> JS -> JS-      valueError _ l@(JSNumericLiteral _) = l-      valueError _ l@(JSStringLiteral _)  = l-      valueError _ l@(JSBooleanLiteral _) = l-      valueError s _                      = JSAccessor "name" . JSAccessor "constructor" $ JSVar s+      valueError _ l@(JSNumericLiteral _ _) = l+      valueError _ l@(JSStringLiteral _ _)  = l+      valueError _ l@(JSBooleanLiteral _ _) = l+      valueError s _                        = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s        guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]       guardsToJs (Left gs) = forM gs $ \(cond, val) -> do         cond' <- valueToJs cond         done  <- valueToJs val-        return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing-      guardsToJs (Right v) = return . JSReturn <$> valueToJs v+        return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing+      guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v +  binderToJs :: String -> [JS] -> Binder Ann -> m [JS]+  binderToJs s done binder =+    let (ss, _, _, _) = extractBinderAnn binder in+    traverse (withPos ss) =<< binderToJs' s done binder+   -- |   -- Generate code in the simplified Javascript intermediate representation for a pattern match   -- binder.   ---  binderToJs :: String -> [JS] -> Binder Ann -> m [JS]-  binderToJs _ done (NullBinder{}) = return done-  binderToJs varName done (LiteralBinder _ l) =+  binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]+  binderToJs' _ done (NullBinder{}) = return done+  binderToJs' varName done (LiteralBinder _ l) =     literalToBinderJS varName done l-  binderToJs varName done (VarBinder _ ident) =-    return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)-  binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =+  binderToJs' varName done (VarBinder _ ident) =+    return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : done)+  binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =     binderToJs varName done b-  binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do+  binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do     js <- go (zip fields bs) done     return $ case ctorType of       ProductType -> js       SumType ->-        [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))-                  (JSBlock js)+        [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))+                  (JSBlock Nothing js)                   Nothing]     where     go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]@@ -375,24 +392,24 @@       argVar <- freshName       done'' <- go remain done'       js <- binderToJs argVar done'' binder-      return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)-  binderToJs _ _ ConstructorBinder{} =+      return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)+  binderToJs' _ _ ConstructorBinder{} =     internalError "binderToJs: Invalid ConstructorBinder in binderToJs"-  binderToJs varName done (NamedBinder _ ident binder) = do+  binderToJs' varName done (NamedBinder _ ident binder) = do     js <- binderToJs varName done binder-    return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)+    return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js)    literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]   literalToBinderJS varName done (NumericLiteral num) =-    return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]+    return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]   literalToBinderJS varName done (CharLiteral c) =-    return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral [c])) (JSBlock done) Nothing]+    return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing [c])) (JSBlock Nothing done) Nothing]   literalToBinderJS varName done (StringLiteral str) =-    return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]+    return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]   literalToBinderJS varName done (BooleanLiteral True) =-    return [JSIfElse (JSVar varName) (JSBlock done) Nothing]+    return [JSIfElse Nothing (JSVar Nothing varName) (JSBlock Nothing done) Nothing]   literalToBinderJS varName done (BooleanLiteral False) =-    return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]+    return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]   literalToBinderJS varName done (ObjectLiteral bs) = go done bs     where     go :: [JS] -> [(String, Binder Ann)] -> m [JS]@@ -401,10 +418,10 @@       propVar <- freshName       done'' <- go done' bs'       js <- binderToJs propVar done'' binder-      return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)+      return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)   literalToBinderJS varName done (ArrayLiteral bs) = do     js <- go done 0 bs-    return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]+    return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]     where     go :: [JS] -> Integer -> [Binder Ann] -> m [JS]     go done' _ [] = return done'@@ -412,21 +429,21 @@       elVar <- freshName       done'' <- go done' (index + 1) bs'       js <- binderToJs elVar done'' binder-      return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)+      return (JSVariableIntroduction Nothing elVar (Just (JSIndexer Nothing (JSNumericLiteral Nothing (Left index)) (JSVar Nothing varName))) : js)    -- Check that all integers fall within the valid int range for JavaScript.   checkIntegers :: JS -> m ()   checkIntegers = void . everywhereOnJSTopDownM go     where     go :: JS -> m JS-    go (JSUnary Negate (JSNumericLiteral (Left i))) =+    go (JSUnary _ Negate (JSNumericLiteral ss (Left i))) =       -- Move the negation inside the literal; since this is a top-down       -- traversal doing this replacement will stop the next case from raising       -- the error when attempting to use -2147483648, as if left unrewritten       -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and       -- 2147483648 is larger than the maximum allowed int.-      return $ JSNumericLiteral (Left (-i))-    go js@(JSNumericLiteral (Left i)) =+      return $ JSNumericLiteral ss (Left (-i))+    go js@(JSNumericLiteral _ (Left i)) =       let minInt = -2147483648           maxInt = 2147483647       in if i < minInt || i > maxInt

@@ -10,6 +10,7 @@  import Language.PureScript.Comments import Language.PureScript.Traversals+import Language.PureScript.AST (SourceSpan(..))  -- | -- Built-in unary operators@@ -126,121 +127,191 @@   -- |   -- A numeric literal   ---  = JSNumericLiteral (Either Integer Double)+  = JSNumericLiteral (Maybe SourceSpan) (Either Integer Double)   -- |   -- A string literal   ---  | JSStringLiteral String+  | JSStringLiteral (Maybe SourceSpan) String   -- |   -- A boolean literal   ---  | JSBooleanLiteral Bool+  | JSBooleanLiteral (Maybe SourceSpan) Bool   -- |   -- A unary operator application   ---  | JSUnary UnaryOperator JS+  | JSUnary (Maybe SourceSpan) UnaryOperator JS   -- |   -- A binary operator application   ---  | JSBinary BinaryOperator JS JS+  | JSBinary (Maybe SourceSpan) BinaryOperator JS JS   -- |   -- An array literal   ---  | JSArrayLiteral [JS]+  | JSArrayLiteral (Maybe SourceSpan) [JS]   -- |   -- An array indexer expression   ---  | JSIndexer JS JS+  | JSIndexer (Maybe SourceSpan) JS JS   -- |   -- An object literal   ---  | JSObjectLiteral [(String, JS)]+  | JSObjectLiteral (Maybe SourceSpan) [(String, JS)]   -- |   -- An object property accessor expression   ---  | JSAccessor String JS+  | JSAccessor (Maybe SourceSpan) String JS   -- |   -- A function introduction (optional name, arguments, body)   ---  | JSFunction (Maybe String) [String] JS+  | JSFunction (Maybe SourceSpan) (Maybe String) [String] JS   -- |   -- Function application   ---  | JSApp JS [JS]+  | JSApp (Maybe SourceSpan) JS [JS]   -- |   -- Variable   ---  | JSVar String+  | JSVar (Maybe SourceSpan) String   -- |   -- Conditional expression   ---  | JSConditional JS JS JS+  | JSConditional (Maybe SourceSpan) JS JS JS   -- |   -- A block of expressions in braces   ---  | JSBlock [JS]+  | JSBlock (Maybe SourceSpan) [JS]   -- |   -- A variable introduction and optional initialization   ---  | JSVariableIntroduction String (Maybe JS)+  | JSVariableIntroduction (Maybe SourceSpan) String (Maybe JS)   -- |   -- A variable assignment   ---  | JSAssignment JS JS+  | JSAssignment (Maybe SourceSpan) JS JS   -- |   -- While loop   ---  | JSWhile JS JS+  | JSWhile (Maybe SourceSpan) JS JS   -- |   -- For loop   ---  | JSFor String JS JS JS+  | JSFor (Maybe SourceSpan) String JS JS JS   -- |   -- ForIn loop   ---  | JSForIn String JS JS+  | JSForIn (Maybe SourceSpan) String JS JS   -- |   -- If-then-else statement   ---  | JSIfElse JS JS (Maybe JS)+  | JSIfElse (Maybe SourceSpan) JS JS (Maybe JS)   -- |   -- Return statement   ---  | JSReturn JS+  | JSReturn (Maybe SourceSpan) JS   -- |   -- Throw statement   ---  | JSThrow JS+  | JSThrow (Maybe SourceSpan) JS   -- |   -- Type-Of operator   ---  | JSTypeOf JS+  | JSTypeOf (Maybe SourceSpan) JS   -- |   -- InstanceOf test   ---  | JSInstanceOf JS JS+  | JSInstanceOf (Maybe SourceSpan) JS JS   -- |   -- Labelled statement   ---  | JSLabel String JS+  | JSLabel (Maybe SourceSpan) String JS   -- |   -- Break statement   ---  | JSBreak String+  | JSBreak (Maybe SourceSpan) String   -- |   -- Continue statement   ---  | JSContinue String+  | JSContinue (Maybe SourceSpan) String   -- |   -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)   ---  | JSRaw String+  | JSRaw (Maybe SourceSpan) String   -- |   -- Commented Javascript   ---  | JSComment [Comment] JS-  deriving (Show, Read, Eq)+  | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Read, Eq) +withSourceSpan :: SourceSpan -> JS -> JS+withSourceSpan withSpan = go+  where+  ss :: Maybe SourceSpan+  ss = Just withSpan++  go :: JS -> JS+  go (JSNumericLiteral _ n) = JSNumericLiteral ss n+  go (JSStringLiteral _ s) = JSStringLiteral ss s+  go (JSBooleanLiteral _ b) = JSBooleanLiteral ss b+  go (JSUnary _ op j) = JSUnary ss op j+  go (JSBinary _ op j1 j2) = JSBinary ss op j1 j2+  go (JSArrayLiteral _ js) = JSArrayLiteral ss js+  go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2+  go (JSObjectLiteral _ js) = JSObjectLiteral ss js+  go (JSAccessor _ prop j) = JSAccessor ss prop j+  go (JSFunction _ name args j) = JSFunction ss name args j+  go (JSApp _ j js) = JSApp ss j js+  go (JSVar _ s) = JSVar ss s+  go (JSConditional _ j1 j2 j3) = JSConditional ss j1 j2 j3+  go (JSBlock _ js) = JSBlock ss js+  go (JSVariableIntroduction _ name j) = JSVariableIntroduction ss name j+  go (JSAssignment _ j1 j2) = JSAssignment ss j1 j2+  go (JSWhile _ j1 j2) = JSWhile ss j1 j2+  go (JSFor _ name j1 j2 j3) = JSFor ss name j1 j2 j3+  go (JSForIn _ name j1 j2) = JSForIn ss name j1 j2+  go (JSIfElse _ j1 j2 j3) = JSIfElse ss j1 j2 j3+  go (JSReturn _ js) = JSReturn ss js+  go (JSThrow _ js) = JSThrow ss js+  go (JSTypeOf _ js) = JSTypeOf ss js+  go (JSInstanceOf _ j1 j2) = JSInstanceOf ss j1 j2+  go (JSLabel _ name js) = JSLabel ss name js+  go (JSBreak _ s) = JSBreak ss s+  go (JSContinue _ s) = JSContinue ss s+  go (JSRaw _ s) = JSRaw ss s+  go (JSComment _ com j) = JSComment ss com j++getSourceSpan :: JS -> Maybe SourceSpan+getSourceSpan = go+  where+  go :: JS -> Maybe SourceSpan+  go (JSNumericLiteral ss _) = ss+  go (JSStringLiteral ss _) = ss+  go (JSBooleanLiteral ss _) = ss+  go (JSUnary ss _ _) = ss+  go (JSBinary ss _ _ _) = ss+  go (JSArrayLiteral ss _) = ss+  go (JSIndexer ss _ _) = ss+  go (JSObjectLiteral ss _) = ss+  go (JSAccessor ss _ _) = ss+  go (JSFunction ss _ _ _) = ss+  go (JSApp ss _ _) = ss+  go (JSVar ss _) = ss+  go (JSConditional ss _ _ _) = ss+  go (JSBlock ss _) = ss+  go (JSVariableIntroduction ss _ _) = ss+  go (JSAssignment ss _ _) = ss+  go (JSWhile ss _ _) = ss+  go (JSFor ss _ _ _ _) = ss+  go (JSForIn ss _ _ _) = ss+  go (JSIfElse ss _ _ _) = ss+  go (JSReturn ss _) = ss+  go (JSThrow ss _) = ss+  go (JSTypeOf ss _) = ss+  go (JSInstanceOf ss _ _) = ss+  go (JSLabel ss _ _) = ss+  go (JSBreak ss _) = ss+  go (JSContinue ss _) = ss+  go (JSRaw ss _) = ss+  go (JSComment ss _ _) = ss+ -- -- Traversals --@@ -249,28 +320,28 @@ everywhereOnJS f = go   where   go :: JS -> JS-  go (JSUnary op j) = f (JSUnary op (go j))-  go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))-  go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))-  go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))-  go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))-  go (JSAccessor prop j) = f (JSAccessor prop (go j))-  go (JSFunction name args j) = f (JSFunction name args (go j))-  go (JSApp j js) = f (JSApp (go j) (map go js))-  go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))-  go (JSBlock js) = f (JSBlock (map go js))-  go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))-  go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))-  go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))-  go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))-  go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))-  go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))-  go (JSReturn js) = f (JSReturn (go js))-  go (JSThrow js) = f (JSThrow (go js))-  go (JSTypeOf js) = f (JSTypeOf (go js))-  go (JSLabel name js) = f (JSLabel name (go js))-  go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))-  go (JSComment com j) = f (JSComment com (go j))+  go (JSUnary ss op j) = f (JSUnary ss op (go j))+  go (JSBinary ss op j1 j2) = f (JSBinary ss op (go j1) (go j2))+  go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js))+  go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2))+  go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js))+  go (JSAccessor ss prop j) = f (JSAccessor ss prop (go j))+  go (JSFunction ss name args j) = f (JSFunction ss name args (go j))+  go (JSApp ss j js) = f (JSApp ss (go j) (map go js))+  go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3))+  go (JSBlock ss js) = f (JSBlock ss (map go js))+  go (JSVariableIntroduction ss name j) = f (JSVariableIntroduction ss name (fmap go j))+  go (JSAssignment ss j1 j2) = f (JSAssignment ss (go j1) (go j2))+  go (JSWhile ss j1 j2) = f (JSWhile ss (go j1) (go j2))+  go (JSFor ss name j1 j2 j3) = f (JSFor ss name (go j1) (go j2) (go j3))+  go (JSForIn ss name j1 j2) = f (JSForIn ss name (go j1) (go j2))+  go (JSIfElse ss j1 j2 j3) = f (JSIfElse ss (go j1) (go j2) (fmap go j3))+  go (JSReturn ss js) = f (JSReturn ss (go js))+  go (JSThrow ss js) = f (JSThrow ss (go js))+  go (JSTypeOf ss js) = f (JSTypeOf ss (go js))+  go (JSLabel ss name js) = f (JSLabel ss name (go js))+  go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2))+  go (JSComment ss com j) = f (JSComment ss com (go j))   go other = f other  everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS@@ -280,54 +351,54 @@ everywhereOnJSTopDownM f = f >=> go   where   f' = f >=> go-  go (JSUnary op j) = JSUnary op <$> f' j-  go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2-  go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js-  go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2-  go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (sndM f') js-  go (JSAccessor prop j) = JSAccessor prop <$> f' j-  go (JSFunction name args j) = JSFunction name args <$> f' j-  go (JSApp j js) = JSApp <$> f' j <*> traverse f' js-  go (JSConditional j1 j2 j3) = JSConditional <$> f' j1 <*> f' j2 <*> f' j3-  go (JSBlock js) = JSBlock <$> traverse f' js-  go (JSVariableIntroduction name j) = JSVariableIntroduction name <$> traverse f' j-  go (JSAssignment j1 j2) = JSAssignment <$> f' j1 <*> f' j2-  go (JSWhile j1 j2) = JSWhile <$> f' j1 <*> f' j2-  go (JSFor name j1 j2 j3) = JSFor name <$> f' j1 <*> f' j2 <*> f' j3-  go (JSForIn name j1 j2) = JSForIn name <$> f' j1 <*> f' j2-  go (JSIfElse j1 j2 j3) = JSIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3-  go (JSReturn j) = JSReturn <$> f' j-  go (JSThrow j) = JSThrow <$> f' j-  go (JSTypeOf j) = JSTypeOf <$> f' j-  go (JSLabel name j) = JSLabel name <$> f' j-  go (JSInstanceOf j1 j2) = JSInstanceOf <$> f' j1 <*> f' j2-  go (JSComment com j) = JSComment com <$> f' j+  go (JSUnary ss op j) = JSUnary ss op <$> f' j+  go (JSBinary ss op j1 j2) = JSBinary ss op <$> f' j1 <*> f' j2+  go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js+  go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2+  go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js+  go (JSAccessor ss prop j) = JSAccessor ss prop <$> f' j+  go (JSFunction ss name args j) = JSFunction ss name args <$> f' j+  go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js+  go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3+  go (JSBlock ss js) = JSBlock ss <$> traverse f' js+  go (JSVariableIntroduction ss name j) = JSVariableIntroduction ss name <$> traverse f' j+  go (JSAssignment ss j1 j2) = JSAssignment ss <$> f' j1 <*> f' j2+  go (JSWhile ss j1 j2) = JSWhile ss <$> f' j1 <*> f' j2+  go (JSFor ss name j1 j2 j3) = JSFor ss name <$> f' j1 <*> f' j2 <*> f' j3+  go (JSForIn ss name j1 j2) = JSForIn ss name <$> f' j1 <*> f' j2+  go (JSIfElse ss j1 j2 j3) = JSIfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3+  go (JSReturn ss j) = JSReturn ss <$> f' j+  go (JSThrow ss j) = JSThrow ss <$> f' j+  go (JSTypeOf ss j) = JSTypeOf ss <$> f' j+  go (JSLabel ss name j) = JSLabel ss name <$> f' j+  go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2+  go (JSComment ss com j) = JSComment ss com <$> f' j   go other = f other  everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r everythingOnJS (<>) f = go   where-  go j@(JSUnary _ j1) = f j <> go j1-  go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2-  go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)-  go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2-  go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)-  go j@(JSAccessor _ j1) = f j <> go j1-  go j@(JSFunction _ _ j1) = f j <> go j1-  go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)-  go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3-  go j@(JSBlock js) = foldl (<>) (f j) (map go js)-  go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1-  go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2-  go j@(JSWhile j1 j2) = f j <> go j1 <> go j2-  go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3-  go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2-  go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2-  go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3-  go j@(JSReturn j1) = f j <> go j1-  go j@(JSThrow j1) = f j <> go j1-  go j@(JSTypeOf j1) = f j <> go j1-  go j@(JSLabel _ j1) = f j <> go j1-  go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2-  go j@(JSComment _ j1) = f j <> go j1+  go j@(JSUnary _ _ j1) = f j <> go j1+  go j@(JSBinary _ _ j1 j2) = f j <> go j1 <> go j2+  go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js)+  go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2+  go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)+  go j@(JSAccessor _ _ j1) = f j <> go j1+  go j@(JSFunction _ _ _ j1) = f j <> go j1+  go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js)+  go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3+  go j@(JSBlock _ js) = foldl (<>) (f j) (map go js)+  go j@(JSVariableIntroduction _ _ (Just j1)) = f j <> go j1+  go j@(JSAssignment _ j1 j2) = f j <> go j1 <> go j2+  go j@(JSWhile _ j1 j2) = f j <> go j1 <> go j2+  go j@(JSFor _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3+  go j@(JSForIn _ _ j1 j2) = f j <> go j1 <> go j2+  go j@(JSIfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2+  go j@(JSIfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3+  go j@(JSReturn _ j1) = f j <> go j1+  go j@(JSThrow _ j1) = f j <> go j1+  go j@(JSTypeOf _ j1) = f j <> go j1+  go j@(JSLabel _ _ j1) = f j <> go j1+  go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2+  go j@(JSComment _ _ j1) = f j <> go j1   go other = f other

@@ -53,11 +53,11 @@   opts <- ask   js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll     [ inlineCommonValues-    , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]-    , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x]-    , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]-    , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x]-    , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer+    , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp Nothing f [x]+    , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]+    , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp Nothing f [x]+    , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]+    , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)     , inlineCommonOperators     ]) js   untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'

@@ -27,16 +27,16 @@ collapseNestedBlocks = everywhereOnJS collapse   where   collapse :: JS -> JS-  collapse (JSBlock sts) = JSBlock (concatMap go sts)+  collapse (JSBlock ss sts) = JSBlock ss (concatMap go sts)   collapse js = js   go :: JS -> [JS]-  go (JSBlock sts) = sts+  go (JSBlock _ sts) = sts   go s = [s]  collapseNestedIfs :: JS -> JS collapseNestedIfs = everywhereOnJS collapse   where   collapse :: JS -> JS-  collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =-      JSIfElse (JSBinary And cond1 cond2) body Nothing+  collapse (JSIfElse s1 cond1 (JSBlock _ [JSIfElse s2 cond2 body Nothing]) Nothing) =+      JSIfElse s1 (JSBinary s2 And cond1 cond2) body Nothing   collapse js = js

@@ -14,67 +14,67 @@ replaceIdent :: String -> JS -> JS -> JS replaceIdent var1 js = everywhereOnJS replace   where-  replace (JSVar var2) | var1 == var2 = js+  replace (JSVar _ var2) | var1 == var2 = js   replace other = other  replaceIdents :: [(String, JS)] -> JS -> JS replaceIdents vars = everywhereOnJS replace   where-  replace v@(JSVar var) = fromMaybe v $ lookup var vars+  replace v@(JSVar _ var) = fromMaybe v $ lookup var vars   replace other = other  isReassigned :: String -> JS -> Bool isReassigned var1 = everythingOnJS (||) check   where   check :: JS -> Bool-  check (JSFunction _ args _) | var1 `elem` args = True-  check (JSVariableIntroduction arg _) | var1 == arg = True-  check (JSAssignment (JSVar arg) _) | var1 == arg = True-  check (JSFor arg _ _ _) | var1 == arg = True-  check (JSForIn arg _ _) | var1 == arg = True+  check (JSFunction _ _ args _) | var1 `elem` args = True+  check (JSVariableIntroduction _ arg _) | var1 == arg = True+  check (JSAssignment _ (JSVar _ arg) _) | var1 == arg = True+  check (JSFor _ arg _ _ _) | var1 == arg = True+  check (JSForIn _ arg _ _) | var1 == arg = True   check _ = False  isRebound :: JS -> JS -> Bool isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)   where-  variablesOf (JSVar var) = [var]+  variablesOf (JSVar _ var) = [var]   variablesOf _ = []  isUsed :: String -> JS -> Bool isUsed var1 = everythingOnJS (||) check   where   check :: JS -> Bool-  check (JSVar var2) | var1 == var2 = True-  check (JSAssignment target _) | var1 == targetVariable target = True+  check (JSVar _ var2) | var1 == var2 = True+  check (JSAssignment _ target _) | var1 == targetVariable target = True   check _ = False  targetVariable :: JS -> String-targetVariable (JSVar var) = var-targetVariable (JSAccessor _ tgt) = targetVariable tgt-targetVariable (JSIndexer _ tgt) = targetVariable tgt+targetVariable (JSVar _ var) = var+targetVariable (JSAccessor _ _ tgt) = targetVariable tgt+targetVariable (JSIndexer _ _ tgt) = targetVariable tgt targetVariable _ = internalError "Invalid argument to targetVariable"  isUpdated :: String -> JS -> Bool isUpdated var1 = everythingOnJS (||) check   where   check :: JS -> Bool-  check (JSAssignment target _) | var1 == targetVariable target = True+  check (JSAssignment _ target _) | var1 == targetVariable target = True   check _ = False  removeFromBlock :: ([JS] -> [JS]) -> JS -> JS-removeFromBlock go (JSBlock sts) = JSBlock (go sts)+removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts) removeFromBlock _  js = js  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 (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = x == fnName && y == moduleName+isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = x == fnName && y == moduleName isFn _ _ = False  isFn' :: [(String, String)] -> JS -> Bool isFn' xs js = any (`isFn` js) xs  isDict :: (String, String) -> JS -> Bool-isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName+isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName isDict _ _ = False  isDict' :: [(String, String)] -> JS -> Bool

@@ -29,42 +29,42 @@ -- Needs to be: { 0..toFixed(10); } -- Probably needs to be fixed in pretty-printer instead. shouldInline :: JS -> Bool-shouldInline (JSVar _) = True-shouldInline (JSNumericLiteral _) = True-shouldInline (JSStringLiteral _) = True-shouldInline (JSBooleanLiteral _) = True-shouldInline (JSAccessor _ val) = shouldInline val-shouldInline (JSIndexer index val) = shouldInline index && shouldInline val+shouldInline (JSVar _ _) = True+shouldInline (JSNumericLiteral _ _) = True+shouldInline (JSStringLiteral _ _) = True+shouldInline (JSBooleanLiteral _ _) = True+shouldInline (JSAccessor _ _ val) = shouldInline val+shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val shouldInline _ = False  etaConvert :: JS -> JS etaConvert = everywhereOnJS convert   where   convert :: JS -> JS-  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])+  convert (JSBlock ss [JSReturn _ (JSApp _ (JSFunction _ Nothing idents block@(JSBlock _ body)) args)])     | all shouldInline args &&-      not (any (`isRebound` block) (map JSVar idents)) &&+      not (any (`isRebound` block) (map (JSVar Nothing) idents)) &&       not (any (`isRebound` block) args)-      = JSBlock (map (replaceIdents (zip idents args)) body)-  convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn+      = JSBlock ss (map (replaceIdents (zip idents args)) body)+  convert (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ (JSApp _ fn [])])) = fn   convert js = js  unThunk :: JS -> JS unThunk = everywhereOnJS convert   where   convert :: JS -> JS-  convert (JSBlock []) = JSBlock []-  convert (JSBlock jss) =+  convert (JSBlock ss []) = JSBlock ss []+  convert (JSBlock ss jss) =     case last jss of-      JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body-      _ -> JSBlock jss+      JSReturn _ (JSApp _ (JSFunction _ Nothing [] (JSBlock _ body)) []) -> JSBlock ss $ init jss ++ body+      _ -> JSBlock ss jss   convert js = js  evaluateIifes :: JS -> JS evaluateIifes = everywhereOnJS convert   where   convert :: JS -> JS-  convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret+  convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret   convert js = js  inlineVariables :: JS -> JS@@ -72,7 +72,7 @@   where   go :: [JS] -> [JS]   go [] = []-  go (JSVariableIntroduction var (Just js) : sts)+  go (JSVariableIntroduction _ var (Just js) : sts)     | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =       go (map (replaceIdent var js) sts)   go (s:sts) = s : go sts@@ -81,16 +81,16 @@ inlineCommonValues = everywhereOnJS convert   where   convert :: JS -> JS-  convert (JSApp fn [dict])-    | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral (Left 0)-    | isDict' (semiringNumber ++ 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 (JSApp (JSApp fn [dict]) [x]) [y])-    | isDict' semiringInt dict && isFn' fnAdd fn = intOp Add x y-    | isDict' semiringInt dict && isFn' fnMultiply fn = intOp Multiply x y-    | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp Divide x y-    | isDict' ringInt dict && isFn' fnSubtract fn = intOp Subtract x y+  convert (JSApp ss fn [dict])+    | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral ss (Left 0)+    | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral ss (Left 1)+    | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral ss False+    | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral ss True+  convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y])+    | isDict' semiringInt dict && isFn' fnAdd fn = intOp ss Add x y+    | isDict' semiringInt dict && isFn' fnMultiply fn = intOp ss Multiply x y+    | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp ss Divide x y+    | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y   convert other = other   fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)]   fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]@@ -100,16 +100,16 @@   fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)]   fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]   fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]-  intOp op x y = JSBinary BitwiseOr (JSBinary op x y) (JSNumericLiteral (Left 0))+  intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))  inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS inlineOperator (m, op) f = everywhereOnJS convert   where   convert :: JS -> JS-  convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y+  convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y   convert other = other-  isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)-  isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'+  isOp (JSAccessor _ longForm (JSVar _ m')) = m == m' && longForm == identToJs (Op op)+  isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op'   isOp _ = False  inlineCommonOperators :: JS -> JS@@ -177,49 +177,49 @@   binary dict fns op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary op x y+    convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary ss 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 (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y     convert other = other   unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS   unary dicts fns op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary op x+    convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary ss op x     convert other = other   unary' :: String -> String -> UnaryOperator -> JS -> JS   unary' moduleName fnName op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x+    convert (JSApp ss fn [x]) | isFn (moduleName, fnName) fn = JSUnary ss op x     convert other = other   mkFn :: Int -> JS -> JS   mkFn 0 = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =-      JSFunction Nothing [] (JSBlock js)+    convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN =+      JSFunction s1 Nothing [] (JSBlock s2 js)     convert other = other   mkFn n = everywhereOnJS convert     where     convert :: JS -> JS-    convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =+    convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =       case collectArgs n [] fn of-        Just (args, js) -> JSFunction Nothing args (JSBlock js)+        Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js)         Nothing -> orig     convert other = other     collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])-    collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)-    collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret+    collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)+    collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret     collectArgs _ _   _ = Nothing    isNFn :: String -> Int -> JS -> Bool-  isNFn prefix n (JSVar name) = name == (prefix ++ show n)-  isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)+  isNFn prefix n (JSVar _ name) = name == (prefix ++ show n)+  isNFn prefix n (JSAccessor _ name (JSVar _ dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)   isNFn _ _ _ = False    runFn :: Int -> JS -> JS@@ -229,8 +229,8 @@     convert js = fromMaybe js $ go n [] js      go :: Int -> [JS] -> JS -> Maybe JS-    go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)-    go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs+    go 0 acc (JSApp ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp ss fn acc)+    go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs     go _ _   _ = Nothing  -- (f <<< g $ x) = f (g x)@@ -239,16 +239,16 @@ inlineFnComposition = everywhereOnJSTopDownM convert   where   convert :: (MonadSupply m) => JS -> m JS-  convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z])-    | isFnCompose dict' fn = return $ JSApp x [JSApp y [z]]-    | isFnComposeFlipped dict' fn = return $ JSApp y [JSApp x [z]]-  convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y])+  convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z])+    | isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]]+    | isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]]+  convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y])     | isFnCompose dict' fn = do         arg <- freshName-        return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])+        return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing x [JSApp Nothing y [JSVar Nothing arg]]])     | isFnComposeFlipped dict' fn = do         arg <- freshName-        return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp y [JSApp x [JSVar arg]]])+        return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]])   convert other = return other   isFnCompose :: JS -> JS -> Bool   isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn

@@ -40,46 +40,46 @@   -- Desugar monomorphic calls to >>= and return for the Eff monad   convert :: JS -> JS   -- Desugar pure & return-  convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val+  convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val   -- Desugar >>-  convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =-    JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js )+  convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isBind bind =+    JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js )   -- Desugar >>=-  convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind =-    JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js)+  convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind =+    JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js)   -- Desugar untilE-  convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =-    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []+  convert (JSApp s1 (JSApp _ f [arg]) []) | isEffFunc C.untilE f =+    JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSUnary s1 Not (JSApp s1 arg [])) (JSBlock s1 []), JSReturn s1 $ JSObjectLiteral s1 []])) []   -- Desugar whileE-  convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =-    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []+  convert (JSApp _ (JSApp _ (JSApp s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f =+    JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSApp s1 arg1 []) (JSBlock s1 [ JSApp s1 arg2 [] ]), JSReturn s1 $ JSObjectLiteral s1 []])) []   convert other = other   -- Check if an expression represents a monomorphic call to >>= for the Eff monad-  isBind (JSApp fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True+  isBind (JSApp _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True   isBind _ = False   -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative-  isPure (JSApp fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True+  isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True   isPure _ = False   -- Check if an expression represents the polymorphic >>= function   isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)]   -- Check if an expression represents the polymorphic pure or return function   isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')]   -- Check if an expression represents a function in the Eff module-  isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'+  isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name'   isEffFunc _ _ = False    -- Remove __do function applications which remain after desugaring   undo :: JS -> JS-  undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body+  undo (JSReturn _ (JSApp _ (JSFunction _ (Just ident) [] body) [])) | ident == fnName = body   undo other = other    applyReturns :: JS -> JS-  applyReturns (JSReturn ret) = JSReturn (JSApp ret [])-  applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)-  applyReturns (JSWhile cond js) = JSWhile cond (applyReturns js)-  applyReturns (JSFor v lo hi js) = JSFor v lo hi (applyReturns js)-  applyReturns (JSForIn v xs js) = JSForIn v xs (applyReturns js)-  applyReturns (JSIfElse cond t f) = JSIfElse cond (applyReturns t) (applyReturns `fmap` f)+  applyReturns (JSReturn ss ret) = JSReturn ss (JSApp ss ret [])+  applyReturns (JSBlock ss jss) = JSBlock ss (map applyReturns jss)+  applyReturns (JSWhile ss cond js) = JSWhile ss cond (applyReturns js)+  applyReturns (JSFor ss v lo hi js) = JSFor ss v lo hi (applyReturns js)+  applyReturns (JSForIn ss v xs js) = JSForIn ss v xs (applyReturns js)+  applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f)   applyReturns other = other  -- |@@ -91,7 +91,7 @@   -- Look for runST blocks and inline the STRefs there.   -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then   -- we can be more aggressive about inlining, and actually turn STRefs into local variables.-  convertBlock (JSApp f [arg]) | isSTFunc C.runST f =+  convertBlock (JSApp _ f [arg]) | isSTFunc C.runST f =     let refs = nub . findSTRefsIn $ arg         usages = findAllSTUsagesIn arg         allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages@@ -101,34 +101,34 @@   -- Convert a block in a safe way, preserving object wrappers of references,   -- or in a more aggressive way, turning wrappers into local variables depending on the   -- agg(ressive) parameter.-  convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =-   JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])-  convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =-    if agg then ref else JSAccessor C.stRefValue ref-  convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =-    if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg-  convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =-    if agg then JSAssignment ref (JSApp func [ref]) else  JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])+  convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =+   JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]])+  convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =+    if agg then ref else JSAccessor s1 C.stRefValue ref+  convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =+    if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg+  convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =+    if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref])   convert _ other = other   -- Check if an expression represents a function in the ST module-  isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'+  isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name'   isSTFunc _ _ = False   -- Find all ST Refs initialized in this block   findSTRefsIn = everythingOnJS (++) isSTRef     where-    isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]+    isSTRef (JSVariableIntroduction _ ident (Just (JSApp _ (JSApp _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]     isSTRef _ = []   -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef   findAllSTUsagesIn = everythingOnJS (++) isSTUsage     where-    isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]-    isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]+    isSTUsage (JSApp _ (JSApp _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]+    isSTUsage (JSApp _ (JSApp _ (JSApp _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]     isSTUsage _ = []   -- Find all uses of a variable   appearingIn ref = everythingOnJS (++) isVar     where-    isVar e@(JSVar v) | v == ref = [e]+    isVar e@(JSVar _ v) | v == ref = [e]     isVar _ = []   -- Convert a JS value to a String if it is a JSVar-  toVar (JSVar v) = Just v+  toVar (JSVar _ v) = Just v   toVar _ = Nothing

@@ -40,7 +40,7 @@   copyVar arg = "__copy_" ++ arg    convert :: JS -> JS-  convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =+  convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =     let       (argss, body', replace) = collectAllFunctionArgs [] id fn     in case () of@@ -48,19 +48,19 @@             let               allArgs = concat $ reverse argss             in-              JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))+              JSVariableIntroduction ss 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-  collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =-    (args : allArgs, body, f . JSFunction ident (map copyVar args))-  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =-    collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body-  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =-    (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))+  collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =+    collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body+  collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =+    (args : allArgs, body, f . JSFunction ss ident (map copyVar args))+  collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args (JSBlock s3 [body]))) =+    collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn s1 (JSFunction s2 ident (map copyVar args) (JSBlock s3 [b])))) body+  collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args body@(JSBlock _ _))) =+    (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))   collectAllFunctionArgs allArgs f body = (allArgs, body, f)    isTailCall :: String -> JS -> Bool@@ -77,51 +77,53 @@       && numSelfCallWithFnArgs == 0     where     countSelfCalls :: JS -> Int-    countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1+    countSelfCalls (JSApp _ (JSVar _ ident') _) | ident == ident' = 1     countSelfCalls _ = 0-    +     countSelfCallsInTailPosition :: JS -> Int-    countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1+    countSelfCallsInTailPosition (JSReturn _ ret) | isSelfCall ident ret = 1     countSelfCallsInTailPosition _ = 0-    +     countSelfCallsUnderFunctions :: JS -> Int-    countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'+    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 ++-        [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]+  toLoop ident allArgs js = JSBlock rootSS $+        map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs +++        [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]     where+    rootSS = Nothing+     loopify :: JS -> JS-    loopify (JSReturn ret) | isSelfCall ident ret =+    loopify (JSReturn ss ret) | isSelfCall ident ret =       let         allArgumentValues = concat $ collectSelfCallArgs [] ret       in-        JSBlock $ zipWith (\val arg ->-                    JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs+        JSBlock ss $ zipWith (\val arg ->+                    JSVariableIntroduction ss (tcoVar arg) (Just val)) allArgumentValues allArgs                   ++ map (\arg ->-                    JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs-                  ++ [ JSContinue tcoLabel ]+                    JSAssignment ss (JSVar ss arg) (JSVar ss (tcoVar arg))) allArgs+                  ++ [ JSContinue ss tcoLabel ]     loopify other = other     collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]-    collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn+    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') _) = ident == ident'+  isSelfCall ident (JSApp _ fn _) = 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 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 :: JS -> Bool   hasFunction = getAny . everythingOnJS mappend (Any . isFunction)     where     isFunction JSFunction{} = True

@@ -30,17 +30,17 @@   go :: [JS] -> [JS]   go jss | not (any isJSReturn jss) = jss          | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret]-  isJSReturn (JSReturn _) = True+  isJSReturn (JSReturn _ _) = True   isJSReturn _ = False  removeUnusedArg :: JS -> JS removeUnusedArg = everywhereOnJS convert   where-  convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body+  convert (JSFunction ss name [arg] body) | arg == C.__unused = JSFunction ss name [] body   convert js = js  removeUndefinedApp :: JS -> JS removeUndefinedApp = everywhereOnJS convert   where-  convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []+  convert (JSApp ss fn [JSVar _ arg]) | arg == C.undefined = JSApp ss fn []   convert js = js

@@ -98,6 +98,9 @@ notEq :: String notEq = "notEq" +compare :: String+compare = "compare"+ (&&) :: String (&&) = "&&" 

@@ -31,5 +31,12 @@   -- |   -- A binder which binds its input to an identifier   ---  | NamedBinder a Ident (Binder a)-  deriving (Show, Read, Functor)+  | NamedBinder a Ident (Binder a) deriving (Show, Read, Functor)+++extractBinderAnn :: Binder a -> a+extractBinderAnn (NullBinder a) = a+extractBinderAnn (LiteralBinder a _) = a+extractBinderAnn (VarBinder a _) = a+extractBinderAnn (ConstructorBinder a _ _ _) = a+extractBinderAnn (NamedBinder a _ _) = a

@@ -1,5 +1,9 @@ module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where +import Prelude ()+import Prelude.Compat++ import Data.Function (on) import Data.List (sort, sortBy, nub) import Data.Maybe (mapMaybe)@@ -30,36 +34,52 @@ moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =   internalError "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =-  let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls+  let imports = mapMaybe importToCoreFn decls ++ findQualModules decls+      imports' = nub $ filter (keepImp imports) imports-- TODO could be more efficient       exps' = nub $ concatMap exportToCoreFn exps       externs = nub $ mapMaybe externToCoreFn decls       decls' = concatMap (declToCoreFn Nothing []) decls-  in Module coms mn imports exps' externs decls'+  in Module coms mn imports' exps' externs decls'    where +  -- Remove duplicate imports favoring the one containing sourcespan info+  keepImp :: [(Ann, ModuleName)] -> (Ann, ModuleName) -> Bool+  keepImp imps (a, i) = hasSS a || not (any hasDup imps)+    where+      hasDup (a', i') = i == i' && hasSS a'++  hasSS :: Ann -> Bool+  hasSS (Just _, _, _, _) = True+  hasSS _ = False++  ssA :: Maybe SourceSpan -> Ann+  ssA ss = (ss, [], Nothing, Nothing)+   -- |   -- Desugars member declarations from AST to CoreFn representation.   --   declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]   declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =-    [NonRec (properToIdent ctor) $+    [NonRec (ssA ss) (properToIdent ctor) $       Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]   declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =     error $ "Found newtype with multiple constructors: " ++ show d   declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =     flip map ctors $ \(ctor, _) ->       let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)-      in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields+      in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields   declToCoreFn ss _   (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds   declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =-    [NonRec name (exprToCoreFn ss com Nothing e)]+    [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]   declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =-    [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)]+    let meta = either getValueMeta (Just . getConstructorMeta) alias+        alias' = either id (fmap properToIdent) alias+    in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) alias')]   declToCoreFn ss _   (A.BindingGroupDeclaration ds) =-    [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]+    [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]   declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =-    [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]+    [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members]   declToCoreFn _  com (A.PositionedDeclaration ss com1 d) =     declToCoreFn (Just ss) (com ++ com1) d   declToCoreFn _ _ _ = []@@ -157,6 +177,12 @@     binderToCoreFn (Just ss) (com ++ com1) b   binderToCoreFn ss com (A.TypedBinder _ b) =     binderToCoreFn ss com b+  binderToCoreFn _ _ A.OpBinder{} =+    internalError "OpBinder should have been desugared before binderToCoreFn"+  binderToCoreFn _ _ A.BinaryNoParensBinder{} =+    internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn"+  binderToCoreFn _ _ A.ParensInBinder{} =+    internalError "ParensInBinder should have been desugared before binderToCoreFn"    -- |   -- Gets metadata for values.@@ -195,31 +221,36 @@ -- ensure instances are imported from any module that is referenced by the -- current module, not just from those that are imported explicitly (#667). ---findQualModules :: [A.Declaration] -> [ModuleName]+findQualModules :: [A.Declaration] -> [(Ann, ModuleName)] findQualModules decls =   let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])   in f `concatMap` decls   where-  fqDecls :: A.Declaration -> [ModuleName]-  fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]-  fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]+  fqDecls :: A.Declaration -> [(Ann, ModuleName)]+  fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q+  fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq   fqDecls _ = [] -  fqValues :: A.Expr -> [ModuleName]-  fqValues (A.Var (Qualified (Just mn) _)) = [mn]-  fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]+  fqValues :: A.Expr -> [(Ann, ModuleName)]+  fqValues (A.Var q) = getQual q+  fqValues (A.Constructor q) = getQual q   fqValues _ = [] -  fqBinders :: A.Binder -> [ModuleName]-  fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]+  fqBinders :: A.Binder -> [(Ann, ModuleName)]+  fqBinders (A.ConstructorBinder q _) = getQual q   fqBinders _ = [] +  getQual :: Qualified a -> [(Ann, ModuleName)]+  getQual (Qualified (Just mn) _) = [(nullAnn, mn)]+  getQual _ = []+ -- | -- Desugars import declarations from AST to CoreFn representation. ---importToCoreFn :: A.Declaration -> Maybe ModuleName-importToCoreFn (A.ImportDeclaration name _ _ _) = Just name-importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d+importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName)+importToCoreFn (A.ImportDeclaration name _ _ _) = Just (nullAnn, name)+importToCoreFn (A.PositionedDeclaration ss _ d) =+  ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d importToCoreFn _ = Nothing  -- |

@@ -60,12 +60,11 @@   -- |   -- Non-recursive binding for a single value   ---  = NonRec Ident (Expr a)+  = NonRec a Ident (Expr a)   -- |   -- Mutually recursive binding group for several values   ---  | Rec [(Ident, Expr a)]-  deriving (Show, Read, Functor)+  | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor)  -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders@@ -84,8 +83,7 @@     -- The result expression or a collect of guarded expressions     --   , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)-  }-  deriving (Show, Read)+  } deriving (Show, Read)  instance Functor CaseAlternative where 

@@ -24,8 +24,7 @@   -- |   -- The contained reference is for a foreign member   ---  | IsForeign-  deriving (Show, Read)+  | IsForeign deriving (Show, Read, Eq)  -- | -- Data constructor metadata@@ -38,5 +37,4 @@   -- |   -- The constructor is for a type with multiple construcors   ---  | SumType-  deriving (Show, Read)+  | SumType deriving (Show, Read, Eq)

@@ -22,7 +22,7 @@ data Module a = Module   { moduleComments :: [Comment]   , moduleName :: ModuleName-  , moduleImports :: [ModuleName]+  , moduleImports :: [(a, ModuleName)]   , moduleExports :: [Ident]   , moduleForeign :: [ForeignDecl]   , moduleDecls :: [Bind a]

@@ -26,7 +26,7 @@                       (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a) everywhereOnValues f g h = (f', g', h')   where-  f' (NonRec name e) = f (NonRec name (g' e))+  f' (NonRec a name e) = f (NonRec a name (g' e))   f' (Rec es) = f (Rec (map (second g') es))    g' (Literal ann e) = g (Literal ann (handleLiteral g' e))@@ -61,7 +61,7 @@                       (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r) everythingOnValues (<>) f g h i = (f', g', h', i')   where-  f' b@(NonRec _ e) = f b <> g' e+  f' b@(NonRec _ _ e) = f b <> g' e   f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)    g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))

@@ -11,4 +11,4 @@ import Language.PureScript.Docs.RenderedCode.Render as Docs import Language.PureScript.Docs.Convert as Docs import Language.PureScript.Docs.Render as Docs-import Language.PureScript.Docs.ParseAndDesugar as Docs+import Language.PureScript.Docs.ParseAndBookmark as Docs

@@ -31,31 +31,29 @@ renderModulesAsMarkdown ::   (Functor m, Applicative m,   MonadError P.MultipleErrors m) =>-  P.Env ->   [P.Module] ->   m String-renderModulesAsMarkdown env =-  fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env+renderModulesAsMarkdown =+  fmap (runDocs . modulesAsMarkdown) . Convert.convertModules  modulesAsMarkdown :: [Module] -> Docs modulesAsMarkdown = mapM_ moduleAsMarkdown  moduleAsMarkdown :: Module -> Docs moduleAsMarkdown Module{..} = do-  headerLevel 2 $ "Module " ++ modName+  headerLevel 2 $ "Module " ++ P.runModuleName modName   spacer   for_ modComments tell'   mapM_ (declAsMarkdown modName) modDeclarations   spacer   for_ modReExports $ \(mn, decls) -> do-    let modName' = P.runModuleName mn-    headerLevel 3 $ "Re-exported from " ++ modName' ++ ":"+    headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":"     spacer-    mapM_ (declAsMarkdown modName') decls+    mapM_ (declAsMarkdown mn) decls -declAsMarkdown :: String -> Declaration -> Docs+declAsMarkdown :: P.ModuleName -> Declaration -> Docs declAsMarkdown mn decl@Declaration{..} = do-  let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) }+  let options = defaultRenderTypeOptions { currentModule = Just mn }   headerLevel 4 (ticks declTitle)   spacer 

@@ -16,12 +16,17 @@ import Prelude () import Prelude.Compat -import Control.Monad.Error.Class (MonadError)-import Control.Arrow ((&&&))+import Control.Arrow ((&&&), second) import Control.Category ((>>>))+import Control.Monad+import Control.Monad.State (runStateT)+import Control.Monad.Writer.Strict (runWriterT)+import Control.Monad.Error.Class (MonadError) import qualified Data.Map as Map +import Text.Parsec (eof) import qualified Language.PureScript as P+import qualified Language.PureScript.Constants as C  import Language.PureScript.Docs.Types import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)@@ -33,18 +38,17 @@ -- documentation. -- convertModulesInPackage ::-  (Functor m, MonadError P.MultipleErrors m) =>-  P.Env ->+  (Functor m, Applicative m, MonadError P.MultipleErrors m) =>   [InPackage P.Module] ->   m [Module]-convertModulesInPackage env modules =+convertModulesInPackage modules =   go modules   where   localNames =-    map (P.runModuleName . P.getModuleName) (takeLocals modules)+    map P.getModuleName (takeLocals modules)   go =     map ignorePackage-     >>> convertModules env+     >>> convertModules      >>> fmap (filter ((`elem` localNames) . modName))  -- |@@ -53,35 +57,140 @@ -- imports/exports information about the list of modules, which is needed for -- documenting re-exports. ----- Preconditions:------     * If any module in the list re-exports documentation from other---     modules, those modules must also be included in the list.---     * The modules passed must have had names desugared and re-exports---     elaborated first.+-- Note that the whole module dependency graph must be included in the list; if+-- some modules import things from other modules, then those modules must also+-- be included. ----- If either of these are not satisfied, an internal error will be thrown. To--- avoid this, it is recommended to use--- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this--- function.+-- For value declarations, if explicit type signatures are omitted, or a+-- wildcard type is used, then we typecheck the modules and use the inferred+-- types. -- convertModules ::-  (Functor m, MonadError P.MultipleErrors m) =>-  P.Env ->+  (Functor m, Applicative m, MonadError P.MultipleErrors m) =>   [P.Module] ->   m [Module]-convertModules env =-  P.sortModules >>> fmap (convertSorted env . fst)+convertModules =+  P.sortModules+    >>> fmap (fst >>> map importPrim)+    >=> convertSorted +importPrim :: P.Module -> P.Module+importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])+ -- | -- Convert a sorted list of modules. ---convertSorted :: P.Env -> [P.Module] -> [Module]-convertSorted env modules =-  let-    traversalOrder =-      map P.getModuleName modules-    moduleMap =-      Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules-  in-    Map.elems (updateReExports env traversalOrder moduleMap)+convertSorted ::+  (Functor m, Applicative m, MonadError P.MultipleErrors m) =>+  [P.Module] ->+  m [Module]+convertSorted modules = do+  (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules++  modulesWithTypes <- typeCheckIfNecessary modules convertedModules+  let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)++  let traversalOrder = map P.getModuleName modules+  pure (Map.elems (updateReExports env traversalOrder moduleMap))++-- |+-- If any exported value declarations have either wildcard type signatures, or+-- none at all, then typecheck in order to fill them in with the inferred+-- types.+--+typeCheckIfNecessary ::+  (Functor m, Applicative m, MonadError P.MultipleErrors m) =>+  [P.Module] ->+  [Module] ->+  m [Module]+typeCheckIfNecessary modules convertedModules =+  if any hasWildcards convertedModules+    then go+    else pure convertedModules++  where+  hasWildcards =+     any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations++  go = do+    checkEnv <- snd <$> typeCheck modules+    pure (map (insertValueTypes checkEnv) convertedModules)++-- |+-- Typechecks all the modules together. Also returns the final 'P.Environment',+-- which is useful for adding in inferred types where explicit declarations+-- were not provided.+--+typeCheck ::+  (Functor m, MonadError P.MultipleErrors m) =>+  [P.Module] ->+  m ([P.Module], P.Environment)+typeCheck =+  (P.desugar [] >=> check)+  >>> fmap (second P.checkEnv)+  >>> P.evalSupplyT 0+  >>> ignoreWarnings++  where+  check ms =+    runStateT+      (traverse P.typeCheckModule ms)+      (P.emptyCheckState P.initEnvironment)++  ignoreWarnings =+    fmap fst . runWriterT++-- |+-- Updates all the types of the ValueDeclarations inside the module based on+-- their types inside the given Environment.+--+insertValueTypes ::+  P.Environment -> Module -> Module+insertValueTypes env m =+  m { modDeclarations = map go (modDeclarations m) }+  where+  go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard }) =+    let+      ident = parseIdent (declTitle d)+      ty = lookupName ident+    in+      d { declInfo = ValueDeclaration ty }+  go other =+    other++  parseIdent =+    either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent++  lookupName name =+    let key = (modName m, name)+    in case Map.lookup key (P.names env) of+      Just (ty, _, _) ->+        ty+      Nothing ->+        err ("name not found: " ++ show key)++  err msg =+    P.internalError ("Docs.Convert.insertValueTypes: " ++ msg)++runParser :: P.TokenParser a -> String -> Either String a+runParser p s = either (Left . show) Right $ do+  ts <- P.lex "" s+  P.runTokenParser "" (p <* eof) ts++-- |+-- Partially desugar modules so that they are suitable for extracting+-- documentation information from.+--+partiallyDesugar ::+  (Functor m, Applicative m, MonadError P.MultipleErrors m) =>+  [P.Module]+  -> m (P.Env, [P.Module])+partiallyDesugar = P.evalSupplyT 0 . desugar'+  where+  desugar' =+    traverse P.desugarDoModule+      >=> P.desugarCasesModule+      >=> P.desugarTypeDeclarationsModule+      >=> ignoreWarnings . P.desugarImportsWithEnv []++  ignoreWarnings = fmap fst . runWriterT

@@ -155,16 +155,16 @@ -- findImport ::   (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) =>-  [(P.Qualified name, P.ModuleName)] ->+  [P.ImportRecord name] ->   (name, P.ModuleName) ->   m (P.ModuleName, name) findImport imps (name, orig) =   let-    matches (qual, mn) = P.disqualify qual == name && mn == orig+    matches (P.ImportRecord qual mn _) = P.disqualify qual == name && mn == orig     matching = filter matches imps     getQualified (P.Qualified mname _) = mname   in-    case mapMaybe (getQualified . fst) matching of+    case mapMaybe (getQualified . P.importName) matching of       -- A value can occur more than once if it is imported twice (eg, if it is       -- exported by A, re-exported from A by B, and C imports it from both A       -- and B). In this case, we just take its first appearance.

@@ -29,7 +29,7 @@ -- convertSingleModule :: P.Module -> Module convertSingleModule m@(P.Module _ coms moduleName  _ _) =-  Module (P.runModuleName moduleName) comments (declarations m) []+  Module moduleName comments (declarations m) []   where   comments = convertComments coms   declarations =@@ -109,7 +109,7 @@   defaultFixity = P.Fixity P.Infixl (-1)  getDeclarationTitle :: P.Declaration -> Maybe String-getDeclarationTitle (P.TypeDeclaration name _)               = Just (P.showIdent name)+getDeclarationTitle (P.ValueDeclaration name _ _ _)          = Just (P.showIdent name) getDeclarationTitle (P.ExternDeclaration name _)             = Just (P.showIdent name) getDeclarationTitle (P.DataDeclaration _ name _ _)           = Just (P.runProperName name) getDeclarationTitle (P.ExternDataDeclaration name _)         = Just (P.runProperName name)@@ -135,8 +135,12 @@ basicDeclaration title info = Just $ Right $ mkDeclaration title info  convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration-convertDeclaration (P.TypeDeclaration _ ty) title =+convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =   basicDeclaration title (ValueDeclaration ty)+convertDeclaration (P.ValueDeclaration _ _ _ _) title =+  -- If no explicit type declaration was provided, insert a wildcard, so that+  -- the actual type will be added during type checking.+  basicDeclaration title (ValueDeclaration P.TypeWildcard) convertDeclaration (P.ExternDeclaration _ ty) title =   basicDeclaration title (ValueDeclaration ty) convertDeclaration (P.DataDeclaration dtype _ args ctors) title =

@@ -0,0 +1,100 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}++module Language.PureScript.Docs.ParseAndBookmark+  ( parseAndBookmark+  ) where++import Prelude ()+import Prelude.Compat++import qualified Data.Map as M+import Control.Arrow (first)++import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.IO.Class (MonadIO(..))++import Web.Bower.PackageMeta (PackageName)++import qualified Language.PureScript as P+import Language.PureScript.Docs.Types+import Language.PureScript.Docs.Convert (collectBookmarks)++-- |+-- Given:+--+--    * A list of local source files+--    * A list of source files from external dependencies, together with their+--      package names+--+-- This function does the following:+--+--    * Parse all of the input and dependency source files+--    * Associate each dependency module with its package name, thereby+--      distinguishing these from local modules+--    * Collect a list of bookmarks from the whole set of source files+--    * Return the parsed modules and the bookmarks+parseAndBookmark ::+  (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>+  [FilePath]+  -> [(PackageName, FilePath)]+  -> m ([InPackage P.Module], [Bookmark])+parseAndBookmark inputFiles depsFiles = do+  inputFiles' <- traverse (parseAs Local) inputFiles+  depsFiles'  <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles++  addBookmarks <$> parseFiles (inputFiles' ++ depsFiles')++parseFiles ::+  (MonadError P.MultipleErrors m, MonadIO m) =>+  [(FileInfo, FilePath)]+  -> m [(FileInfo, P.Module)]+parseFiles =+  throwLeft . P.parseModulesFromFiles fileInfoToString++addBookmarks ::+  [(FileInfo, P.Module)]+  -> ([InPackage P.Module], [Bookmark])+addBookmarks msInfo =+  let+    msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)+    msPackages = map (addPackage msDeps . snd) msInfo+    bookmarks = concatMap collectBookmarks msPackages+  in+    (msPackages, bookmarks)++throwLeft :: (MonadError l m) => Either l r -> m r+throwLeft = either throwError return++-- | Specifies whether a PureScript source file is considered as:+--+-- 1) with the `Local` constructor, a target source file, i.e., we want to see+--    its modules in the output+-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do+--    not want its modules in the output; it is there to enable desugaring, and+--    to ensure that links between modules are constructed correctly.+type FileInfo = InPackage FilePath++fileInfoToString :: FileInfo -> FilePath+fileInfoToString (Local fn) = fn+fileInfoToString (FromDep _ fn) = fn++parseFile :: FilePath -> IO (FilePath, String)+parseFile input' = (,) input' <$> readFile input'++parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)+parseAs g = fmap (first g) . liftIO . parseFile++getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName+getDepsModuleNames = foldl go M.empty+  where+  go deps p = deps # case p of+    Local _ -> id+    FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName+  (#) = flip ($)++addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module+addPackage depsModules m =+  case M.lookup (P.getModuleName m) depsModules of+    Just pkgName -> FromDep pkgName m+    Nothing -> Local m

@@ -1,137 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}--module Language.PureScript.Docs.ParseAndDesugar-  ( parseAndDesugar-  ) where--import Prelude ()-import Prelude.Compat--import qualified Data.Map as M-import Control.Arrow (first)-import Control.Monad--import Control.Monad.Writer.Strict (runWriterT)-import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.IO.Class (MonadIO(..))--import Web.Bower.PackageMeta (PackageName)--import qualified Language.PureScript as P-import qualified Language.PureScript.Constants as C-import Language.PureScript.Docs.Types-import Language.PureScript.Docs.Convert (collectBookmarks)---- |--- Given:------    * A list of local source files---    * A list of source files from external dependencies, together with their---      package names------ This function does the following:------    * Parse all of the input and dependency source files---    * Associate each dependency module with its package name, thereby---      distinguishing these from local modules---    * Partially desugar all of the resulting modules (just enough for---      producing documentation from them)---    * Collect a list of bookmarks from the whole set of source files---    * Return the desugared modules, the bookmarks, and the imports/exports---      Env (which is needed for producing documentation).-parseAndDesugar ::-  (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>-  [FilePath]-  -> [(PackageName, FilePath)]-  -> m ([InPackage P.Module], [Bookmark], P.Env)-parseAndDesugar inputFiles depsFiles = do-  inputFiles' <- traverse (parseAs Local) inputFiles-  depsFiles'  <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles--  ms  <- parseFiles (inputFiles' ++ depsFiles')-  ms' <- sortModules (map snd ms)-  desugarWithBookmarks ms ms'--parseFiles ::-  (MonadError P.MultipleErrors m, MonadIO m) =>-  [(FileInfo, FilePath)]-  -> m [(FileInfo, P.Module)]-parseFiles =-  throwLeft . P.parseModulesFromFiles fileInfoToString--sortModules ::-  (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>-  [P.Module]-  -> m [P.Module]-sortModules =-  fmap fst . throwLeft . sortModules' . map importPrim-  where-  sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)-  sortModules' = P.sortModules--desugarWithBookmarks ::-  (MonadError P.MultipleErrors m, MonadIO m) =>-  [(FileInfo, P.Module)]-  -> [P.Module]-  -> m ([InPackage P.Module], [Bookmark], P.Env)-desugarWithBookmarks msInfo msSorted =  do-  (env, msDesugared) <- throwLeft (desugar msSorted)--  let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)-      msPackages = map (addPackage msDeps) msDesugared-      bookmarks = concatMap collectBookmarks msPackages--  return (msPackages, bookmarks, env)--throwLeft :: (MonadError l m) => Either l r -> m r-throwLeft = either throwError return---- | Specifies whether a PureScript source file is considered as:------ 1) with the `Local` constructor, a target source file, i.e., we want to see---    its modules in the output--- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do---    not want its modules in the output; it is there to enable desugaring, and---    to ensure that links between modules are constructed correctly.-type FileInfo = InPackage FilePath--fileInfoToString :: FileInfo -> FilePath-fileInfoToString (Local fn) = fn-fileInfoToString (FromDep _ fn) = fn--importPrim :: P.Module -> P.Module-importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])--desugar ::-  (Functor m, Applicative m, MonadError P.MultipleErrors m) =>-  [P.Module]-  -> m (P.Env, [P.Module])-desugar = P.evalSupplyT 0 . desugar'-  where-  desugar' =-    traverse P.desugarDoModule-      >=> P.desugarCasesModule-      >=> ignoreWarnings . P.desugarImportsWithEnv []--  ignoreWarnings m = liftM fst (runWriterT m)--parseFile :: FilePath -> IO (FilePath, String)-parseFile input' = (,) input' <$> readFile input'--parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)-parseAs g = fmap (first g) . liftIO . parseFile--getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName-getDepsModuleNames = foldl go M.empty-  where-  go deps p = deps # case p of-    Local _ -> id-    FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName-  (#) = flip ($)--addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module-addPackage depsModules m =-  case M.lookup (P.getModuleName m) depsModules of-    Just pkgName -> FromDep pkgName m-    Nothing -> Local m

@@ -61,7 +61,11 @@     AliasDeclaration for (P.Fixity associativity precedence) ->       [ keywordFixity associativity       , syntax $ show precedence-      , ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for+      , ident $+          either+            (P.showQualified P.runIdent . dequalifyCurrentModule)+            (P.showQualified P.runProperName . dequalifyCurrentModule)+            for       , keyword "as"       , ident . tail . init $ declTitle       ]

@@ -73,7 +73,7 @@ packageName = bowerName . pkgMeta  data Module = Module-  { modName         :: String+  { modName         :: P.ModuleName   , modComments     :: Maybe String   , modDeclarations :: [Declaration]   -- Re-exported values from other modules@@ -133,7 +133,7 @@   -- An operator alias declaration, with the member the alias is for and the   -- operator's fixity.   ---  | AliasDeclaration (P.Qualified P.Ident) P.Fixity+  | AliasDeclaration (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) P.Fixity   deriving (Show, Eq, Ord)  declInfoToString :: DeclarationInfo -> String@@ -346,7 +346,7 @@  asModule :: Parse PackageError Module asModule =-  Module <$> key "name" asString+  Module <$> key "name" (P.moduleNameFromString <$> asString)          <*> key "comments" (perhaps asString)          <*> key "declarations" (eachInArray asDeclaration)          <*> key "reExports" (eachInArray asReExport)@@ -406,11 +406,14 @@       TypeClassDeclaration <$> key "arguments" asTypeArguments                            <*> key "superclasses" (eachInArray asConstraint)     "alias" ->-      AliasDeclaration <$> key "for" asQualifiedIdent+      AliasDeclaration <$> key "for" asAliasFor                        <*> key "fixity" asFixity     other ->       throwCustomError (InvalidDeclarationType other) +asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName)))+asAliasFor = fromAesonParser+ asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)] asTypeArguments = eachInArray asTypeArgument   where@@ -512,7 +515,7 @@  instance A.ToJSON Module where   toJSON Module{..} =-    A.object [ "name"         .= modName+    A.object [ "name"         .= P.runModuleName modName              , "comments"     .= modComments              , "declarations" .= modDeclarations              , "reExports"    .= map toObj modReExports

@@ -24,6 +24,7 @@ import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Pretty+import Language.PureScript.Pretty.Common (before) import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds@@ -68,6 +69,7 @@   | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)   | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)   | ScopeConflict String [ModuleName]+  | ScopeShadowing String (Maybe ModuleName) [ModuleName]   | ConflictingTypeDecls (ProperName 'TypeName)   | ConflictingCtorDecls (ProperName 'ConstructorName)   | TypeConflictsWithClass (ProperName 'TypeName)@@ -112,6 +114,7 @@   | InvalidNewtype (ProperName 'TypeName)   | InvalidInstanceHead Type   | TransitiveExportError DeclarationRef [DeclarationRef]+  | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)   | ShadowedName Ident   | ShadowedTypeVar String   | UnusedTypeVar String@@ -128,6 +131,7 @@   | UnusedDctorImport (ProperName 'TypeName)   | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]   | DeprecatedOperatorDecl String+  | DeprecatedOperatorSection Expr (Either Expr Expr)   | DeprecatedQualifiedSyntax ModuleName ModuleName   | DeprecatedClassImport ModuleName (ProperName 'ClassName)   | DeprecatedClassExport (ProperName 'ClassName)@@ -142,6 +146,8 @@   | ImplicitImport ModuleName [DeclarationRef]   | HidingImport ModuleName [DeclarationRef]   | CaseBinderLengthDiffers Int [Binder]+  | IncorrectAnonymousArgument+  | InvalidOperatorInBinder Ident Ident   deriving (Show)  -- | Error message hints, providing more detailed information about failure.@@ -243,6 +249,7 @@   UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"   UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"   ScopeConflict{} -> "ScopeConflict"+  ScopeShadowing{} -> "ScopeShadowing"   ConflictingTypeDecls{} -> "ConflictingTypeDecls"   ConflictingCtorDecls{} -> "ConflictingCtorDecls"   TypeConflictsWithClass{} -> "TypeConflictsWithClass"@@ -287,6 +294,7 @@   InvalidNewtype{} -> "InvalidNewtype"   InvalidInstanceHead{} -> "InvalidInstanceHead"   TransitiveExportError{} -> "TransitiveExportError"+  TransitiveDctorExportError{} -> "TransitiveDctorExportError"   ShadowedName{} -> "ShadowedName"   ShadowedTypeVar{} -> "ShadowedTypeVar"   UnusedTypeVar{} -> "UnusedTypeVar"@@ -303,6 +311,7 @@   UnusedDctorImport{} -> "UnusedDctorImport"   UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"   DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"+  DeprecatedOperatorSection{} -> "DeprecatedOperatorSection"   DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"   DeprecatedClassImport{} -> "DeprecatedClassImport"   DeprecatedClassExport{} -> "DeprecatedClassExport"@@ -317,6 +326,8 @@   ImplicitImport{} -> "ImplicitImport"   HidingImport{} -> "HidingImport"   CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"+  IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"+  InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"  -- | -- A stack trace for an error@@ -424,7 +435,7 @@ -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough -- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert--- DeprecatedClassExport, DeprecatedClassImport,  would want to replace smaller span?+-- DeprecatedClassExport, DeprecatedClassImport, DeprecatedOperatorSection, would want to replace smaller span? errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion errorSuggestion err = case err of   UnusedImport{} -> emptySuggestion@@ -595,6 +606,13 @@       paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"             , indent $ paras $ map (line . runModuleName) ms             ]+    renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =+      paras [ line $ "Shadowed definitions are in scope for " ++ nm ++ " from the following open imports:"+            , indent $ paras $ map (line . ("import " ++) . runModuleName) ms+            , line $ "These will be ignored and the " ++ case exmn of+                Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used."+                Nothing -> "local declaration will be used."+            ]     renderSimpleErrorMessage (ConflictingTypeDecls nm) =       line $ "Conflicting type declarations for " ++ runProperName nm     renderSimpleErrorMessage (ConflictingCtorDecls nm) =@@ -784,6 +802,10 @@       paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "             , indent $ paras $ map (line . prettyPrintExport) ys             ]+    renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =+      paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following data constructor to also be exported: "+            , indent $ line $ runProperName ctor+            ]     renderSimpleErrorMessage (ShadowedName nm) =       line $ "Name '" ++ showIdent nm ++ "' was shadowed."     renderSimpleErrorMessage (ShadowedTypeVar tv) =@@ -798,7 +820,7 @@     renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =       line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."     renderSimpleErrorMessage (ImportHidingModule name) =-      paras [ line $ "'hiding' imports cannot be used to hide modules."+      paras [ line "'hiding' imports cannot be used to hide modules."             , line $ "An attempt was made to hide the import of " ++ runModuleName name             ]     renderSimpleErrorMessage (WildcardInferredType ty) =@@ -812,14 +834,14 @@             , indent $ typeAsBox ty             ]     renderSimpleErrorMessage (NotExhaustivePattern bs b) =-      paras $ [ line "A case expression could not be determined to cover all inputs."-              , line "The following additional cases are required to cover all inputs:\n"-              , indent $ paras $-                  [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]-                  ++ [ line "..." | not b ]-              , line "Or alternatively, add a Partial constraint to the type of the enclosing value."-              , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."-              ]+      paras [ line "A case expression could not be determined to cover all inputs."+            , line "The following additional cases are required to cover all inputs:\n"+            , indent $ paras $+                [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]+                ++ [ line "..." | not b ]+            , line "Or alternatively, add a Partial constraint to the type of the enclosing value."+            , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."+            ]     renderSimpleErrorMessage (OverlappingPattern bs b) =       paras $ [ line "A case expression contains unreachable cases:\n"               , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))@@ -835,7 +857,7 @@     renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =       paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"             , indent $ paras $ map line names-            , line $ "It could be replaced with:"+            , line "It could be replaced with:"             , indent $ line $ showSuggestion msg ]      renderSimpleErrorMessage (UnusedDctorImport name) =@@ -849,15 +871,39 @@       paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."             , line "Operator aliases are declared by using a fixity declaration, for example:"             , indent $ line $ "infixl 9 someFunction as " ++ name-            , line $ "Support for value-declared operators will be removed in PureScript 0.9."+            , line "Support for value-declared operators will be removed in PureScript 0.9."             ] +    renderSimpleErrorMessage (DeprecatedOperatorSection op val) =+      paras [ line "An operator section uses legacy syntax. Operator sections are now written using anonymous function syntax:"+            , indent $ foldr1 before $+                case val of+                  Left l ->+                    [ line "("+                    , prettyPrintValue valueDepth l+                    , line " "+                    , renderOperator op+                    , line " _)"+                    ]+                  Right r ->+                    [ line "(_ "+                    , renderOperator op+                    , line " "+                    , prettyPrintValue valueDepth r+                    , line ")"+                    ]+            , line "Support for legacy operator sections will be removed in PureScript 0.9."+            ]+      where+        renderOperator (PositionedValue _ _ ex) = renderOperator ex+        renderOperator (Var (Qualified _ (Op ident))) = line ident+        renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ]     renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =-      paras [ line $ "Import uses the deprecated 'qualified' syntax:"+      paras [ line "Import uses the deprecated 'qualified' syntax:"             , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName             , line "Should instead use the form:"             , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName-            , line $ "The deprecated syntax will be removed in PureScript 0.9."+            , line "The deprecated syntax will be removed in PureScript 0.9."             ]      renderSimpleErrorMessage (DeprecatedClassImport mn name) =@@ -865,15 +911,15 @@             , indent $ line $ runProperName name             , line "Should instead use the form:"             , indent $ line $ "class " ++ runProperName name-            , line $ "The deprecated syntax will be removed in PureScript 0.9."+            , line "The deprecated syntax will be removed in PureScript 0.9."             ]      renderSimpleErrorMessage (DeprecatedClassExport name) =-      paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:"+      paras [ line "Class export uses deprecated syntax that omits the 'class' keyword:"             , indent $ line $ runProperName name             , line "Should instead use the form:"             , indent $ line $ "class " ++ runProperName name-            , line $ "The deprecated syntax will be removed in PureScript 0.9."+            , line "The deprecated syntax will be removed in PureScript 0.9."             ]      renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =@@ -915,9 +961,18 @@             ]      renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =-      paras $ [ line $ "Binder list length differs in case alternative:"-              , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs-              , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ]+      paras [ line "Binder list length differs in case alternative:"+            , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs+            , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "."+            ]++    renderSimpleErrorMessage IncorrectAnonymousArgument =+      line "An anonymous function argument appears in an invalid context."++    renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =+      paras $ [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."+              , line "Only aliases for data constructors may be used in patterns."+              ]      renderHint :: ErrorMessageHint -> Box.Box -> Box.Box     renderHint (ErrorUnifyingTypes t1 t2) detail =

@@ -73,7 +73,7 @@   -- | The operator symbol   , efOperator :: String   -- | The value the operator is an alias for-  , efAlias :: Maybe (Qualified Ident)+  , efAlias :: Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)))   } deriving (Show, Read)  -- | A type or value declaration appearing in an externs file@@ -153,7 +153,8 @@   efDeclarations  = concatMap toExternsDeclaration efExports    fixityDecl :: Declaration -> Maybe ExternsFixity-  fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)+  fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) =+      fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)     where     exportsOp :: DeclarationRef -> Bool     exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

@@ -0,0 +1,199 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PackageImports        #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TupleSections         #-}++module Language.PureScript.Ide where++import           Prelude                            ()+import           Prelude.Compat++import           Control.Monad.Error.Class+import           Control.Monad.IO.Class+import           "monad-logger" Control.Monad.Logger+import           Control.Monad.Reader.Class+import           Data.Foldable+import qualified Data.Map.Lazy                      as M+import           Data.Maybe                         (catMaybes, mapMaybe)+import           Data.Monoid+import           Data.Text                          (Text)+import qualified Data.Text                          as T+import qualified Language.PureScript.Ide.CaseSplit  as CS+import           Language.PureScript.Ide.Command+import           Language.PureScript.Ide.Completion+import           Language.PureScript.Ide.Error+import           Language.PureScript.Ide.Externs+import           Language.PureScript.Ide.Filter+import           Language.PureScript.Ide.Matcher+import           Language.PureScript.Ide.Pursuit+import           Language.PureScript.Ide.Reexports+import           Language.PureScript.Ide.SourceFile+import           Language.PureScript.Ide.State+import           Language.PureScript.Ide.Types+import           System.Directory+import           System.FilePath+import           System.Exit+++handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                 Command -> m Success+handleCommand (Load modules deps) =+    loadModulesAndDeps modules deps+handleCommand (Type search filters) =+    findType search filters+handleCommand (Complete filters matcher) =+    findCompletions filters matcher+handleCommand (Pursuit query Package) =+    findPursuitPackages query+handleCommand (Pursuit query Identifier) =+    findPursuitCompletions query+handleCommand (List LoadedModules) =+    printModules+handleCommand (List AvailableModules) =+    listAvailableModules+handleCommand (List (Imports fp)) =+    importsForFile fp+handleCommand (CaseSplit l b e wca t) =+    caseSplit l b e wca t+handleCommand (AddClause l wca) =+    pure $ addClause l wca+handleCommand Cwd =+    TextResult . T.pack <$> liftIO getCurrentDirectory+handleCommand Quit = liftIO exitSuccess++findCompletions :: (PscIde m, MonadLogger m) =>+                   [Filter] -> Matcher -> m Success+findCompletions filters matcher =+  CompletionResult . getCompletions filters matcher <$> getAllModulesWithReexports++findType :: (PscIde m, MonadLogger m) =>+            DeclIdent -> [Filter] -> m Success+findType search filters =+  CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports++findPursuitCompletions :: (Applicative m, MonadIO m, MonadLogger m) =>+                          PursuitQuery -> m Success+findPursuitCompletions (PursuitQuery q) =+  PursuitResult <$> liftIO (searchPursuitForDeclarations q)++findPursuitPackages :: (Applicative m, MonadIO m, MonadLogger m) =>+                       PursuitQuery -> m Success+findPursuitPackages (PursuitQuery q) =+  PursuitResult <$> liftIO (findPackagesForModuleIdent q)++loadExtern ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>+             FilePath -> m ()+loadExtern fp = do+  m <- readExternFile fp+  insertModule m++printModules :: (PscIde m) => m Success+printModules = printModules' <$> getPscIdeState++printModules' :: M.Map ModuleIdent [ExternDecl] -> Success+printModules' = ModuleList . M.keys++listAvailableModules :: PscIde m => m Success+listAvailableModules = do+  outputPath <- confOutputPath . envConfiguration <$> ask+  liftIO $ do+    cwd <- getCurrentDirectory+    dirs <- getDirectoryContents (cwd </> outputPath)+    return (ModuleList (listAvailableModules' dirs))++listAvailableModules' :: [FilePath] -> [Text]+listAvailableModules' dirs =+  let cleanedModules = filter (`notElem` [".", ".."]) dirs+  in map T.pack cleanedModules++caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+  Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success+caseSplit l b e csa t = do+  patterns <- CS.makePattern l b e csa <$> CS.caseSplit t+  pure (MultilineTextResult patterns)++addClause :: Text -> CS.WildcardAnnotations -> Success+addClause t wca = MultilineTextResult (CS.addClause t wca)++importsForFile :: (Applicative m, MonadIO m, MonadLogger m, MonadError PscIdeError m) =>+                  FilePath -> m Success+importsForFile fp = do+  imports <- getImportsForFile fp+  pure (ImportList imports)++-- | The first argument is a set of modules to load. The second argument+--   denotes modules for which to load dependencies+loadModulesAndDeps :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                     [ModuleIdent] -> [ModuleIdent] -> m Success+loadModulesAndDeps mods deps = do+  r1 <- mapM loadModule (mods ++ deps)+  r2 <- mapM loadModuleDependencies deps+  let moduleResults = T.concat r1+  let dependencyResults = T.concat r2+  pure (TextResult (moduleResults <> ", " <> dependencyResults))++loadModuleDependencies ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                         ModuleIdent -> m Text+loadModuleDependencies moduleName = do+  m <- getModule moduleName+  case getDependenciesForModule <$> m of+    Just deps -> do+      mapM_ loadModule deps+      -- We need to load the modules, that get reexported from the dependencies+      depModules <- catMaybes <$> mapM getModule deps+      -- What to do with errors here? This basically means a reexported dependency+      -- doesn't exist in the output/ folder+      traverse_ loadReexports depModules+      pure ("Dependencies for " <> moduleName <> " loaded.")+    Nothing -> throwError (ModuleNotFound moduleName)++loadReexports :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                Module -> m [ModuleIdent]+loadReexports m = case getReexports m of+  [] -> pure []+  exportDeps -> do+    -- I'm fine with this crashing on a failed pattern match.+    -- If this ever fails I'll need to look at GADTs+    let reexports = map (\(Export mn) -> mn) exportDeps+    $(logDebug) ("Loading reexports for module: " <> fst m <>+                 " reexports: " <> T.intercalate ", " reexports)+    traverse_ loadModule reexports+    exportDepsModules <- catMaybes <$> traverse getModule reexports+    exportDepDeps <- traverse loadReexports exportDepsModules+    return $ concat exportDepDeps++getDependenciesForModule :: Module -> [ModuleIdent]+getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls+  where getDependencyName (Dependency dependencyName _ _) = Just dependencyName+        getDependencyName _ = Nothing++loadModule :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+              ModuleIdent -> m Text+loadModule "Prim" = pure "Prim won't be loaded"+loadModule mn = do+  path <- filePathFromModule mn+  loadExtern path+  $(logDebug) ("Loaded extern file at: " <> T.pack path)+  pure ("Loaded extern file at: " <> T.pack path)++filePathFromModule :: (PscIde m, MonadError PscIdeError m) =>+                      ModuleIdent -> m FilePath+filePathFromModule moduleName = do+  outputPath <- confOutputPath . envConfiguration <$> ask+  cwd <- liftIO getCurrentDirectory+  let path = cwd </> outputPath </> T.unpack moduleName </> "externs.json"+  ex <- liftIO $ doesFileExist path+  if ex+    then pure path+    else throwError (ModuleFileNotFound moduleName)++-- | Taken from Data.Either.Utils+maybeToEither :: MonadError e m =>+                 e                      -- ^ (Left e) will be returned if the Maybe value is Nothing+              -> Maybe a                -- ^ (Right a) will be returned if this is (Just a)+              -> m a+maybeToEither errorval Nothing = throwError errorval+maybeToEither _ (Just normalval) = return normalval

@@ -0,0 +1,157 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PackageImports        #-}+{-# LANGUAGE RecordWildCards       #-}++module Language.PureScript.Ide.CaseSplit+       ( WildcardAnnotations()+       , explicitAnnotations+       , noAnnotations+       , makePattern+       , addClause+       , caseSplit+       ) where++import           Prelude                                 ()+import           Prelude.Compat                          hiding (lex)++import           Control.Monad.Error.Class+import           "monad-logger" Control.Monad.Logger+import           Data.List                               (find)+import           Data.Monoid+import           Data.Text                               (Text)+import qualified Data.Text                               as T+import           Language.PureScript.AST+import           Language.PureScript.Environment+import           Language.PureScript.Externs+import           Language.PureScript.Ide.Error+import           Language.PureScript.Ide.Externs         (unwrapPositioned)+import           Language.PureScript.Ide.State+import           Language.PureScript.Ide.Types           hiding (Type)+import           Language.PureScript.Names+import           Language.PureScript.Parser.Common       (runTokenParser)+import           Language.PureScript.Parser.Declarations+import           Language.PureScript.Parser.Lexer        (lex)+import           Language.PureScript.Parser.Types+import           Language.PureScript.Pretty+import           Language.PureScript.Types+import           Text.Parsec                             as P++type Constructor = (ProperName 'ConstructorName, [Type])++newtype WildcardAnnotations = WildcardAnnotations Bool++explicitAnnotations :: WildcardAnnotations+explicitAnnotations = WildcardAnnotations True++noAnnotations :: WildcardAnnotations+noAnnotations = WildcardAnnotations False++caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+             Text -> m [Constructor]+caseSplit q = do+  (tc, args) <- splitTypeConstructor (parseType' (T.unpack q))+  (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc+  let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args))+  let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors+  pure appliedCtors++{- ["EDType {+     edTypeName = ProperName {runProperName = \"Either\"}+   , edTypeKind = FunKind Star (FunKind Star Star)+   , edTypeDeclarationKind =+       DataType [(\"a\",Just Star),(\"b\",Just Star)]+                [(ProperName {runProperName = \"Left\"},[TypeVar \"a\"])+                ,(ProperName {runProperName = \"Right\"},[TypeVar \"b\"])]}"]+-}++findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                         ProperName 'TypeName -> m ExternsDeclaration+findTypeDeclaration q = do+  efs <- getExternFiles+  let m = getFirst $ foldMap (findTypeDeclaration' q) efs+  case m of+    Just mn -> pure mn+    Nothing -> throwError (GeneralError "Not Found")++findTypeDeclaration' ::+  ProperName 'TypeName+  -> ExternsFile+  -> First ExternsDeclaration+findTypeDeclaration' t ExternsFile{..} =+  First $ find (\case+            EDType tn _ _ -> tn == t+            _ -> False) efDeclarations++splitTypeConstructor :: (Applicative m, MonadError PscIdeError m) =>+                        Type -> m (ProperName 'TypeName, [Type])+splitTypeConstructor = go []+  where+    go acc (TypeApp ty arg) = go (arg : acc) ty+    go acc (TypeConstructor tc) = pure (disqualify tc, acc)+    go _ _ = throwError (GeneralError "Failed to read TypeConstructor")++prettyCtor :: WildcardAnnotations -> Constructor -> Text+prettyCtor _ (ctorName, []) = T.pack (runProperName ctorName)+prettyCtor wsa (ctorName, ctorArgs) =+  "("<> T.pack (runProperName ctorName) <> " "+  <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"++prettyPrintWildcard :: WildcardAnnotations -> Type -> Text+prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard+prettyPrintWildcard (WildcardAnnotations False) = const "_"++prettyWildcard :: Type -> Text+prettyWildcard t = "( _ :: " <> T.strip (T.pack (prettyPrintTypeAtom t)) <> ")"++-- | Constructs Patterns to insert into a sourcefile+makePattern :: Text -- ^ Current line+            -> Int -- ^ Begin of the split+            -> Int -- ^ End of the split+            -> WildcardAnnotations -- ^ Whether to explicitly type the splits+            -> [Constructor] -- ^ Constructors to split+            -> [Text]+makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t)+  where+    makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs)++addClause :: Text -> WildcardAnnotations -> [Text]+addClause s wca =+  let (fName, fType) = parseTypeDeclaration' (T.unpack s)+      (args, _) = splitFunctionType fType+      template = T.pack (runIdent fName) <> " " <>+        T.unwords (map (prettyPrintWildcard wca) args) <>+        " = ?" <> (T.strip . T.pack . runIdent $ fName)+  in [s, template]++parseType' :: String -> Type+parseType' s = let (Right t) = do+                     ts <- lex "" s+                     runTokenParser "" (parseType <* P.eof) ts+               in t++parseTypeDeclaration' :: String -> (Ident, Type)+parseTypeDeclaration' s =+  let x = do+        ts <- lex "" s+        runTokenParser "" (parseDeclaration <* P.eof) ts+  in+    case unwrapPositioned <$> x of+      Right (TypeDeclaration i t) -> (i, t)+      y -> error (show y)++splitFunctionType :: Type -> ([Type], Type)+splitFunctionType t = (arguments, returns)+  where+    returns = last splitted+    arguments = init splitted+    splitted = splitType' t+    splitType' (ForAll _ t' _) = splitType' t'+    splitType' (ConstrainedType _ t') = splitType' t'+    splitType' (TypeApp (TypeApp t' lhs) rhs)+          | t' == tyFunction = lhs : splitType' rhs+    splitType' t' = [t']

@@ -0,0 +1,13 @@+module Language.PureScript.Ide.CodecJSON where++import Data.Aeson+import Data.Text (Text())+import Data.Text.Lazy (toStrict, fromStrict)+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)++encodeT :: (ToJSON a) => a -> Text+encodeT = toStrict . decodeUtf8 . encode++decodeT :: (FromJSON a) => Text -> Maybe a+decodeT = decode . encodeUtf8 . fromStrict+

@@ -0,0 +1,101 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}++module Language.PureScript.Ide.Command where++import           Prelude                           ()+import           Prelude.Compat++import           Control.Monad+import           Data.Aeson+import           Data.Maybe+import           Data.Text                         (Text)+import           Language.PureScript.Ide.CaseSplit+import           Language.PureScript.Ide.Filter+import           Language.PureScript.Ide.Matcher+import           Language.PureScript.Ide.Types++data Command+    = Load { loadModules      :: [ModuleIdent]+           , loadDependencies :: [ModuleIdent]}+    | Type { typeSearch  :: DeclIdent+           , typeFilters :: [Filter]}+    | Complete { completeFilters :: [Filter]+               , completeMatcher :: Matcher}+    | Pursuit { pursuitQuery      :: PursuitQuery+              , pursuitSearchType :: PursuitSearchType}+    | List {listType :: ListType}+    | CaseSplit {+      caseSplitLine          :: Text+      , caseSplitBegin       :: Int+      , caseSplitEnd         :: Int+      , caseSplitAnnotations :: WildcardAnnotations+      , caseSplitType        :: Type}+    | AddClause {+      addClauseLine          :: Text+      , addClauseAnnotations :: WildcardAnnotations}+    | Cwd+    | Quit++data ListType = LoadedModules | Imports FilePath | AvailableModules++instance FromJSON ListType where+  parseJSON = withObject "ListType" $ \o -> do+    (listType' :: String) <- o .: "type"+    case listType' of+      "import" -> do+        fp <- o .: "file"+        return (Imports fp)+      "loadedModules" -> return LoadedModules+      "availableModules" -> return AvailableModules+      _ -> mzero++instance FromJSON Command where+  parseJSON = withObject "command" $ \o -> do+    (command :: String) <- o .: "command"+    case command of+      "list" -> do+        listType' <- o .:? "params"+        return $ List (fromMaybe LoadedModules listType')+      "cwd"  -> return Cwd+      "quit" -> return Quit+      "load" -> do+        params <- o .: "params"+        mods <- params .:? "modules"+        deps <- params .:? "dependencies"+        return $ Load (fromMaybe [] mods) (fromMaybe [] deps)+      "type" -> do+        params <- o .: "params"+        search <- params .: "search"+        filters <- params .: "filters"+        return $ Type search filters+      "complete" -> do+        params <- o .: "params"+        filters <- params .:? "filters"+        matcher <- params .:? "matcher"+        return $ Complete (fromMaybe [] filters) (fromMaybe mempty matcher)+      "pursuit" -> do+        params <- o .: "params"+        query <- params .: "query"+        queryType <- params .: "type"+        return $ Pursuit query queryType+      "caseSplit" -> do+        params <- o .: "params"+        line <- params .: "line"+        begin <- params .: "begin"+        end <- params .: "end"+        annotations <- params .: "annotations"+        type' <- params .: "type"+        return $ CaseSplit line begin end (if annotations+                                           then explicitAnnotations+                                           else noAnnotations) type'+      "addClause" -> do+        params <- o .: "params"+        line <- params .: "line"+        annotations <- params .: "annotations"+        return $ AddClause line (if annotations+                                 then explicitAnnotations+                                 else noAnnotations)+      _ -> mzero+