purescript 0.10.5 → 0.10.6

raw patch · 102 files changed

+3435/−2139 lines, 102 filesdep +blaze-htmldep +cheapskatedep +deepseqdep ~lensdep ~monad-loggerdep ~optparse-applicativePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: blaze-html, cheapskate, deepseq

Dependency ranges changed: lens, monad-logger, optparse-applicative, transformers, transformers-compat, turtle

API changes (from Hackage documentation)

Files

• CONTRIBUTORS.md +4/−0
• LICENSE +310/−0
• examples/docs/src/ExplicitTypeSignatures.purs +0/−2
• examples/failing/2445.purs +6/−0
• examples/failing/2542.purs +9/−0
• examples/failing/2601.purs +7/−0
• examples/failing/BindInDo-2.purs +9/−0
• examples/failing/BindInDo.purs +9/−0
• examples/failing/ImportModule.purs +1/−1
• examples/failing/MPTCs.purs +1/−1
• examples/failing/TooFewClassInstanceArgs.purs +8/−0
• examples/passing/2136.purs +9/−0
• examples/passing/2288.purs +19/−0
• examples/passing/NestedRecordUpdate.purs +24/−0
• examples/passing/NestedRecordUpdateWildcards.purs +20/−0
• examples/warning/2542.purs +16/−0
• examples/warning/CustomWarning.purs +9/−0
• psc-docs/Main.hs +2/−2
• psc-ide-client/Main.hs +2/−0
• psc-ide-server/Main.hs +16/−8
• psc-package/Main.hs +35/−32
• psc-publish/Main.hs +3/−0
• purescript.cabal +23/−19
• src/Language/PureScript/AST/Declarations.hs +47/−2
• src/Language/PureScript/AST/Traversals.hs +7/−0
• src/Language/PureScript/CodeGen/JS.hs +52/−36
• src/Language/PureScript/CodeGen/JS/AST.hs +0/−9
• src/Language/PureScript/CodeGen/JS/Optimizer.hs +1/−1
• src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +5/−12
• src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +93/−85
• src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +7/−7
• src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +11/−12
• src/Language/PureScript/Constants.hs +136/−127
• src/Language/PureScript/Crash.hs +27/−11
• src/Language/PureScript/Docs.hs +2/−3
• src/Language/PureScript/Docs/AsHtml.hs +299/−0
• src/Language/PureScript/Docs/AsMarkdown.hs +4/−6
• src/Language/PureScript/Docs/Convert.hs +42/−30
• src/Language/PureScript/Docs/Convert/ReExports.hs +2/−5
• src/Language/PureScript/Docs/Convert/Single.hs +4/−23
• src/Language/PureScript/Docs/ParseAndBookmark.hs +0/−97
• src/Language/PureScript/Docs/ParseInPackage.hs +73/−0
• src/Language/PureScript/Docs/Prim.hs +9/−0
• src/Language/PureScript/Docs/Render.hs +17/−27
• src/Language/PureScript/Docs/RenderedCode.hs +9/−8
• src/Language/PureScript/Docs/RenderedCode/Render.hs +0/−215
• src/Language/PureScript/Docs/RenderedCode/RenderKind.hs +57/−0
• src/Language/PureScript/Docs/RenderedCode/RenderType.hs +208/−0
• src/Language/PureScript/Docs/RenderedCode/Types.hs +252/−75
• src/Language/PureScript/Docs/Types.hs +209/−35
• src/Language/PureScript/Environment.hs +6/−3
• src/Language/PureScript/Errors.hs +94/−92
• src/Language/PureScript/Ide.hs +38/−14
• src/Language/PureScript/Ide/CaseSplit.hs +6/−6
• src/Language/PureScript/Ide/Command.hs +4/−0
• src/Language/PureScript/Ide/Completion.hs +3/−0
• src/Language/PureScript/Ide/Conversions.hs +0/−29
• src/Language/PureScript/Ide/Error.hs +5/−4
• src/Language/PureScript/Ide/Externs.hs +19/−16
• src/Language/PureScript/Ide/Filter.hs +2/−0
• src/Language/PureScript/Ide/Imports.hs +8/−8
• src/Language/PureScript/Ide/Logging.hs +4/−0
• src/Language/PureScript/Ide/Rebuild.hs +44/−14
• src/Language/PureScript/Ide/Reexports.hs +33/−21
• src/Language/PureScript/Ide/SourceFile.hs +7/−4
• src/Language/PureScript/Ide/State.hs +74/−27
• src/Language/PureScript/Ide/Types.hs +29/−14
• src/Language/PureScript/Ide/Util.hs +40/−9
• src/Language/PureScript/Make.hs +85/−87
• src/Language/PureScript/ModuleDependencies.hs +41/−77
• src/Language/PureScript/PSString.hs +10/−0
• src/Language/PureScript/Parser/Common.hs +49/−73
• src/Language/PureScript/Parser/Declarations.hs +94/−118
• src/Language/PureScript/Pretty/Common.hs +1/−1
• src/Language/PureScript/Pretty/JS.hs +22/−14
• src/Language/PureScript/Pretty/Types.hs +58/−28
• src/Language/PureScript/Pretty/Values.hs +9/−1
• src/Language/PureScript/Publish.hs +29/−30
• src/Language/PureScript/Publish/ErrorsWarnings.hs +5/−1
• src/Language/PureScript/Sugar/DoNotation.hs +8/−1
• src/Language/PureScript/Sugar/ObjectWildcards.hs +50/−29
• src/Language/PureScript/TypeChecker.hs +8/−0
• src/Language/PureScript/TypeChecker/Entailment.hs +14/−6
• src/Language/PureScript/TypeChecker/Types.hs +21/−17
• src/Language/PureScript/Types.hs +2/−0
• stack.yaml +3/−0
• tests/Language/PureScript/Ide/FilterSpec.hs +2/−0
• tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +0/−83
• tests/Language/PureScript/Ide/ImportsSpec.hs +66/−1
• tests/Language/PureScript/Ide/Integration.hs +0/−273
• tests/Language/PureScript/Ide/MatcherSpec.hs +0/−13
• tests/Language/PureScript/Ide/RebuildSpec.hs +41/−37
• tests/Language/PureScript/Ide/ReexportsSpec.hs +15/−13
• tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs +0/−41
• tests/Language/PureScript/Ide/SourceFileSpec.hs +69/−1
• tests/Language/PureScript/Ide/StateSpec.hs +53/−13
• tests/Language/PureScript/Ide/Test.hs +135/−0
• tests/TestDocs.hs +7/−5
• tests/TestPscIde.hs +3/−5
• tests/TestPscPublish.hs +3/−9
• tests/TestUtils.hs +1/−0
• tests/support/pscide/src/SourceFileSpec.purs +0/−10

@@ -76,6 +76,7 @@ - [@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).+- [@taktoa](https://github.com/taktoa) (Remy Goldschmidt) My existing contributions and all future contributions until further notice are Copyright Remy Goldschmidt, 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). - [@tmcgilchrist](https://github.com/tmcgilchrist) (Tim McGilchrist) My existing contributions and all future contributions until further notice are Copyright Tim McGilchrist, 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).@@ -87,6 +88,9 @@ - [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, 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). - [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, 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). - [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, 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).+- [@matthewleon](https://github.com/matthewleon) (Matthew Leon) My existing contributions and all future contributions until further notice are Copyright Matthew Leon, 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).+- [@alexbiehl](https://github.com/alexbiehl) (Alexander Biehl) My existing contributions and all future contributions until further notice are Copyright Alexander Biehl, 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).+- [@noraesae](https://github.com/noraesae) (Hyunje Jun) My existing contributions and all future contributions until further notice are Copyright Hyunje Jun, 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 

@@ -48,6 +48,7 @@   bytestring-builder   case-insensitive   cereal+  cheapskate   clock   cmdargs   comonad@@ -58,7 +59,13 @@   contravariant   cookie   cryptonite+  css-text+  data-default   data-default-class+  data-default-instances-base+  data-default-instances-containers+  data-default-instances-dlist+  data-default-instances-old-locale   data-ordlist   deepseq   directory@@ -142,6 +149,7 @@   system-fileio   system-filepath   tagged+  tagsoup   template-haskell   temporary   terminfo@@ -152,6 +160,7 @@   transformers-base   transformers-compat   turtle+  uniplate   unix   unix-compat   unix-time@@ -172,6 +181,7 @@   x509-store   x509-system   x509-validation+  xss-sanitize   zlib  Glob LICENSE file:@@ -1311,6 +1321,39 @@   ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE   POSSIBILITY OF SUCH DAMAGE. +cheapskate LICENSE file:++  Copyright (c) 2013, John MacFarlane++  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 John MacFarlane 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.+ clock LICENSE file:    Copyright (c) 2009-2012, Cetin Sert@@ -1606,6 +1649,63 @@   OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF   SUCH DAMAGE. +css-text LICENSE file:++  The following license covers this documentation, and the source code, except+  where otherwise indicated.++  Copyright 2010, Michael Snoyman. 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.++  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.++data-default LICENSE file:++  Copyright (c) 2013 Lukas Mai++  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 the author nor the names of his 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 HOLDERS 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.+ data-default-class LICENSE file:    Copyright (c) 2013 Lukas Mai@@ -1635,6 +1735,122 @@   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +data-default-instances-base LICENSE file:++  Copyright (c) 2013 Lukas Mai++  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 the author nor the names of his 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 HOLDERS 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.++data-default-instances-containers LICENSE file:++  Copyright (c) 2013 Lukas Mai++  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 the author nor the names of his contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++  THIS SOFTWARE IS PROVIDED BY LUKAS MAI 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 REGENTS 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.++data-default-instances-dlist LICENSE file:++  Copyright (c) 2013 Lukas Mai++  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 the author nor the names of his contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++  THIS SOFTWARE IS PROVIDED BY LUKAS MAI 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 REGENTS 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.++data-default-instances-old-locale LICENSE file:++  Copyright (c) 2013 Lukas Mai++  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 the author nor the names of his contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++  THIS SOFTWARE IS PROVIDED BY LUKAS MAI 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 REGENTS 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.+ data-ordlist LICENSE file:    Copyright (c) 2009-2010, Melding Monads@@ -4366,6 +4582,39 @@   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +tagsoup LICENSE file:++  Copyright Neil Mitchell 2006-2016.+  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 Neil Mitchell 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.+ template-haskell LICENSE file:  @@ -4649,6 +4898,39 @@   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +uniplate LICENSE file:++  Copyright Neil Mitchell 2006-2013.+  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 Neil Mitchell 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.+ unix LICENSE file:    The Glasgow Haskell Compiler License@@ -5237,6 +5519,34 @@   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.++xss-sanitize LICENSE file:++  The following license covers this documentation, and the source code, except+  where otherwise indicated.++  Copyright 2010, Greg Weber. 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.++  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.  zlib LICENSE file: 

@@ -14,5 +14,3 @@  -- This should infer a type. aNumber = 1.0--foreign import nestedForAll :: forall c. (forall a b. c)

@@ -0,0 +1,6 @@+-- @shouldFailWith ErrorParsingModule+module Main where++data X a = X++eg = \(X :: (forall a. X a)) -> X

@@ -0,0 +1,9 @@+-- @shouldFailWith UndefinedTypeVariable+module Main where++type T = forall a. Array a++foo :: T+foo = bar where+  bar :: Array a+  bar = []

@@ -0,0 +1,7 @@+-- @shouldFailWith KindsDoNotUnify+module Main where++type Syn (a :: * -> *) = String++val :: Syn Int+val = "bad"

@@ -0,0 +1,9 @@+-- @shouldFailWith CannotUseBindWithDo+module Main where++import Prelude++foo = do+  let bind = 42+  x <- [4, 5, 6]+  pure x

@@ -0,0 +1,9 @@+-- @shouldFailWith CannotUseBindWithDo+module Main where++import Prelude++foo = do+  bind <- [1,2,3]+  x <- [4, 5, 6]+  pure x

@@ -1,4 +1,4 @@--- @shouldFailWith UnknownName
+-- @shouldFailWith ModuleNotFound
 module Main where
 
 import M1

@@ -1,4 +1,4 @@--- @shouldFailWith KindsDoNotUnify+-- @shouldFailWith ClassInstanceArityMismatch module Main where  import Prelude

@@ -0,0 +1,8 @@+-- @shouldFailWith ClassInstanceArityMismatch+module Main where++import Prelude++class Foo a b++instance fooString :: Foo String

@@ -0,0 +1,9 @@+module Main where++import Prelude+import Control.Monad.Eff.Console (log)++main = +  if (negate (bottom :: Int) > top)+    then log "Fail"+    else log "Done"

@@ -0,0 +1,19 @@+module Main where++import Prelude+import Control.Monad.Eff+import Control.Monad.Eff.Console+import Data.Array+import Data.Array.Partial as P+import Partial.Unsafe++length :: forall a. Array a -> Int+length = go 0 where+  go acc arr =+    if null arr+    then acc+    else go (acc + 1) (unsafePartial P.tail arr)++main = do+  logShow (length (1 .. 10000))+  log "Done"

@@ -0,0 +1,24 @@+module Main where++import Prelude+import Control.Monad.Eff.Console++type T = { foo :: Int, bar :: { baz :: Int, qux :: { lhs :: Int, rhs :: Int } } }++init :: T+init = { foo: 1, bar: { baz: 2, qux: { lhs: 3, rhs: 4 } } }++updated :: T+updated = init { foo = 10, bar { baz = 20, qux { lhs = 30, rhs = 40 } } }++expected :: T+expected = { foo: 10, bar: { baz: 20, qux: { lhs: 30, rhs: 40 } } }++check l r =+  l.foo == r.foo &&+  l.bar.baz == r.bar.baz &&+  l.bar.qux.lhs == r.bar.qux.lhs &&+  l.bar.qux.rhs == r.bar.qux.rhs++main = do+  when (check updated expected) $ log "Done"

@@ -0,0 +1,20 @@+module Main where++import Prelude+import Control.Monad.Eff.Console++update = _ { foo = _, bar { baz = _, qux = _ } }++init = { foo: 1, bar: { baz: 2, qux: 3 } }++after = update init 10 20 30++expected = { foo: 10, bar: { baz: 20, qux: 30 } }++check l r =+  l.foo == r.foo &&+  l.bar.baz == r.bar.baz &&+  l.bar.qux == r.bar.qux++main = do+  when (check after expected) $ log "Done"

@@ -0,0 +1,16 @@+-- @shouldWarnWith MissingTypeDeclaration+module Main where++import Control.Monad.Eff.Console++type T = forall a. Array a++-- | Note: This should not raise a `ShadowedTypeVar` warning as the +-- | type `a` introduced in `T` should not be in scope +-- | in the definition of `bar`.+foo :: T+foo = bar where+  bar :: forall a. Array a+  bar = []++main = log "Done"

@@ -0,0 +1,9 @@+-- @shouldWarnWith UserDefinedWarning+module Main where++foo :: forall t. Warn (TypeConcat "Custom warning " (TypeString t)) => t -> t+foo x = x++bar :: Int+bar = foo 42+

@@ -60,8 +60,8 @@     Etags -> dumpTags input dumpEtags     Ctags -> dumpTags input dumpCtags     Markdown -> do-      ms <- runExceptT (D.parseAndBookmark input []-                           >>= (fst >>> D.convertModulesInPackage))+      ms <- runExceptT (D.parseFilesInPackages input []+                           >>= uncurry D.convertModulesInPackage)                >>= successOrExit        case output of

@@ -35,6 +35,8 @@  client :: PortID -> IO () client port = do+    hSetEncoding stdin utf8+    hSetEncoding stdout utf8     h <-         connectTo "127.0.0.1" port `catch`         (\(SomeException e) ->

@@ -29,6 +29,7 @@ import qualified Data.Text.IO                      as T import qualified Data.ByteString.Lazy.Char8        as BS8 import           Data.Version                      (showVersion)+import           GHC.IO.Exception                  (IOErrorType(..), IOException(..)) import           Language.PureScript.Ide import           Language.PureScript.Ide.Command import           Language.PureScript.Ide.Util@@ -130,9 +131,9 @@   where     loop :: (Ide m, MonadLogger m) => Socket -> m ()     loop sock = do-      accepted <- runExceptT $ acceptCommand sock+      accepted <- runExceptT (acceptCommand sock)       case accepted of-        Left err -> $(logDebug) err+        Left err -> $(logError) err         Right (cmd, h) -> do           case decodeT cmd of             Just cmd' -> do@@ -144,15 +145,22 @@               -- $(logDebug) ("Answer was: " <> T.pack (show result))               liftIO (hFlush stdout)               case result of-                Right r  -> liftIO $ BS8.hPutStrLn h (Aeson.encode r)-                Left err -> liftIO $ BS8.hPutStrLn h (Aeson.encode err)+                Right r  -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode r))+                Left err -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode err))             Nothing -> do-              $(logDebug) ("Parsing the command failed. Command: " <> cmd)+              $(logError) ("Parsing the command failed. Command: " <> cmd)               liftIO $ do-                T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))+                catchGoneHandle (T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")))                 hFlush stdout-          liftIO (hClose h)+          liftIO $ catchGoneHandle (hClose h) +catchGoneHandle :: IO () -> IO ()+catchGoneHandle =+  handle (\e -> case e of+    IOError { ioe_type = ResourceVanished } ->+      putText ("[Error] psc-ide-server tried interact with the handle, but the connection was already gone.")+    _ -> throwIO e)+ acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)                  => Socket -> m (Text, Handle) acceptCommand sock = do@@ -167,7 +175,7 @@   case cmd' of     Nothing -> throwError "Connection was closed before any input arrived"     Just cmd -> do-      $(logDebug) cmd+      $(logDebug) ("Received command: " <> cmd)       pure (cmd, h)   where    acceptConnection = liftIO $ do

@@ -28,9 +28,12 @@ import qualified Options.Applicative as Opts import qualified Paths_purescript as Paths import qualified System.IO as IO-import           Turtle hiding (fold, s, x)+import           Turtle hiding (echo, fold, s, x) import qualified Turtle +echoT :: Text -> IO ()+echoT = Turtle.printf (Turtle.s % "\n")+ packageFile :: Path.FilePath packageFile = "psc-package.json" @@ -56,12 +59,12 @@ readPackageFile = do   exists <- testfile packageFile   unless exists $ do-    echo "psc-package.json does not exist"+    echoT "psc-package.json does not exist"     exit (ExitFailure 1)   mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile   case mpkg of     Nothing -> do-      echo "Unable to parse psc-package.json"+      echoT "Unable to parse psc-package.json"       exit (ExitFailure 1)     Just pkg -> return pkg @@ -124,13 +127,13 @@   :: Text   -- ^ repo   -> Turtle.Shell Text-listRemoteTags from =-  inproc "git"-         [ "ls-remote"-         , "-q"-         , "-t"-         , from-         ] empty+listRemoteTags from = let gitProc = inproc "git"+                                    [ "ls-remote"+                                    , "-q"+                                    , "-t"+                                    , from+                                    ] empty+                      in lineToText <$> gitProc  getPackageSet :: PackageConfig -> IO () getPackageSet PackageConfig{ source, set } = do@@ -143,12 +146,12 @@   let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"   exists <- testfile dbFile   unless exists $ do-    echo $ format (fp%" does not exist") dbFile+    echoT $ format (fp%" does not exist") dbFile     exit (ExitFailure 1)   mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile   case mdb of     Nothing -> do-      echo "Unable to parse packages.json"+      echoT "Unable to parse packages.json"       exit (ExitFailure 1)     Just db -> return db @@ -159,7 +162,7 @@  installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath installOrUpdate set pkgName PackageInfo{ repo, version } = do-  echo ("Updating " <> pkgName)+  echoT ("Updating " <> pkgName)   let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version   exists <- testdir pkgDir   unless exists . void $ cloneShallow repo version pkgDir@@ -170,7 +173,7 @@   pkgs <- for depends $ \pkg ->     case Map.lookup pkg db of       Nothing -> do-        echo ("Package " <> pkg <> " does not exist in package set")+        echoT ("Package " <> pkg <> " does not exist in package set")         exit (ExitFailure 1)       Just PackageInfo{ dependencies } -> return (pkg : dependencies)   let unique = Set.toList (foldMap Set.fromList pkgs)@@ -181,16 +184,16 @@   getPackageSet config   db <- readPackageSet config   trans <- getTransitiveDeps db depends-  echo ("Updating " <> pack (show (length trans)) <> " packages...")+  echoT ("Updating " <> pack (show (length trans)) <> " packages...")   for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg  initialize :: IO () initialize = do   exists <- testfile "psc-package.json"   when exists $ do-    echo "psc-package.json already exists"+    echoT "psc-package.json already exists"     exit (ExitFailure 1)-  echo "Initializing new project in current directory"+  echoT "Initializing new project in current directory"   pkgName <- pathToTextUnsafe . Path.filename <$> pwd   let pkg = defaultPackage pkgName   writePackageFile pkg@@ -200,7 +203,7 @@ update = do   pkg <- readPackageFile   updateImpl pkg-  echo "Update complete"+  echoT "Update complete"  install :: String -> IO () install pkgName = do@@ -208,7 +211,7 @@   let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }   updateImpl pkg'   writePackageFile pkg'-  echo "psc-package.json file was updated"+  echoT "psc-package.json file was updated"  uninstall :: String -> IO () uninstall pkgName = do@@ -216,20 +219,20 @@   let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg }   updateImpl pkg'   writePackageFile pkg'-  echo "psc-package.json file was updated"+  echoT "psc-package.json file was updated"  listDependencies :: IO () listDependencies = do   pkg@PackageConfig{ depends } <- readPackageFile   db <- readPackageSet pkg   trans <- getTransitiveDeps db depends-  traverse_ (echo . fst) trans+  traverse_ (echoT . fst) trans  listPackages :: IO () listPackages = do   pkg <- readPackageFile   db <- readPackageSet pkg-  traverse_ echo (fmt <$> Map.assocs db)+  traverse_ echoT (fmt <$> Map.assocs db)   where   fmt :: (Text, PackageInfo) -> Text   fmt (name, PackageInfo{ version }) = name <> " (" <> version <> ")"@@ -251,7 +254,7 @@   pkg@PackageConfig{ depends } <- readPackageFile   db <- readPackageSet pkg   paths <- getSourcePaths pkg db depends-  traverse_ (echo . pathToTextUnsafe) paths+  traverse_ (echoT . pathToTextUnsafe) paths  exec :: Text -> IO () exec exeName = do@@ -267,11 +270,11 @@     pkg <- readPackageFile     db <- readPackageSet pkg -    echo ("Checking " <> pack (show (Map.size db)) <> " packages for updates.")-    echo "Warning: this could take some time!"+    echoT ("Checking " <> pack (show (Map.size db)) <> " packages for updates.")+    echoT "Warning: this could take some time!"      newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do-      echo ("Checking package " <> name)+      echoT ("Checking package " <> name)       tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list       let tags = mapMaybe parseTag tagLines       newVersion <- case parseVersion version of@@ -280,7 +283,7 @@                 case filter (isMinorReleaseFrom parts) tags of                   [] -> pure version                   minorReleases -> do-                    echo ("New minor release available")+                    echoT ("New minor release available")                     case applyMinorUpdates of                       True -> do                         let latestMinorRelease = maximum minorReleases@@ -290,7 +293,7 @@                 case filter (isMajorReleaseFrom parts) tags of                   [] -> applyMinor                   newReleases -> do-                    echo ("New major release available")+                    echoT ("New major release available")                     case applyMajorUpdates of                       True -> do                         let latestRelease = maximum newReleases@@ -298,7 +301,7 @@                       False -> applyMinor           in applyMajor         _ -> do-          echo "Unable to parse version string"+          echoT "Unable to parse version string"           pure version       pure (name, p { version = newVersion })) @@ -345,15 +348,15 @@   pkg <- readPackageFile   db <- readPackageSet pkg -  echo ("Verifying " <> pack (show (Map.size db)) <> " packages.")-  echo "Warning: this could take some time!"+  echoT ("Verifying " <> pack (show (Map.size db)) <> " packages.")+  echoT "Warning: this could take some time!"    let installOrUpdate' (name, pkgInfo) = (name, ) <$> installOrUpdate (set pkg) name pkgInfo   paths <- Map.fromList <$> traverse installOrUpdate' (Map.toList db)    for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do     let dirFor = fromMaybe (error "verifyPackageSet: no directory") . (`Map.lookup` paths)-    echo ("Verifying package " <> name)+    echoT ("Verifying package " <> name)     let srcGlobs = map (pathToTextUnsafe . (</> ("src" </> "**" </> "*.purs")) . dirFor) (name : dependencies)     procs "psc" srcGlobs empty 

@@ -2,10 +2,12 @@  module Main where +import Control.Monad.IO.Class (liftIO) import Data.Version (Version(..), showVersion) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy.Char8 as BL import Data.Monoid ((<>))+import Data.Time.Clock (getCurrentTime)  import Options.Applicative (Parser, ParseError (..)) import qualified Options.Applicative as Opts@@ -25,6 +27,7 @@ dryRunOptions = defaultPublishOptions   { publishGetVersion = return dummyVersion   , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn+  , publishGetTagTime = const (liftIO getCurrentTime)   }   where dummyVersion = ("0.0.0", Version [0,0,0] []) 

@@ -1,5 +1,5 @@ name: purescript-version: 0.10.5+version: 0.10.6 cabal-version: >=1.8 build-type: Simple license: BSD3@@ -117,12 +117,15 @@                    aeson-better-errors >= 0.8,                    ansi-terminal >= 0.6.2 && < 0.7,                    base-compat >=0.6.0,+                   blaze-html >= 0.8.1 && < 0.9,                    bower-json >= 1.0.0.1 && < 1.1,                    boxes >= 0.1.4 && < 0.2.0,                    bytestring -any,+                   cheapskate >= 0.1 && < 0.2,                    containers -any,                    clock -any,                    data-ordlist >= 0.4.7.0,+                   deepseq -any,                    directory >= 1.2,                    dlist -any,                    edit-distance -any,@@ -266,9 +269,11 @@                      Language.PureScript.Docs.Types                      Language.PureScript.Docs.RenderedCode                      Language.PureScript.Docs.RenderedCode.Types-                     Language.PureScript.Docs.RenderedCode.Render+                     Language.PureScript.Docs.RenderedCode.RenderType+                     Language.PureScript.Docs.RenderedCode.RenderKind                      Language.PureScript.Docs.AsMarkdown-                     Language.PureScript.Docs.ParseAndBookmark+                     Language.PureScript.Docs.AsHtml+                     Language.PureScript.Docs.ParseInPackage                      Language.PureScript.Docs.Utils.MonoidExtras                       Language.PureScript.Publish@@ -280,7 +285,6 @@                      Language.PureScript.Ide.CaseSplit                      Language.PureScript.Ide.Command                      Language.PureScript.Ide.Completion-                     Language.PureScript.Ide.Conversions                      Language.PureScript.Ide.Externs                      Language.PureScript.Ide.Error                      Language.PureScript.Ide.Filter@@ -347,7 +351,7 @@                    filepath -any,                    Glob >= 0.7 && < 0.8,                    mtl -any,-                   optparse-applicative >= 0.12.1,+                   optparse-applicative >= 0.13.0,                    parsec -any,                    text -any,                    time -any,@@ -374,7 +378,7 @@                    haskeline >= 0.7.0.0,                    http-types == 0.9.*,                    mtl -any,-                   optparse-applicative >= 0.12.1,+                   optparse-applicative >= 0.13.0,                    parsec -any,                    process -any,                    stm >= 0.2.4.0,@@ -400,7 +404,7 @@                    filepath -any,                    Glob -any,                    mtl -any,-                   optparse-applicative >= 0.12.1,+                   optparse-applicative >= 0.13.0,                    process -any,                    split -any,                    text -any,@@ -420,7 +424,9 @@                    purescript -any,                    aeson >= 0.8 && < 1.0,                    bytestring -any,-                   optparse-applicative -any+                   optparse-applicative -any,+                   time -any,+                   transformers -any     main-is: Main.hs     other-modules: Paths_purescript     buildable: True@@ -438,7 +444,7 @@                    optparse-applicative -any,                    system-filepath -any,                    text -any,-                   turtle <1.3+                   turtle ==1.3.*     main-is: Main.hs     other-modules: Paths_purescript     buildable: True@@ -452,7 +458,7 @@                    filepath -any,                    Glob -any,                    mtl -any,-                   optparse-applicative >= 0.12.1,+                   optparse-applicative >= 0.13.0,                    parsec -any,                    process -any,                    text -any@@ -475,7 +481,7 @@                        filepath -any,                        Glob -any,                        mtl -any,-                       optparse-applicative >= 0.12.1,+                       optparse-applicative >= 0.13.0,                        sourcemap >= 0.1.6,                        transformers -any,                        transformers-compat -any,@@ -492,18 +498,16 @@                        aeson >= 0.8 && < 1.0,                        bytestring -any,                        purescript -any,-                       base-compat >=0.6.0,                        directory -any,                        filepath -any,                        monad-logger -any,                        mtl -any,                        network -any,-                       optparse-applicative >= 0.12.1,+                       optparse-applicative >= 0.13.0,                        protolude >= 0.1.6,                        stm -any,                        text -any,-                       transformers -any,-                       transformers-compat -any+                       transformers -any   ghc-options:         -Wall -O2 -threaded   hs-source-dirs:      psc-ide-server @@ -516,7 +520,7 @@                        bytestring -any,                        mtl -any,                        network -any,-                       optparse-applicative >= 0.12.1,+                       optparse-applicative >= 0.13.0,                        text -any   ghc-options:         -Wall -O2   hs-source-dirs:      psc-ide-client@@ -538,6 +542,8 @@                    hspec -any,                    hspec-discover -any,                    HUnit -any,+                   lens -any,+                   monad-logger -any,                    mtl -any,                    optparse-applicative -any,                    parsec -any,@@ -562,14 +568,12 @@                    TestPsci                    TestPscIde                    PscIdeSpec+                   Language.PureScript.Ide.Test                    Language.PureScript.Ide.FilterSpec                    Language.PureScript.Ide.ImportsSpec-                   Language.PureScript.Ide.Imports.IntegrationSpec-                   Language.PureScript.Ide.Integration                    Language.PureScript.Ide.MatcherSpec                    Language.PureScript.Ide.RebuildSpec                    Language.PureScript.Ide.ReexportsSpec-                   Language.PureScript.Ide.SourceFile.IntegrationSpec                    Language.PureScript.Ide.SourceFileSpec                    Language.PureScript.Ide.StateSpec     buildable: True

@@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}  -- | -- Data types for modules and declarations@@ -43,7 +45,8 @@  -- | A type of error messages data SimpleErrorMessage-  = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)+  = ModuleNotFound ModuleName +  | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)   | ErrorParsingModule P.ParseError   | MissingFFIModule ModuleName   | MultipleFFIModules ModuleName [FilePath]@@ -134,10 +137,14 @@   | CaseBinderLengthDiffers Int [Binder]   | IncorrectAnonymousArgument   | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)-  | DeprecatedRequirePath   | CannotGeneralizeRecursiveFunction Ident Type   | CannotDeriveNewtypeForData (ProperName 'TypeName)   | ExpectedWildcard (ProperName 'TypeName)+  | CannotUseBindWithDo+  -- | instance name, type class, expected argument count, actual argument count+  | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int+  -- | a user-defined warning raised by using the Warn type class+  | UserDefinedWarning Type   deriving (Show)  -- | Error message hints, providing more detailed information about failure.@@ -581,6 +588,11 @@   --   | ObjectUpdate Expr [(PSString, Expr)]   -- |+  -- Object updates with nested support: `x { foo { bar = e } }`+  -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s+  --+  | ObjectUpdateNested Expr (PathTree Expr)+  -- |   -- Function introduction   --   | Abs (Either Ident Binder) Expr@@ -694,6 +706,39 @@   --   | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement   deriving (Show)+++-- For a record update such as:+--+--  x { foo = 0+--    , bar { baz = 1+--          , qux = 2 } }+--+-- We represent the updates as the `PathTree`:+--+--  [ ("foo", Leaf 3)+--  , ("bar", Branch [ ("baz", Leaf 1)+--                   , ("qux", Leaf 2) ]) ]+--+-- Which we then convert to an expression representing the following:+--+--   let x' = x+--   in x' { foo = 0+--         , bar = x'.bar { baz = 1+--                        , qux = 2 } }+--+-- The `let` here is required to prevent re-evaluating the object expression `x`.+-- However we don't generate this when using an anonymous argument for the object.+--++newtype PathTree t = PathTree (AssocList PSString (PathNode t))+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++data PathNode t = Leaf t | Branch (PathTree t)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }+  deriving (Show, Eq, Ord, Foldable, Functor, Traversable)  $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)

@@ -48,6 +48,7 @@   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' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (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))@@ -115,6 +116,7 @@   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' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (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')@@ -182,6 +184,7 @@   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' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse 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@@ -254,6 +257,7 @@   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@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' 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@@ -331,6 +335,7 @@   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 (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) 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@@ -410,6 +415,7 @@   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 (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (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@@ -500,6 +506,7 @@   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 (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs   g' s (Abs (Left name) v1) =     let s' = S.insert name s     in g'' s' v1

@@ -35,7 +35,7 @@                                    errorMessage, rethrowWithPosition, addHint) import Language.PureScript.Names import Language.PureScript.Options-import Language.PureScript.PSString (PSString, mkString, decodeString)+import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Traversals (sndM) import qualified Language.PureScript.Constants as C @@ -69,7 +69,7 @@     let standardExps = exps \\ foreignExps     let exps' = JSObjectLiteral Nothing $ map (mkString . runIdent &&& JSVar Nothing . identToJs) standardExps                                ++ map (mkString . runIdent &&& foreignIdent) foreignExps-    return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']+    return $ moduleBody ++ [JSAssignment Nothing (accessorString "exports" (JSVar Nothing "module")) exps']    where @@ -138,8 +138,8 @@   -- Generate code in the simplified Javascript intermediate representation for a declaration   --   bindToJs :: Bind Ann -> m [JS]-  bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val-  bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)+  bindToJs (NonRec ann ident val) = nonRecToJS ann ident val+  bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS)    -- |   -- Generate code in the simplified Javascript intermediate representation for a single non-recursive@@ -147,15 +147,22 @@   --   -- The main purpose of this function is to handle code generation for comments.   ---  nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS+  nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS]   nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do     withoutComment <- asks optionsNoComments     if withoutComment        then nonRecToJS a i (modifyAnn removeComments e)-       else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)+       else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)+    where+      withHead _ [] = []+      withHead f (x:xs) = f x : xs   nonRecToJS (ss, _, _, _) ident val = do-    js <- valueToJs val-    withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)+    case constructorToJs ident val of+      Just jss ->+        traverse (withPos ss) jss+      Nothing -> do+        js <- valueToJs val+        return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js))    withPos :: Maybe SourceSpan -> JS -> m JS   withPos (Just ss) js = do@@ -182,12 +189,7 @@   accessor (GenIdent _ _) = internalError "GenIdent in accessor"    accessorString :: PSString -> JS -> JS-  accessorString prop =-    case decodeString prop of-      Just s | not (identNeedsEscaping s) ->-        JSAccessor Nothing s-      _ ->-        JSIndexer Nothing (JSStringLiteral Nothing prop)+  accessorString prop = JSIndexer Nothing (JSStringLiteral Nothing prop)    -- |   -- Generate code in the simplified Javascript intermediate representation for a value or expression.@@ -201,9 +203,9 @@   valueToJs' (Literal (pos, _, _, _) l) =     maybe id rethrowWithPosition pos $ literalToValueJS l   valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =-    return $ JSAccessor Nothing "value" $ qualifiedToJS id name+    return $ accessorString "value" $ qualifiedToJS id name   valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =-    return $ JSAccessor Nothing "create" $ qualifiedToJS id name+    return $ accessorString "create" $ qualifiedToJS id name   valueToJs' (Accessor _ prop val) =     accessorString prop <$> valueToJs val   valueToJs' (ObjectUpdate _ o ps) = do@@ -256,23 +258,37 @@                 JSObjectLiteral Nothing [("create",                   JSFunction Nothing Nothing ["value"]                     (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])-  valueToJs' (Constructor _ _ (ProperName ctor) []) =-    return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])-           , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing (properToJs ctor)))-                (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]-  valueToJs' (Constructor _ _ (ProperName ctor) fields) =-    let constructor =-          let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]-          in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)-        createFn =-          let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)-          in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields-    in return $ iife (properToJs ctor) [ constructor-                          , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn-                          ]+  valueToJs' (Constructor _ _ (ProperName ctor) _) =+    internalError $ "Unexpected constructor definition: " ++ T.unpack ctor -  iife :: Text -> [JS] -> JS-  iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []+  -- |+  -- Attempt to generate code in the simplified JS intermediate representation for a constructor definition.+  -- If the argument is not a constructor, this returns Nothing.+  --+  constructorToJs :: Ident -> Expr Ann -> Maybe [JS]+  constructorToJs ident (Constructor _ _ (ProperName ctor) fs) =+    Just jss+    where+      mkAccessor name = JSAssignment Nothing (accessorString name (JSVar Nothing (identToJs ident)))+      jss = case fs of+        [] ->+          [ JSVariableIntroduction Nothing (identToJs ident) (Just $+              JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []))+          , mkAccessor "value" $+              JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) []+          ]+        fields ->+          let constructor =+                let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]+                in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)+              createFn =+                let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)+                in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields+          in [ constructor+             , mkAccessor "create" createFn+             ]+  constructorToJs _ _ =+    Nothing    literalToValueJS :: Literal (Expr Ann) -> m JS   literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)@@ -299,7 +315,7 @@       evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj)       objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])       copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]-      cond = JSApp Nothing (JSAccessor Nothing "call" (JSAccessor Nothing "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]+      cond = JSApp Nothing (accessorString "call" (accessorString "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]       assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)]       stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js       extend = map stToAssign sts@@ -356,7 +372,7 @@       valueError _ l@(JSNumericLiteral _ _) = l       valueError _ l@(JSStringLiteral _ _)  = l       valueError _ l@(JSBooleanLiteral _ _) = l-      valueError s _                        = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s+      valueError s _                        = accessorString "name" . accessorString "constructor" $ JSVar Nothing s        guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]       guardsToJs (Left gs) = forM gs $ \(cond, val) -> do@@ -397,7 +413,7 @@       argVar <- freshName       done'' <- go remain done'       js <- binderToJs argVar done'' binder-      return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)+      return (JSVariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ JSVar Nothing varName) : js)   binderToJs' _ _ ConstructorBinder{} =     internalError "binderToJs: Invalid ConstructorBinder in binderToJs"   binderToJs' varName done (NamedBinder _ ident binder) = do@@ -426,7 +442,7 @@       return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)   literalToBinderJS varName done (ArrayLiteral bs) = do     js <- go done 0 bs-    return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]+    return [JSIfElse Nothing (JSBinary Nothing EqualTo (accessorString "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'

@@ -159,10 +159,6 @@   --   | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)]   -- |-  -- An object property accessor expression-  ---  | JSAccessor (Maybe SourceSpan) Text JS-  -- |   -- A function introduction (optional name, arguments, body)   --   | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS@@ -259,7 +255,6 @@   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@@ -293,7 +288,6 @@   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@@ -328,7 +322,6 @@   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))@@ -359,7 +352,6 @@   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@@ -386,7 +378,6 @@   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

@@ -46,7 +46,7 @@ optimize' :: (MonadReader Options m, MonadSupply m) => JS -> m JS optimize' js = do   opts <- ask-  js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll+  js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll     [ inlineCommonValues     , inlineCommonOperators     ]) js

@@ -11,7 +11,7 @@  import Language.PureScript.Crash import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.PSString (mkString)+import Language.PureScript.PSString (PSString)  applyAll :: [a -> a] -> a -> a applyAll = foldl' (.) id@@ -55,7 +55,6 @@  targetVariable :: JS -> Text targetVariable (JSVar _ var) = var-targetVariable (JSAccessor _ _ tgt) = targetVariable tgt targetVariable (JSIndexer _ _ tgt) = targetVariable tgt targetVariable _ = internalError "Invalid argument to targetVariable" @@ -70,16 +69,10 @@ removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts) removeFromBlock _  js = js -isFn :: (Text, Text) -> JS -> Bool-isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) =-  x == fnName && y == moduleName-isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =-  x == mkString fnName && y == moduleName-isFn _ _ = False--isDict :: (Text, Text) -> JS -> Bool-isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName+isDict :: (Text, PSString) -> JS -> Bool+isDict (moduleName, dictName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =+  x == dictName && y == moduleName isDict _ _ = False -isDict' :: [(Text, Text)] -> JS -> Bool+isDict' :: [(Text, PSString)] -> JS -> Bool isDict' xs js = any (`isDict` js) xs

@@ -6,6 +6,7 @@   , inlineCommonValues   , inlineCommonOperators   , inlineFnComposition+  , inlineUnsafePartial   , etaConvert   , unThunk   , evaluateIifes@@ -17,9 +18,11 @@  import Data.Maybe (fromMaybe) import Data.Monoid ((<>))+import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T +import Language.PureScript.PSString (PSString) import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common import qualified Language.PureScript.Constants as C@@ -33,7 +36,6 @@ shouldInline (JSNumericLiteral _ _) = True shouldInline (JSStringLiteral _ _) = True shouldInline (JSBooleanLiteral _ _) = True-shouldInline (JSAccessor _ _ val) = shouldInline val shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val shouldInline _ = False @@ -65,6 +67,8 @@   where   convert :: JS -> JS   convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret+  convert (JSApp _ (JSFunction _ Nothing idents (JSBlock _ [JSReturn ss ret])) [])+    | not (any (`isReassigned` ret) idents) = replaceIdents (map (, JSVar ss C.undefined) idents) ret   convert js = js  inlineVariables :: JS -> JS@@ -82,15 +86,17 @@   where   convert :: JS -> JS   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+    | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = JSNumericLiteral ss (Left 0)+    | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = JSNumericLiteral ss (Left 1)+    | isDict boundedBoolean dict && isDict fnBottom fn = JSBooleanLiteral ss False+    | isDict boundedBoolean dict && isDict fnTop fn = JSBooleanLiteral ss True+  convert (JSApp ss (JSApp _ fn [dict]) [x])+    | isDict ringInt dict && isDict fnNegate fn = JSBinary ss BitwiseOr (JSUnary ss Negate x) (JSNumericLiteral ss (Left 0))   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 euclideanRingInt dict && isFn fnDivide fn = intOp ss Divide x y-    | isDict ringInt dict && isFn fnSubtract fn = intOp ss Subtract x y+    | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add x y+    | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y+    | isDict euclideanRingInt dict && isDict fnDivide fn = intOp ss Divide x y+    | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract x y   convert other = other   fnZero = (C.dataSemiring, C.zero)   fnOne = (C.dataSemiring, C.one)@@ -100,17 +106,16 @@   fnDivide = (C.dataEuclideanRing, C.div)   fnMultiply = (C.dataSemiring, C.mul)   fnSubtract = (C.dataRing, C.sub)+  fnNegate = (C.dataRing, C.negate)   intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))  inlineCommonOperators :: JS -> JS-inlineCommonOperators = applyAll $+inlineCommonOperators = everywhereOnJSTopDown $ applyAll $   [ binary semiringNumber opAdd Add   , binary semiringNumber opMul Multiply    , binary ringNumber opSub Subtract   , unary  ringNumber opNegate Negate-  , binary ringInt opSub Subtract-  , unary  ringInt opNegate Negate    , binary euclideanRingNumber opDiv Divide   , binary euclideanRingInt opMod Modulus@@ -167,39 +172,33 @@   ] ++   [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]   where-  binary :: (Text, Text) -> (Text, Text) -> BinaryOperator -> JS -> JS-  binary dict fns op = everywhereOnJS convert-    where+  binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS+  binary dict fns op = convert where     convert :: JS -> JS-    convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y+    convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = JSBinary ss op x y     convert other = other-  binary' :: Text -> Text -> BinaryOperator -> JS -> JS-  binary' moduleName opString op = everywhereOnJS convert-    where+  binary' :: Text -> PSString -> BinaryOperator -> JS -> JS+  binary' moduleName opString op = convert where     convert :: JS -> JS-    convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y+    convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y     convert other = other-  unary :: (Text, Text) -> (Text, Text) -> UnaryOperator -> JS -> JS-  unary dicts fns op = everywhereOnJS convert-    where+  unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS+  unary dicts fns op = convert where     convert :: JS -> JS-    convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x+    convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = JSUnary ss op x     convert other = other-  unary' :: Text -> Text -> UnaryOperator -> JS -> JS-  unary' moduleName fnName op = everywhereOnJS convert-    where+  unary' :: Text -> PSString -> UnaryOperator -> JS -> JS+  unary' moduleName fnName op = convert where     convert :: JS -> JS-    convert (JSApp ss fn [x]) | isFn (moduleName, fnName) fn = JSUnary ss op x+    convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x     convert other = other   mkFn :: Int -> JS -> JS-  mkFn 0 = everywhereOnJS convert-    where+  mkFn 0 = convert where     convert :: JS -> 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+  mkFn n = convert where     convert :: JS -> JS     convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =       case collectArgs n [] fn of@@ -213,12 +212,12 @@    isNFn :: Text -> Int -> JS -> Bool   isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n))-  isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n))+  isNFn prefix n (JSIndexer _ (JSStringLiteral _ name) (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried =+    name == fromString (T.unpack prefix <> show n)   isNFn _ _ _ = False    runFn :: Int -> JS -> JS-  runFn n = everywhereOnJS convert-    where+  runFn n = convert where     convert :: JS -> JS     convert js = fromMaybe js $ go n [] js @@ -228,26 +227,26 @@     go _ _   _ = Nothing    inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS-  inlineNonClassFunction p f = everywhereOnJS convert-    where+  inlineNonClassFunction p f = convert where     convert :: JS -> JS     convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y     convert other = other -  isModFn :: (Text, Text) -> JS -> Bool-  isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'+  isModFn :: (Text, PSString) -> JS -> Bool+  isModFn (m, op) (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) =+    m == m' && op == op'   isModFn _ _ = False -  isModFnWithDict :: (Text, Text) -> JS -> Bool-  isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [JSVar _ _]) = m == m' && op == op'+  isModFnWithDict :: (Text, PSString) -> JS -> Bool+  isModFnWithDict (m, op) (JSApp _ (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) [JSVar _ _]) =+    m == m' && op == op'   isModFnWithDict _ _ = False  -- (f <<< g $ x) = f (g x) -- (f <<< g)     = \x -> f (g x)-inlineFnComposition :: (MonadSupply m) => JS -> m JS-inlineFnComposition = everywhereOnJSTopDownM convert-  where-  convert :: (MonadSupply m) => JS -> m JS+inlineFnComposition :: forall m. MonadSupply m => JS -> m JS+inlineFnComposition = everywhereOnJSTopDownM convert where+  convert :: JS -> m JS   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]]@@ -260,118 +259,127 @@         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+  isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn   isFnComposeFlipped :: JS -> JS -> Bool-  isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn-  fnCompose :: (Text, Text)+  isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn+  fnCompose :: forall a b. (IsString a, IsString b) => (a, b)   fnCompose = (C.controlSemigroupoid, C.compose)-  fnComposeFlipped :: (Text, Text)+  fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)   fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) -semiringNumber :: (Text, Text)+inlineUnsafePartial :: JS -> JS+inlineUnsafePartial = everywhereOnJSTopDown convert where+  convert (JSApp ss (JSIndexer _ (JSStringLiteral _ unsafePartial) (JSVar _ partialUnsafe)) [ comp ])+    | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe+    -- Apply to undefined here, the application should be optimized away+    -- if it is safe to do so+    = JSApp ss comp [ JSVar ss C.undefined ]+  convert other = other++semiringNumber :: forall a b. (IsString a, IsString b) => (a, b) semiringNumber = (C.dataSemiring, C.semiringNumber) -semiringInt :: (Text, Text)+semiringInt :: forall a b. (IsString a, IsString b) => (a, b) semiringInt = (C.dataSemiring, C.semiringInt) -ringNumber :: (Text, Text)+ringNumber :: forall a b. (IsString a, IsString b) => (a, b) ringNumber = (C.dataRing, C.ringNumber) -ringInt :: (Text, Text)+ringInt :: forall a b. (IsString a, IsString b) => (a, b) ringInt = (C.dataRing, C.ringInt) -euclideanRingNumber :: (Text, Text)+euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b) euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber) -euclideanRingInt :: (Text, Text)+euclideanRingInt :: forall a b. (IsString a, IsString b) => (a, b) euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt) -eqNumber :: (Text, Text)+eqNumber :: forall a b. (IsString a, IsString b) => (a, b) eqNumber = (C.dataEq, C.eqNumber) -eqInt :: (Text, Text)+eqInt :: forall a b. (IsString a, IsString b) => (a, b) eqInt = (C.dataEq, C.eqInt) -eqString :: (Text, Text)+eqString :: forall a b. (IsString a, IsString b) => (a, b) eqString = (C.dataEq, C.eqString) -eqChar :: (Text, Text)+eqChar :: forall a b. (IsString a, IsString b) => (a, b) eqChar = (C.dataEq, C.eqChar) -eqBoolean :: (Text, Text)+eqBoolean :: forall a b. (IsString a, IsString b) => (a, b) eqBoolean = (C.dataEq, C.eqBoolean) -ordBoolean :: (Text, Text)+ordBoolean :: forall a b. (IsString a, IsString b) => (a, b) ordBoolean = (C.dataOrd, C.ordBoolean) -ordNumber :: (Text, Text)+ordNumber :: forall a b. (IsString a, IsString b) => (a, b) ordNumber = (C.dataOrd, C.ordNumber) -ordInt :: (Text, Text)+ordInt :: forall a b. (IsString a, IsString b) => (a, b) ordInt = (C.dataOrd, C.ordInt) -ordString :: (Text, Text)+ordString :: forall a b. (IsString a, IsString b) => (a, b) ordString = (C.dataOrd, C.ordString) -ordChar :: (Text, Text)+ordChar :: forall a b. (IsString a, IsString b) => (a, b) ordChar = (C.dataOrd, C.ordChar) -semigroupString :: (Text, Text)+semigroupString :: forall a b. (IsString a, IsString b) => (a, b) semigroupString = (C.dataSemigroup, C.semigroupString) -boundedBoolean :: (Text, Text)+boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b) boundedBoolean = (C.dataBounded, C.boundedBoolean) -heytingAlgebraBoolean :: (Text, Text)+heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b) heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean) -semigroupoidFn :: (Text, Text)+semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b) semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn) -opAdd :: (Text, Text)+opAdd :: forall a b. (IsString a, IsString b) => (a, b) opAdd = (C.dataSemiring, C.add) -opMul :: (Text, Text)+opMul :: forall a b. (IsString a, IsString b) => (a, b) opMul = (C.dataSemiring, C.mul) -opEq :: (Text, Text)+opEq :: forall a b. (IsString a, IsString b) => (a, b) opEq = (C.dataEq, C.eq) -opNotEq :: (Text, Text)+opNotEq :: forall a b. (IsString a, IsString b) => (a, b) opNotEq = (C.dataEq, C.notEq) -opLessThan :: (Text, Text)+opLessThan :: forall a b. (IsString a, IsString b) => (a, b) opLessThan = (C.dataOrd, C.lessThan) -opLessThanOrEq :: (Text, Text)+opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b) opLessThanOrEq = (C.dataOrd, C.lessThanOrEq) -opGreaterThan :: (Text, Text)+opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b) opGreaterThan = (C.dataOrd, C.greaterThan) -opGreaterThanOrEq :: (Text, Text)+opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b) opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq) -opAppend :: (Text, Text)+opAppend :: forall a b. (IsString a, IsString b) => (a, b) opAppend = (C.dataSemigroup, C.append) -opSub :: (Text, Text)+opSub :: forall a b. (IsString a, IsString b) => (a, b) opSub = (C.dataRing, C.sub) -opNegate :: (Text, Text)+opNegate :: forall a b. (IsString a, IsString b) => (a, b) opNegate = (C.dataRing, C.negate) -opDiv :: (Text, Text)+opDiv :: forall a b. (IsString a, IsString b) => (a, b) opDiv = (C.dataEuclideanRing, C.div) -opMod :: (Text, Text)+opMod :: forall a b. (IsString a, IsString b) => (a, b) opMod = (C.dataEuclideanRing, C.mod) -opConj :: (Text, Text)+opConj :: forall a b. (IsString a, IsString b) => (a, b) opConj = (C.dataHeytingAlgebra, C.conj) -opDisj :: (Text, Text)+opDisj :: forall a b. (IsString a, IsString b) => (a, b) opDisj = (C.dataHeytingAlgebra, C.disj) -opNot :: (Text, Text)+opNot :: forall a b. (IsString a, IsString b) => (a, b) opNot = (C.dataHeytingAlgebra, C.not)

@@ -64,11 +64,11 @@   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.controlBind, C.bind)+  isBindPoly = isDict (C.controlBind, C.bind)   -- Check if an expression represents the polymorphic pure or return function-  isPurePoly = isFn (C.controlApplicative, C.pure')+  isPurePoly = isDict (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 (JSIndexer _ (JSStringLiteral _ name') (JSVar _ eff)) = eff == C.eff && name == name'   isEffFunc _ _ = False    -- Remove __do function applications which remain after desugaring@@ -107,14 +107,14 @@   convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =    JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]])   convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =-    if agg then ref else JSAccessor s1 C.stRefValue ref+    if agg then ref else JSIndexer s1 (JSStringLiteral 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+    if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSIndexer s1 (JSStringLiteral 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])+    if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) (JSApp s1 func [JSIndexer s1 (JSStringLiteral 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 (JSIndexer _ (JSStringLiteral _ name') (JSVar _ st)) = st == C.st && name == name'   isSTFunc _ _ = False   -- Find all ST Refs initialized in this block   findSTRefsIn = everythingOnJS (++) isSTRef

@@ -80,8 +80,18 @@     countSelfCallsUnderFunctions _ = 0      countSelfCallsWithFnArgs :: JS -> Int-    countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0+    countSelfCallsWithFnArgs = go [] where+      go acc (JSVar _ ident')+        | ident == ident' && any hasFunction acc = 1+      go acc (JSApp _ fn args) = go (args ++ acc) fn+      go _ _ = 0 +    hasFunction :: JS -> Bool+    hasFunction = getAny . everythingOnJS mappend (Any . isFunction)+      where+      isFunction JSFunction{} = True+      isFunction _ = False+   toLoop :: Text -> [Text] -> JS -> JS   toLoop ident allArgs js = JSBlock rootSS $         map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++@@ -108,14 +118,3 @@   isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'   isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn   isSelfCall _ _ = False--  isSelfCallWithFnArgs :: Text -> JS -> [JS] -> Bool-  isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True-  isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)-  isSelfCallWithFnArgs _ _ _ = False--  hasFunction :: JS -> Bool-  hasFunction = getAny . everythingOnJS mappend (Any . isFunction)-    where-    isFunction JSFunction{} = True-    isFunction _ = False

@@ -2,319 +2,319 @@ module Language.PureScript.Constants where  import Prelude.Compat-import Data.Text (Text)+import Data.String (IsString) import Language.PureScript.Names  -- Operators -($) :: Text+($) :: forall a. (IsString a) => a ($) = "$" -apply :: Text+apply :: forall a. (IsString a) => a apply = "apply" -(#) :: Text+(#) :: forall a. (IsString a) => a (#) = "#" -applyFlipped :: Text+applyFlipped :: forall a. (IsString a) => a applyFlipped = "applyFlipped" -(<>) :: Text+(<>) :: forall a. (IsString a) => a (<>) = "<>" -(++) :: Text+(++) :: forall a. (IsString a) => a (++) = "++" -append :: Text+append :: forall a. (IsString a) => a append = "append" -(>>=) :: Text+(>>=) :: forall a. (IsString a) => a (>>=) = ">>=" -bind :: Text+bind :: forall a. (IsString a) => a bind = "bind" -(+) :: Text+(+) :: forall a. (IsString a) => a (+) = "+" -add :: Text+add :: forall a. (IsString a) => a add = "add" -(-) :: Text+(-) :: forall a. (IsString a) => a (-) = "-" -sub :: Text+sub :: forall a. (IsString a) => a sub = "sub" -(*) :: Text+(*) :: forall a. (IsString a) => a (*) = "*" -mul :: Text+mul :: forall a. (IsString a) => a mul = "mul" -(/) :: Text+(/) :: forall a. (IsString a) => a (/) = "/" -div :: Text+div :: forall a. (IsString a) => a div = "div" -(%) :: Text+(%) :: forall a. (IsString a) => a (%) = "%" -mod :: Text+mod :: forall a. (IsString a) => a mod = "mod" -(<) :: Text+(<) :: forall a. (IsString a) => a (<) = "<" -lessThan :: Text+lessThan :: forall a. (IsString a) => a lessThan = "lessThan" -(>) :: Text+(>) :: forall a. (IsString a) => a (>) = ">" -greaterThan :: Text+greaterThan :: forall a. (IsString a) => a greaterThan = "greaterThan" -(<=) :: Text+(<=) :: forall a. (IsString a) => a (<=) = "<=" -lessThanOrEq :: Text+lessThanOrEq :: forall a. (IsString a) => a lessThanOrEq = "lessThanOrEq" -(>=) :: Text+(>=) :: forall a. (IsString a) => a (>=) = ">=" -greaterThanOrEq :: Text+greaterThanOrEq :: forall a. (IsString a) => a greaterThanOrEq = "greaterThanOrEq" -(==) :: Text+(==) :: forall a. (IsString a) => a (==) = "==" -eq :: Text+eq :: forall a. (IsString a) => a eq = "eq" -(/=) :: Text+(/=) :: forall a. (IsString a) => a (/=) = "/=" -notEq :: Text+notEq :: forall a. (IsString a) => a notEq = "notEq" -compare :: Text+compare :: forall a. (IsString a) => a compare = "compare" -(&&) :: Text+(&&) :: forall a. (IsString a) => a (&&) = "&&" -conj :: Text+conj :: forall a. (IsString a) => a conj = "conj" -(||) :: Text+(||) :: forall a. (IsString a) => a (||) = "||" -disj :: Text+disj :: forall a. (IsString a) => a disj = "disj" -unsafeIndex :: Text+unsafeIndex :: forall a. (IsString a) => a unsafeIndex = "unsafeIndex" -or :: Text+or :: forall a. (IsString a) => a or = "or" -and :: Text+and :: forall a. (IsString a) => a and = "and" -xor :: Text+xor :: forall a. (IsString a) => a xor = "xor" -(<<<) :: Text+(<<<) :: forall a. (IsString a) => a (<<<) = "<<<" -compose :: Text+compose :: forall a. (IsString a) => a compose = "compose" -(>>>) :: Text+(>>>) :: forall a. (IsString a) => a (>>>) = ">>>" -composeFlipped :: Text+composeFlipped :: forall a. (IsString a) => a composeFlipped = "composeFlipped" -map :: Text+map :: forall a. (IsString a) => a map = "map"  -- Functions -negate :: Text+negate :: forall a. (IsString a) => a negate = "negate" -not :: Text+not :: forall a. (IsString a) => a not = "not" -shl :: Text+shl :: forall a. (IsString a) => a shl = "shl" -shr :: Text+shr :: forall a. (IsString a) => a shr = "shr" -zshr :: Text+zshr :: forall a. (IsString a) => a zshr = "zshr" -complement :: Text+complement :: forall a. (IsString a) => a complement = "complement"  -- Prelude Values -zero :: Text+zero :: forall a. (IsString a) => a zero = "zero" -one :: Text+one :: forall a. (IsString a) => a one = "one" -bottom :: Text+bottom :: forall a. (IsString a) => a bottom = "bottom" -top :: Text+top :: forall a. (IsString a) => a top = "top" -return :: Text+return :: forall a. (IsString a) => a return = "return" -pure' :: Text+pure' :: forall a. (IsString a) => a pure' = "pure" -returnEscaped :: Text+returnEscaped :: forall a. (IsString a) => a returnEscaped = "$return" -untilE :: Text+untilE :: forall a. (IsString a) => a untilE = "untilE" -whileE :: Text+whileE :: forall a. (IsString a) => a whileE = "whileE" -runST :: Text+runST :: forall a. (IsString a) => a runST = "runST" -stRefValue :: Text+stRefValue :: forall a. (IsString a) => a stRefValue = "value" -newSTRef :: Text+newSTRef :: forall a. (IsString a) => a newSTRef = "newSTRef" -readSTRef :: Text+readSTRef :: forall a. (IsString a) => a readSTRef = "readSTRef" -writeSTRef :: Text+writeSTRef :: forall a. (IsString a) => a writeSTRef = "writeSTRef" -modifySTRef :: Text+modifySTRef :: forall a. (IsString a) => a modifySTRef = "modifySTRef" -mkFn :: Text+mkFn :: forall a. (IsString a) => a mkFn = "mkFn" -runFn :: Text+runFn :: forall a. (IsString a) => a runFn = "runFn" -unit :: Text+unit :: forall a. (IsString a) => a unit = "unit"  -- Prim values -undefined :: Text+undefined :: forall a. (IsString a) => a undefined = "undefined"  -- Type Class Dictionary Names -monadEffDictionary :: Text+monadEffDictionary :: forall a. (IsString a) => a monadEffDictionary = "monadEff" -applicativeEffDictionary :: Text+applicativeEffDictionary :: forall a. (IsString a) => a applicativeEffDictionary = "applicativeEff" -bindEffDictionary :: Text+bindEffDictionary :: forall a. (IsString a) => a bindEffDictionary = "bindEff" -semiringNumber :: Text+semiringNumber :: forall a. (IsString a) => a semiringNumber = "semiringNumber" -semiringInt :: Text+semiringInt :: forall a. (IsString a) => a semiringInt = "semiringInt" -ringNumber :: Text+ringNumber :: forall a. (IsString a) => a ringNumber = "ringNumber" -ringInt :: Text+ringInt :: forall a. (IsString a) => a ringInt = "ringInt" -moduloSemiringNumber :: Text+moduloSemiringNumber :: forall a. (IsString a) => a moduloSemiringNumber = "moduloSemiringNumber" -moduloSemiringInt :: Text+moduloSemiringInt :: forall a. (IsString a) => a moduloSemiringInt = "moduloSemiringInt" -euclideanRingNumber :: Text+euclideanRingNumber :: forall a. (IsString a) => a euclideanRingNumber = "euclideanRingNumber" -euclideanRingInt :: Text+euclideanRingInt :: forall a. (IsString a) => a euclideanRingInt = "euclideanRingInt" -ordBoolean :: Text+ordBoolean :: forall a. (IsString a) => a ordBoolean = "ordBoolean" -ordNumber :: Text+ordNumber :: forall a. (IsString a) => a ordNumber = "ordNumber" -ordInt :: Text+ordInt :: forall a. (IsString a) => a ordInt = "ordInt" -ordString :: Text+ordString :: forall a. (IsString a) => a ordString = "ordString" -ordChar :: Text+ordChar :: forall a. (IsString a) => a ordChar = "ordChar" -eqNumber :: Text+eqNumber :: forall a. (IsString a) => a eqNumber = "eqNumber" -eqInt :: Text+eqInt :: forall a. (IsString a) => a eqInt = "eqInt" -eqString :: Text+eqString :: forall a. (IsString a) => a eqString = "eqString" -eqChar :: Text+eqChar :: forall a. (IsString a) => a eqChar = "eqChar" -eqBoolean :: Text+eqBoolean :: forall a. (IsString a) => a eqBoolean = "eqBoolean" -boundedBoolean :: Text+boundedBoolean :: forall a. (IsString a) => a boundedBoolean = "boundedBoolean" -booleanAlgebraBoolean :: Text+booleanAlgebraBoolean :: forall a. (IsString a) => a booleanAlgebraBoolean = "booleanAlgebraBoolean" -heytingAlgebraBoolean :: Text+heytingAlgebraBoolean :: forall a. (IsString a) => a heytingAlgebraBoolean = "heytingAlgebraBoolean" -semigroupString :: Text+semigroupString :: forall a. (IsString a) => a semigroupString = "semigroupString" -semigroupoidFn :: Text+semigroupoidFn :: forall a. (IsString a) => a semigroupoidFn = "semigroupoidFn"  -- Generic Deriving -generic :: Text+generic :: forall a. (IsString a) => a generic = "Generic" -toSpine :: Text+toSpine :: forall a. (IsString a) => a toSpine = "toSpine" -fromSpine :: Text+fromSpine :: forall a. (IsString a) => a fromSpine = "fromSpine" -toSignature :: Text+toSignature :: forall a. (IsString a) => a toSignature = "toSignature"  -- Data.Symbol@@ -352,12 +352,12 @@  -- Main module -main :: Text+main :: forall a. (IsString a) => a main = "main"  -- Prim -partial :: Text+partial :: forall a. (IsString a) => a partial = "Partial"  pattern Prim :: ModuleName@@ -369,78 +369,87 @@ pattern Fail :: Qualified (ProperName 'ClassName) pattern Fail = Qualified (Just Prim) (ProperName "Fail") -typ :: Text+pattern Warn :: Qualified (ProperName 'ClassName)+pattern Warn = Qualified (Just Prim) (ProperName "Warn")++typ :: forall a. (IsString a) => a typ = "Type" -effect :: Text+effect :: forall a. (IsString a) => a effect = "Effect" -symbol :: Text+symbol :: forall a. (IsString a) => a symbol = "Symbol"  -- Code Generation -__superclass_ :: Text+__superclass_ :: forall a. (IsString a) => a __superclass_ = "__superclass_" -__unused :: Text+__unused :: forall a. (IsString a) => a __unused = "__unused"  -- Modules -prim :: Text+prim :: forall a. (IsString a) => a prim = "Prim" -prelude :: Text+prelude :: forall a. (IsString a) => a prelude = "Prelude" -dataArray :: Text+dataArray :: forall a. (IsString a) => a dataArray = "Data_Array" -eff :: Text+eff :: forall a. (IsString a) => a eff = "Control_Monad_Eff" -st :: Text+st :: forall a. (IsString a) => a st = "Control_Monad_ST" -controlApplicative :: Text+controlApplicative :: forall a. (IsString a) => a controlApplicative = "Control_Applicative" -controlSemigroupoid :: Text+controlSemigroupoid :: forall a. (IsString a) => a controlSemigroupoid = "Control_Semigroupoid" -controlBind :: Text+controlBind :: forall a. (IsString a) => a controlBind = "Control_Bind" -dataBounded :: Text+dataBounded :: forall a. (IsString a) => a dataBounded = "Data_Bounded" -dataSemigroup :: Text+dataSemigroup :: forall a. (IsString a) => a dataSemigroup = "Data_Semigroup" -dataHeytingAlgebra :: Text+dataHeytingAlgebra :: forall a. (IsString a) => a dataHeytingAlgebra = "Data_HeytingAlgebra" -dataEq :: Text+dataEq :: forall a. (IsString a) => a dataEq = "Data_Eq" -dataOrd :: Text+dataOrd :: forall a. (IsString a) => a dataOrd = "Data_Ord" -dataSemiring :: Text+dataSemiring :: forall a. (IsString a) => a dataSemiring = "Data_Semiring" -dataRing :: Text+dataRing :: forall a. (IsString a) => a dataRing = "Data_Ring" -dataEuclideanRing :: Text+dataEuclideanRing :: forall a. (IsString a) => a dataEuclideanRing = "Data_EuclideanRing" -dataFunction :: Text+dataFunction :: forall a. (IsString a) => a dataFunction = "Data_Function" -dataFunctionUncurried :: Text+dataFunctionUncurried :: forall a. (IsString a) => a dataFunctionUncurried = "Data_Function_Uncurried" -dataIntBits :: Text+dataIntBits :: forall a. (IsString a) => a dataIntBits = "Data_Int_Bits"++partialUnsafe :: forall a. (IsString a) => a+partialUnsafe = "Partial_Unsafe"++unsafePartial :: forall a. (IsString a) => a+unsafePartial = "unsafePartial"

@@ -1,11 +1,27 @@-module Language.PureScript.Crash where
-
-import Prelude.Compat
-
--- | Exit with an error message and a crash report link.
-internalError :: String -> a
-internalError =
-  error
-  . ("An internal error ocurred during compilation: " ++)
-  . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")
-  . show
+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImplicitParams #-}++module Language.PureScript.Crash where++import Prelude.Compat++import qualified GHC.Stack++-- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint.+#if __GLASGOW_HASKELL__ >= 800+type HasCallStack = GHC.Stack.HasCallStack+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)+type HasCallStack = (?callStack :: GHC.Stack.CallStack)+#else+import GHC.Exts (Constraint)+-- CallStack wasn't present in GHC 7.10.1+type HasCallStack = (() :: Constraint)+#endif++-- | Exit with an error message and a crash report link.+internalError :: HasCallStack => String -> a+internalError =+  error+  . ("An internal error occurred during compilation: " ++)+  . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")+  . show

@@ -8,8 +8,7 @@  import Language.PureScript.Docs.Convert as Docs import Language.PureScript.Docs.Prim as Docs-import Language.PureScript.Docs.ParseAndBookmark as Docs+import Language.PureScript.Docs.ParseInPackage as Docs import Language.PureScript.Docs.Render as Docs-import Language.PureScript.Docs.RenderedCode.Render as Docs-import Language.PureScript.Docs.RenderedCode.Types as Docs+import Language.PureScript.Docs.RenderedCode as Docs import Language.PureScript.Docs.Types as Docs

@@ -0,0 +1,299 @@++-- | Functions for rendering generated documentation from PureScript code as+-- HTML.++module Language.PureScript.Docs.AsHtml (+  HtmlOutput(..),+  HtmlOutputModule(..),+  HtmlRenderContext(..),+  nullRenderContext,+  declNamespace,+  packageAsHtml,+  moduleAsHtml,+  makeFragment,+  renderMarkdown+) where++import Prelude+import Control.Arrow (second)+import Control.Category ((>>>))+import Control.Monad (unless)+import Data.Char (isUpper)+import Data.Monoid ((<>))+import Data.Foldable (for_)+import Data.String (fromString)++import Data.Text (Text)+import qualified Data.Text as T++import Text.Blaze.Html5 as H hiding (map)+import qualified Text.Blaze.Html5.Attributes as A+import qualified Cheapskate++import qualified Language.PureScript as P++import Language.PureScript.Docs.Types+import Language.PureScript.Docs.RenderedCode hiding (sp)+import qualified Language.PureScript.Docs.Render as Render++declNamespace :: Declaration -> Namespace+declNamespace = declInfoNamespace . declInfo++data HtmlOutput a = HtmlOutput+  { htmlIndex     :: [(Maybe Char, a)]+  , htmlModules   :: [(P.ModuleName, HtmlOutputModule a)]+  }+  deriving (Show, Functor)++data HtmlOutputModule a = HtmlOutputModule+  { htmlOutputModuleLocals    :: a+  , htmlOutputModuleReExports :: [(InPackage P.ModuleName, a)]+  }+  deriving (Show, Functor)++data HtmlRenderContext = HtmlRenderContext+  { currentModuleName :: P.ModuleName+  , buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink+  , renderDocLink :: DocLink -> Text+  , renderSourceLink :: P.SourceSpan -> Text+  }++-- |+-- An HtmlRenderContext for when you don't want to render any links.+nullRenderContext :: P.ModuleName -> HtmlRenderContext+nullRenderContext mn = HtmlRenderContext+  { currentModuleName = mn+  , buildDocLink = const (const (const Nothing))+  , renderDocLink = const ""+  , renderSourceLink = const ""+  }++packageAsHtml :: (P.ModuleName -> HtmlRenderContext) -> Package a -> HtmlOutput Html+packageAsHtml getHtmlCtx Package{..} =+  HtmlOutput indexFile modules+  where+  indexFile = []+  modules = map (\m -> moduleAsHtml (getHtmlCtx (modName m)) m) pkgModules++moduleAsHtml :: HtmlRenderContext -> Module -> (P.ModuleName, HtmlOutputModule Html)+moduleAsHtml r Module{..} = (modName, HtmlOutputModule modHtml reexports)+  where+  renderDecl = declAsHtml r+  modHtml = do+    for_ modComments renderMarkdown+    for_ modDeclarations renderDecl+  reexports =+    map (second (foldMap renderDecl)) modReExports++-- renderIndex :: LinksContext -> [(Maybe Char, Html)]+-- renderIndex LinksContext{..} = go ctxBookmarks+--   where+--   go = takeLocals+--      >>> groupIndex getIndex renderEntry+--      >>> map (second (ul . mconcat))+-- +--   getIndex (_, title_) = do+--     c <- textHeadMay title_+--     guard (toUpper c `elem` ['A'..'Z'])+--     pure c+-- +--   textHeadMay t =+--     case T.length t of+--       0 -> Nothing+--       _ -> Just (T.index t 0)+-- +--   renderEntry (mn, title_) =+--     li $ do+--       let url = T.pack (filePathFor mn `relativeTo` "index") <> "#" <> title_+--       code $+--         a ! A.href (v url) $ text title_+--       sp+--       text ("(" <> P.runModuleName mn <> ")")+-- +--   groupIndex :: Ord i => (a -> Maybe i) -> (a -> b) -> [a] -> [(Maybe i, [b])]+--   groupIndex f g =+--     map (second DList.toList) . M.toList . foldr go' M.empty . sortBy (comparing f)+--     where+--     go' x = insertOrAppend (f x) (g x)+--     insertOrAppend idx val m =+--       let cur = M.findWithDefault DList.empty idx m+--           new = DList.snoc cur val+--       in  M.insert idx new m++declAsHtml :: HtmlRenderContext -> Declaration -> Html+declAsHtml r d@Declaration{..} = do+  let declFragment = makeFragment (declInfoNamespace declInfo) declTitle+  H.div ! A.class_ "decl" ! A.id (v (T.drop 1 declFragment)) $ do+    h3 ! A.class_ "decl__title clearfix" $ do+      a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#"+      text declTitle+      for_ declSourceSpan (linkToSource r)++    H.div ! A.class_ "decl__body" $ do+      case declInfo of+        AliasDeclaration fixity alias_ ->+          renderAlias fixity alias_+        _ ->+          pre ! A.class_ "decl__signature" $ code $+            codeAsHtml r (Render.renderDeclaration d)++      for_ declComments renderMarkdown++      let (instances, dctors, members) = partitionChildren declChildren++      unless (null dctors) $ do+        h4 "Constructors"+        renderChildren r dctors++      unless (null members) $ do+        h4 "Members"+        renderChildren r members++      unless (null instances) $ do+        h4 "Instances"+        renderChildren r instances+  where+    linkToSource :: HtmlRenderContext -> P.SourceSpan -> Html+    linkToSource ctx srcspan =+      H.span ! A.class_ "decl__source" $+        a ! A.href (v (renderSourceLink ctx srcspan)) $ text "Source"++renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html+renderChildren _ [] = return ()+renderChildren r xs = ul $ mapM_ go xs+  where+  go decl = item decl . code . codeAsHtml r . Render.renderChildDeclaration $ decl+  item decl = let fragment = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl)+              in  li ! A.id (v (T.drop 1 fragment))++codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html+codeAsHtml r = outputWith elemAsHtml+  where+  elemAsHtml e = case e of+    Syntax x ->+      withClass "syntax" (text x)+    Keyword x ->+      withClass "keyword" (text x)+    Space ->+      text " "+    Symbol ns name link_ ->+      case link_ of+        Link mn ->+          let+            class_ = if startsWithUpper name then "ctor" else "ident"+          in+            linkToDecl ns name mn (withClass class_ (text name))+        NoLink ->+          text name++  linkToDecl = linkToDeclaration r++  startsWithUpper :: Text -> Bool+  startsWithUpper str =+    if T.null str+      then False+      else isUpper (T.index str 0)++renderLink :: HtmlRenderContext -> DocLink -> Html -> Html+renderLink r link_@DocLink{..} =+  a ! A.href (v (renderDocLink r link_ <> fragmentFor link_))+    ! A.title (v fullyQualifiedName)+  where+  fullyQualifiedName = case linkLocation of+    SameModule                -> fq (currentModuleName r) linkTitle+    LocalModule _ modName     -> fq modName linkTitle+    DepsModule _ _ _ modName  -> fq modName linkTitle+    BuiltinModule modName     -> fq modName linkTitle++  fq mn str = P.runModuleName mn <> "." <> str++makeFragment :: Namespace -> Text -> Text+makeFragment ns = (prefix <>) . escape+  where+  prefix = case ns of+    TypeLevel -> "#t:"+    ValueLevel -> "#v:"+    KindLevel -> "#k:"++  -- TODO+  escape = id++fragmentFor :: DocLink -> Text+fragmentFor l = makeFragment (linkNamespace l) (linkTitle l)++linkToDeclaration ::+  HtmlRenderContext ->+  Namespace ->+  Text ->+  ContainingModule ->+  Html ->+  Html+linkToDeclaration r ns target containMn =+  maybe id (renderLink r) (buildDocLink r ns target containMn)++renderAlias :: P.Fixity -> FixityAlias -> Html+renderAlias (P.Fixity associativity precedence) alias_ =+  p $ do+    -- TODO: Render a link+    toHtml $ "Operator alias for " <> P.showQualified showAliasName alias_ <> " "+    em $+      text ("(" <> associativityStr <> " / precedence " <> T.pack (show precedence) <> ")")+  where+  showAliasName (Left valueAlias) = P.runProperName valueAlias+  showAliasName (Right typeAlias) = case typeAlias of+    (Left identifier)  -> P.runIdent identifier+    (Right properName) -> P.runProperName properName+  associativityStr = case associativity of+    P.Infixl -> "left-associative"+    P.Infixr -> "right-associative"+    P.Infix  -> "non-associative"++-- | Render Markdown to HTML. Safe for untrusted input. Relative links are+-- | removed.+renderMarkdown :: Text -> H.Html+renderMarkdown =+  H.toMarkup . removeRelativeLinks . Cheapskate.markdown opts+  where+  opts = Cheapskate.def { Cheapskate.allowRawHtml = False }++removeRelativeLinks :: Cheapskate.Doc -> Cheapskate.Doc+removeRelativeLinks = Cheapskate.walk go+  where+  go :: Cheapskate.Inlines -> Cheapskate.Inlines+  go = (>>= stripRelatives)++  stripRelatives :: Cheapskate.Inline -> Cheapskate.Inlines+  stripRelatives (Cheapskate.Link contents_ href _)+    | isRelativeURI href = contents_+  stripRelatives other = pure other++  -- Tests for a ':' character in the first segment of a URI.+  --+  -- See Section 4.2 of RFC 3986:+  -- https://tools.ietf.org/html/rfc3986#section-4.2+  --+  -- >>> isRelativeURI "http://example.com/" == False+  -- >>> isRelativeURI "mailto:me@example.com" == False+  -- >>> isRelativeURI "foo/bar" == True+  -- >>> isRelativeURI "/bar" == True+  -- >>> isRelativeURI "./bar" == True+  isRelativeURI :: Text -> Bool+  isRelativeURI =+    T.takeWhile (/= '/') >>> T.all (/= ':')++v :: Text -> AttributeValue+v = toValue++withClass :: String -> Html -> Html+withClass className content = H.span ! A.class_ (fromString className) $ content++partitionChildren ::+  [ChildDeclaration] ->+  ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])+partitionChildren = foldl go ([], [], [])+  where+  go (instances, dctors, members) rcd =+    case cdeclInfo rcd of+      ChildInstance _ _      -> (rcd : instances, dctors, members)+      ChildDataConstructor _ -> (instances, rcd : dctors, members)+      ChildTypeClassMember _ -> (instances, dctors, rcd : members)

@@ -77,12 +77,10 @@ codeToString :: RenderedCode -> Text codeToString = outputWith elemAsMarkdown   where-  elemAsMarkdown (Syntax x)  = x-  elemAsMarkdown (Ident x _) = x-  elemAsMarkdown (Ctor x _)  = x-  elemAsMarkdown (Kind x)    = x-  elemAsMarkdown (Keyword x) = x-  elemAsMarkdown Space       = " "+  elemAsMarkdown (Syntax x)     = x+  elemAsMarkdown (Keyword x)    = x+  elemAsMarkdown Space          = " "+  elemAsMarkdown (Symbol _ x _) = x  -- fixityAsMarkdown :: P.Fixity -> Docs -- fixityAsMarkdown (P.Fixity associativity precedence) =

@@ -3,28 +3,27 @@  module Language.PureScript.Docs.Convert   ( convertModules+  , convertModulesWithEnv   , convertModulesInPackage-  , collectBookmarks+  , convertModulesInPackageWithEnv   ) where -import Prelude.Compat+import Protolude hiding (check) -import Control.Arrow ((&&&), second)+import Control.Arrow ((&&&)) import Control.Category ((>>>))-import Control.Monad-import Control.Monad.Error.Class (MonadError)-import Control.Monad.State (runStateT) import Control.Monad.Writer.Strict (runWriterT)-import Data.List (find) import qualified Data.Map as Map-import Data.Text (Text)+import Data.String (String)  import Language.PureScript.Docs.Convert.ReExports (updateReExports)-import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)+import Language.PureScript.Docs.Convert.Single (convertSingleModule) import Language.PureScript.Docs.Types import qualified Language.PureScript as P import qualified Language.PureScript.Constants as C +import Web.Bower.PackageMeta (PackageName)+ import Text.Parsec (eof)  -- |@@ -34,32 +33,36 @@ -- convertModulesInPackage ::   (MonadError P.MultipleErrors m) =>-  [InPackage P.Module] ->+  [P.Module] ->+  Map P.ModuleName PackageName ->   m [Module]-convertModulesInPackage modules =+convertModulesInPackage modules modulesDeps =+  fmap fst (convertModulesInPackageWithEnv modules modulesDeps)++convertModulesInPackageWithEnv ::+  (MonadError P.MultipleErrors m) =>+  [P.Module] ->+  Map P.ModuleName PackageName ->+  m ([Module], P.Env)+convertModulesInPackageWithEnv modules modulesDeps =   go modules   where-  localNames =-    map P.getModuleName (takeLocals modules)   go =-    map ignorePackage-     >>> convertModules withPackage-     >>> fmap (filter ((`elem` localNames) . modName))+     convertModulesWithEnv withPackage+     >>> fmap (first (filter (isLocal . modName)))    withPackage :: P.ModuleName -> InPackage P.ModuleName   withPackage mn =-    case find ((== mn) . P.getModuleName . ignorePackage) modules of-      Just m ->-        fmap P.getModuleName m-      Nothing ->-        P.internalError $ "withPackage: missing module:" ++-          show (P.runModuleName mn)+    case Map.lookup mn modulesDeps of+      Just pkgName -> FromDep pkgName mn+      Nothing -> Local mn +  isLocal :: P.ModuleName -> Bool+  isLocal = not . flip Map.member modulesDeps + -- | -- Convert a group of modules to the intermediate format, designed for--- producing documentation from. It is also necessary to pass an Env containing--- imports/exports information about the list of modules, which is needed for--- documenting re-exports.+-- producing documentation from. -- -- 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@@ -75,6 +78,14 @@   [P.Module] ->   m [Module] convertModules withPackage =+  fmap fst . convertModulesWithEnv withPackage++convertModulesWithEnv ::+  (MonadError P.MultipleErrors m) =>+  (P.ModuleName -> InPackage P.ModuleName) ->+  [P.Module] ->+  m ([Module], P.Env)+convertModulesWithEnv withPackage =   P.sortModules     >>> fmap (fst >>> map importPrim)     >=> convertSorted withPackage@@ -83,21 +94,22 @@ importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])  -- |--- Convert a sorted list of modules.+-- Convert a sorted list of modules, returning both the list of converted+-- modules and the Env produced during desugaring. -- convertSorted ::   (MonadError P.MultipleErrors m) =>   (P.ModuleName -> InPackage P.ModuleName) ->   [P.Module] ->-  m [Module]+  m ([Module], P.Env) convertSorted withPackage modules = do   (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules    modulesWithTypes <- typeCheckIfNecessary modules convertedModules-  let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)+  let moduleMap = Map.fromList (map (modName &&& identity) modulesWithTypes)    let traversalOrder = map P.getModuleName modules-  pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap))+  pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap), env)  -- | -- If any exported value declarations have either wildcard type signatures, or@@ -166,7 +178,7 @@     other    parseIdent =-    either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent+    either (err . ("failed to parse Ident: " ++)) identity . runParser P.parseIdent    lookupName name =     let key = P.Qualified (Just (modName m)) name

@@ -457,11 +457,8 @@   addConstraint constraint =     P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint] -splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)-splitMap = foldl go (Map.empty, Map.empty) . Map.toList-  where-  go (m1, m2) (k, (v1, v2)) =-    (Map.insert k v1 m1, Map.insert k v2 m2)+splitMap :: Map k (v1, v2) -> (Map k v1, Map k v2)+splitMap = fmap fst &&& fmap snd  -- | -- Given a list of exported constructor names, remove any data constructor

@@ -1,18 +1,11 @@ module Language.PureScript.Docs.Convert.Single   ( convertSingleModule-  , collectBookmarks   ) where -import Prelude.Compat+import Protolude  import Control.Category ((>>>))-import Control.Monad -import Data.Either-import Data.List (nub)-import Data.Maybe (mapMaybe, fromMaybe)-import Data.Monoid ((<>))-import Data.Text (Text) import qualified Data.Text as T  import Language.PureScript.Docs.Types@@ -67,7 +60,7 @@ -- the type synonym IntermediateDeclaration for more information. augmentDeclarations :: [IntermediateDeclaration] -> [Declaration] augmentDeclarations (partitionEithers -> (augments, toplevels)) =-  foldl go toplevels augments+  foldl' go toplevels augments   where   go ds (parentTitles, a) =     map (\d ->@@ -142,14 +135,14 @@   Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))   where   classNameString = unQual className-  typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)+  typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)   unQual x = let (P.Qualified _ y) = x in P.runProperName y    extractProperNames (P.TypeConstructor n) = [unQual n]   extractProperNames _ = []    childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)-  classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys+  classApp = foldl' P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title =   Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias))) convertDeclaration (P.TypeFixityDeclaration fixity (P.Qualified mn alias) _) title =@@ -190,15 +183,3 @@    dropPrefix prefix str =     fromMaybe str (T.stripPrefix prefix str)---- | Go through a PureScript module and extract a list of Bookmarks; references--- to data types or values, to be used as a kind of index. These are used for--- generating links in the HTML documentation, for example.-collectBookmarks :: InPackage P.Module -> [Bookmark]-collectBookmarks (Local m) = map Local (collectBookmarks' m)-collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)--collectBookmarks' :: P.Module -> [(P.ModuleName, Text)]-collectBookmarks' m =-  map (P.getModuleName m, )-      (mapMaybe getDeclarationTitle (P.exportedDeclarations m))

@@ -1,97 +0,0 @@-module Language.PureScript.Docs.ParseAndBookmark-  ( parseAndBookmark-  ) where--import Prelude.Compat--import Control.Arrow (first)-import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.IO.Class (MonadIO(..))--import qualified Data.Map as M-import Data.Text (Text)--import Language.PureScript.Docs.Convert (collectBookmarks)-import Language.PureScript.Docs.Types-import qualified Language.PureScript as P-import System.IO.UTF8 (readUTF8FileT)-import Web.Bower.PackageMeta (PackageName)---- |--- 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 ::-  (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) =>-  [(FileInfo, Text)]-  -> 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, Text)-parseFile input' = (,) input' <$> readUTF8FileT input'--parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, Text)-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

@@ -0,0 +1,73 @@+module Language.PureScript.Docs.ParseInPackage+  ( parseFilesInPackages+  ) where++import Protolude++import qualified Data.Map as M++import Language.PureScript.Docs.Types+import qualified Language.PureScript as P+import System.IO.UTF8 (readUTF8FileT)+import Web.Bower.PackageMeta (PackageName)++-- |+-- 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+--    * Return the parsed modules and a Map mapping module names to package+--      names for modules which come from dependencies. If a module does not+--      exist in the map, it can safely be assumed to be local.+parseFilesInPackages ::+  (MonadError P.MultipleErrors m, MonadIO m) =>+  [FilePath]+  -> [(PackageName, FilePath)]+  -> m ([P.Module], Map P.ModuleName PackageName)+parseFilesInPackages inputFiles depsFiles = do+  inputFiles' <- traverse (readFileAs . Local) inputFiles+  depsFiles'  <- traverse (readFileAs . uncurry FromDep) depsFiles++  modules <- parse (inputFiles' ++ depsFiles')++  let mnMap = M.fromList (mapMaybe (\(inpkg, m) -> (P.getModuleName m,) <$> inPkgToMaybe inpkg) modules)++  pure (map snd modules, mnMap)++  where+  parse ::+    (MonadError P.MultipleErrors m) =>+    [(FileInfo, Text)]+    -> m [(FileInfo, P.Module)]+  parse =+    throwLeft . P.parseModulesFromFiles fileInfoToString++  inPkgToMaybe = \case+    Local _ -> Nothing+    FromDep pkgName _ -> Just pkgName++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++readFileAs :: (MonadIO m) => FileInfo -> m (FileInfo, Text)+readFileAs fi = liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi)

@@ -24,6 +24,7 @@       , boolean       , partial       , fail+      , warn       , typeConcat       , typeString       , kindType@@ -220,6 +221,14 @@   [ "The Fail type class is part of the custom type errors feature. To provide"   , "a custom type error when someone tries to use a particular instance,"   , "write that instance out with a Fail constraint."+  , ""+  , "For more information, see"+  , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."+  ]++warn :: Declaration+warn = primClass "Warn" $ T.unlines+  [ "The Warn type class allows a custom compiler warning to be displayed."   , ""   , "For more information, see"   , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

@@ -28,7 +28,7 @@ renderDeclarationWithOptions opts Declaration{..} =   mintersperse sp $ case declInfo of     ValueDeclaration ty ->-      [ ident declTitle+      [ ident' declTitle       , syntax "::"       , renderType' ty       ]@@ -70,40 +70,25 @@              [idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ]            ]         where-          idents = mintersperse sp . map ident+          idents = mintersperse sp . map ident' -    AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->+    AliasDeclaration (P.Fixity associativity precedence) for ->       [ keywordFixity associativity       , syntax $ T.pack $ show precedence-      , ident $ renderQualAlias for-      , keyword "as"-      , ident $ adjustAliasName alias declTitle+      , alias for+      , keywordAs+      , aliasName for declTitle       ]      ExternKindDeclaration ->       [ keywordKind-      , renderKind (P.NamedKind (notQualified declTitle))+      , kind (notQualified declTitle)       ]    where   renderType' :: P.Type -> RenderedCode   renderType' = renderTypeWithOptions opts -  renderQualAlias :: FixityAlias -> Text-  renderQualAlias (P.Qualified mn alias)-    | mn == currentModule opts = renderAlias id alias-    | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias--  renderAlias-    :: (forall a. (a -> Text) -> a -> Text)-    -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))-    -> Text-  renderAlias f-    = either (("type " <>) . f P.runProperName)-    $ either (f P.runIdent) (f P.runProperName)--  adjustAliasName _ title = T.tail (T.init title)- renderChildDeclaration :: ChildDeclaration -> RenderedCode renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions @@ -113,18 +98,17 @@     ChildInstance constraints ty ->       maybeToList (renderConstraints constraints) ++ [ renderType' ty ]     ChildDataConstructor args ->-      [ renderType' typeApp' ]-      where-      typeApp' = foldl P.TypeApp ctor' args-      ctor' = P.TypeConstructor (notQualified cdeclTitle)+      [ dataCtor' cdeclTitle ]+      ++ map renderTypeAtom' args      ChildTypeClassMember ty ->-      [ ident cdeclTitle+      [ ident' cdeclTitle       , syntax "::"       , renderType' ty       ]   where   renderType' = renderTypeWithOptions opts+  renderTypeAtom' = renderTypeAtomWithOptions opts  renderConstraint :: P.Constraint -> RenderedCode renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions@@ -150,6 +134,12 @@  notQualified :: Text -> P.Qualified (P.ProperName a) notQualified = P.Qualified Nothing . P.ProperName++ident' :: Text -> RenderedCode+ident' = ident . P.Qualified Nothing . P.Ident++dataCtor' :: Text -> RenderedCode+dataCtor' = dataCtor . notQualified  typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type typeApp title typeArgs =

@@ -1,8 +1,9 @@-
--- | Data types and functions for representing a simplified form of PureScript
--- code, intended for use in e.g. HTML documentation.
-
-module Language.PureScript.Docs.RenderedCode (module RenderedCode) where
-
-import Language.PureScript.Docs.RenderedCode.Types as RenderedCode
-import Language.PureScript.Docs.RenderedCode.Render as RenderedCode
++-- | Data types and functions for representing a simplified form of PureScript+-- code, intended for use in e.g. HTML documentation.++module Language.PureScript.Docs.RenderedCode (module RenderedCode) where++import Language.PureScript.Docs.RenderedCode.Types as RenderedCode+import Language.PureScript.Docs.RenderedCode.RenderType as RenderedCode+import Language.PureScript.Docs.RenderedCode.RenderKind as RenderedCode

@@ -1,215 +0,0 @@--- | Functions for producing RenderedCode values from PureScript Type values.--module Language.PureScript.Docs.RenderedCode.Render-  ( renderType-  , renderTypeAtom-  , renderRow-  , renderKind-  , RenderTypeOptions(..)-  , defaultRenderTypeOptions-  , renderTypeWithOptions-  ) where--import Prelude.Compat--import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))-import Data.Text (Text)--import Control.Arrow ((<+>))-import Control.PatternArrows as PA--import Language.PureScript.Crash-import Language.PureScript.Docs.RenderedCode.Types-import Language.PureScript.Docs.Utils.MonoidExtras-import Language.PureScript.Environment-import Language.PureScript.Kinds-import Language.PureScript.Names-import Language.PureScript.Pretty.Kinds-import Language.PureScript.Pretty.Types-import Language.PureScript.Types-import Language.PureScript.Label (Label)--typeLiterals :: Pattern () Type RenderedCode-typeLiterals = mkPattern match-  where-  match TypeWildcard{} =-    Just (syntax "_")-  match (TypeVar var) =-    Just (ident var)-  match (PrettyPrintObject row) =-    Just $ mintersperse sp-              [ syntax "{"-              , renderRow row-              , syntax "}"-              ]-  match (TypeConstructor (Qualified mn name)) =-    Just (ctor (runProperName name) (maybeToContainingModule mn))-  match REmpty =-    Just (syntax "()")-  match row@RCons{} =-    Just (syntax "(" <> renderRow row <> syntax ")")-  match (BinaryNoParensType op l r) =-    Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r-  match (TypeOp (Qualified mn op)) =-    Just (ident' (runOpName op) (maybeToContainingModule mn))-  match _ =-    Nothing--renderConstraint :: Constraint -> RenderedCode-renderConstraint (Constraint pn tys _) =-  let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys-  in  renderType instApp--renderConstraints :: [Constraint] -> RenderedCode -> RenderedCode-renderConstraints deps ty =-  mintersperse sp-    [ if length deps == 1-         then constraints-         else syntax "(" <> constraints <> syntax ")"-    , syntax "=>"-    , ty-    ]-  where-    constraints = mintersperse (syntax "," <> sp) (map renderConstraint deps)---- |--- Render code representing a Row----renderRow :: Type -> RenderedCode-renderRow = uncurry renderRow' . rowToList-  where-  renderRow' h t = renderHead h <> renderTail t--renderHead :: [(Label, Type)] -> RenderedCode-renderHead = mintersperse (syntax "," <> sp) . map renderLabel--renderLabel :: (Label, Type) -> RenderedCode-renderLabel (label, ty) =-  mintersperse sp-    [ syntax $ prettyPrintLabel label-    , syntax "::"-    , renderType ty-    ]--renderTail :: Type -> RenderedCode-renderTail REmpty = mempty-renderTail other = sp <> syntax "|" <> sp <> renderType other--typeApp :: Pattern () Type (Type, Type)-typeApp = mkPattern match-  where-  match (TypeApp f x) = Just (f, x)-  match _ = Nothing--appliedFunction :: Pattern () Type (Type, Type)-appliedFunction = mkPattern match-  where-  match (PrettyPrintFunction arg ret) = Just (arg, ret)-  match _ = Nothing--kinded :: Pattern () Type (Kind, Type)-kinded = mkPattern match-  where-  match (KindedType t k) = Just (k, t)-  match _ = Nothing--constrained :: Pattern () Type ([Constraint], Type)-constrained = mkPattern match-  where-  match (ConstrainedType deps ty) = Just (deps, ty)-  match _ = Nothing--explicitParens :: Pattern () Type ((), Type)-explicitParens = mkPattern match-  where-  match (ParensInType ty) = Just ((), ty)-  match _ = Nothing--matchTypeAtom :: Pattern () Type RenderedCode-matchTypeAtom = typeLiterals <+> fmap parens_ matchType-  where-  parens_ x = syntax "(" <> x <> syntax ")"--matchType :: Pattern () Type RenderedCode-matchType = buildPrettyPrinter operators matchTypeAtom-  where-  operators :: OperatorTable () Type RenderedCode-  operators =-    OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]-                  , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]-                  , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ]-                  , [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ]-                  , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]-                  , [ Wrap explicitParens $ \_ ty -> ty ]-                  ]--forall_ :: Pattern () Type ([Text], Type)-forall_ = mkPattern match-  where-  match (PrettyPrintForAll idents ty) = Just (idents, ty)-  match _ = Nothing--insertPlaceholders :: RenderTypeOptions -> Type -> Type-insertPlaceholders opts =-  everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts)--dePrim :: Type -> Type-dePrim ty@(TypeConstructor (Qualified _ name))-  | ty == tyBoolean || ty == tyNumber || ty == tyString =-    TypeConstructor $ Qualified Nothing name-dePrim other = other--convert :: RenderTypeOptions -> Type -> Type-convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret-convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r-convert _ other = other--convertForAlls :: Type -> Type-convertForAlls (ForAll i ty _) = go [i] ty-  where-  go idents (ForAll i' ty' _) = go (i' : idents) ty'-  go idents other = PrettyPrintForAll idents other-convertForAlls other = other--preprocessType :: RenderTypeOptions -> Type -> Type-preprocessType opts = dePrim . insertPlaceholders opts---- |--- Render code representing a Kind----renderKind :: Kind -> RenderedCode-renderKind = kind . prettyPrintKind---- |--- Render code representing a Type, as it should appear inside parentheses----renderTypeAtom :: Type -> RenderedCode-renderTypeAtom-  = fromMaybe (internalError "Incomplete pattern")-  . PA.pattern matchTypeAtom ()-  . preprocessType defaultRenderTypeOptions---- |--- Render code representing a Type----renderType :: Type -> RenderedCode-renderType = renderTypeWithOptions defaultRenderTypeOptions--data RenderTypeOptions = RenderTypeOptions-  { prettyPrintObjects :: Bool-  , currentModule :: Maybe ModuleName-  }--defaultRenderTypeOptions :: RenderTypeOptions-defaultRenderTypeOptions =-  RenderTypeOptions-    { prettyPrintObjects = True-    , currentModule = Nothing-    }--renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode-renderTypeWithOptions opts-  = fromMaybe (internalError "Incomplete pattern")-  . PA.pattern matchType ()-  . preprocessType opts

@@ -0,0 +1,57 @@+-- | Functions for producing RenderedCode values from PureScript Kind values.+--+module Language.PureScript.Docs.RenderedCode.RenderKind+  ( renderKind+  ) where++-- TODO: This is pretty much copied from Language.PureScript.Pretty.Kinds.+-- Ideally we would unify the two.++import Prelude.Compat++import Control.Arrow (ArrowPlus(..))+import Control.PatternArrows as PA++import Data.Monoid ((<>))+import Data.Maybe (fromMaybe)+import qualified Data.Text as T++import Language.PureScript.Crash+import Language.PureScript.Kinds++import Language.PureScript.Docs.RenderedCode.Types++typeLiterals :: Pattern () Kind RenderedCode+typeLiterals = mkPattern match+  where+  match (KUnknown u) =+    Just $ typeVar $ T.cons 'k' (T.pack (show u))+  match (NamedKind n) =+    Just $ kind n+  match _ = Nothing++matchRow :: Pattern () Kind ((), Kind)+matchRow = mkPattern match+  where+  match (Row k) = Just ((), k)+  match _ = Nothing++funKind :: Pattern () Kind (Kind, Kind)+funKind = mkPattern match+  where+  match (FunKind arg ret) = Just (arg, ret)+  match _ = Nothing++-- | Generate RenderedCode value representing a Kind+renderKind :: Kind -> RenderedCode+renderKind+  = fromMaybe (internalError "Incomplete pattern")+  . PA.pattern matchKind ()+  where+  matchKind :: Pattern () Kind RenderedCode+  matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)++  operators :: OperatorTable () Kind RenderedCode+  operators =+    OperatorTable [ [ Wrap matchRow $ \_ k -> syntax "#" <> sp <> k]+                  , [ AssocR funKind $ \arg ret -> arg <> sp <> syntax "->" <> sp <> ret ] ]

@@ -0,0 +1,208 @@+-- | Functions for producing RenderedCode values from PureScript Type values.++module Language.PureScript.Docs.RenderedCode.RenderType+  ( renderType+  , renderTypeAtom+  , renderRow+  , RenderTypeOptions(..)+  , defaultRenderTypeOptions+  , renderTypeWithOptions+  , renderTypeAtomWithOptions+  ) where++import Prelude.Compat++import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)++import Control.Arrow ((<+>))+import Control.PatternArrows as PA++import Language.PureScript.Crash+import Language.PureScript.Environment+import Language.PureScript.Kinds+import Language.PureScript.Names+import Language.PureScript.Pretty.Types+import Language.PureScript.Types+import Language.PureScript.Label (Label)++import Language.PureScript.Docs.RenderedCode.Types+import Language.PureScript.Docs.Utils.MonoidExtras+import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind)++typeLiterals :: Pattern () Type RenderedCode+typeLiterals = mkPattern match+  where+  match TypeWildcard{} =+    Just (syntax "_")+  match (TypeVar var) =+    Just (typeVar var)+  match (PrettyPrintObject row) =+    Just $ mintersperse sp+              [ syntax "{"+              , renderRow row+              , syntax "}"+              ]+  match (TypeConstructor n) =+    Just (typeCtor n)+  match REmpty =+    Just (syntax "()")+  match row@RCons{} =+    Just (syntax "(" <> renderRow row <> syntax ")")+  match (BinaryNoParensType op l r) =+    Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r+  match (TypeOp n) =+    Just (typeOp n)+  match _ =+    Nothing++renderConstraint :: Constraint -> RenderedCode+renderConstraint (Constraint pn tys _) =+  let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys+  in  renderType instApp++renderConstraints :: [Constraint] -> RenderedCode -> RenderedCode+renderConstraints deps ty =+  mintersperse sp+    [ if length deps == 1+         then constraints+         else syntax "(" <> constraints <> syntax ")"+    , syntax "=>"+    , ty+    ]+  where+    constraints = mintersperse (syntax "," <> sp) (map renderConstraint deps)++-- |+-- Render code representing a Row+--+renderRow :: Type -> RenderedCode+renderRow = uncurry renderRow' . rowToList+  where+  renderRow' h t = renderHead h <> renderTail t++renderHead :: [(Label, Type)] -> RenderedCode+renderHead = mintersperse (syntax "," <> sp) . map renderLabel++renderLabel :: (Label, Type) -> RenderedCode+renderLabel (label, ty) =+  mintersperse sp+    [ typeVar $ prettyPrintLabel label+    , syntax "::"+    , renderType ty+    ]++renderTail :: Type -> RenderedCode+renderTail REmpty = mempty+renderTail other = sp <> syntax "|" <> sp <> renderType other++typeApp :: Pattern () Type (Type, Type)+typeApp = mkPattern match+  where+  match (TypeApp f x) = Just (f, x)+  match _ = Nothing++appliedFunction :: Pattern () Type (Type, Type)+appliedFunction = mkPattern match+  where+  match (PrettyPrintFunction arg ret) = Just (arg, ret)+  match _ = Nothing++kinded :: Pattern () Type (Kind, Type)+kinded = mkPattern match+  where+  match (KindedType t k) = Just (k, t)+  match _ = Nothing++constrained :: Pattern () Type ([Constraint], Type)+constrained = mkPattern match+  where+  match (ConstrainedType deps ty) = Just (deps, ty)+  match _ = Nothing++explicitParens :: Pattern () Type ((), Type)+explicitParens = mkPattern match+  where+  match (ParensInType ty) = Just ((), ty)+  match _ = Nothing++matchTypeAtom :: Pattern () Type RenderedCode+matchTypeAtom = typeLiterals <+> fmap parens_ matchType+  where+  parens_ x = syntax "(" <> x <> syntax ")"++matchType :: Pattern () Type RenderedCode+matchType = buildPrettyPrinter operators matchTypeAtom+  where+  operators :: OperatorTable () Type RenderedCode+  operators =+    OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]+                  , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]+                  , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ]+                  , [ Wrap forall_ $ \tyVars ty -> mconcat [keywordForall, sp, mintersperse sp (map typeVar tyVars), syntax ".", sp, ty] ]+                  , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]+                  , [ Wrap explicitParens $ \_ ty -> ty ]+                  ]++forall_ :: Pattern () Type ([Text], Type)+forall_ = mkPattern match+  where+  match (PrettyPrintForAll idents ty) = Just (idents, ty)+  match _ = Nothing++insertPlaceholders :: RenderTypeOptions -> Type -> Type+insertPlaceholders opts =+  everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts)++convert :: RenderTypeOptions -> Type -> Type+convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret+convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r+convert _ other = other++convertForAlls :: Type -> Type+convertForAlls (ForAll i ty _) = go [i] ty+  where+  go idents (ForAll i' ty' _) = go (i' : idents) ty'+  go idents other = PrettyPrintForAll idents other+convertForAlls other = other++preprocessType :: RenderTypeOptions -> Type -> Type+preprocessType opts = insertPlaceholders opts+++-- |+-- Render code representing a Type+--+renderType :: Type -> RenderedCode+renderType = renderTypeWithOptions defaultRenderTypeOptions++-- |+-- Render code representing a Type, as it should appear inside parentheses+--+renderTypeAtom :: Type -> RenderedCode+renderTypeAtom = renderTypeAtomWithOptions defaultRenderTypeOptions++data RenderTypeOptions = RenderTypeOptions+  { prettyPrintObjects :: Bool+  , currentModule :: Maybe ModuleName+  }++defaultRenderTypeOptions :: RenderTypeOptions+defaultRenderTypeOptions =+  RenderTypeOptions+    { prettyPrintObjects = True+    , currentModule = Nothing+    }++renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode+renderTypeWithOptions opts+  = fromMaybe (internalError "Incomplete pattern")+  . PA.pattern matchType ()+  . preprocessType opts++renderTypeAtomWithOptions :: RenderTypeOptions -> Type -> RenderedCode+renderTypeAtomWithOptions opts+  = fromMaybe (internalError "Incomplete pattern")+  . PA.pattern matchTypeAtom ()+  . preprocessType opts

@@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric #-}  -- | Data types and functions for representing a simplified form of PureScript -- code, intended for use in e.g. HTML documentation.@@ -11,15 +12,16 @@  , containingModuleToMaybe  , maybeToContainingModule  , fromContainingModule+ , fromQualified+ , Namespace(..)+ , Link(..)+ , FixityAlias  , RenderedCode  , asRenderedCode  , outputWith  , sp+ , parens  , syntax- , ident- , ident'- , ctor- , kind  , keyword  , keywordForall  , keywordData@@ -30,106 +32,217 @@  , keywordWhere  , keywordFixity  , keywordKind+ , keywordAs+ , ident+ , dataCtor+ , typeCtor+ , typeOp+ , typeVar+ , kind+ , alias+ , aliasName  ) where  import Prelude.Compat+import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) -import Data.Aeson.BetterErrors+import Data.Monoid ((<>))+import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText, eachInArray) import qualified Data.Aeson as A import Data.Text (Text)--import qualified Language.PureScript as P+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BS+import qualified Data.Text.Encoding as TE --- |--- A single element in a rendered code fragment. The intention is to support--- multiple output formats. For example, plain text, or highlighted HTML.----data RenderedCodeElement-  = Syntax Text-  | Ident Text ContainingModule-  | Ctor Text ContainingModule-  | Kind Text-  | Keyword Text-  | Space-  deriving (Show, Eq, Ord)+import Language.PureScript.Names+import Language.PureScript.AST (Associativity(..))+import Language.PureScript.Crash (internalError) -instance A.ToJSON RenderedCodeElement where-  toJSON (Syntax str) =-    A.toJSON ["syntax", str]-  toJSON (Ident str mn) =-    A.toJSON ["ident", A.toJSON str, A.toJSON mn]-  toJSON (Ctor str mn) =-    A.toJSON ["ctor", A.toJSON str, A.toJSON mn ]-  toJSON (Kind str) =-    A.toJSON ["kind", str]-  toJSON (Keyword str) =-    A.toJSON ["keyword", str]-  toJSON Space =-    A.toJSON ["space" :: Text]+-- | Given a list of actions, attempt them all, returning the first success.+-- If all the actions fail, 'tryAll' returns the first argument.+tryAll :: MonadError e m => m a -> [m a] -> m a+tryAll = foldr $ \x y -> catchError x (const y) -asRenderedCodeElement :: Parse Text RenderedCodeElement-asRenderedCodeElement =-  a Syntax "syntax" <|>-  asIdent <|>-  asCtor <|>-  a Kind "kind" <|>-  a Keyword "keyword" <|>-  asSpace <|>-  unableToParse+firstEq :: Text -> Parse Text a -> Parse Text a+firstEq str p = nth 0 (withText (eq str)) *> p   where-  p <|> q = catchError p (const q)+  eq s s' = if s == s' then Right () else Left "" -  a ctor' ctorStr = ctor' <$> (nth 0 (withText (eq ctorStr)) *> nth 1 asText)-  asIdent = nth 0 (withText (eq "ident")) *> (Ident <$> nth 1 asText <*> nth 2 asContainingModule)-  asCtor = nth 0 (withText (eq "ctor")) *> (Ctor <$> nth 1 asText <*> nth 2 asContainingModule)-  asSpace = nth 0 (withText (eq "space")) *> pure Space+-- |+-- Try the given parsers in sequence. If all fail, fail with the given message,+-- and include the JSON in the error.+--+tryParse :: Text -> [Parse Text a] -> Parse Text a+tryParse msg =+  tryAll (withValue (Left . (fullMsg <>) . showJSON)) -  eq s s' = if s == s' then Right () else Left ""+  where+  fullMsg = "Invalid " <> msg <> ": " -  unableToParse = withText Left+  showJSON :: A.Value -> Text+  showJSON = TE.decodeUtf8 . BS.toStrict . A.encode  -- |--- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier--- to read, as the meaning is more explicit.+-- This type is isomorphic to 'Maybe' 'ModuleName'. It makes code a bit+-- easier to read, as the meaning is more explicit. -- data ContainingModule   = ThisModule-  | OtherModule P.ModuleName+  | OtherModule ModuleName   deriving (Show, Eq, Ord)  instance A.ToJSON ContainingModule where-  toJSON mn = A.toJSON (P.runModuleName <$> containingModuleToMaybe mn)+  toJSON = A.toJSON . go+    where+    go = \case+      ThisModule -> ["ThisModule"]+      OtherModule mn -> ["OtherModule", runModuleName mn] -asContainingModule :: Parse e ContainingModule+instance A.FromJSON ContainingModule where+  parseJSON = toAesonParser id asContainingModule++asContainingModule :: Parse Text ContainingModule asContainingModule =-  maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText)+  tryParse "containing module" $+    current ++ backwardsCompat+  where+  current =+    [ firstEq "ThisModule" (pure ThisModule)+    , firstEq "OtherModule" (OtherModule <$> nth 1 asModuleName)+    ] +  -- For JSON produced by compilers up to 0.10.5.+  backwardsCompat =+    [ maybeToContainingModule <$> perhaps asModuleName+    ]++  asModuleName = moduleNameFromString <$> asText+ -- |--- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious+-- Convert a 'Maybe' 'ModuleName' to a 'ContainingModule', using the obvious -- isomorphism. ---maybeToContainingModule :: Maybe P.ModuleName -> ContainingModule+maybeToContainingModule :: Maybe ModuleName -> ContainingModule maybeToContainingModule Nothing = ThisModule maybeToContainingModule (Just mn) = OtherModule mn  -- |--- Convert a 'ContainingModule' to a 'Maybe' 'P.ModuleName', using the obvious+-- Convert a 'ContainingModule' to a 'Maybe' 'ModuleName', using the obvious -- isomorphism. ---containingModuleToMaybe :: ContainingModule -> Maybe P.ModuleName+containingModuleToMaybe :: ContainingModule -> Maybe ModuleName containingModuleToMaybe ThisModule = Nothing containingModuleToMaybe (OtherModule mn) = Just mn  -- | -- A version of 'fromMaybe' for 'ContainingModule' values. ---fromContainingModule :: P.ModuleName -> ContainingModule -> P.ModuleName+fromContainingModule :: ModuleName -> ContainingModule -> ModuleName fromContainingModule def ThisModule = def fromContainingModule _ (OtherModule mn) = mn +fromQualified :: Qualified a -> (ContainingModule, a)+fromQualified (Qualified mn x) =+  (maybeToContainingModule mn, x)++data Link+  = NoLink+  | Link ContainingModule+  deriving (Show, Eq, Ord)++instance A.ToJSON Link where+  toJSON = \case+    NoLink -> A.toJSON ["NoLink" :: Text]+    Link mn -> A.toJSON ["Link", A.toJSON mn]++asLink :: Parse Text Link+asLink =+  tryParse "link"+    [ firstEq "NoLink" (pure NoLink)+    , firstEq "Link" (Link <$> nth 1 asContainingModule)+    ]++instance A.FromJSON Link where+  parseJSON = toAesonParser id asLink++data Namespace+  = ValueLevel+  | TypeLevel+  | KindLevel+  deriving (Show, Eq, Ord, Generic)++instance NFData Namespace++instance A.ToJSON Namespace where+  toJSON = A.toJSON . show++asNamespace :: Parse Text Namespace+asNamespace =+  tryParse "namespace"+    [ withText $ \case+        "ValueLevel" -> Right ValueLevel+        "TypeLevel" -> Right TypeLevel+        "KindLevel" -> Right KindLevel+        _ -> Left ""+    ]++instance A.FromJSON Namespace where+  parseJSON = toAesonParser id asNamespace+ -- |+-- A single element in a rendered code fragment. The intention is to support+-- multiple output formats. For example, plain text, or highlighted HTML.+--+data RenderedCodeElement+  = Syntax Text+  | Keyword Text+  | Space+  -- | Any symbol which you might or might not want to link to, in any+  -- namespace (value, type, or kind). Note that this is not related to the+  -- kind called Symbol for type-level strings.+  | Symbol Namespace Text Link+  deriving (Show, Eq, Ord)++instance A.ToJSON RenderedCodeElement where+  toJSON (Syntax str) =+    A.toJSON ["syntax", str]+  toJSON (Keyword str) =+    A.toJSON ["keyword", str]+  toJSON Space =+    A.toJSON ["space" :: Text]+  toJSON (Symbol ns str link) =+    A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link]++asRenderedCodeElement :: Parse Text RenderedCodeElement+asRenderedCodeElement =+  tryParse "RenderedCodeElement" $+    [ a Syntax "syntax"+    , a Keyword "keyword"+    , asSpace+    , asSymbol+    ] ++ backwardsCompat+  where+  a ctor' ctorStr = firstEq ctorStr (ctor' <$> nth 1 asText)+  asSymbol = firstEq "symbol" (Symbol <$> nth 1 asNamespace <*> nth 2 asText <*> nth 3 asLink)+  asSpace = firstEq "space" (pure Space)++  -- These will make some mistakes e.g. treating data constructors as types,+  -- because the old code did not save information which is necessary to+  -- distinguish these cases. This is the best we can do.+  backwardsCompat =+    [ oldAsIdent+    , oldAsCtor+    , oldAsKind+    ]++  oldAsIdent = firstEq "ident" (Symbol ValueLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule))+  oldAsCtor = firstEq "ctor" (Symbol TypeLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule))+  oldAsKind = firstEq "kind" (Symbol KindLevel <$> nth 1 asText <*> pure (Link ThisModule))++-- | -- A type representing a highly simplified version of PureScript code, intended -- for use in output formats like plain text or HTML. --@@ -158,21 +271,17 @@ sp :: RenderedCode sp = RC [Space] +-- |+-- Wrap a RenderedCode value in parens.+parens :: RenderedCode -> RenderedCode+parens x = syntax "(" <> x <> syntax ")"++-- possible TODO: instead of this function, export RenderedCode values for+-- each syntax element, eg syntaxArr (== syntax "->"), syntaxLBrace,+-- syntaxRBrace, etc. syntax :: Text -> RenderedCode syntax x = RC [Syntax x] -ident :: Text -> RenderedCode-ident x = RC [Ident x ThisModule]--ident' :: Text -> ContainingModule -> RenderedCode-ident' x m = RC [Ident x m]--ctor :: Text -> ContainingModule -> RenderedCode-ctor x m = RC [Ctor x m]--kind :: Text -> RenderedCode-kind x = RC [Kind x]- keyword :: Text -> RenderedCode keyword kw = RC [Keyword kw] @@ -197,10 +306,78 @@ keywordWhere :: RenderedCode keywordWhere = keyword "where" -keywordFixity :: P.Associativity -> RenderedCode-keywordFixity P.Infixl = keyword "infixl"-keywordFixity P.Infixr = keyword "infixr"-keywordFixity P.Infix = keyword "infix"+keywordFixity :: Associativity -> RenderedCode+keywordFixity Infixl = keyword "infixl"+keywordFixity Infixr = keyword "infixr"+keywordFixity Infix = keyword "infix"  keywordKind :: RenderedCode keywordKind = keyword "kind"++keywordAs :: RenderedCode+keywordAs = keyword "as"++ident :: Qualified Ident -> RenderedCode+ident (fromQualified -> (mn, name)) =+  RC [Symbol ValueLevel (runIdent name) (Link mn)]++dataCtor :: Qualified (ProperName 'ConstructorName) -> RenderedCode+dataCtor (fromQualified -> (mn, name)) =+  RC [Symbol ValueLevel (runProperName name) (Link mn)]++typeCtor :: Qualified (ProperName 'TypeName) -> RenderedCode+typeCtor (fromQualified -> (mn, name)) =+  RC [Symbol TypeLevel (runProperName name) (Link mn)]++typeOp :: Qualified (OpName 'TypeOpName) -> RenderedCode+typeOp (fromQualified -> (mn, name)) =+  RC [Symbol TypeLevel (runOpName name) (Link mn)]++typeVar :: Text -> RenderedCode+typeVar x = RC [Symbol TypeLevel x NoLink]++kind :: Qualified (ProperName 'KindName) -> RenderedCode+kind (fromQualified -> (mn, name)) =+  RC [Symbol KindLevel (runProperName name) (Link mn)]++type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName)))++alias :: FixityAlias -> RenderedCode+alias for =+  prefix <> RC [Symbol ns name (Link mn)]+  where+  (ns, name, mn) = unpackFixityAlias for+  prefix = case ns of+    TypeLevel ->+      keywordType <> sp+    _ ->+      mempty++aliasName :: FixityAlias -> Text -> RenderedCode+aliasName for name' =+  let+    (ns, _, _) = unpackFixityAlias for+    unParen = T.tail . T.init+    name = unParen name'+  in+    case ns of+      ValueLevel ->+        ident (Qualified Nothing (Ident name))+      TypeLevel ->+        typeCtor (Qualified Nothing (ProperName name))+      KindLevel ->+        internalError "Kind aliases are not supported"++-- | Converts a FixityAlias into a different representation which is more+-- useful to other functions in this module.+unpackFixityAlias :: FixityAlias -> (Namespace, Text, ContainingModule)+unpackFixityAlias (fromQualified -> (mn, x)) =+  case x of+    -- We add some seemingly superfluous type signatures here just to be extra+    -- sure we are not mixing up our namespaces.+    Left (n :: ProperName 'TypeName) ->+      (TypeLevel, runProperName n, mn)+    Right (Left n) ->+      (ValueLevel, runIdent n, mn)+    Right (Right (n :: ProperName 'ConstructorName)) ->+      (ValueLevel, runProperName n, mn)

@@ -4,23 +4,24 @@   )   where -import Prelude.Compat+import Protolude hiding (to, from)+import Prelude (String, unlines, lookup) -import Control.Arrow (first, (***))-import Control.Monad (when)-import Control.Monad.Error.Class (catchError)+import Control.Arrow ((***)) -import Data.Monoid ((<>)) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors-import Data.ByteString.Lazy (ByteString)-import Data.Either (isLeft, isRight)-import Data.Maybe (mapMaybe, fromMaybe)-import Data.Text (Text)+  (Parse, ParseError, parse, keyOrDefault, throwCustomError, key, asText,+   keyMay, withString, eachInArray, asNull, (.!), toAesonParser, toAesonParser',+   fromAesonParser, perhaps, withText, asIntegral, nth, eachInObjectWithKey,+   asString)+import qualified Data.Map as Map+import Data.Time.Clock (UTCTime)+import qualified Data.Time.Format as TimeFormat import Data.Version-import qualified Data.Vector as V import qualified Data.Aeson as A import qualified Data.Text as T+import qualified Data.Vector as V  import qualified Language.PureScript as P @@ -31,7 +32,8 @@ import Language.PureScript.Docs.RenderedCode as ReExports   (RenderedCode, asRenderedCode,    ContainingModule(..), asContainingModule,-   RenderedCodeElement(..), asRenderedCodeElement)+   RenderedCodeElement(..), asRenderedCodeElement,+   Namespace(..), FixityAlias)  -------------------- -- Types@@ -40,8 +42,12 @@   { pkgMeta                 :: PackageMeta   , pkgVersion              :: Version   , pkgVersionTag           :: Text+  -- TODO: When this field was introduced, it was given the Maybe type for the+  -- sake of backwards compatibility, as older JSON blobs will not include the+  -- field. It should eventually be changed to just UTCTime.+  , pkgTagTime              :: Maybe UTCTime   , pkgModules              :: [Module]-  , pkgBookmarks            :: [Bookmark]+  , pkgModuleMap            :: Map P.ModuleName PackageName   , pkgResolvedDependencies :: [(PackageName, Version)]   , pkgGithub               :: (GithubUser, GithubRepo)   , pkgUploader             :: a@@ -62,8 +68,9 @@   Package pkgMeta           pkgVersion           pkgVersionTag+          pkgTagTime           pkgModules-          pkgBookmarks+          pkgModuleMap           pkgResolvedDependencies           pkgGithub           verifiedUser@@ -72,6 +79,29 @@ packageName :: Package a -> PackageName packageName = bowerName . pkgMeta +-- |+-- The time format used for serializing package tag times in the JSON format.+-- This is the ISO 8601 date format which includes a time and a timezone.+--+jsonTimeFormat :: String+jsonTimeFormat = "%Y-%m-%dT%H:%M:%S%z"++-- |+-- Convenience function for formatting a time in the format expected by this+-- module.+--+formatTime :: UTCTime -> String+formatTime =+  TimeFormat.formatTime TimeFormat.defaultTimeLocale jsonTimeFormat++-- |+-- Convenience function for parsing a time in the format expected by this+-- module.+--+parseTime :: String -> Maybe UTCTime+parseTime =+  TimeFormat.parseTimeM False TimeFormat.defaultTimeLocale jsonTimeFormat+ data Module = Module   { modName         :: P.ModuleName   , modComments     :: Maybe Text@@ -158,8 +188,6 @@       ) $ argsVec V.!? i   toArgs from to = (map getArg from, map getArg to) -type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName)))- declInfoToString :: DeclarationInfo -> Text declInfoToString (ValueDeclaration _) = "value" declInfoToString (DataDeclaration _ _) = "data"@@ -169,6 +197,23 @@ declInfoToString (AliasDeclaration _ _) = "alias" declInfoToString ExternKindDeclaration = "kind" +declInfoNamespace :: DeclarationInfo -> Namespace+declInfoNamespace = \case+  ValueDeclaration{} ->+    ValueLevel+  DataDeclaration{} ->+    TypeLevel+  ExternDataDeclaration{} ->+    TypeLevel+  TypeSynonymDeclaration{} ->+    TypeLevel+  TypeClassDeclaration{} ->+    TypeLevel+  AliasDeclaration _ alias ->+    either (const TypeLevel) (const ValueLevel) (P.disqualify alias)+  ExternKindDeclaration{} ->+    KindLevel+ isTypeClass :: Declaration -> Bool isTypeClass Declaration{..} =   case declInfo of@@ -244,6 +289,20 @@ childDeclInfoToString (ChildDataConstructor _) = "dataConstructor" childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember" +childDeclInfoNamespace :: ChildDeclarationInfo -> Namespace+childDeclInfoNamespace =+  -- We could just write this as `const ValueLevel` but by doing it this way,+  -- if another constructor is added, we get a warning which acts as a prompt+  -- to update this, instead of having this function (possibly incorrectly)+  -- just return ValueLevel for the new constructor.+  \case+    ChildInstance{} ->+      ValueLevel+    ChildDataConstructor{} ->+      ValueLevel+    ChildTypeClassMember{} ->+      ValueLevel+ isTypeClassMember :: ChildDeclaration -> Bool isTypeClassMember ChildDeclaration{..} =   case cdeclInfo of@@ -275,10 +334,9 @@   | InvalidFixity   | InvalidKind Text   | InvalidDataDeclType Text+  | InvalidTime   deriving (Show, Eq, Ord) -type Bookmark = InPackage (P.ModuleName, Text)- data InPackage a   = Local a   | FromDep PackageName a@@ -299,13 +357,96 @@ ignorePackage (Local x) = x ignorePackage (FromDep _ x) = x +----------------------------------------------------+-- Types for links between declarations++data LinksContext = LinksContext+  { ctxGithub               :: (GithubUser, GithubRepo)+  , ctxModuleMap            :: Map P.ModuleName PackageName+  , ctxResolvedDependencies :: [(PackageName, Version)]+  , ctxPackageName          :: PackageName+  , ctxVersion              :: Version+  , ctxVersionTag           :: Text+  }+  deriving (Show, Eq, Ord)++data DocLink = DocLink+  { linkLocation  :: LinkLocation+  , linkTitle     :: Text+  , linkNamespace :: Namespace+  }+  deriving (Show, Eq, Ord)++data LinkLocation+  -- | A link to a declaration in the same module.+  = SameModule++  -- | A link to a declaration in a different module, but still in the current+  -- package; we need to store the current module and the other declaration's+  -- module.+  | LocalModule P.ModuleName P.ModuleName++  -- | A link to a declaration in a different package. We store: current module+  -- name, name of the other package, version of the other package, and name of+  -- the module in the other package that the declaration is in.+  | DepsModule P.ModuleName PackageName Version P.ModuleName++  -- | A link to a declaration that is built in to the compiler, e.g. the Prim+  -- module. In this case we only need to store the module that the builtin+  -- comes from (at the time of writing, this will only ever be "Prim").+  | BuiltinModule P.ModuleName+  deriving (Show, Eq, Ord)++-- | Given a links context, a thing to link to (either a value or a type), and+-- its containing module, attempt to create a DocLink.+getLink :: LinksContext -> P.ModuleName -> Namespace -> Text -> ContainingModule -> Maybe DocLink+getLink LinksContext{..} curMn namespace target containingMod = do+  location <- getLinkLocation+  return DocLink+    { linkLocation = location+    , linkTitle = target+    , linkNamespace = namespace+    }++  where+  getLinkLocation = normalLinkLocation <|> builtinLinkLocation++  normalLinkLocation = do+    case containingMod of+      ThisModule ->+        return SameModule+      OtherModule destMn ->+        case Map.lookup destMn ctxModuleMap of+          Nothing ->+            return $ LocalModule curMn destMn+          Just pkgName -> do+            pkgVersion <- lookup pkgName ctxResolvedDependencies+            return $ DepsModule curMn pkgName pkgVersion destMn++  builtinLinkLocation = do+    let primMn = P.moduleNameFromString "Prim"+    guard $ containingMod == OtherModule primMn+    -- TODO: ensure the declaration exists in the builtin module too+    return $ BuiltinModule primMn++getLinksContext :: Package a -> LinksContext+getLinksContext Package{..} =+  LinksContext+    { ctxGithub               = pkgGithub+    , ctxModuleMap            = pkgModuleMap+    , ctxResolvedDependencies = pkgResolvedDependencies+    , ctxPackageName          = bowerName pkgMeta+    , ctxVersion              = pkgVersion+    , ctxVersionTag           = pkgVersionTag+    }+ ---------------------- -- Parsing -parseUploadedPackage :: Version -> ByteString -> Either (ParseError PackageError) UploadedPackage+parseUploadedPackage :: Version -> LByteString -> Either (ParseError PackageError) UploadedPackage parseUploadedPackage minVersion = parse $ asUploadedPackage minVersion -parseVerifiedPackage :: Version -> ByteString -> Either (ParseError PackageError) VerifiedPackage+parseVerifiedPackage :: Version -> LByteString -> Either (ParseError PackageError) VerifiedPackage parseVerifiedPackage minVersion = parse $ asVerifiedPackage minVersion  asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a)@@ -320,13 +461,22 @@   Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta           <*> key "version" asVersion           <*> key "versionTag" asText+          <*> keyMay "tagTime" (withString parseTimeEither)           <*> key "modules" (eachInArray asModule)-          <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta+          <*> moduleMap           <*> key "resolvedDependencies" asResolvedDependencies           <*> key "github" asGithub           <*> key "uploader" uploader           <*> pure compilerVersion+  where+  moduleMap =+    key "moduleMap" asModuleMap+    `pOr` (key "bookmarks" bookmarksAsModuleMap .! ErrorInPackageMeta) +parseTimeEither :: String -> Either PackageError UTCTime+parseTimeEither =+  maybe (Left InvalidTime) Right . parseTime+ asUploadedPackage :: Version -> Parse PackageError UploadedPackage asUploadedPackage minVersion = asPackage minVersion asNotYetKnown @@ -359,6 +509,8 @@     "Invalid kind: \"" <> str <> "\""   InvalidDataDeclType str ->     "Invalid data declaration type: \"" <> str <> "\""+  InvalidTime ->+    "Invalid time"  instance A.FromJSON a => A.FromJSON (Package a) where   parseJSON = toAesonParser displayPackageError@@ -406,9 +558,10 @@   asReExportModuleName :: Parse PackageError (InPackage P.ModuleName)   asReExportModuleName =     asInPackage fromAesonParser .! ErrorInPackageMeta-    <|> fmap Local fromAesonParser+    `pOr` fmap Local fromAesonParser -  (<|>) p q = catchError p (const q)+pOr :: Parse e a -> Parse e a -> Parse e a+p `pOr` q = catchError p (const q)  asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a) asInPackage inner =@@ -521,21 +674,39 @@ asQualifiedIdent :: Parse e (P.Qualified P.Ident) asQualifiedIdent = fromAesonParser -asBookmarks :: Parse BowerError [Bookmark]-asBookmarks = eachInArray asBookmark+asModuleMap :: Parse PackageError (Map P.ModuleName PackageName)+asModuleMap =+  Map.fromList <$>+    eachInObjectWithKey (Right . P.moduleNameFromString)+                        (withText parsePackageName') -asBookmark :: Parse BowerError Bookmark-asBookmark =-  asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText)-                   <*> nth 1 asText)+-- This is here to preserve backwards compatibility with compilers which used+-- to generate a 'bookmarks' field in the JSON (i.e. up to 0.10.5). We should+-- remove this after the next breaking change to the JSON.+bookmarksAsModuleMap :: Parse BowerError (Map P.ModuleName PackageName)+bookmarksAsModuleMap =+  convert <$>+    eachInArray (asInPackage (nth 0 (P.moduleNameFromString <$> asText))) +  where+  convert :: [InPackage P.ModuleName] -> Map P.ModuleName PackageName+  convert = Map.fromList . mapMaybe toTuple++  toTuple (Local _) = Nothing+  toTuple (FromDep pkgName mn) = Just (mn, pkgName)+ asResolvedDependencies :: Parse PackageError [(PackageName, Version)] asResolvedDependencies =-  eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName) asVersion-  where-  mapLeft f (Left x) = Left (f x)-  mapLeft _ (Right x) = Right x+  eachInObjectWithKey parsePackageName' asVersion +parsePackageName' :: Text -> Either PackageError PackageName+parsePackageName' =+  mapLeft ErrorInPackageMeta . parsePackageName++mapLeft :: (a -> a') -> Either a b -> Either a' b+mapLeft f (Left x) = Left (f x)+mapLeft _ (Right x) = Right x+ asGithub :: Parse e (GithubUser, GithubRepo) asGithub = (,) <$> nth 0 (GithubUser <$> asText)                <*> nth 1 (GithubRepo <$> asText)@@ -550,19 +721,22 @@  instance A.ToJSON a => A.ToJSON (Package a) where   toJSON Package{..} =-    A.object+    A.object $       [ "packageMeta"          .= pkgMeta       , "version"              .= showVersion pkgVersion       , "versionTag"           .= pkgVersionTag       , "modules"              .= pkgModules-      , "bookmarks"            .= map (fmap (first P.runModuleName)) pkgBookmarks+      , "moduleMap"            .= assocListToJSON P.runModuleName+                                                  runPackageName+                                                  (Map.toList pkgModuleMap)       , "resolvedDependencies" .= assocListToJSON runPackageName                                                   (T.pack . showVersion)                                                   pkgResolvedDependencies       , "github"               .= pkgGithub       , "uploader"             .= pkgUploader       , "compilerVersion"      .= showVersion P.version-      ]+      ] +++      fmap (\t -> "tagTime" .= formatTime t) (maybeToList pkgTagTime)  instance A.ToJSON NotYetKnown where   toJSON _ = A.Null

@@ -347,7 +347,7 @@  -- | -- The primitive types in the external javascript environment with their--- associated kinds. There are also pseudo `Fail` and `Partial` types+-- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types -- that correspond to the classes with the same names. -- primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)@@ -363,20 +363,23 @@     , (primName "Boolean",    (kindType, ExternData))     , (primName "Partial",    (kindType, ExternData))     , (primName "Fail",       (FunKind kindSymbol kindType, ExternData))+    , (primName "Warn",       (FunKind kindSymbol kindType, ExternData))     , (primName "TypeString", (FunKind kindType kindSymbol, ExternData))     , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))     ]  -- |--- The primitive class map. This just contains the `Fail` and `Partial`+-- The primitive class map. This just contains the `Fail`, `Warn`, and `Partial` -- classes. `Partial` is used as a kind of magic constraint for partial--- functions. `Fail` is used for user-defined type errors.+-- functions. `Fail` is used for user-defined type errors. `Warn` for+-- user-defined warnings. -- primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses =   M.fromList     [ (primName "Partial", (makeTypeClassData [] [] [] []))     , (primName "Fail",    (makeTypeClassData [("message", Just kindSymbol)] [] [] []))+    , (primName "Warn",    (makeTypeClassData [("message", Just kindSymbol)] [] [] []))     ]  -- |

@@ -6,44 +6,42 @@   , module Language.PureScript.Errors   ) where -import Prelude.Compat--import Control.Arrow ((&&&))-import Control.Monad-import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.Trans.State.Lazy-import Control.Monad.Writer+import           Prelude.Compat -import Data.Char (isSpace)-import Data.Either (lefts, rights)-import Data.Foldable (fold)-import Data.Functor.Identity (Identity(..))-import Data.List (transpose, nub, nubBy, sortBy, partition)-import Data.Maybe (maybeToList, fromMaybe, mapMaybe)-import Data.Ord (comparing)+import           Control.Arrow ((&&&))+import           Control.Monad+import           Control.Monad.Error.Class (MonadError(..))+import           Control.Monad.Trans.State.Lazy+import           Control.Monad.Writer+import           Data.Char (isSpace)+import           Data.Either (lefts, rights)+import           Data.Foldable (fold)+import           Data.Functor.Identity (Identity(..))+import           Data.List (transpose, nub, nubBy, sortBy, partition)+import           Data.Maybe (maybeToList, fromMaybe, mapMaybe)+import           Data.Ord (comparing)+import           Data.String (fromString) import qualified Data.Map as M import qualified Data.Text as T-import Data.Text (Text)--import Language.PureScript.AST-import Language.PureScript.Crash-import Language.PureScript.Environment-import Language.PureScript.Names-import Language.PureScript.Pretty-import Language.PureScript.Traversals-import Language.PureScript.Types-import Language.PureScript.Label (Label(..))-import Language.PureScript.Pretty.Common (before, endWith)+import           Data.Text (Text)+import           Language.PureScript.AST import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.Constants as C-+import           Language.PureScript.Crash+import           Language.PureScript.Environment+import           Language.PureScript.Label (Label(..))+import           Language.PureScript.Names+import           Language.PureScript.Pretty+import           Language.PureScript.Pretty.Common (endWith)+import           Language.PureScript.PSString (PSString, decodeStringWithReplacement)+import           Language.PureScript.Traversals+import           Language.PureScript.Types+import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers import qualified System.Console.ANSI as ANSI- import qualified Text.Parsec as P import qualified Text.Parsec.Error as PE+import           Text.Parsec.Error (Message(..)) import qualified Text.PrettyPrint.Boxes as Box-import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers-import Text.Parsec.Error (Message(..))  newtype ErrorSuggestion = ErrorSuggestion Text @@ -72,11 +70,10 @@   shouldStrip (PositionedError _) = True   shouldStrip _ = False --- |--- Get the error code for a particular error type---+-- | Get the error code for a particular error type errorCode :: ErrorMessage -> Text errorCode em = case unwrapErrorMessage em of+  ModuleNotFound{} -> "ModuleNotFound"   ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"   ErrorParsingModule{} -> "ErrorParsingModule"   MissingFFIModule{} -> "MissingFFIModule"@@ -168,30 +165,27 @@   CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"   IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"   InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"-  DeprecatedRequirePath{} -> "DeprecatedRequirePath"   CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"   CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"   ExpectedWildcard{} -> "ExpectedWildcard"+  CannotUseBindWithDo{} -> "CannotUseBindWithDo"+  ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"+  UserDefinedWarning{} -> "UserDefinedWarning" --- |--- A stack trace for an error---+-- | A stack trace for an error newtype MultipleErrors = MultipleErrors-  { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)+  { runMultipleErrors :: [ErrorMessage]+  } deriving (Show, Monoid)  -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool nonEmpty = not . null . runMultipleErrors --- |--- Create an error set from a single simple error message---+-- | Create an error set from a single simple error message errorMessage :: SimpleErrorMessage -> MultipleErrors errorMessage err = MultipleErrors [ErrorMessage [] err] --- |--- Create an error set from a single error message---+-- | Create an error set from a single error message singleError :: ErrorMessage -> MultipleErrors singleError = MultipleErrors . pure @@ -224,15 +218,12 @@ -- | How critical the issue is data Level = Error | Warning deriving Show --- |--- Extract nested error messages from wrapper errors---+-- | Extract nested error messages from wrapper errors unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage unwrapErrorMessage (ErrorMessage _ se) = se  replaceUnknowns :: Type -> State TypeMap Type-replaceUnknowns = everywhereOnTypesM replaceTypes-  where+replaceUnknowns = everywhereOnTypesM replaceTypes where   replaceTypes :: Type -> State TypeMap Type   replaceTypes (TUnknown u) = do     m <- get@@ -385,10 +376,7 @@   , ppeShowDocs  = True   } ---- |--- Pretty print a single error, simplifying if necessary---+-- | Pretty print a single error, simplifying if necessary prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do   em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)@@ -429,6 +417,10 @@       unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type"      renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box+    renderSimpleErrorMessage (ModuleNotFound mn) =+      paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found."+            , line "Make sure the source file exists, and that it has been provided as an input to psc."+            ]     renderSimpleErrorMessage (CannotGetFileInfo path) =       paras [ line "Unable to read file info: "             , indent . lineS $ path@@ -690,7 +682,7 @@     renderSimpleErrorMessage (ExtraneousClassMember ident className) =       line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)     renderSimpleErrorMessage (ExpectedType ty kind) =-      paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode "*" <> "."+      paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (prettyPrintKind kindType) <> "."             , line "The error arises from the type"             , markCodeBox $ indent $ typeAsBox ty             , line "having the kind"@@ -862,9 +854,6 @@             , line "Only aliases for data constructors may be used in patterns."             ] -    renderSimpleErrorMessage DeprecatedRequirePath =-      line "The require-path option is deprecated and will be removed in PureScript 0.9."-     renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =       paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."             , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"@@ -880,6 +869,23 @@       paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "."             ] +    renderSimpleErrorMessage CannotUseBindWithDo =+      paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."+            ]++    renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) =+      paras [ line $ "The type class " <> markCode (showQualified runProperName className) <>+                     " expects " <> T.pack (show expected) <> " argument(s)."+            , line $ "But the instance " <> markCode (showIdent dictName) <> " only provided " <>+                     T.pack (show actual) <> "."+            ]++    renderSimpleErrorMessage (UserDefinedWarning msgTy) =+      let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in+      paras [ line "A custom warning occurred while solving type class constraints:"+            , indent msg+            ]+     renderHint :: ErrorMessageHint -> Box.Box -> Box.Box     renderHint (ErrorUnifyingTypes t1 t2) detail =       paras [ detail@@ -1160,15 +1166,11 @@ prettyPrintRef (PositionedDeclarationRef _ _ ref) =   prettyPrintRef ref --- |--- Pretty print multiple errors---+-- | Pretty print multiple errors prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions --- |--- Pretty print multiple warnings---+-- | Pretty print multiple warnings prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions @@ -1199,11 +1201,10 @@ prettyPrintParseError :: P.ParseError -> Box.Box prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages --- |--- Pretty print ParseError detail messages.------ Adapted from 'Text.Parsec.Error.showErrorMessages', see <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>.+-- | Pretty print 'ParseError' detail messages. --+-- Adapted from 'Text.Parsec.Error.showErrorMessages'.+-- See <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>. prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs   | null msgs = Box.text msgUnknown@@ -1265,16 +1266,17 @@   whiteSpace = all isSpace  toTypelevelString :: Type -> Maybe Box.Box-toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ prettyPrintString s-toTypelevelString (TypeApp (TypeConstructor f) x)-  | f == primName "TypeString" = Just $ typeAsBox x-toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)-  | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret)-toTypelevelString _ = Nothing+toTypelevelString t = (Box.text . decodeStringWithReplacement) <$> toTypelevelString' t+  where+  toTypelevelString' :: Type -> Maybe PSString+  toTypelevelString' (TypeLevelString s) = Just s+  toTypelevelString' (TypeApp (TypeConstructor f) x)+    | f == primName "TypeString" = Just $ fromString $ prettyPrintType x+  toTypelevelString' (TypeApp (TypeApp (TypeConstructor f) x) ret)+    | f == primName "TypeConcat" = toTypelevelString' x <> toTypelevelString' ret+  toTypelevelString' _ = Nothing --- |--- Rethrow an error with a more detailed error message in the case of failure---+-- | Rethrow an error with a more detailed error message in the case of failure rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e) @@ -1287,9 +1289,7 @@ warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a warnAndRethrow f = rethrow f . censor f --- |--- Rethrow an error with source position information---+-- | Rethrow an error with source position information rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos)) @@ -1302,10 +1302,8 @@ withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se --- |--- Runs a computation listening for warnings and then escalating any warnings+-- | Runs a computation listening for warnings and then escalating any warnings -- that match the predicate to error status.--- escalateWarningWhen   :: (MonadWriter MultipleErrors m, MonadError MultipleErrors m)   => (ErrorMessage -> Bool)@@ -1318,16 +1316,20 @@   unless (null errors) $ throwError $ MultipleErrors errors   return a --- |--- Collect errors in in parallel----parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b]-parU xs f = forM xs (withError . f) >>= collectErrors+-- | Collect errors in in parallel+parU+  :: forall m a b+   . MonadError MultipleErrors m+  => [a]+  -> (a -> m b)+  -> m [b]+parU xs f =+    forM xs (withError . f) >>= collectErrors   where-  withError :: (MonadError MultipleErrors m) => m a -> m (Either MultipleErrors a)-  withError u = catchError (Right <$> u) (return . Left)+    withError :: m b -> m (Either MultipleErrors b)+    withError u = catchError (Right <$> u) (return . Left) -  collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a]-  collectErrors es = case lefts es of-    [] -> return $ rights es-    errs -> throwError $ fold errs+    collectErrors :: [Either MultipleErrors b] -> m [b]+    collectErrors es = case lefts es of+      [] -> return $ rights es+      errs -> throwError $ fold errs

@@ -43,13 +43,17 @@  -- | Accepts a Commmand and runs it against psc-ide's State. This is the main -- entry point for the server.-handleCommand :: (Ide m, MonadLogger m, MonadError PscIdeError m) =>+handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) =>                  Command -> m Success handleCommand c = case c of   Load [] ->-    findAvailableExterns >>= loadModules+    findAvailableExterns >>= loadModulesAsync   Load modules ->-    loadModules modules+    loadModulesAsync modules+  LoadSync [] ->+    findAvailableExterns >>= loadModulesSync+  LoadSync modules ->+    loadModulesSync modules   Type search filters currentModule ->     findType search filters currentModule   Complete filters matcher currentModule ->@@ -78,7 +82,9 @@       Left question ->         pure (CompletionResult (map (completionFromMatch . map withEmptyAnn) question))   Rebuild file ->-    rebuildFile file+    rebuildFileAsync file+  RebuildSync file ->+    rebuildFileSync file   Cwd ->     TextResult . toS <$> liftIO getCurrentDirectory   Reset ->@@ -125,7 +131,7 @@     let cleaned = filter (`notElem` [".", ".."]) contents     return (ModuleList (map toS cleaned)) -caseSplit :: (Ide m, MonadError PscIdeError m) =>+caseSplit :: (Ide m, MonadError IdeError 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@@ -133,7 +139,7 @@  -- | Finds all the externs.json files inside the output folder and returns the -- corresponding Modulenames-findAvailableExterns :: (Ide m, MonadError PscIdeError m) => m [P.ModuleName]+findAvailableExterns :: (Ide m, MonadError IdeError m) => m [P.ModuleName] findAvailableExterns = do   oDir <- outputDirectory   unlessM (liftIO (doesDirectoryExist oDir))@@ -162,8 +168,33 @@ -- server state. Then proceeds to parse all the specified sourcefiles and -- inserts their ASTs into the state. Finally kicks off an async worker, which -- populates Stage 2 and 3 of the state.+loadModulesAsync+  :: (Ide m, MonadError IdeError m, MonadLogger m)+  => [P.ModuleName]+  -> m Success+loadModulesAsync moduleNames = do+  tr <- loadModules moduleNames++  -- Finally we kick off the worker with @async@ and return the number of+  -- successfully parsed modules.+  env <- ask+  let ll = confLogLevel (ideConfiguration env)+  -- populateStage2 and 3 return Unit for now, so it's fine to discard this+  -- result. We might want to block on this in a benchmarking situation.+  _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env)))+  pure tr++loadModulesSync+  :: (Ide m, MonadError IdeError m, MonadLogger m)+  => [P.ModuleName]+  -> m Success+loadModulesSync moduleNames = do+  tr <- loadModules moduleNames+  populateStage2 *> populateStage3+  pure tr+ loadModules-  :: (Ide m, MonadError PscIdeError m, MonadLogger m)+  :: (Ide m, MonadError IdeError m, MonadLogger m)   => [P.ModuleName]   -> m Success loadModules moduleNames = do@@ -182,12 +213,5 @@     $(logWarn) ("Failed to parse: " <> show failures)   traverse_ insertModule allModules -  -- Finally we kick off the worker with @async@ and return the number of-  -- successfully parsed modules.-  env <- ask-  let ll = confLogLevel (ideConfiguration env)-  -- populateStage2 and 3 return Unit for now, so it's fine to discard this-  -- result. We might want to block on this in a benchmarking situation.-  _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env)))   pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "                     <> show (length allModules) <> " source files."))

@@ -45,7 +45,7 @@ noAnnotations :: WildcardAnnotations noAnnotations = WildcardAnnotations False -caseSplit :: (Ide m, MonadError PscIdeError m) =>+caseSplit :: (Ide m, MonadError IdeError m) =>              Text -> m [Constructor] caseSplit q = do   type' <- parseType' q@@ -55,7 +55,7 @@   let appliedCtors = map (second (map applyTypeVars)) ctors   pure appliedCtors -findTypeDeclaration :: (Ide m, MonadError PscIdeError m) =>+findTypeDeclaration :: (Ide m, MonadError IdeError m) =>                          P.ProperName 'P.TypeName -> m ExternsDeclaration findTypeDeclaration q = do   efs <- getExternFiles@@ -73,7 +73,7 @@             EDType tn _ _ -> tn == t             _ -> False) efDeclarations -splitTypeConstructor :: (MonadError PscIdeError m) =>+splitTypeConstructor :: (MonadError IdeError m) =>                         P.Type -> m (P.ProperName 'P.TypeName, [P.Type]) splitTypeConstructor = go []   where@@ -105,7 +105,7 @@   where     makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs) -addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Text]+addClause :: (MonadError IdeError m) => Text -> WildcardAnnotations -> m [Text] addClause s wca = do   (fName, fType) <- parseTypeDeclaration' s   let args = splitFunctionType fType@@ -114,7 +114,7 @@         " = ?" <> (T.strip . P.runIdent $ fName)   pure [s, template] -parseType' :: (MonadError PscIdeError m) =>+parseType' :: (MonadError IdeError m) =>               Text -> m P.Type parseType' s =   case P.lex "<psc-ide>" (toS s) >>= P.runTokenParser "<psc-ide>" (P.parseType <* Parsec.eof) of@@ -123,7 +123,7 @@       throwError (GeneralError ("Parsing the splittype failed with:"                                 <> show err)) -parseTypeDeclaration' :: (MonadError PscIdeError m) => Text -> m (P.Ident, P.Type)+parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.Type) parseTypeDeclaration' s =   let x = do         ts <- P.lex "" (toS s)

@@ -25,6 +25,7 @@  data Command     = Load [P.ModuleName]+    | LoadSync [P.ModuleName] -- used in tests     | Type       { typeSearch        :: Text       , typeFilters       :: [Filter]@@ -54,6 +55,7 @@     | Import FilePath (Maybe FilePath) [Filter] ImportCommand     | List { listType :: ListType }     | Rebuild FilePath -- ^ Rebuild the specified file using the loaded externs+    | RebuildSync FilePath -- ^ Rebuild the specified file using the loaded externs     | Cwd     | Reset     | Quit@@ -61,6 +63,7 @@ commandName :: Command -> Text commandName c = case c of   Load{} -> "Load"+  LoadSync{} -> "LoadSync"   Type{} -> "Type"   Complete{} -> "Complete"   Pursuit{} -> "Pursuit"@@ -69,6 +72,7 @@   Import{} -> "Import"   List{} -> "List"   Rebuild{} -> "Rebuild"+  RebuildSync{} -> "RebuildSync"   Cwd{} -> "Cwd"   Reset{} -> "Reset"   Quit{} -> "Quit"

@@ -8,6 +8,9 @@ import           Language.PureScript.Ide.Filter import           Language.PureScript.Ide.Matcher import           Language.PureScript.Ide.Types+import qualified Language.PureScript as P++type Module = (P.ModuleName, [IdeDeclarationAnn])  -- | Applies the CompletionFilters and the Matcher to the given Modules --   and sorts the found Completions according to the Matching Score

@@ -1,29 +0,0 @@------------------------------------------------------------------------------------ Module      : Language.PureScript.Ide.Conversions--- Description : Conversions to Text for PureScript types--- Copyright   : Christoph Hegemann 2016--- License     : MIT (http://opensource.org/licenses/MIT)------ Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>--- Stability   : experimental------ |--- Conversions to Text for PureScript types--------------------------------------------------------------------------------module Language.PureScript.Ide.Conversions where--import           Control.Lens.Iso-import           Data.Text           (lines, strip, unwords, pack)-import qualified Language.PureScript as P-import           Protolude--properNameT :: Iso' (P.ProperName a) Text-properNameT = iso P.runProperName P.ProperName--identT :: Iso' P.Ident Text-identT = iso P.runIdent P.Ident--prettyTypeT :: P.Type -> Text-prettyTypeT = unwords . map strip . lines . pack . P.prettyPrintType

@@ -13,7 +13,7 @@ -----------------------------------------------------------------------------  module Language.PureScript.Ide.Error-       ( PscIdeError(..)+       ( IdeError(..)        ) where  import           Data.Aeson@@ -22,15 +22,16 @@ import           Protolude import qualified Text.Parsec.Error               as P -data PscIdeError+data IdeError     = GeneralError Text     | NotFound Text     | ModuleNotFound ModuleIdent     | ModuleFileNotFound ModuleIdent     | ParseError P.ParseError Text     | RebuildError [JSONError]+    deriving (Show, Eq) -instance ToJSON PscIdeError where+instance ToJSON IdeError where   toJSON (RebuildError errs) = object     [ "resultType" .= ("error" :: Text)     , "result" .= errs@@ -40,7 +41,7 @@     , "result" .= textError err     ] -textError :: PscIdeError -> Text+textError :: IdeError -> Text textError (GeneralError msg)          = msg textError (NotFound ident)            = "Symbol '" <> ident <> "' not found." textError (ModuleNotFound ident)      = "Module '" <> ident <> "' not found."

@@ -28,13 +28,13 @@ import qualified Data.ByteString as BS import qualified Data.Map as Map import           Data.Version (showVersion)-import           Language.PureScript.Ide.Error (PscIdeError (..))+import           Language.PureScript.Ide.Error (IdeError (..)) import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util  import qualified Language.PureScript as P -readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>+readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) =>                   FilePath -> m P.ExternsFile readExternFile fp = do    parseResult <- liftIO (decodeStrict <$> BS.readFile fp)@@ -54,9 +54,9 @@      where        version = toS (showVersion P.version) -convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)])+convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)]) convertExterns ef =-  ((P.efModuleName ef, decls), exportDecls)+  (decls, exportDecls)   where     decls = map       (IdeDeclarationAnn emptyAnn)@@ -71,8 +71,10 @@  removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration] removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)-  where notDuplicate (IdeDeclType t) = n ^. properNameT /= t ^. ideTypeName . properNameT-        notDuplicate (IdeDeclTypeSynonym s) = n ^. properNameT /= s ^. ideSynonymName . properNameT+  where notDuplicate (IdeDeclType t) =+          n ^. ideTCName . properNameT /= t ^. ideTypeName . properNameT+        notDuplicate (IdeDeclTypeSynonym s) =+          n ^. ideTCName . properNameT /= s ^. ideSynonymName . properNameT         notDuplicate _ = True removeTypeDeclarationsForClass _ = mempty @@ -88,12 +90,13 @@ convertDecl P.EDType{..} = Just $ IdeDeclType $   IdeType edTypeName edTypeKind convertDecl P.EDTypeSynonym{..} = Just $ IdeDeclTypeSynonym-  (IdeSynonym edTypeSynonymName edTypeSynonymType)+  (IdeTypeSynonym edTypeSynonymName edTypeSynonymType) convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $   IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType convertDecl P.EDValue{..} = Just $ IdeDeclValue $   IdeValue edValueName edValueType-convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName)+convertDecl P.EDClass{..} = Just $ IdeDeclTypeClass $+  IdeTypeClass edClassName [] convertDecl P.EDKind{..} = Just (IdeDeclKind edKindName) convertDecl P.EDInstance{} = Nothing @@ -117,10 +120,10 @@  annotateModule   :: (DefinitionSites P.SourceSpan, TypeAnnotations)-  -> Module-  -> Module-annotateModule (defs, types) (moduleName, decls) =-  (moduleName, map convertDeclaration decls)+  -> [IdeDeclarationAnn]+  -> [IdeDeclarationAnn]+annotateModule (defs, types) decls =+  map convertDeclaration decls   where     convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn     convertDeclaration (IdeDeclarationAnn ann d) = case d of@@ -132,12 +135,12 @@         annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s)       IdeDeclDataConstructor dtor ->         annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)-      IdeDeclTypeClass i ->-        annotateType (i ^. properNameT) (IdeDeclTypeClass i)+      IdeDeclTypeClass tc ->+        annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc)       IdeDeclValueOperator op ->-        annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)+        annotateValue (op ^. ideValueOpName . opNameT) (IdeDeclValueOperator op)       IdeDeclTypeOperator op ->-        annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)+        annotateType (op ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator op)       IdeDeclKind i ->         annotateKind (i ^. properNameT) (IdeDeclKind i)       where

@@ -32,6 +32,8 @@  newtype Filter = Filter (Endo [Module]) deriving(Monoid) +type Module = (P.ModuleName, [IdeDeclarationAnn])+ mkFilter :: ([Module] -> [Module]) -> Filter mkFilter = Filter . Endo 

@@ -39,7 +39,7 @@ import           Language.PureScript.Ide.State import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util-import           System.IO.UTF8                     (readUTF8FileT, writeUTF8FileT)+import           System.IO.UTF8                     (writeUTF8FileT)  data Import = Import P.ModuleName P.ImportDeclarationType  (Maybe P.ModuleName)               deriving (Eq, Show)@@ -67,10 +67,10 @@  -- | Reads a file and returns the (lines before the imports, the imports, the -- lines after the imports)-parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>+parseImportsFromFile :: (MonadIO m, MonadError IdeError m) =>                         FilePath -> m (P.ModuleName, [Text], [Import], [Text]) parseImportsFromFile fp = do-  file <- liftIO (readUTF8FileT fp)+  file <- ideReadFile fp   case sliceImportSection (T.lines file) of     Right res -> pure res     Left err -> throwError (GeneralError err)@@ -147,7 +147,7 @@   P.runTokenParser "<psc-ide>" P.parseModule tokens  -- | Adds an implicit import like @import Prelude@ to a Sourcefile.-addImplicitImport :: (MonadIO m, MonadError PscIdeError m)+addImplicitImport :: (MonadIO m, MonadError IdeError m)                      => FilePath     -- ^ The Sourcefile read from                      -> P.ModuleName -- ^ The module to import                      -> m [Text]@@ -170,7 +170,7 @@ -- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing -- @import Prelude (bind)@ in the file File.purs returns @["import Prelude -- (bind, unit)"]@-addExplicitImport :: (MonadIO m, MonadError PscIdeError m) =>+addExplicitImport :: (MonadIO m, MonadError IdeError m) =>                      FilePath -> IdeDeclaration -> P.ModuleName -> m [Text] addExplicitImport fp decl moduleName = do   (mn, pre, imports, post) <- parseImportsFromFile fp@@ -197,8 +197,8 @@     then imports     else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports   where-    refFromDeclaration (IdeDeclTypeClass n) =-      P.TypeClassRef n+    refFromDeclaration (IdeDeclTypeClass tc) =+      P.TypeClassRef (tc ^. ideTCName)     refFromDeclaration (IdeDeclDataConstructor dtor) =       P.TypeRef (dtor ^. ideDtorTypeName) Nothing     refFromDeclaration (IdeDeclType t) =@@ -249,7 +249,7 @@ -- -- * If more than one possible imports are found, reports the possibilities as a -- list of completions.-addImportForIdentifier :: (Ide m, MonadError PscIdeError m)+addImportForIdentifier :: (Ide m, MonadError IdeError m)                           => FilePath -- ^ The Sourcefile to read from                           -> Text     -- ^ The identifier to import                           -> [Filter] -- ^ Filters to apply before searching for

@@ -4,6 +4,7 @@        ( runLogger        , logPerf        , displayTimeSpec+       , labelTimespec        ) where  import           Protolude@@ -23,6 +24,9 @@                                          LogNone -> False                                          LogDebug -> not (logLevel == LevelOther "perf")                                          LogPerf -> logLevel == LevelOther "perf")++labelTimespec :: Text -> TimeSpec -> Text+labelTimespec label duration = label <> ": " <> displayTimeSpec duration  logPerf :: (MonadIO m, MonadLogger m) => (TimeSpec -> Text) -> m t -> m t logPerf format f = do

@@ -2,7 +2,9 @@ {-# LANGUAGE TemplateHaskell       #-}  module Language.PureScript.Ide.Rebuild-  ( rebuildFile+  ( rebuildFileSync+  , rebuildFileAsync+  , rebuildFile   ) where  import           Protolude@@ -15,9 +17,10 @@ import qualified Language.PureScript             as P import           Language.PureScript.Errors.JSON import           Language.PureScript.Ide.Error+import           Language.PureScript.Ide.Logging import           Language.PureScript.Ide.State import           Language.PureScript.Ide.Types-import           System.IO.UTF8                  (readUTF8FileT)+import           Language.PureScript.Ide.Util  -- | Given a filepath performs the following steps: --@@ -35,12 +38,15 @@ -- warnings, and if rebuilding fails, returns a @RebuildError@ with the -- generated errors. rebuildFile-  :: (Ide m, MonadLogger m, MonadError PscIdeError m)+  :: (Ide m, MonadLogger m, MonadError IdeError m)   => FilePath+  -- ^ The file to rebuild+  -> (ReaderT IdeEnvironment (LoggingT IO) () -> m ())+  -- ^ A runner for the second build with open exports   -> m Success-rebuildFile path = do+rebuildFile path runOpenBuild = do -  input <- liftIO (readUTF8FileT path)+  input <- ideReadFile path    m <- case snd <$> P.parseModuleFromFile identity (path, input) of     Left parseError -> throwError@@ -51,7 +57,7 @@    -- Externs files must be sorted ahead of time, so that they get applied   -- correctly to the 'Environment'.-  externs <- sortExterns m =<< getExternFiles+  externs <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles)    outputDirectory <- confOutputPath . ideConfiguration <$> ask @@ -62,25 +68,49 @@    let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False   -- Rebuild the single module using the cached externs-  (result, warnings) <- liftIO+  (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $+    liftIO     . P.runMake P.defaultOptions     . P.rebuildModule (buildMakeActions                         >>= shushProgress $ makeEnv) externs $ m   case result of     Left errors -> throwError (RebuildError (toJSONErrors False P.Error errors))     Right _ -> do-      rebuildModuleOpen makeEnv externs m+      runOpenBuild (rebuildModuleOpen makeEnv externs m)       pure (RebuildSuccess (toJSONErrors False P.Warning warnings)) +rebuildFileAsync+  :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)+  => FilePath -> m Success+rebuildFileAsync fp = rebuildFile fp asyncRun+  where+    asyncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m ()+    asyncRun action = do+        env <- ask+        let ll = confLogLevel (ideConfiguration env)+        void (liftIO (async (runLogger ll (runReaderT action env))))++rebuildFileSync+  :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)+  => FilePath -> m Success+rebuildFileSync fp = rebuildFile fp syncRun+  where+    syncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m ()+    syncRun action = do+        env <- ask+        let ll = confLogLevel (ideConfiguration env)+        void (liftIO (runLogger ll (runReaderT action env)))++ -- | Rebuilds a module but opens up its export list first and stores the result -- inside the rebuild cache rebuildModuleOpen-  :: (Ide m, MonadLogger m, MonadError PscIdeError m)+  :: (Ide m, MonadLogger m)   => MakeActionsEnv   -> [P.ExternsFile]   -> P.Module   -> m ()-rebuildModuleOpen makeEnv externs m = do+rebuildModuleOpen makeEnv externs m = void $ runExceptT $ do   (openResult, _) <- liftIO     . P.runMake P.defaultOptions     . P.rebuildModule (buildMakeActions@@ -99,8 +129,8 @@ data MakeActionsEnv =   MakeActionsEnv   { maeOutputDirectory :: FilePath-  , maeFilePathMap     :: Map P.ModuleName (Either P.RebuildPolicy FilePath)-  , maeForeignPathMap  :: Map P.ModuleName FilePath+  , maeFilePathMap     :: ModuleMap (Either P.RebuildPolicy FilePath)+  , maeForeignPathMap  :: ModuleMap FilePath   , maePrefixComment   :: Bool   } @@ -128,9 +158,9 @@ -- module. Throws an error if there is a cyclic dependency within the -- ExternsFiles sortExterns-  :: (Ide m, MonadError PscIdeError m)+  :: (Ide m, MonadError IdeError m)   => P.Module-  -> Map P.ModuleName P.ExternsFile+  -> ModuleMap P.ExternsFile   -> m [P.ExternsFile] sortExterns m ex = do   sorted' <- runExceptT

@@ -18,25 +18,26 @@   , prettyPrintReexportResult   , reexportHasFailures   , ReexportResult(..)+  -- for tests+  , resolveReexports'   ) where  import           Protolude  import           Control.Lens                  hiding ((&))- import qualified Data.Map                      as Map import qualified Language.PureScript           as P import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util --- | Contains the module with resolved reexports, and eventual failures+-- | Contains the module with resolved reexports, and possible failures data ReexportResult a   = ReexportResult   { reResolved :: a   , reFailed   :: [(P.ModuleName, P.DeclarationRef)]   } deriving (Show, Eq, Functor) --- | Uses the passed formatter to format the resolved module, and adds eventual+-- | Uses the passed formatter to format the resolved module, and adds possible -- failures prettyPrintReexportResult   :: (a -> Text)@@ -56,16 +57,27 @@ reexportHasFailures :: ReexportResult a -> Bool reexportHasFailures = not . null . reFailed --- | Resolves Reexports for a given Module, by looking up the reexported values--- from the passed in Map+-- | Resolves Reexports for the given Modules, by looking up the reexported+-- values from the passed in DeclarationRefs resolveReexports-  :: Map P.ModuleName [IdeDeclarationAnn]+  :: ModuleMap [(P.ModuleName, P.DeclarationRef)]+  -- ^ the references to resolve+  -> ModuleMap [IdeDeclarationAnn]   -- ^ Modules to search for the reexported declarations-  -> (Module, [(P.ModuleName, P.DeclarationRef)])-  -- ^ The module to resolve reexports for, aswell as the references to resolve-  -> ReexportResult Module-resolveReexports modules ((moduleName, decls), refs) =-  ReexportResult (moduleName, decls <> concat resolvedRefs) failedRefs+  -> ModuleMap (ReexportResult [IdeDeclarationAnn])+resolveReexports reexportRefs modules =+  Map.mapWithKey (\moduleName decls ->+                    maybe (ReexportResult decls [])+                      (resolveReexports' modules decls)+                      (Map.lookup moduleName reexportRefs)) modules++resolveReexports'+  :: ModuleMap [IdeDeclarationAnn]+  -> [IdeDeclarationAnn]+  -> [(P.ModuleName, P.DeclarationRef)]+  -> ReexportResult [IdeDeclarationAnn]+resolveReexports' modules decls refs =+  ReexportResult (decls <> concat resolvedRefs) failedRefs   where     (failedRefs, resolvedRefs) = partitionEithers (resolveRef' <$> refs)     resolveRef' x@(mn, r) = case Map.lookup mn modules of@@ -78,7 +90,7 @@   -> Either P.DeclarationRef [IdeDeclarationAnn] resolveRef decls ref = case ref of   P.TypeRef tn mdtors ->-    case findRef (\x -> x ^? _IdeDeclType . ideTypeName <&> (== tn) & fromMaybe False) of+    case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn)) of       Nothing -> Left ref       Just d -> Right $ d : case mdtors of           Nothing ->@@ -88,13 +100,13 @@             findDtors tn           Just dtors -> mapMaybe lookupDtor dtors   P.ValueRef i ->-    findWrapped (\x -> x ^? _IdeDeclValue . ideValueIdent <&> (== i) & fromMaybe False)+    findWrapped (anyOf (_IdeDeclValue . ideValueIdent) (== i))   P.ValueOpRef name ->-    findWrapped (\x -> x ^? _IdeDeclValueOperator . ideValueOpName <&> (== name) & fromMaybe False)+    findWrapped (anyOf (_IdeDeclValueOperator . ideValueOpName) (== name))   P.TypeOpRef name ->-    findWrapped (\x -> x ^? _IdeDeclTypeOperator . ideTypeOpName <&> (== name) & fromMaybe False)+    findWrapped (anyOf (_IdeDeclTypeOperator . ideTypeOpName) (== name))   P.TypeClassRef name ->-    findWrapped (\case IdeDeclTypeClass n -> n == name; _ -> False)+    findWrapped (anyOf (_IdeDeclTypeClass . ideTCName) (== name))   _ ->     Left ref   where@@ -102,9 +114,9 @@     findRef f = find (f . discardAnn) decls      lookupDtor name =-      findRef (\x -> x ^? _IdeDeclDataConstructor . ideDtorName <&> (== name) & fromMaybe False)+      findRef (anyOf (_IdeDeclDataConstructor . ideDtorName) (== name)) -    findDtors tn = filter (f . discardAnn) decls-      where-        f :: IdeDeclaration -> Bool-        f decl = decl ^? _IdeDeclDataConstructor . ideDtorTypeName <&> (== tn) & fromMaybe False+    findDtors tn = filter (anyOf+                           (idaDeclaration+                            . _IdeDeclDataConstructor+                            . ideDtorTypeName) (== tn)) decls

@@ -28,14 +28,13 @@ import           Language.PureScript.Ide.Error import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util-import           System.IO.UTF8                (readUTF8FileT)  parseModule-  :: (MonadIO m)+  :: (MonadIO m, MonadError IdeError m)   => FilePath   -> m (Either FilePath (FilePath, P.Module)) parseModule path = do-  contents <- liftIO (readUTF8FileT path)+  contents <- ideReadFile path   case P.parseModuleFromFile identity (path, contents) of     Left _ -> pure (Left path)     Right m -> pure (Right m)@@ -47,7 +46,7 @@     isImport (P.PositionedDeclaration _ _ (P.ImportDeclaration a b c)) = Just (a, b, c)     isImport _ = Nothing -getImportsForFile :: (MonadIO m, MonadError PscIdeError m) =>+getImportsForFile :: (MonadIO m, MonadError IdeError m) =>                      FilePath -> m [ModuleImport] getImportsForFile fp = do   moduleE <- parseModule fp@@ -106,6 +105,10 @@   P.DataDeclaration _ name _ ctors ->     (IdeNSType (P.runProperName name), ss)     : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors+  P.FixityDeclaration (Left (P.ValueFixity _ _ opName)) ->+    [(IdeNSValue (P.runOpName opName), ss)]+  P.FixityDeclaration (Right (P.TypeFixity _ _ opName)) ->+    [(IdeNSType (P.runOpName opName), ss)]   P.ExternDeclaration ident _ ->     [(IdeNSValue (P.runIdent ident), ss)]   P.ExternDataDeclaration name _ ->

@@ -14,6 +14,7 @@  {-# LANGUAGE PackageImports        #-} {-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE NamedFieldPuns        #-}  module Language.PureScript.Ide.State   ( getLoadedModulenames@@ -29,10 +30,12 @@   , populateStage3STM   -- for tests   , resolveOperatorsForModule+  , resolveInstances   ) where  import           Protolude +import           Control.Arrow import           Control.Concurrent.STM import           Control.Lens                       hiding (op, (&)) import           "monad-logger" Control.Monad.Logger@@ -58,7 +61,7 @@ getLoadedModulenames = Map.keys <$> getExternFiles  -- | Gets all loaded ExternFiles-getExternFiles :: Ide m => m (Map P.ModuleName ExternsFile)+getExternFiles :: Ide m => m (ModuleMap ExternsFile) getExternFiles = s1Externs <$> getStage1  -- | Insert a Module into Stage1 of the State@@ -121,7 +124,7 @@ -- | Checks if the given ModuleName matches the last rebuild cache and if it -- does returns all loaded definitions + the definitions inside the rebuild -- cache-getAllModules :: Ide m => Maybe P.ModuleName -> m [Module]+getAllModules :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclarationAnn])] getAllModules mmoduleName = do   declarations <- s3Declarations <$> getStage3   rebuild <- cachedRebuild@@ -136,7 +139,7 @@                 ast =                   fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)                 cachedModule =-                  snd . annotateModule ast . fst . convertExterns $ ef+                  annotateModule ast (fst (convertExterns ef))                 tmp =                   Map.insert moduleName cachedModule declarations                 resolved =@@ -192,43 +195,84 @@   st <- ideStateVar <$> ask   let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration   results <- logPerf message (liftIO (atomically (populateStage3STM st)))-  traverse_-    (logWarnN . prettyPrintReexportResult (P.runModuleName . fst))-    (filter reexportHasFailures results)+  void $ Map.traverseWithKey+    (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))+    (Map.filter reexportHasFailures results)  -- | STM version of populateStage3-populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]+populateStage3STM+  :: TVar IdeState+  -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn])) populateStage3STM ref = do   externs <- s1Externs <$> getStage1STM ref   (AstData asts) <- s2AstData <$> getStage2STM ref-  let modules = Map.map convertExterns externs-      nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])-      nModules = Map.mapWithKey-        (\moduleName (m, refs) ->-           (fromMaybe m $ annotateModule <$> Map.lookup moduleName asts <*> pure m, refs)) modules-      -- resolves reexports and discards load failures for now-      result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules-      resultP = resolveOperators (Map.fromList (reResolved <$> result))-  setStage3STM ref (Stage3 resultP Nothing)-  pure result+  let (modules, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs)+      results =+        resolveLocations asts modules+        & resolveInstances externs+        & resolveOperators+        & resolveReexports reexportRefs+  setStage3STM ref (Stage3 (map reResolved results) Nothing)+  pure results ++resolveLocations+  :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)+  -> ModuleMap [IdeDeclarationAnn]+  -> ModuleMap [IdeDeclarationAnn]+resolveLocations asts =+  Map.mapWithKey (\mn decls ->+                    maybe decls (flip annotateModule decls) (Map.lookup mn asts))++resolveInstances+  :: ModuleMap P.ExternsFile+  -> ModuleMap [IdeDeclarationAnn]+  -> ModuleMap [IdeDeclarationAnn]+resolveInstances externs declarations =+  Map.foldr (flip (foldr go)) declarations+  . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef))+  $ externs+  where+    extractInstances mn P.EDInstance{..} =+      case edInstanceClassName of+          P.Qualified (Just classModule) className ->+            Just (IdeInstance mn+                  edInstanceName+                  edInstanceTypes+                  edInstanceConstraints, classModule, className)+          _ -> Nothing+    extractInstances _ _ = Nothing++    go ::+      (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName)+      -> ModuleMap [IdeDeclarationAnn]+      -> ModuleMap [IdeDeclarationAnn]+    go (ideInstance, classModule, className) acc' =+      let+        matchTC =+          anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className)+        updateDeclaration =+          mapIf matchTC (idaDeclaration+                         . _IdeDeclTypeClass+                         . ideTCInstances+                         %~ cons ideInstance)+      in+        acc' & ix classModule %~ updateDeclaration+ resolveOperators-  :: Map P.ModuleName [IdeDeclarationAnn]-  -> Map P.ModuleName [IdeDeclarationAnn]+  :: ModuleMap [IdeDeclarationAnn]+  -> ModuleMap [IdeDeclarationAnn] resolveOperators modules =   map (resolveOperatorsForModule modules) modules  -- | Looks up the types and kinds for operators and assigns them to their -- declarations resolveOperatorsForModule-  :: Map P.ModuleName [IdeDeclarationAnn]+  :: ModuleMap [IdeDeclarationAnn]   -> [IdeDeclarationAnn]   -> [IdeDeclarationAnn]-resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)+resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator)   where-    hasName :: Eq b => Lens' a b -> b -> a -> Bool-    hasName l a x = x ^. l == a-     getDeclarations :: P.ModuleName -> [IdeDeclaration]     getDeclarations moduleName =       Map.lookup moduleName modules@@ -239,14 +283,14 @@       | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias =           let t = getDeclarations mn                   & mapMaybe (preview _IdeDeclValue)-                  & filter (hasName ideValueIdent ident)+                  & filter (anyOf ideValueIdent (== ident))                   & map (view ideValueType)                   & listToMaybe           in IdeDeclValueOperator (op & ideValueOpType .~ t)       | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias =           let t = getDeclarations mn                   & mapMaybe (preview _IdeDeclDataConstructor)-                  & filter (hasName ideDtorName dtor)+                  & filter (anyOf ideDtorName (== dtor))                   & map (view ideDtorType)                   & listToMaybe           in IdeDeclValueOperator (op & ideValueOpType .~ t)@@ -254,9 +298,12 @@       | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias =           let k = getDeclarations mn                   & mapMaybe (preview _IdeDeclType)-                  & filter (hasName ideTypeName properName)+                  & filter (anyOf ideTypeName (== properName))                   & map (view ideTypeKind)                   & listToMaybe           in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)     resolveOperator x = x ++mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b+mapIf p f = map (\x -> if p x then f x else x)

@@ -27,13 +27,14 @@ import qualified Language.PureScript.Errors.JSON     as P  type ModuleIdent = Text+type ModuleMap a = Map P.ModuleName a  data IdeDeclaration   = IdeDeclValue IdeValue   | IdeDeclType IdeType-  | IdeDeclTypeSynonym IdeSynonym+  | IdeDeclTypeSynonym IdeTypeSynonym   | IdeDeclDataConstructor IdeDataConstructor-  | IdeDeclTypeClass (P.ProperName 'P.ClassName)+  | IdeDeclTypeClass IdeTypeClass   | IdeDeclValueOperator IdeValueOperator   | IdeDeclTypeOperator IdeTypeOperator   | IdeDeclKind (P.ProperName 'P.KindName)@@ -49,7 +50,7 @@  , _ideTypeKind :: P.Kind  } deriving (Show, Eq, Ord) -data IdeSynonym = IdeSynonym+data IdeTypeSynonym = IdeTypeSynonym   { _ideSynonymName :: P.ProperName 'P.TypeName   , _ideSynonymType :: P.Type   } deriving (Show, Eq, Ord)@@ -60,6 +61,18 @@   , _ideDtorType     :: P.Type   } deriving (Show, Eq, Ord) +data IdeTypeClass = IdeTypeClass+  { _ideTCName :: P.ProperName 'P.ClassName+  , _ideTCInstances :: [IdeInstance]+  } deriving (Show, Eq, Ord)++data IdeInstance = IdeInstance+  { _ideInstanceModule      :: P.ModuleName+  , _ideInstanceName        :: P.Ident+  , _ideInstanceTypes       :: [P.Type]+  , _ideInstanceConstraints :: Maybe [P.Constraint]+  } deriving (Show, Eq, Ord)+ data IdeValueOperator = IdeValueOperator   { _ideValueOpName          :: P.OpName 'P.ValueOpName   , _ideValueOpAlias         :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))@@ -79,8 +92,10 @@ makePrisms ''IdeDeclaration makeLenses ''IdeValue makeLenses ''IdeType-makeLenses ''IdeSynonym+makeLenses ''IdeTypeSynonym makeLenses ''IdeDataConstructor+makeLenses ''IdeTypeClass+makeLenses ''IdeInstance makeLenses ''IdeValueOperator makeLenses ''IdeTypeOperator @@ -101,11 +116,9 @@ emptyAnn :: Annotation emptyAnn = Annotation Nothing Nothing Nothing -type Module = (P.ModuleName, [IdeDeclarationAnn])- type DefinitionSites a = Map IdeDeclNamespace a type TypeAnnotations = Map P.Ident P.Type-newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations))+newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations))   -- ^ SourceSpans for the definition sites of Values and Types aswell as type   -- annotations found in a module   deriving (Show, Eq, Ord, Functor, Foldable)@@ -132,7 +145,7 @@   { ideStage1 :: Stage1   , ideStage2 :: Stage2   , ideStage3 :: Stage3-  }+  } deriving (Show)  emptyIdeState :: IdeState emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3@@ -147,18 +160,18 @@ emptyStage3 = Stage3 M.empty Nothing  data Stage1 = Stage1-  { s1Externs :: M.Map P.ModuleName P.ExternsFile-  , s1Modules :: M.Map P.ModuleName (P.Module, FilePath)-  }+  { s1Externs :: ModuleMap P.ExternsFile+  , s1Modules :: ModuleMap (P.Module, FilePath)+  } deriving (Show)  data Stage2 = Stage2   { s2AstData :: AstData P.SourceSpan-  }+  } deriving (Show, Eq)  data Stage3 = Stage3-  { s3Declarations  :: M.Map P.ModuleName [IdeDeclarationAnn]+  { s3Declarations  :: ModuleMap [IdeDeclarationAnn]   , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)-  }+  } deriving (Show)  newtype Match a = Match (P.ModuleName, a)            deriving (Show, Eq, Functor)@@ -216,6 +229,8 @@ identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name identifierFromDeclarationRef (P.KindRef name) = P.runProperName name+identifierFromDeclarationRef (P.ValueOpRef op) = P.showOp op+identifierFromDeclarationRef (P.TypeOpRef op) = P.showOp op identifierFromDeclarationRef _ = ""  data Success =

@@ -24,21 +24,27 @@   , withEmptyAnn   , valueOperatorAliasT   , typeOperatorAliasT-  , module Language.PureScript.Ide.Conversions+  , prettyTypeT+  , properNameT+  , identT+  , opNameT+  , ideReadFile   , module Language.PureScript.Ide.Logging   ) where  import           Protolude                           hiding (decodeUtf8,                                                       encodeUtf8) -import           Control.Lens                        ((^.))+import           Control.Lens                        hiding ((&), op) import           Data.Aeson import qualified Data.Text                           as T+import qualified Data.Text.Lazy                      as TL import           Data.Text.Lazy.Encoding             (decodeUtf8, encodeUtf8) import qualified Language.PureScript                 as P-import           Language.PureScript.Ide.Conversions+import           Language.PureScript.Ide.Error import           Language.PureScript.Ide.Logging import           Language.PureScript.Ide.Types+import           System.IO.UTF8                  (readUTF8FileT)  identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of@@ -46,7 +52,7 @@   IdeDeclType t -> t ^. ideTypeName . properNameT   IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT   IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT-  IdeDeclTypeClass name -> P.runProperName name+  IdeDeclTypeClass tc -> tc ^. ideTCName . properNameT   IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName   IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName   IdeDeclKind name -> P.runProperName name@@ -66,14 +72,14 @@   where     (complIdentifier, complExpandedType) = case decl of       IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT)-      IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )+      IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind)       IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)       IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)-      IdeDeclTypeClass name -> (P.runProperName name, "class")+      IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, "type class")       IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->         (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)       IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->-        (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)+        (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind)       IdeDeclKind k -> (P.runProperName k, "kind")      complModule = P.runModuleName m@@ -102,10 +108,10 @@   P.showQualified P.runProperName i  encodeT :: (ToJSON a) => a -> Text-encodeT = toS . decodeUtf8 . encode+encodeT = TL.toStrict . decodeUtf8 . encode  decodeT :: (FromJSON a) => Text -> Maybe a-decodeT = decode . encodeUtf8 . toS+decodeT = decode . encodeUtf8 . TL.fromStrict  unwrapPositioned :: P.Declaration -> P.Declaration unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x@@ -114,3 +120,28 @@ unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x unwrapPositionedRef x = x++properNameT :: Iso' (P.ProperName a) Text+properNameT = iso P.runProperName P.ProperName++identT :: Iso' P.Ident Text+identT = iso P.runIdent P.Ident++opNameT :: Iso' (P.OpName a) Text+opNameT = iso P.runOpName P.OpName++ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text+ideReadFile fp = do+  contents :: Either IOException Text <- liftIO (try (readUTF8FileT fp))+  either+    (\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp)))+    pure+    contents++prettyTypeT :: P.Type -> Text+prettyTypeT =+  T.unwords+  . map T.strip+  . T.lines+  . T.pack+  . P.prettyPrintTypeWithUnicode

@@ -20,53 +20,51 @@   , inferForeignModules   ) where -import Prelude.Compat--import Control.Concurrent.Lifted as C-import Control.Monad hiding (sequence)-import Control.Monad.Base (MonadBase(..))-import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.IO.Class-import Control.Monad.Logger-import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)-import Control.Monad.Supply-import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Trans.Control (MonadBaseControl(..))-import Control.Monad.Trans.Except-import Control.Monad.Writer.Class (MonadWriter(..))+import           Prelude.Compat -import Data.Aeson (encode, decode)+import           Control.Concurrent.Lifted as C+import           Control.Monad hiding (sequence)+import           Control.Monad.Base (MonadBase(..))+import           Control.Monad.Error.Class (MonadError(..))+import           Control.Monad.IO.Class+import           Control.Monad.Logger+import           Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)+import           Control.Monad.Supply+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.Control (MonadBaseControl(..))+import           Control.Monad.Trans.Except+import           Control.Monad.Writer.Class (MonadWriter(..))+import           Data.Aeson (encode, decode) import qualified Data.Aeson as Aeson-import Data.Either (partitionEithers)-import Data.Function (on)-import Data.Foldable (for_)-import Data.List (foldl', sortBy, groupBy)-import Data.Maybe (fromMaybe, catMaybes)-import Data.Monoid ((<>))-import Data.Time.Clock-import Data.Traversable (for)-import Data.Version (showVersion)+import           Data.Either (partitionEithers)+import           Data.Function (on)+import           Data.Foldable (for_)+import           Data.List (foldl', sortBy, groupBy)+import           Data.Maybe (fromMaybe, catMaybes)+import           Data.Monoid ((<>))+import           Data.Time.Clock+import           Data.Traversable (for)+import           Data.Version (showVersion) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE--import Language.PureScript.AST-import Language.PureScript.Crash-import Language.PureScript.Environment-import Language.PureScript.Errors-import Language.PureScript.Externs-import Language.PureScript.Linter-import Language.PureScript.ModuleDependencies-import Language.PureScript.Names-import Language.PureScript.Options-import Language.PureScript.Pretty-import Language.PureScript.Pretty.Common(SMap(..))-import Language.PureScript.Renamer-import Language.PureScript.Sugar-import Language.PureScript.TypeChecker+import           Language.PureScript.AST+import           Language.PureScript.Crash+import           Language.PureScript.Environment+import           Language.PureScript.Errors+import           Language.PureScript.Externs+import           Language.PureScript.Linter+import           Language.PureScript.ModuleDependencies+import           Language.PureScript.Names+import           Language.PureScript.Options+import           Language.PureScript.Pretty+import           Language.PureScript.Pretty.Common(SMap(..))+import           Language.PureScript.Renamer+import           Language.PureScript.Sugar+import           Language.PureScript.TypeChecker import qualified Language.JavaScript.Parser as JS import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.CodeGen.JS as J@@ -74,21 +72,18 @@ import qualified Language.PureScript.CoreFn as CF import qualified Language.PureScript.CoreFn.ToJSON as CFJ import qualified Language.PureScript.Parser as PSParser- import qualified Paths_purescript as Paths--import SourceMap-import SourceMap.Types--import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)-import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)-import System.IO.Error (tryIOError)-+import           SourceMap+import           SourceMap.Types+import           System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)+import           System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)+import           System.IO.Error (tryIOError) import qualified Text.Parsec as Parsec  -- | Progress messages from the make process data ProgressMessage   = CompilingModule ModuleName+  -- ^ Compilation started for the specified module   deriving (Show, Eq, Ord)  -- | Render a progress message@@ -102,7 +97,6 @@ -- * The particular backend being used (Javascript, C++11, etc.) -- -- * The details of how files are read/written etc.--- data MakeActions m = MakeActions   { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))   -- ^ Get the timestamp for the input file(s) for a module. If there are multiple@@ -121,26 +115,26 @@   -- ^ Respond to a progress update.   } --- |--- Generated code for an externs file.---+-- | Generated code for an externs file. type Externs = B.ByteString --- |--- Determines when to rebuild a module---+-- | Determines when to rebuild a module data RebuildPolicy   -- | Never rebuild this module   = RebuildNever   -- | Always rebuild this module   | RebuildAlways deriving (Show, Eq, Ord) --- | Rebuild a single module-rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)-     => MakeActions m-     -> [ExternsFile]-     -> Module-     -> m ExternsFile+-- | Rebuild a single module.+--+-- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples).+rebuildModule+  :: forall m+   . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => MakeActions m+  -> [ExternsFile]+  -> Module+  -> m ExternsFile rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do   progress $ CompilingModule moduleName   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs@@ -157,12 +151,10 @@   evalSupplyT nextVar . codegen renamed env' . encode $ exts   return exts --- |--- Compiles in "make" mode, compiling each module separately to a js files and an externs file+-- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file. -- -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again.--- make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)      => MakeActions m      -> [Module]@@ -244,7 +236,7 @@       putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs       putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors -  maximumMaybe :: (Ord a) => [a] -> Maybe a+  maximumMaybe :: Ord a => [a] -> Maybe a   maximumMaybe [] = Nothing   maximumMaybe xs = Just $ maximum xs @@ -262,11 +254,10 @@ importPrim :: Module -> Module importPrim = addDefaultImport (ModuleName [ProperName C.prim]) --- |--- A monad for running make actions----newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }-  deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)+-- | A monad for running make actions+newtype Make a = Make+  { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a+  } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)  instance MonadBase IO Make where   liftBase = liftIO@@ -276,12 +267,12 @@   liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)   restoreM = Make . restoreM --- |--- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.---+-- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings. runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors) runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake +-- | Run an 'IO' action in the 'Make' monad, by specifying how IO errors should+-- be rendered as 'ErrorMessage' values. makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a makeIO f io = do   e <- liftIO $ tryIOError io@@ -299,7 +290,8 @@    . MonadIO m   => M.Map ModuleName (Either RebuildPolicy FilePath)   -> m (M.Map ModuleName FilePath)-inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule+inferForeignModules =+    fmap (M.mapMaybe id) . traverse inferForeignModule   where     inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)     inferForeignModule (Left _) = return Nothing@@ -310,16 +302,19 @@         then return (Just jsFile)         else return Nothing --- |--- A set of make actions that read and write modules from the given directory.----buildMakeActions :: FilePath -- ^ the output directory-                 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module-                 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module-                 -> Bool -- ^ Generate a prefix comment?-                 -> MakeActions Make+-- | A set of make actions that read and write modules from the given directory.+buildMakeActions+  :: FilePath+  -- ^ the output directory+  -> M.Map ModuleName (Either RebuildPolicy FilePath)+  -- ^ a map between module names and paths to the file containing the PureScript module+  -> M.Map ModuleName FilePath+  -- ^ a map between module name and the file containing the foreign javascript for the module+  -> Bool+  -- ^ Generate a prefix comment?+  -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix =-  MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress+    MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress   where    getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))@@ -331,10 +326,15 @@    getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)   getOutputTimestamp mn = do+    dumpCoreFn <- asks optionsDumpCoreFn     let filePath = T.unpack (runModuleName mn)         jsFile = outputDir </> filePath </> "index.js"         externsFile = outputDir </> filePath </> "externs.json"-    min <$> getTimestamp jsFile <*> getTimestamp externsFile+        coreFnFile = outputDir </> filePath </> "corefn.json"+        min3 js exts coreFn+          | dumpCoreFn = min (min js exts) coreFn+          | otherwise = min js exts+    min3 <$> getTimestamp jsFile <*> getTimestamp externsFile <*> getTimestamp coreFnFile    readExterns :: ModuleName -> Make (FilePath, Externs)   readExterns mn = do@@ -421,10 +421,8 @@   progress :: ProgressMessage -> Make ()   progress = liftIO . putStrLn . renderProgressMessage --- |--- Check that the declarations in a given PureScript module match with those+-- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module.--- checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make () checkForeignDecls m path = do   jsStr <- lift $ readTextFile path

@@ -1,24 +1,18 @@--- |--- Provides the ability to sort modules based on module dependencies---+-- | Provides the ability to sort modules based on module dependencies module Language.PureScript.ModuleDependencies   ( sortModules   , ModuleGraph   ) where -import Prelude.Compat--import Control.Monad.Error.Class (MonadError(..))--import Data.Graph-import Data.List (nub)-import Data.Maybe (fromMaybe)+import           Protolude -import Language.PureScript.AST-import Language.PureScript.Crash-import Language.PureScript.Errors-import Language.PureScript.Names-import Language.PureScript.Types+import           Data.Graph+import qualified Data.Set as S+import           Language.PureScript.AST+import qualified Language.PureScript.Constants as C+import           Language.PureScript.Crash+import           Language.PureScript.Errors+import           Language.PureScript.Names  -- | A list of modules with their transitive dependencies type ModuleGraph = [(ModuleName, [ModuleName])]@@ -26,75 +20,45 @@ -- | Sort a collection of modules based on module dependencies. -- -- Reports an error if the module graph contains a cycle.----sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)+sortModules+  :: forall m+   . MonadError MultipleErrors m+  => [Module]+  -> m ([Module], ModuleGraph) sortModules ms = do-  let verts = map goModule ms-  ms' <- mapM toModule $ stronglyConnComp verts-  let (graph, fromVertex, toVertex) = graphFromEdges verts-      moduleGraph = do (_, mn, _) <- verts-                       let v       = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)-                           deps    = reachable graph v-                           toKey i = case fromVertex i of (_, key, _) -> key-                       return (mn, filter (/= mn) (map toKey deps))-  return (ms', moduleGraph)+    let mns = S.fromList $ map getModuleName ms+    verts <- mapM (toGraphNode mns) ms+    ms' <- mapM toModule $ stronglyConnComp verts+    let (graph, fromVertex, toVertex) = graphFromEdges verts+        moduleGraph = do (_, mn, _) <- verts+                         let v       = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)+                             deps    = reachable graph v+                             toKey i = case fromVertex i of (_, key, _) -> key+                         return (mn, filter (/= mn) (map toKey deps))+    return (ms', moduleGraph)   where-  goModule :: Module -> (Module, ModuleName, [ModuleName])-  goModule m@(Module _ _ _ ds _) =-    let ams = concatMap extractQualAs ds-    in (m, getModuleName m, nub (concatMap (usedModules ams) ds))--  -- Extract module names that have been brought into scope by an `as` import.-  extractQualAs :: Declaration -> [ModuleName]-  extractQualAs (PositionedDeclaration _ _ d) = extractQualAs d-  extractQualAs (ImportDeclaration _ _ (Just am)) = [am]-  extractQualAs _ = []+    toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName])+    toGraphNode mns m@(Module _ _ mn ds _) = do+      let deps = ordNub (concatMap usedModules ds)+      forM_ deps $ \dep ->+        when (dep /= C.Prim && S.notMember dep mns) $+          throwError . addHint (ErrorInModule mn) . errorMessage $ ModuleNotFound dep+      pure (m, getModuleName m, deps) --- |--- Calculate a list of used modules based on explicit imports and qualified--- names. `ams` is a list of `ModuleNames` that refer to names brought into--- scope by importing with `as` - this ensures that when building the list we--- don't inadvertantly assume a dependency on an actual module, if there is a--- module that has the same name as the qualified import.----usedModules :: [ModuleName] -> Declaration -> [ModuleName]-usedModules ams d =-  let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])-      (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)-  in nub (f d ++ g d)-  where+-- | Calculate a list of used modules based on explicit imports and qualified names.+usedModules :: Declaration -> [ModuleName]+usedModules d = f d where+  f :: Declaration -> [ModuleName]+  (f, _, _, _, _) = everythingOnValues (++) forDecls (const []) (const []) (const []) (const [])    forDecls :: Declaration -> [ModuleName]-  forDecls (ImportDeclaration mn _ _) =-    -- Regardless of whether an imported module is qualified we still need to-    -- take into account its import to build an accurate list of dependencies.-    [mn]-  forDecls (FixityDeclaration fd)-    | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn]-  forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _)-    | mn `notElem` ams = [mn]+  -- Regardless of whether an imported module is qualified we still need to+  -- take into account its import to build an accurate list of dependencies.+  forDecls (ImportDeclaration mn _ _) = [mn]   forDecls _ = [] -  forValues :: Expr -> [ModuleName]-  forValues (Var (Qualified (Just mn) _))-    | mn `notElem` ams = [mn]-  forValues (Constructor (Qualified (Just mn) _))-    | mn `notElem` ams = [mn]-  forValues _ = []--  forTypes :: Type -> [ModuleName]-  forTypes (TypeConstructor (Qualified (Just mn) _))-    | mn `notElem` ams = [mn]-  forTypes _ = []--  extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName-  extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn-  extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn---- |--- Convert a strongly connected component of the module graph to a module----toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module+-- | Convert a strongly connected component of the module graph to a module+toModule :: MonadError MultipleErrors m => SCC Module -> m Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)

@@ -5,6 +5,7 @@   , toUTF16CodeUnits   , decodeString   , decodeStringEither+  , decodeStringWithReplacement   , prettyPrintString   , prettyPrintStringJS   , mkString@@ -52,14 +53,23 @@ instance Show PSString where   show = show . codePoints +-- | -- Decode a PSString to a String, representing any lone surrogates as the -- reserved code point with that index. Warning: if there are any lone -- surrogates, converting the result to Text via Data.Text.pack will result in -- loss of information as those lone surrogates will be replaced with U+FFFD -- REPLACEMENT CHARACTER. Because this function requires care to use correctly, -- we do not export it.+-- codePoints :: PSString -> String codePoints = map (either (chr . fromIntegral) id) . decodeStringEither++-- |+-- Decode a PSString as UTF-16 text. Lone surrogates will be replaced with+-- U+FFFD REPLACEMENT CHARACTER+--+decodeStringWithReplacement :: PSString -> String+decodeStringWithReplacement = map (either (const '\xFFFD') id) . decodeStringEither  -- | -- Decode a PSString as UTF-16. Lone surrogates in the input are represented in

@@ -1,52 +1,39 @@--- |--- Constants and utility functions to be used when parsing---+-- | Useful common functions for building parsers module Language.PureScript.Parser.Common where -import Prelude.Compat+import           Prelude.Compat -import Control.Applicative ((<|>))-import Control.Monad (guard)-import Data.Monoid ((<>))-import Data.Text (Text)+import           Control.Applicative ((<|>))+import           Control.Monad (guard)+import           Data.Maybe (fromMaybe)+import           Data.Monoid ((<>))+import           Data.Text (Text) import qualified Data.Text as T--import Language.PureScript.AST.SourcePos-import Language.PureScript.Comments-import Language.PureScript.Names-import Language.PureScript.Parser.Lexer-import Language.PureScript.Parser.State-import Language.PureScript.PSString (PSString, mkString)-+import           Language.PureScript.AST.SourcePos+import           Language.PureScript.Comments+import           Language.PureScript.Names+import           Language.PureScript.Parser.Lexer+import           Language.PureScript.Parser.State+import           Language.PureScript.PSString (PSString, mkString) import qualified Text.Parsec as P --- |--- Parse a general proper name.---+-- | Parse a general proper name. properName :: TokenParser (ProperName a) properName = ProperName <$> uname --- |--- Parse a proper name for a type.---+-- | Parse a proper name for a type. typeName :: TokenParser (ProperName 'TypeName) typeName = ProperName <$> tyname --- |--- Parse a proper name for a kind.---+-- | Parse a proper name for a kind. kindName :: TokenParser (ProperName 'KindName) kindName = ProperName <$> kiname --- |--- Parse a proper name for a data constructor.---+-- | Parse a proper name for a data constructor. dataConstructorName :: TokenParser (ProperName 'ConstructorName) dataConstructorName = ProperName <$> dconsname --- |--- Parse a module name---+-- | Parse a module name moduleName :: TokenParser ModuleName moduleName = part []   where@@ -55,9 +42,7 @@               <|> (ModuleName . snoc path . ProperName <$> mname)   snoc path name = path ++ [name] --- |--- Parse a qualified name, i.e. M.name or just name---+-- | Parse a qualified name, i.e. M.name or just name parseQualified :: TokenParser a -> TokenParser (Qualified a) parseQualified parser = part []   where@@ -67,42 +52,30 @@   updatePath path name = path ++ [name]   qual path = if null path then Nothing else Just $ ModuleName path --- |--- Parse an identifier.---+-- | Parse an identifier. parseIdent :: TokenParser Ident parseIdent = Ident <$> identifier --- |--- Parse a label, which may look like an identifier or a string---+-- | Parse a label, which may look like an identifier or a string parseLabel :: TokenParser PSString parseLabel = (mkString <$> lname) <|> stringLiteral --- |--- Parse an operator.---+-- | Parse an operator. parseOperator :: TokenParser (OpName a) parseOperator = OpName <$> symbol --- |--- Run the first parser, then match the second if possible, applying the specified function on a successful match---+-- | Run the first parser, then match the second if possible, applying the specified function on a successful match augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q --- |--- Run the first parser, then match the second zero or more times, applying the specified function for each match---+-- | Run the first parser, then match the second zero or more times, applying the specified function for each match fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a fold first' more combine = do   a <- first'   bs <- P.many more   return $ foldl combine a bs --- |--- Build a parser from a smaller parser and a list of parsers for postfix operators---+-- | Build a parser from a smaller parser and a list of parsers for postfix operators buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a buildPostfixParser fs first' = do   a <- first'@@ -114,9 +87,7 @@       Nothing -> return a       Just a' -> go a' --- |--- Mark the current indentation level---+-- | Mark the current indentation level mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a mark p = do   current <- indentationLevel <$> P.getState@@ -126,9 +97,7 @@   P.modifyState $ \st -> st { indentationLevel = current }   return a --- |--- Check that the current identation level matches a predicate---+-- | Check that the current identation level matches a predicate checkIndentation   :: (P.Column -> Text)   -> (P.Column -> P.Column -> Bool)@@ -138,32 +107,39 @@   current <- indentationLevel <$> P.getState   guard (col `rel` current) P.<?> T.unpack (mkMsg current) --- |--- Check that the current indentation level is past the current mark---+-- | Check that the current indentation level is past the current mark indented :: P.Parsec s ParseState () indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>) --- |--- Check that the current indentation level is at the same indentation as the current mark---+-- | Check that the current indentation level is at the same indentation as the current mark same :: P.Parsec s ParseState () same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==) --- |--- Read the comments from the the next token, without consuming it---+-- | Read the comments from the the next token, without consuming it readComments :: P.Parsec [PositionedToken] u [Comment] readComments = P.lookAhead $ ptComments <$> P.anyToken --- |--- Run a parser---+-- | Run a parser runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a runTokenParser filePath p = P.runParser p (ParseState 0) filePath --- |--- Convert from Parsec sourcepos---+-- | Convert from Parsec sourcepos toSourcePos :: P.SourcePos -> SourcePos toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)++-- | Read source position information and comments+withSourceSpan+  :: (SourceSpan -> [Comment] -> a -> b)+  -> P.Parsec [PositionedToken] u a+  -> P.Parsec [PositionedToken] u b+withSourceSpan f p = do+  start <- P.getPosition+  comments <- readComments+  x <- p+  end <- P.getPosition+  input <- P.getInput+  let end' = case input of+        pt:_ -> ptPrevEndPos pt+        _ -> Nothing+  let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos $ fromMaybe end end')+  return $ f sp comments x