summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-07-11 15:26:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-07-11 15:26:00 (GMT)
commit72ab68866f2cbf61810e650b8c4025cca1eab66c (patch)
treec953e7a0354e707ae88801784ec29c35fc8531a9
parent0f4090890a1b18cff078fbd427318c6848097703 (diff)
version 0.9.20.9.2
-rw-r--r--CONTRIBUTORS.md1
-rw-r--r--LICENSE280
-rw-r--r--psc-bundle/Main.hs10
-rw-r--r--psc-ide-client/Main.hs22
-rw-r--r--psc-ide-server/Main.hs75
-rw-r--r--psci/Main.hs286
-rw-r--r--psci/static/index.html10
-rw-r--r--psci/static/index.js63
-rw-r--r--purescript.cabal48
-rw-r--r--src/Language/PureScript/AST/Declarations.hs21
-rw-r--r--src/Language/PureScript/Bundle.hs11
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs4
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs2
-rw-r--r--src/Language/PureScript/Constants.hs3
-rw-r--r--src/Language/PureScript/Docs/ParseAndBookmark.hs2
-rw-r--r--src/Language/PureScript/Errors.hs47
-rw-r--r--src/Language/PureScript/Ide.hs307
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs54
-rw-r--r--src/Language/PureScript/Ide/Command.hs29
-rw-r--r--src/Language/PureScript/Ide/Completion.hs34
-rw-r--r--src/Language/PureScript/Ide/Conversions.hs35
-rw-r--r--src/Language/PureScript/Ide/Error.hs20
-rw-r--r--src/Language/PureScript/Ide/Externs.hs125
-rw-r--r--src/Language/PureScript/Ide/Filter.hs67
-rw-r--r--src/Language/PureScript/Ide/Imports.hs88
-rw-r--r--src/Language/PureScript/Ide/Matcher.hs58
-rw-r--r--src/Language/PureScript/Ide/Pursuit.hs21
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs34
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs157
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs161
-rw-r--r--src/Language/PureScript/Ide/State.hs265
-rw-r--r--src/Language/PureScript/Ide/Types.hs174
-rw-r--r--src/Language/PureScript/Ide/Util.hs104
-rw-r--r--src/Language/PureScript/Ide/Watcher.hs18
-rw-r--r--src/Language/PureScript/Interactive.hs86
-rw-r--r--src/Language/PureScript/Interactive/Types.hs1
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs4
-rw-r--r--src/Language/PureScript/Linter/Imports.hs3
-rw-r--r--src/Language/PureScript/Make.hs4
-rw-r--r--src/Language/PureScript/Parser/Common.hs2
-rw-r--r--src/Language/PureScript/Pretty/Common.hs2
-rw-r--r--src/Language/PureScript/Publish.hs1
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs2
-rw-r--r--src/Language/PureScript/Sugar/Names.hs55
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs2
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs3
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs3
-rw-r--r--src/Language/PureScript/TypeChecker.hs16
-rw-r--r--src/Language/PureScript/TypeChecker/Rows.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs4
-rw-r--r--stack.yaml7
-rw-r--r--tests/Language/PureScript/Ide/FilterSpec.hs53
-rw-r--r--tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs39
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs18
-rw-r--r--tests/Language/PureScript/Ide/Integration.hs150
-rw-r--r--tests/Language/PureScript/Ide/MatcherSpec.hs33
-rw-r--r--tests/Language/PureScript/Ide/RebuildSpec.hs16
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs125
-rw-r--r--tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs36
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs46
-rw-r--r--tests/Language/PureScript/IdeSpec.hs35
-rw-r--r--tests/TestUtils.hs11
-rw-r--r--tests/support/pscide/src/ImportsSpec.purs4
-rw-r--r--tests/support/pscide/src/MatcherSpec.purs (renamed from tests/support/pscide/src/Main.purs)2
-rw-r--r--tests/support/pscide/src/RebuildSpecSingleModule.purs2
-rw-r--r--tests/support/pscide/src/RebuildSpecWithForeign.js2
-rw-r--r--tests/support/pscide/src/SourceFileSpec.purs10
68 files changed, 2037 insertions, 1382 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 057000d..d6ec3ec 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -72,6 +72,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, 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).
- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, 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).
- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, 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).
+- - [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, 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
diff --git a/LICENSE b/LICENSE
index be37ddb..e6ad9e7 100644
--- a/LICENSE
+++ b/LICENSE
@@ -46,6 +46,7 @@ PureScript uses the following Haskell library packages. Their license files foll
bytestring-builder
case-insensitive
cereal
+ clock
conduit
conduit-extra
connection
@@ -56,8 +57,10 @@ PureScript uses the following Haskell library packages. Their license files foll
deepseq
directory
dlist
+ easy-file
edit-distance
exceptions
+ fail
fast-logger
filepath
fsnotify
@@ -82,6 +85,7 @@ PureScript uses the following Haskell library packages. Their license files foll
network
network-uri
old-locale
+ old-time
optparse-applicative
parallel
parsec
@@ -91,6 +95,7 @@ PureScript uses the following Haskell library packages. Their license files foll
pipes-http
primitive
process
+ protolude
random
regex-base
regex-tdfa
@@ -105,6 +110,7 @@ PureScript uses the following Haskell library packages. Their license files foll
stm
stm-chans
streaming-commons
+ string-conv
syb
tagged
template-haskell
@@ -117,6 +123,7 @@ PureScript uses the following Haskell library packages. Their license files foll
transformers-compat
unix
unix-compat
+ unix-time
unordered-containers
utf8-string
vector
@@ -955,6 +962,41 @@ cereal LICENSE file:
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
+ Copyright (c) 2010, Eugene Kirpichov
+
+ 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.
+
+ * The names of contributors may not 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.
+
conduit LICENSE file:
Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
@@ -1142,16 +1184,16 @@ data-default-class LICENSE file:
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
+ 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 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.
+ 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.
deepseq LICENSE file:
@@ -1295,6 +1337,38 @@ dlist LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+easy-file LICENSE file:
+
+ Copyright (c) 2009, IIJ Innovation Institute Inc.
+ 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 copyright holders nor the names of its
+ 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.
+
edit-distance LICENSE file:
Copyright (c) 2008-2013 Maximilian Bolingbroke
@@ -1354,6 +1428,39 @@ exceptions LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+fail LICENSE file:
+
+ Copyright (c) 2015, David Luposchainsky & Herbert Valerio Riedel
+
+ 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 Herbert Valerio Riedel 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.
+
fast-logger LICENSE file:
Copyright (c) 2009, IIJ Innovation Institute Inc.
@@ -2122,6 +2229,72 @@ old-locale LICENSE file:
-----------------------------------------------------------------------------
+old-time LICENSE file:
+
+ This library (libraries/base) is derived from code from two
+ sources:
+
+ * Code from the GHC project which is largely (c) The University of
+ Glasgow, and distributable under a BSD-style license (see below),
+
+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
+ and freely redistributable (but see the full license for
+ restrictions).
+
+ The full text of these licenses is reproduced below. Both of the
+ licenses are BSD-style or compatible.
+
+ -----------------------------------------------------------------------------
+
+ The Glasgow Haskell Compiler License
+
+ Copyright 2004, The University Court of the University of Glasgow.
+ 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 name of the University nor the names of its contributors may be
+ used to endorse or promote products derived from this software without
+ specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+ GLASGOW AND THE 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
+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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.
+
+ -----------------------------------------------------------------------------
+
+ Code derived from the document "Report on the Programming Language
+ Haskell 98", is distributed under the following license:
+
+ Copyright (c) 2002 Simon Peyton Jones
+
+ The authors intend this Report to belong to the entire Haskell
+ community, and so we grant permission to copy and distribute it for
+ any purpose, provided that it is reproduced in its entirety,
+ including this Notice. Modified versions of this Report may also be
+ copied and distributed for any purpose, provided that the modified
+ version is clearly presented as such, and that it does not claim to
+ be a definition of the Haskell 98 Language.
+
+ -----------------------------------------------------------------------------
+
optparse-applicative LICENSE file:
Copyright (c) 2012, Paolo Capriotti
@@ -2276,7 +2449,7 @@ pem LICENSE file:
pipes LICENSE file:
- Copyright (c) 2012-2014 Gabriel Gonzalez
+ Copyright (c) 2012-2016 Gabriel Gonzalez
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
@@ -2427,6 +2600,28 @@ process LICENSE file:
-----------------------------------------------------------------------------
+protolude LICENSE file:
+
+ Copyright (c) 2016, Stephen Diehl
+
+ Permission is hereby granted, free of charge, to any person obtaining a copy
+ of this software and associated documentation files (the "Software"), to
+ deal in the Software without restriction, including without limitation the
+ rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+ sell copies of the Software, and to permit persons to whom the Software is
+ furnished to do so, subject to the following conditions:
+
+ The above copyright notice and this permission notice shall be included in
+ all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+ IN THE SOFTWARE.
+
random LICENSE file:
This library (libraries/base) is derived from code from two
@@ -2873,6 +3068,39 @@ streaming-commons LICENSE file:
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
+string-conv LICENSE file:
+
+ Copyright (c) 2012, Ozgun Ataman
+
+ 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 Ozgun Ataman 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.
+
syb LICENSE file:
This library (libraries/syb) is derived from code from several
@@ -3289,6 +3517,38 @@ unix-compat LICENSE file:
(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-time LICENSE file:
+
+ Copyright (c) 2009, IIJ Innovation Institute Inc.
+ 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 copyright holders nor the names of its
+ 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.
+
unordered-containers LICENSE file:
Copyright (c) 2010, Johan Tibell
diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs
index 5e21484..92ff4f2 100644
--- a/psc-bundle/Main.hs
+++ b/psc-bundle/Main.hs
@@ -15,7 +15,7 @@ import Control.Monad.Error.Class
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
-import System.FilePath (takeFileName, takeDirectory)
+import System.FilePath (takeDirectory)
import System.FilePath.Glob (glob)
import System.Exit (exitFailure)
import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8)
@@ -37,14 +37,6 @@ data Options = Options
, optionsNamespace :: String
} deriving Show
--- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.
-guessModuleIdentifier :: (MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier
-guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename)
- where
- guessModuleType "index.js" = pure Regular
- guessModuleType "foreign.js" = pure Foreign
- guessModuleType name = throwError $ UnsupportedModulePath name
-
-- | The main application function.
-- This function parses the input files, performs dead code elimination, filters empty modules
-- and generates and prints the final Javascript bundle.
diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs
index 79532e5..ec4c761 100644
--- a/psc-ide-client/Main.hs
+++ b/psc-ide-client/Main.hs
@@ -5,16 +5,15 @@ import Prelude ()
import Prelude.Compat
import Control.Exception
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Data.Version (showVersion)
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Text.IO as T
+import Data.Version (showVersion)
import Network
import Options.Applicative
import System.Exit
import System.IO
-import qualified Paths_purescript as Paths
+import qualified Paths_purescript as Paths
data Options = Options
{ optionsPort :: PortID
@@ -41,16 +40,7 @@ client port = do
("Couldn't connect to psc-ide-server on port: " ++
show port ++ " Error: " ++ show e) >>
exitFailure)
- cmd <- T.getLine
- -- Temporary fix for emacs windows bug
- let cleanedCmd = removeSurroundingTicks cmd
- --
- T.hPutStrLn h cleanedCmd
- res <- T.hGetLine h
- putStrLn (T.unpack res)
+ T.hPutStrLn h =<< T.getLine
+ BS8.putStrLn =<< BS8.hGetLine h
hFlush stdout
hClose h
-
--- TODO: Fix this in the emacs plugin by using a real process over shellcommands
-removeSurroundingTicks :: Text -> Text
-removeSurroundingTicks = T.dropWhile (== '\'') . T.dropWhileEnd (== '\'')
diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs
index e7fbdca..ce51302 100644
--- a/psc-ide-server/Main.hs
+++ b/psc-ide-server/Main.hs
@@ -17,22 +17,17 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoImplicitPrelude #-}
module Main where
-import Prelude ()
-import Prelude.Compat
+import Protolude
-import Control.Concurrent (forkFinally)
+import qualified Data.Aeson as Aeson
import Control.Concurrent.STM
-import Control.Exception (bracketOnError, catchJust)
-import Control.Monad
-import Control.Monad.Error.Class
import "monad-logger" Control.Monad.Logger
-import Control.Monad.Reader
-import Control.Monad.Trans.Except
-import qualified Data.Text as T
import qualified Data.Text.IO as T
+import qualified Data.ByteString.Lazy.Char8 as BS8
import Data.Version (showVersion)
import Language.PureScript.Ide
import Language.PureScript.Ide.Util
@@ -43,19 +38,16 @@ import Network hiding (socketPort, accept)
import Network.BSD (getProtocolNumber)
import Network.Socket hiding (PortNumber, Type,
sClose)
-import Options.Applicative
+import Options.Applicative hiding ((<>))
import System.Directory
import System.FilePath
-import System.IO
+import System.IO hiding (putStrLn, print)
import System.IO.Error (isEOFError)
import qualified Paths_purescript as Paths
--- "Borrowed" from the Idris Compiler
--- Copied from upstream impl of listenOn
--- bound to localhost interface instead of iNADDR_ANY
-listenOnLocalhost :: PortID -> IO Socket
-listenOnLocalhost (PortNumber port) = do
+listenOnLocalhost :: PortNumber -> IO Socket
+listenOnLocalhost port = do
proto <- getProtocolNumber "tcp"
localhost <- inet_addr "127.0.0.1"
bracketOnError
@@ -66,59 +58,59 @@ listenOnLocalhost (PortNumber port) = do
bindSocket sock (SockAddrInet port localhost)
listen sock maxListenQueue
pure sock)
-listenOnLocalhost _ = error "Wrong Porttype"
data Options = Options
{ optionsDirectory :: Maybe FilePath
+ , optionsGlobs :: [FilePath]
, optionsOutputPath :: FilePath
- , optionsPort :: PortID
+ , optionsPort :: PortNumber
, optionsNoWatch :: Bool
, optionsDebug :: Bool
}
main :: IO ()
main = do
- Options dir outputPath port noWatch debug <- execParser opts
+ Options dir globs outputPath port noWatch debug <- execParser opts
maybe (pure ()) setCurrentDirectory dir
- serverState <- newTVarIO emptyPscIdeState
+ ideState <- newTVarIO emptyIdeState
cwd <- getCurrentDirectory
let fullOutputPath = cwd </> outputPath
- doesDirectoryExist fullOutputPath
- >>= flip unless
- (do putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath)
- createDirectory fullOutputPath
- putStrLn "This usually means you didn't compile your project yet."
- putStrLn "psc-ide needs you to compile your project (for example by running pulp build)")
+ unlessM (doesDirectoryExist fullOutputPath) $ do
+ putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath)
+ createDirectory fullOutputPath
+ putText "This usually means you didn't compile your project yet."
+ putText "psc-ide needs you to compile your project (for example by running pulp build)"
unless noWatch $
- void (forkFinally (watcher serverState fullOutputPath) print)
+ void (forkFinally (watcher ideState fullOutputPath) print)
- let conf = Configuration {confDebug = debug, confOutputPath = outputPath}
- env = PscIdeEnvironment {envStateVar = serverState, envConfiguration = conf}
+ let conf = Configuration {confDebug = debug, confOutputPath = outputPath, confGlobs = globs}
+ env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}
startServer port env
where
parser =
Options
- <$> optional (strOption (long "directory" <> short 'd'))
- <*> strOption (long "output-directory" <> value "output/")
- <*> (PortNumber . fromIntegral <$>
- option auto (long "port" <> short 'p' <> value (4242 :: Integer)))
+ <$> optional (strOption (long "directory" `mappend` short 'd'))
+ <*> many (argument str (metavar "Source GLOBS..."))
+ <*> strOption (long "output-directory" `mappend` value "output/")
+ <*> (fromIntegral <$>
+ option auto (long "port" `mappend` short 'p' `mappend` value (4242 :: Integer)))
<*> switch (long "no-watch")
<*> switch (long "debug")
opts = info (version <*> helper <*> parser) mempty
version = abortOption
(InfoMsg (showVersion Paths.version))
- (long "version" <> help "Show the version number")
+ (long "version" `mappend` help "Show the version number")
-startServer :: PortID -> PscIdeEnvironment -> IO ()
+startServer :: PortNumber -> IdeEnvironment -> IO ()
startServer port env = withSocketsDo $ do
sock <- listenOnLocalhost port
runLogger (runReaderT (forever (loop sock)) env)
where
- runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (envConfiguration env))
+ runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (ideConfiguration env))
- loop :: (PscIde m, MonadLogger m) => Socket -> m ()
+ loop :: (Ide m, MonadLogger m) => Socket -> m ()
loop sock = do
accepted <- runExceptT $ acceptCommand sock
case accepted of
@@ -130,9 +122,8 @@ startServer port env = withSocketsDo $ do
-- $(logDebug) ("Answer was: " <> T.pack (show result))
liftIO (hFlush stdout)
case result of
- -- What function can I use to clean this up?
- Right r -> liftIO $ T.hPutStrLn h (encodeT r)
- Left err -> liftIO $ T.hPutStrLn h (encodeT err)
+ Right r -> liftIO $ BS8.hPutStrLn h (Aeson.encode r)
+ Left err -> liftIO $ BS8.hPutStrLn h (Aeson.encode err)
Nothing -> do
$(logDebug) ("Parsing the command failed. Command: " <> cmd)
liftIO $ do
@@ -141,8 +132,8 @@ startServer port env = withSocketsDo $ do
liftIO (hClose h)
-acceptCommand :: (MonadIO m, MonadLogger m, MonadError T.Text m)
- => Socket -> m (T.Text, Handle)
+acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)
+ => Socket -> m (Text, Handle)
acceptCommand sock = do
h <- acceptConnection
$(logDebug) "Accepted a connection"
diff --git a/psci/Main.hs b/psci/Main.hs
index e41723e..8dc6c9d 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -1,9 +1,13 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Main (main) where
@@ -11,10 +15,22 @@ module Main (main) where
import Prelude ()
import Prelude.Compat
+import Data.FileEmbed (embedStringFile)
import Data.Monoid ((<>))
+import Data.String (IsString(..))
+import Data.Text (Text, unpack)
+import Data.Traversable (for)
import Data.Version (showVersion)
-import Control.Applicative (many)
+import Control.Applicative (many, (<|>))
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar,
+ tryPutMVar)
+import Control.Concurrent.STM (TVar, atomically, newTVarIO, writeTVar,
+ readTVarIO,
+ TChan, newBroadcastTChanIO, dupTChan,
+ readTChan, writeTChan)
+import Control.Exception (fromException)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class
@@ -23,21 +39,33 @@ import Control.Monad.Trans.State.Strict (StateT, evalStateT)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import qualified Language.PureScript as P
+import qualified Language.PureScript.Bundle as Bundle
import Language.PureScript.Interactive
+import Network.HTTP.Types.Header (hContentType, hCacheControl,
+ hPragma, hExpires)
+import Network.HTTP.Types.Status (status200, status404, status503)
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Network.Wai.Handler.WebSockets as WS
+import qualified Network.WebSockets as WS
+
import qualified Options.Applicative as Opts
import qualified Paths_purescript as Paths
import System.Console.Haskeline
+import System.IO.UTF8 (readUTF8File)
import System.Exit
+import System.FilePath ((</>))
import System.FilePath.Glob (glob)
+import System.Process (readProcessWithExitCode)
-- | Command line options
data PSCiOptions = PSCiOptions
{ psciMultiLineMode :: Bool
, psciInputFile :: [FilePath]
- , psciInputNodeFlags :: [String]
+ , psciBackend :: Backend
}
multiLineMode :: Opts.Parser Bool
@@ -60,10 +88,21 @@ nodeFlagsFlag = Opts.option parser $
where
parser = words <$> Opts.str
+port :: Opts.Parser Int
+port = Opts.option Opts.auto $
+ Opts.long "port"
+ <> Opts.short 'p'
+ <> Opts.help "The web server port"
+
+backend :: Opts.Parser Backend
+backend =
+ (browserBackend <$> port)
+ <|> (nodeBackend <$> nodeFlagsFlag)
+
psciOptions :: Opts.Parser PSCiOptions
psciOptions = PSCiOptions <$> multiLineMode
<*> many inputFile
- <*> nodeFlagsFlag
+ <*> backend
version :: Opts.Parser (a -> a)
version = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $
@@ -92,6 +131,195 @@ getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
go :: [String] -> InputT m String
go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
+-- | Make a JavaScript bundle for the browser.
+bundle :: IO (Either Bundle.ErrorMessage String)
+bundle = runExceptT $ do
+ inputFiles <- liftIO (glob (".psci_modules" </> "node_modules" </> "*" </> "*.js"))
+ input <- for inputFiles $ \filename -> do
+ js <- liftIO (readUTF8File filename)
+ mid <- Bundle.guessModuleIdentifier filename
+ length js `seq` return (mid, js)
+ Bundle.bundle input [] Nothing "PSCI"
+
+indexJS :: IsString string => string
+indexJS = $(embedStringFile "psci/static/index.js")
+
+indexPage :: IsString string => string
+indexPage = $(embedStringFile "psci/static/index.html")
+
+-- | All of the functions required to implement a PSCi backend
+data Backend = forall state. Backend
+ { _backendSetup :: IO state
+ -- ^ Initialize, and call the continuation when the backend is ready
+ , _backendEval :: state -> String -> IO ()
+ -- ^ Evaluate JavaScript code
+ , _backendReload :: state -> IO ()
+ -- ^ Reload the compiled code
+ , _backendShutdown :: state -> IO ()
+ -- ^ Shut down the backend
+ }
+
+-- | Commands which can be sent to the browser
+data BrowserCommand
+ = Eval (MVar String)
+ -- ^ Evaluate the latest JS
+ | Reload
+ -- ^ Reload the page
+
+-- | State for the browser backend
+data BrowserState = BrowserState
+ { browserCommands :: TChan BrowserCommand
+ -- ^ A channel which receives data when the compiled JS has
+ -- been updated
+ , browserShutdownNotice :: MVar ()
+ -- ^ An MVar which becomes full when the server should shut down
+ , browserIndexJS :: TVar (Maybe String)
+ -- ^ A TVar holding the latest compiled JS
+ , browserBundleJS :: TVar (Maybe String)
+ -- ^ A TVar holding the latest bundled JS
+ }
+
+browserBackend :: Int -> Backend
+browserBackend serverPort = Backend setup evaluate reload shutdown
+ where
+ setup :: IO BrowserState
+ setup = do
+ shutdownVar <- newEmptyMVar
+ cmdChan <- newBroadcastTChanIO
+ indexJs <- newTVarIO Nothing
+ bundleJs <- newTVarIO Nothing
+
+ let
+ handleWebsocket :: WS.PendingConnection -> IO ()
+ handleWebsocket pending = do
+ conn <- WS.acceptRequest pending
+ -- Fork a thread to keep the connection alive
+ WS.forkPingThread conn 10
+ -- Clone the command channel
+ cmdChanCopy <- atomically $ dupTChan cmdChan
+ -- Listen for commands
+ forever $ do
+ cmd <- atomically $ readTChan cmdChanCopy
+ case cmd of
+ Eval resultVar -> void $ do
+ WS.sendTextData conn ("eval" :: Text)
+ result <- WS.receiveData conn
+ -- With many connected clients, all but one of
+ -- these attempts will fail.
+ tryPutMVar resultVar (unpack result)
+ Reload -> do
+ WS.sendTextData conn ("reload" :: Text)
+
+ shutdownHandler :: IO () -> IO ()
+ shutdownHandler stopServer = void . forkIO $ do
+ () <- takeMVar shutdownVar
+ stopServer
+
+ onException :: Maybe Wai.Request -> SomeException -> IO ()
+ onException req ex
+ | Just (_ :: WS.ConnectionException) <- fromException ex
+ = return () -- ignore websocket disconnects
+ | otherwise = Warp.defaultOnException req ex
+
+ staticServer :: Wai.Application
+ staticServer req respond =
+ case Wai.pathInfo req of
+ [] ->
+ respond $ Wai.responseLBS status200
+ [(hContentType, "text/html")]
+ indexPage
+ ["js", "index.js"] ->
+ respond $ Wai.responseLBS status200
+ [(hContentType, "application/javascript")]
+ indexJS
+ ["js", "latest.js"] -> do
+ may <- readTVarIO indexJs
+ case may of
+ Nothing ->
+ respond $ Wai.responseLBS status503 [] "Service not available"
+ Just js ->
+ respond $ Wai.responseLBS status200
+ [ (hContentType, "application/javascript")
+ , (hCacheControl, "no-cache, no-store, must-revalidate")
+ , (hPragma, "no-cache")
+ , (hExpires, "0")
+ ]
+ (fromString js)
+ ["js", "bundle.js"] -> do
+ may <- readTVarIO bundleJs
+ case may of
+ Nothing ->
+ respond $ Wai.responseLBS status503 [] "Service not available"
+ Just js ->
+ respond $ Wai.responseLBS status200
+ [ (hContentType, "application/javascript")]
+ (fromString js)
+ _ -> respond $ Wai.responseLBS status404 [] "Not found"
+
+ let browserState = BrowserState cmdChan shutdownVar indexJs bundleJs
+ createBundle browserState
+
+ putStrLn $ "Serving http://localhost:" <> show serverPort <> "/. Waiting for connections..."
+ _ <- forkIO $ Warp.runSettings ( Warp.setInstallShutdownHandler shutdownHandler
+ . Warp.setPort serverPort
+ . Warp.setOnException onException
+ $ Warp.defaultSettings
+ ) $
+ WS.websocketsOr WS.defaultConnectionOptions
+ handleWebsocket
+ staticServer
+ return browserState
+
+ createBundle :: BrowserState -> IO ()
+ createBundle state = do
+ putStrLn "Bundling Javascript..."
+ ejs <- bundle
+ case ejs of
+ Left err -> do
+ putStrLn (unlines (Bundle.printErrorMessage err))
+ exitFailure
+ Right js -> do
+ atomically $ writeTVar (browserBundleJS state) (Just js)
+
+ reload :: BrowserState -> IO ()
+ reload state = do
+ createBundle state
+ atomically $ writeTChan (browserCommands state) Reload
+
+ shutdown :: BrowserState -> IO ()
+ shutdown state = putMVar (browserShutdownNotice state) ()
+
+ evaluate :: BrowserState -> String -> IO ()
+ evaluate state js = liftIO $ do
+ resultVar <- newEmptyMVar
+ atomically $ do
+ writeTVar (browserIndexJS state) (Just js)
+ writeTChan (browserCommands state) (Eval resultVar)
+ result <- takeMVar resultVar
+ putStrLn result
+
+nodeBackend :: [String] -> Backend
+nodeBackend nodeArgs = Backend setup eval reload shutdown
+ where
+ setup :: IO ()
+ setup = return ()
+
+ eval :: () -> String -> IO ()
+ eval _ _ = do
+ writeFile indexFile "require('$PSCI')['$main']();"
+ process <- findNodeProcess
+ result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process
+ case result of
+ Just (ExitSuccess, out, _) -> putStrLn out
+ Just (ExitFailure _, _, err) -> putStrLn err
+ Nothing -> putStrLn "Couldn't find node.js"
+
+ reload :: () -> IO ()
+ reload _ = return ()
+
+ shutdown :: () -> IO ()
+ shutdown _ = return ()
+
-- | Get command line options and drop into the REPL
main :: IO ()
main = getOpt >>= loop
@@ -106,27 +334,31 @@ main = getOpt >>= loop
exitFailure
(externs, env) <- ExceptT . runMake . make $ modules
return (modules, externs, env)
- case e of
- Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
- Right (modules, externs, env) -> do
- historyFilename <- getHistoryFilename
- let settings = defaultSettings { historyFile = Just historyFilename }
- initialState = PSCiState [] [] (zip (map snd modules) externs)
- config = PSCiConfig inputFiles psciInputNodeFlags env
- runner = flip runReaderT config
- . flip evalStateT initialState
- . runInputT (setComplete completion settings)
- putStrLn prologueMessage
- runner go
- where
- go :: InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()
- go = do
- c <- getCommand (not psciMultiLineMode)
- case c of
- Left err -> outputStrLn err >> go
- Right Nothing -> go
- Right (Just QuitPSCi) -> outputStrLn quitMessage
- Right (Just c') -> do
- handleInterrupt (outputStrLn "Interrupted.")
- (withInterrupt (lift (handleCommand c')))
- go
+ case psciBackend of
+ Backend setup eval reload (shutdown :: state -> IO ()) -> do
+ case e of
+ Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
+ Right (modules, externs, env) -> do
+ historyFilename <- getHistoryFilename
+ let settings = defaultSettings { historyFile = Just historyFilename }
+ initialState = PSCiState [] [] (zip (map snd modules) externs)
+ config = PSCiConfig inputFiles env
+ runner = flip runReaderT config
+ . flip evalStateT initialState
+ . runInputT (setComplete completion settings)
+
+ go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()
+ go state = do
+ c <- getCommand (not psciMultiLineMode)
+ case c of
+ Left err -> outputStrLn err >> go state
+ Right Nothing -> go state
+ Right (Just QuitPSCi) -> do
+ outputStrLn quitMessage
+ liftIO $ shutdown state
+ Right (Just c') -> do
+ handleInterrupt (outputStrLn "Interrupted.")
+ (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) c')))
+ go state
+ putStrLn prologueMessage
+ setup >>= runner . go
diff --git a/psci/static/index.html b/psci/static/index.html
new file mode 100644
index 0000000..f749b8a
--- /dev/null
+++ b/psci/static/index.html
@@ -0,0 +1,10 @@
+<!DOCTYPE html>
+<html>
+<head>
+ <title>PureScript Interactive</title>
+ <script src='js/bundle.js'></script>
+ <script src='js/index.js'></script>
+</head>
+<body>
+</body>
+</html>
diff --git a/psci/static/index.js b/psci/static/index.js
new file mode 100644
index 0000000..08b5f1e
--- /dev/null
+++ b/psci/static/index.js
@@ -0,0 +1,63 @@
+var get = function get(uri, callback, onError) {
+ var request = new XMLHttpRequest();
+ request.addEventListener('load', function() {
+ callback(request.responseText);
+ });
+ request.addEventListener('error', onError);
+ request.open('GET', uri);
+ request.send();
+};
+var evaluate = function evaluate(js) {
+ var buffer = [];
+ // Save the old console.log function
+ var oldLog = console.log;
+ console.log = function(s) {
+ // Push log output into a temporary buffer
+ // which will be returned to PSCi.
+ buffer.push(s);
+ };
+ // Replace any require(...) statements with lookups on the PSCI object.
+ var replaced = js.replace(/require\("[^"]*"\)/g, function(s) {
+ return "PSCI['" + s.substring(12, s.length - 2) + "']";
+ });
+ // Wrap the module and evaluate it.
+ var wrapped =
+ [ 'var module = {};'
+ , '(function(module) {'
+ , replaced
+ , '})(module);'
+ , 'return module.exports["$main"] && module.exports["$main"]();'
+ ].join('\n');
+ new Function(wrapped)();
+ // Restore console.log
+ console.log = oldLog;
+ return buffer.join('\n');
+};
+window.onload = function() {
+ var socket = new WebSocket('ws://0.0.0.0:' + location.port);
+ var evalNext = function reload() {
+ get('js/latest.js', function(response) {
+ try {
+ var result = evaluate(response);
+ socket.send(result);
+ } catch (ex) {
+ socket.send(ex.stack);
+ }
+ }, function(err) {
+ socket.send('Error sending JavaScript');
+ });
+ };
+ socket.onopen = function() {
+ console.log('Connected');
+ socket.onmessage = function(event) {
+ switch (event.data) {
+ case 'eval':
+ evalNext();
+ break;
+ case 'reload':
+ location.reload();
+ break;
+ }
+ };
+ };
+};
diff --git a/purescript.cabal b/purescript.cabal
index eceddd6..904a85b 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.9.1
+version: 0.9.2
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -79,6 +79,8 @@ extra-source-files: examples/passing/*.purs
, examples/docs/bower_components/purescript-prelude/src/*.purs
, examples/docs/bower.json
, examples/docs/src/*.purs
+ , psci/static/index.html
+ , psci/static/index.js
, tests/support/package.json
, tests/support/bower.json
, tests/support/setup-win.cmd
@@ -106,6 +108,7 @@ library
boxes >= 0.1.4 && < 0.2.0,
bytestring -any,
containers -any,
+ clock -any,
directory >= 1.2,
dlist -any,
edit-distance -any,
@@ -122,9 +125,10 @@ library
parallel >= 3.2 && < 3.3,
parsec >=3.1.10,
pattern-arrows >= 0.0.2 && < 0.1,
- pipes >= 4.0.0 && < 4.2.0,
+ pipes >= 4.0.0 && < 4.3.0,
pipes-http -any,
process >= 1.2.0 && < 1.5,
+ protolude >= 0.1.5,
regex-tdfa -any,
safe >= 0.3.9 && < 0.4,
semigroups >= 0.16.2 && < 0.19,
@@ -251,22 +255,23 @@ library
Language.PureScript.Publish.BoxesHelpers
Language.PureScript.Ide
+ 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.Pursuit
- Language.PureScript.Ide.Completion
- Language.PureScript.Ide.Matcher
+ Language.PureScript.Ide.Imports
Language.PureScript.Ide.Filter
- Language.PureScript.Ide.Types
- Language.PureScript.Ide.State
- Language.PureScript.Ide.CaseSplit
- Language.PureScript.Ide.SourceFile
- Language.PureScript.Ide.Watcher
+ Language.PureScript.Ide.Matcher
+ Language.PureScript.Ide.Pursuit
+ Language.PureScript.Ide.Rebuild
Language.PureScript.Ide.Reexports
- Language.PureScript.Ide.Imports
+ Language.PureScript.Ide.SourceFile
+ Language.PureScript.Ide.State
+ Language.PureScript.Ide.Types
Language.PureScript.Ide.Util
- Language.PureScript.Ide.Rebuild
+ Language.PureScript.Ide.Watcher
Language.PureScript.Interactive
Language.PureScript.Interactive.Types
@@ -335,18 +340,27 @@ executable psci
purescript -any,
base-compat >=0.6.0,
boxes >= 0.1.4 && < 0.2.0,
+ bytestring -any,
containers -any,
directory -any,
filepath -any,
+ file-embed -any,
Glob -any,
haskeline >= 0.7.0.0,
+ http-types == 0.9.*,
mtl -any,
optparse-applicative >= 0.12.1,
parsec -any,
process -any,
+ stm >= 0.2.4.0,
+ text -any,
time -any,
transformers -any,
- transformers-compat -any
+ transformers-compat -any,
+ wai == 3.*,
+ wai-websockets == 3.*,
+ warp == 3.*,
+ websockets >= 0.9 && <0.10
main-is: Main.hs
buildable: True
hs-source-dirs: psci
@@ -425,6 +439,8 @@ executable psc-ide-server
other-modules: Paths_purescript
other-extensions:
build-depends: base >=4 && <5,
+ aeson >= 0.8 && < 0.12,
+ bytestring -any,
purescript -any,
base-compat >=0.6.0,
directory -any,
@@ -433,6 +449,7 @@ executable psc-ide-server
mtl -any,
network -any,
optparse-applicative >= 0.12.1,
+ protolude >= 0.1.5,
stm -any,
text -any,
transformers -any,
@@ -446,6 +463,7 @@ executable psc-ide-client
other-extensions:
build-depends: base >=4 && <5,
base-compat >=0.6.0,
+ bytestring -any,
mtl -any,
network -any,
optparse-applicative >= 0.12.1,
@@ -473,6 +491,7 @@ test-suite tests
optparse-applicative -any,
parsec -any,
process -any,
+ protolude >= 0.1.5,
silently -any,
stm -any,
text -any,
@@ -498,6 +517,7 @@ test-suite tests
Language.PureScript.Ide.MatcherSpec
Language.PureScript.Ide.RebuildSpec
Language.PureScript.Ide.ReexportsSpec
- Language.PureScript.IdeSpec
+ Language.PureScript.Ide.SourceFile.IntegrationSpec
+ Language.PureScript.Ide.SourceFileSpec
buildable: True
hs-source-dirs: tests
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 0f6df99..a53e759 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -80,19 +80,25 @@ data DeclarationRef
--
| ModuleRef ModuleName
-- |
+ -- A value re-exported from another module. These will be inserted during
+ -- elaboration in name desugaring.
+ --
+ | ReExportRef ModuleName DeclarationRef
+ -- |
-- A declaration reference with source position information
--
| PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
deriving (Show, Read)
instance Eq DeclarationRef where
- (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
- (TypeOpRef name) == (TypeOpRef name') = name == name'
- (ValueRef name) == (ValueRef name') = name == name'
- (ValueOpRef name) == (ValueOpRef name') = name == name'
- (TypeClassRef name) == (TypeClassRef name') = name == name'
+ (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
+ (TypeOpRef name) == (TypeOpRef name') = name == name'
+ (ValueRef name) == (ValueRef name') = name == name'
+ (ValueOpRef name) == (ValueOpRef name') = name == name'
+ (TypeClassRef name) == (TypeClassRef name') = name == name'
(TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
- (ModuleRef name) == (ModuleRef name') = name == name'
+ (ModuleRef name) == (ModuleRef name') = name == name'
+ (ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref'
(PositionedDeclarationRef _ _ r) == r' = r == r'
r == (PositionedDeclarationRef _ _ r') = r == r'
_ == _ = False
@@ -218,7 +224,10 @@ data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'Cons
data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
deriving (Eq, Ord, Show, Read)
+pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op))
+
+pattern TypeFixityDeclaration :: Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration
pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFixity fixity name op))
-- | The members of a type class instance declaration
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 316652c..bdc6d90 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -6,6 +6,7 @@
-- and generates the final Javascript bundle.
module Language.PureScript.Bundle
( bundle
+ , guessModuleIdentifier
, ModuleIdentifier(..)
, moduleName
, ModuleType(..)
@@ -32,6 +33,8 @@ import Language.JavaScript.Parser.AST
import qualified Paths_purescript as Paths
+import System.FilePath (takeFileName, takeDirectory)
+
-- | The type of error messages. We separate generation and rendering of errors using a data
-- type, in case we need to match on error types later.
data ErrorMessage
@@ -58,6 +61,14 @@ data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read,
moduleName :: ModuleIdentifier -> String
moduleName (ModuleIdentifier name _) = name
+-- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.
+guessModuleIdentifier :: MonadError ErrorMessage m => FilePath -> m ModuleIdentifier
+guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename)
+ where
+ guessModuleType "index.js" = pure Regular
+ guessModuleType "foreign.js" = pure Foreign
+ guessModuleType name = throwError $ UnsupportedModulePath name
+
-- | A piece of code is identified by its module and its name. These keys are used to label vertices
-- in the dependency graph.
type Key = (ModuleIdentifier, String)
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
index 2ee3a82..fd045b0 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
@@ -39,12 +39,12 @@ import qualified Language.PureScript.Constants as C
-- |
-- Apply a series of optimizer passes to simplified Javascript code
--
-optimize :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS
+optimize :: (MonadReader Options m, MonadSupply m) => JS -> m JS
optimize js = do
noOpt <- asks optionsNoOptimizations
if noOpt then return js else optimize' js
-optimize' :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS
+optimize' :: (MonadReader Options m, MonadSupply m) => JS -> m JS
optimize' js = do
opts <- ask
js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index c46bc80..5ac1104 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -216,7 +216,7 @@ inlineCommonOperators = applyAll $
isNFn :: String -> Int -> JS -> Bool
isNFn prefix n (JSVar _ name) = name == (prefix ++ show n)
- isNFn prefix n (JSAccessor _ name (JSVar _ dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
+ isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix ++ show n)
isNFn _ _ _ = False
runFn :: Int -> JS -> JS
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 1713a0d..021d3e0 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -391,5 +391,8 @@ dataEuclideanRing = "Data_EuclideanRing"
dataFunction :: String
dataFunction = "Data_Function"
+dataFunctionUncurried :: String
+dataFunctionUncurried = "Data_Function_Uncurried"
+
dataIntBits :: String
dataIntBits = "Data_Int_Bits"
diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs
index a0dc8fe..b87fb41 100644
--- a/src/Language/PureScript/Docs/ParseAndBookmark.hs
+++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs
@@ -44,7 +44,7 @@ parseAndBookmark inputFiles depsFiles = do
addBookmarks <$> parseFiles (inputFiles' ++ depsFiles')
parseFiles ::
- (MonadError P.MultipleErrors m, MonadIO m) =>
+ (MonadError P.MultipleErrors m) =>
[(FileInfo, FilePath)]
-> m [(FileInfo, P.Module)]
parseFiles =
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 9eff7d4..f19827f 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -15,7 +15,7 @@ import Data.Char (isSpace)
import Data.Either (lefts, rights)
import Data.Foldable (fold)
import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)
-import Data.Maybe (maybeToList)
+import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
import Data.Ord (comparing)
import qualified Data.Map as M
@@ -422,7 +422,7 @@ errorSuggestion err = case err of
importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String
importSuggestion mn refs qual =
- "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual
+ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" ++ qstr qual
qstr :: Maybe ModuleName -> String
qstr (Just mn) = " as " ++ runModuleName mn
@@ -1163,27 +1163,42 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
-- Pretty print and export declaration
prettyPrintExport :: DeclarationRef -> String
prettyPrintExport (TypeRef pn _) = runProperName pn
-prettyPrintExport ref = prettyPrintRef ref
+prettyPrintExport ref =
+ fromMaybe
+ (internalError "prettyPrintRef returned Nothing in prettyPrintExport")
+ (prettyPrintRef ref)
prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String
prettyPrintImport mn idt qual =
let i = case idt of
Implicit -> runModuleName mn
- Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
- Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"
+ Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")"
+ Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")"
in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual
-prettyPrintRef :: DeclarationRef -> String
-prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"
-prettyPrintRef (TypeRef pn (Just [])) = runProperName pn
-prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
-prettyPrintRef (TypeOpRef op) = "type " ++ showOp op
-prettyPrintRef (ValueRef ident) = showIdent ident
-prettyPrintRef (ValueOpRef op) = showOp op
-prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn
-prettyPrintRef (TypeInstanceRef ident) = showIdent ident
-prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name
-prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
+prettyPrintRef :: DeclarationRef -> Maybe String
+prettyPrintRef (TypeRef pn Nothing) =
+ Just $ runProperName pn ++ "(..)"
+prettyPrintRef (TypeRef pn (Just [])) =
+ Just $ runProperName pn
+prettyPrintRef (TypeRef pn (Just dctors)) =
+ Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
+prettyPrintRef (TypeOpRef op) =
+ Just $ "type " ++ showOp op
+prettyPrintRef (ValueRef ident) =
+ Just $ showIdent ident
+prettyPrintRef (ValueOpRef op) =
+ Just $ showOp op
+prettyPrintRef (TypeClassRef pn) =
+ Just $ "class " ++ runProperName pn
+prettyPrintRef (TypeInstanceRef ident) =
+ Just $ showIdent ident
+prettyPrintRef (ModuleRef name) =
+ Just $ "module " ++ runModuleName name
+prettyPrintRef (ReExportRef _ _) =
+ Nothing
+prettyPrintRef (PositionedDeclarationRef _ _ ref) =
+ prettyPrintRef ref
-- |
-- Pretty print multiple errors
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index b545a82..697215a 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -18,24 +18,11 @@
module Language.PureScript.Ide
( handleCommand
- -- for tests
- , printModules
) where
-import Prelude ()
-import Prelude.Compat
+import Protolude
-import Control.Monad (unless)
-import Control.Monad.Error.Class
-import Control.Monad.IO.Class
import "monad-logger" Control.Monad.Logger
-import Control.Monad.Reader.Class
-import Data.Foldable
-import qualified Data.Map.Lazy as M
-import Data.Maybe (catMaybes, mapMaybe)
-import Data.Monoid
-import Data.Text (Text)
-import qualified Data.Text as T
import qualified Language.PureScript as P
import qualified Language.PureScript.Ide.CaseSplit as CS
import Language.PureScript.Ide.Command
@@ -47,199 +34,163 @@ import Language.PureScript.Ide.Imports hiding (Import)
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Pursuit
import Language.PureScript.Ide.Rebuild
-import Language.PureScript.Ide.Reexports
import Language.PureScript.Ide.SourceFile
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import System.Directory
-import System.Exit
import System.FilePath
+import System.FilePath.Glob
-handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+-- | 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) =>
Command -> m Success
-handleCommand (Load [] []) = loadAllModules
-handleCommand (Load modules deps) =
- loadModulesAndDeps modules deps
-handleCommand (Type search filters currentModule) =
- findType search filters currentModule
-handleCommand (Complete filters matcher currentModule) =
- findCompletions filters matcher currentModule
-handleCommand (Pursuit query Package) =
- findPursuitPackages query
-handleCommand (Pursuit query Identifier) =
- findPursuitCompletions query
-handleCommand (List LoadedModules) =
- printModules
-handleCommand (List AvailableModules) =
- listAvailableModules
-handleCommand (List (Imports fp)) =
- importsForFile fp
-handleCommand (CaseSplit l b e wca t) =
- caseSplit l b e wca t
-handleCommand (AddClause l wca) =
- pure $ addClause l wca
-handleCommand (Import fp outfp _ (AddImplicitImport mn)) = do
- rs <- addImplicitImport fp mn
- answerRequest outfp rs
-handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do
- rs <- addImportForIdentifier fp ident filters
- case rs of
- Right rs' -> answerRequest outfp rs'
- Left question -> pure $ CompletionResult (mapMaybe completionFromMatch question)
-handleCommand (Rebuild file) =
- rebuildFile file
-handleCommand Cwd =
- TextResult . T.pack <$> liftIO getCurrentDirectory
-handleCommand Reset = resetPscIdeState *> pure (TextResult "State has been reset.")
-handleCommand Quit = liftIO exitSuccess
-
-findCompletions :: (PscIde m, MonadLogger m) =>
- [Filter] -> Matcher -> Maybe P.ModuleName -> m Success
+handleCommand c = case c of
+ Load [] ->
+ findAvailableExterns >>= loadModules
+ Load modules ->
+ loadModules modules
+ Type search filters currentModule ->
+ findType search filters currentModule
+ Complete filters matcher currentModule ->
+ findCompletions filters matcher currentModule
+ Pursuit query Package ->
+ findPursuitPackages query
+ Pursuit query Identifier ->
+ findPursuitCompletions query
+ List LoadedModules ->
+ printModules
+ List AvailableModules ->
+ listAvailableModules
+ List (Imports fp) ->
+ ImportList <$> getImportsForFile fp
+ CaseSplit l b e wca t ->
+ caseSplit l b e wca t
+ AddClause l wca ->
+ MultilineTextResult <$> CS.addClause l wca
+ Import fp outfp _ (AddImplicitImport mn) -> do
+ rs <- addImplicitImport fp mn
+ answerRequest outfp rs
+ Import fp outfp filters (AddImportForIdentifier ident) -> do
+ rs <- addImportForIdentifier fp ident filters
+ case rs of
+ Right rs' -> answerRequest outfp rs'
+ Left question ->
+ pure (CompletionResult (map completionFromMatch question))
+ Rebuild file ->
+ rebuildFile file
+ Cwd ->
+ TextResult . toS <$> liftIO getCurrentDirectory
+ Reset ->
+ resetIdeState $> TextResult "State has been reset."
+ Quit ->
+ liftIO exitSuccess
+
+findCompletions :: Ide m =>
+ [Filter] -> Matcher IdeDeclaration -> Maybe P.ModuleName -> m Success
findCompletions filters matcher currentModule = do
- modules <- getAllModulesWithReexportsAndCache currentModule
- pure . CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher $ modules
+ modules <- getAllModules currentModule
+ pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules
-findType :: (PscIde m, MonadLogger m) =>
- DeclIdent -> [Filter] -> Maybe P.ModuleName -> m Success
+findType :: Ide m =>
+ Text -> [Filter] -> Maybe P.ModuleName -> m Success
findType search filters currentModule = do
- modules <- getAllModulesWithReexportsAndCache currentModule
- pure . CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters $ modules
+ modules <- getAllModules currentModule
+ pure . InfoResult . map infoFromMatch . getExactMatches search filters $ modules
-findPursuitCompletions :: (MonadIO m, MonadLogger m) =>
+findPursuitCompletions :: MonadIO m =>
PursuitQuery -> m Success
findPursuitCompletions (PursuitQuery q) =
PursuitResult <$> liftIO (searchPursuitForDeclarations q)
-findPursuitPackages :: (MonadIO m, MonadLogger m) =>
+findPursuitPackages :: MonadIO m =>
PursuitQuery -> m Success
findPursuitPackages (PursuitQuery q) =
PursuitResult <$> liftIO (findPackagesForModuleIdent q)
-loadExtern :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
- FilePath -> m ()
-loadExtern fp = do
- m <- readExternFile fp
- insertModule m
+printModules :: Ide m => m Success
+printModules = ModuleList . map runModuleNameT <$> getLoadedModulenames
-printModules :: (PscIde m) => m Success
-printModules = printModules' . pscIdeStateModules <$> getPscIdeState
-
-printModules' :: M.Map ModuleIdent [ExternDecl] -> Success
-printModules' = ModuleList . M.keys
+outputDirectory :: Ide m => m FilePath
+outputDirectory = do
+ outputPath <- confOutputPath . ideConfiguration <$> ask
+ cwd <- liftIO getCurrentDirectory
+ pure (cwd </> outputPath)
-listAvailableModules :: PscIde m => m Success
+listAvailableModules :: Ide m => m Success
listAvailableModules = do
- outputPath <- confOutputPath . envConfiguration <$> ask
+ oDir <- outputDirectory
liftIO $ do
- cwd <- getCurrentDirectory
- dirs <- getDirectoryContents (cwd </> outputPath)
- return (ModuleList (listAvailableModules' dirs))
-
-listAvailableModules' :: [FilePath] -> [Text]
-listAvailableModules' dirs =
- let cleanedModules = filter (`notElem` [".", ".."]) dirs
- in map T.pack cleanedModules
+ contents <- getDirectoryContents oDir
+ let cleaned = filter (`notElem` [".", ".."]) contents
+ return (ModuleList (map toS cleaned))
-caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+caseSplit :: (Ide m, MonadError PscIdeError m) =>
Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success
caseSplit l b e csa t = do
patterns <- CS.makePattern l b e csa <$> CS.caseSplit t
pure (MultilineTextResult patterns)
-addClause :: Text -> CS.WildcardAnnotations -> Success
-addClause t wca = MultilineTextResult (CS.addClause t wca)
-
-importsForFile :: (MonadIO m, MonadLogger m, MonadError PscIdeError m) =>
- FilePath -> m Success
-importsForFile fp = do
- imports <- getImportsForFile fp
- pure (ImportList imports)
-
--- | The first argument is a set of modules to load. The second argument
--- denotes modules for which to load dependencies
-loadModulesAndDeps :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
- [ModuleIdent] -> [ModuleIdent] -> m Success
-loadModulesAndDeps mods deps = do
- r1 <- mapM loadModule (mods ++ deps)
- r2 <- mapM loadModuleDependencies deps
- let moduleResults = T.concat r1
- let dependencyResults = T.concat r2
- pure (TextResult (moduleResults <> ", " <> dependencyResults))
-
-loadModuleDependencies ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>
- ModuleIdent -> m Text
-loadModuleDependencies moduleName = do
- m <- getModule moduleName
- case getDependenciesForModule <$> m of
- Just deps -> do
- mapM_ loadModule deps
- -- We need to load the modules, that get reexported from the dependencies
- depModules <- catMaybes <$> mapM getModule deps
- -- What to do with errors here? This basically means a reexported dependency
- -- doesn't exist in the output/ folder
- traverse_ loadReexports depModules
- pure ("Dependencies for " <> moduleName <> " loaded.")
- Nothing -> throwError (ModuleNotFound moduleName)
-
-loadReexports :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
- Module -> m [ModuleIdent]
-loadReexports m = case getReexports m of
- [] -> pure []
- exportDeps -> do
- -- I'm fine with this crashing on a failed pattern match.
- -- If this ever fails I'll need to look at GADTs
- let reexports = map (\(Export mn) -> mn) exportDeps
- $(logDebug) ("Loading reexports for module: " <> fst m <>
- " reexports: " <> T.intercalate ", " reexports)
- traverse_ loadModule reexports
- exportDepsModules <- catMaybes <$> traverse getModule reexports
- exportDepDeps <- traverse loadReexports exportDepsModules
- return $ concat exportDepDeps
-
-getDependenciesForModule :: Module -> [ModuleIdent]
-getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls
- where getDependencyName (Dependency dependencyName _ _) = Just dependencyName
- getDependencyName _ = Nothing
-
-loadModule :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
- ModuleIdent -> m Text
-loadModule "Prim" = pure "Prim won't be loaded"
-loadModule mn = do
- path <- filePathFromModule mn
- loadExtern path
- $(logDebug) ("Loaded extern file at: " <> T.pack path)
- pure ("Loaded extern file at: " <> T.pack path)
-
-loadAllModules :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => m Success
-loadAllModules = do
- outputPath <- confOutputPath . envConfiguration <$> ask
- cwd <- liftIO getCurrentDirectory
- let outputDirectory = cwd </> outputPath
- liftIO (doesDirectoryExist outputDirectory)
- >>= flip unless (throwError (GeneralError "Couldn't locate your output directory"))
- liftIO (getDirectoryContents outputDirectory)
- >>= liftIO . traverse (getExternsPath outputDirectory)
- >>= traverse_ loadExtern . catMaybes
- pure (TextResult "All modules loaded.")
+-- | 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 = do
+ oDir <- outputDirectory
+ unlessM (liftIO (doesDirectoryExist oDir))
+ (throwError (GeneralError "Couldn't locate your output directory."))
+ liftIO $ do
+ directories <- getDirectoryContents oDir
+ moduleNames <- filterM (containsExterns oDir) directories
+ pure (P.moduleNameFromString <$> moduleNames)
where
- getExternsPath :: FilePath -> FilePath -> IO (Maybe FilePath)
- getExternsPath outputDirectory d
- | d `elem` [".", ".."] = pure Nothing
+ -- Takes the output directory and a filepath like "Monad.Control.Eff" and
+ -- looks up, whether that folder contains an externs.json
+ containsExterns :: FilePath -> FilePath -> IO Bool
+ containsExterns oDir d
+ | d `elem` [".", ".."] = pure False
| otherwise = do
- let file = outputDirectory </> d </> "externs.json"
- ex <- doesFileExist file
- if ex
- then pure (Just file)
- else pure Nothing
-
-filePathFromModule :: (PscIde m, MonadError PscIdeError m) =>
- ModuleIdent -> m FilePath
-filePathFromModule moduleName = do
- outputPath <- confOutputPath . envConfiguration <$> ask
- cwd <- liftIO getCurrentDirectory
- let path = cwd </> outputPath </> T.unpack moduleName </> "externs.json"
- ex <- liftIO $ doesFileExist path
- if ex
- then pure path
- else throwError (ModuleFileNotFound moduleName)
+ let file = oDir </> d </> "externs.json"
+ doesFileExist file
+
+-- | Finds all matches for the globs specified at the commandline
+findAllSourceFiles :: Ide m => m [FilePath]
+findAllSourceFiles = do
+ globs <- confGlobs . ideConfiguration <$> ask
+ liftIO (concatMapM glob globs)
+
+-- | Looks up the ExternsFiles for the given Modulenames and loads them into the
+-- 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.
+loadModules
+ :: (Ide m, MonadError PscIdeError m, MonadLogger m)
+ => [P.ModuleName]
+ -> m Success
+loadModules moduleNames = do
+ -- We resolve all the modulenames to externs files and load these into memory.
+ oDir <- outputDirectory
+ let efPaths =
+ map (\mn -> oDir </> P.runModuleName mn </> "externs.json") moduleNames
+ efiles <- traverse readExternFile efPaths
+ traverse_ insertExterns efiles
+
+ -- We parse all source files, log eventual parse failures if the debug flag
+ -- was set and insert the succesful parses into the state.
+ (failures, allModules) <-
+ partitionEithers <$> (traverse parseModule =<< findAllSourceFiles)
+ unless (null failures) $
+ $(logDebug) ("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 runLogger =
+ runStdoutLoggingT
+ . filterLogger (\_ _ -> confDebug (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 (runReaderT (populateStage2 *> populateStage3) env)))
+ pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "
+ <> show (length allModules) <> " source files."))
diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs
index 53e1db0..54f5137 100644
--- a/src/Language/PureScript/Ide/CaseSplit.hs
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -13,7 +13,6 @@
-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
module Language.PureScript.Ide.CaseSplit
( WildcardAnnotations()
@@ -24,26 +23,19 @@ module Language.PureScript.Ide.CaseSplit
, caseSplit
) where
-import Prelude ()
-import Prelude.Compat hiding (lex)
+import Protolude hiding (Constructor)
-import Control.Arrow (second)
-import Control.Monad.Error.Class
-import "monad-logger" Control.Monad.Logger
-import Data.List (find)
-import Data.Monoid
-import Data.Text (Text)
import qualified Data.Text as T
import qualified Language.PureScript as P
import Language.PureScript.Externs
import Language.PureScript.Ide.Error
-import Language.PureScript.Ide.Externs (unwrapPositioned)
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import Text.Parsec as Parsec
+import qualified Text.PrettyPrint.Boxes as Box
type Constructor = (P.ProperName 'P.ConstructorName, [P.Type])
@@ -55,17 +47,17 @@ explicitAnnotations = WildcardAnnotations True
noAnnotations :: WildcardAnnotations
noAnnotations = WildcardAnnotations False
-caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+caseSplit :: (Ide m, MonadError PscIdeError m) =>
Text -> m [Constructor]
caseSplit q = do
- type' <- parseType' (T.unpack q)
+ type' <- parseType' q
(tc, args) <- splitTypeConstructor type'
(EDType _ _ (P.DataType typeVars ctors)) <- findTypeDeclaration tc
let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args))
let appliedCtors = map (second (map applyTypeVars)) ctors
pure appliedCtors
-findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+findTypeDeclaration :: (Ide m, MonadError PscIdeError m) =>
P.ProperName 'P.TypeName -> m ExternsDeclaration
findTypeDeclaration q = do
efs <- getExternFiles
@@ -115,39 +107,41 @@ makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t)
where
makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs)
-addClause :: Text -> WildcardAnnotations -> [Text]
-addClause s wca =
- let (fName, fType) = parseTypeDeclaration' (T.unpack s)
- (args, _) = splitFunctionType fType
+addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Text]
+addClause s wca = do
+ (fName, fType) <- parseTypeDeclaration' s
+ let args = splitFunctionType fType
template = runIdentT fName <> " " <>
T.unwords (map (prettyPrintWildcard wca) args) <>
" = ?" <> (T.strip . runIdentT $ fName)
- in [s, template]
+ pure [s, template]
parseType' :: (MonadError PscIdeError m) =>
- String -> m P.Type
+ Text -> m P.Type
parseType' s =
- case P.lex "<psc-ide>" s >>= P.runTokenParser "<psc-ide>" (P.parseType <* Parsec.eof) of
+ case P.lex "<psc-ide>" (toS s) >>= P.runTokenParser "<psc-ide>" (P.parseType <* Parsec.eof) of
Right type' -> pure type'
Left err ->
throwError (GeneralError ("Parsing the splittype failed with:"
- ++ show err))
+ <> show err))
-parseTypeDeclaration' :: String -> (P.Ident, P.Type)
+parseTypeDeclaration' :: (MonadError PscIdeError m) => Text -> m (P.Ident, P.Type)
parseTypeDeclaration' s =
let x = do
- ts <- P.lex "" s
+ ts <- P.lex "" (toS s)
P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts
in
case unwrapPositioned <$> x of
- Right (P.TypeDeclaration i t) -> (i, t)
- y -> error (show y)
-
-splitFunctionType :: P.Type -> ([P.Type], P.Type)
-splitFunctionType t = (arguments, returns)
+ Right (P.TypeDeclaration i t) -> pure (i, t)
+ Right _ -> throwError (GeneralError "Found a non-type-declaration")
+ Left err ->
+ throwError (GeneralError ("Parsing the type signature failed with: "
+ <> toS (Box.render (P.prettyPrintParseError err))))
+
+splitFunctionType :: P.Type -> [P.Type]
+splitFunctionType t = fromMaybe [] arguments
where
- returns = last splitted
- arguments = init splitted
+ arguments = initMay splitted
splitted = splitType' t
splitType' (P.ForAll _ t' _) = splitType' t'
splitType' (P.ConstrainedType _ t') = splitType' t'
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index 8f405a8..31a20a2 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -16,31 +16,26 @@
module Language.PureScript.Ide.Command where
-import Prelude ()
-import Prelude.Compat
+import Protolude
-import Control.Monad
import Data.Aeson
-import Data.Text (Text)
import qualified Language.PureScript as P
import Language.PureScript.Ide.CaseSplit
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
+import System.FilePath
data Command
- = Load
- { loadModules :: [ModuleIdent]
- , loadDependencies :: [ModuleIdent]
- }
+ = Load [P.ModuleName]
| Type
- { typeSearch :: DeclIdent
+ { typeSearch :: Text
, typeFilters :: [Filter]
, typeCurrentModule :: Maybe P.ModuleName
}
| Complete
{ completeFilters :: [Filter]
- , completeMatcher :: Matcher
+ , completeMatcher :: Matcher IdeDeclaration
, completeCurrentModule :: Maybe P.ModuleName
}
| Pursuit
@@ -68,12 +63,12 @@ data Command
data ImportCommand
= AddImplicitImport P.ModuleName
- | AddImportForIdentifier DeclIdent
+ | AddImportForIdentifier Text
deriving (Show, Eq)
instance FromJSON ImportCommand where
parseJSON = withObject "ImportCommand" $ \o -> do
- (command :: String) <- o .: "importCommand"
+ (command :: Text) <- o .: "importCommand"
case command of
"addImplicitImport" ->
AddImplicitImport <$> (P.moduleNameFromString <$> o .: "module")
@@ -85,7 +80,7 @@ data ListType = LoadedModules | Imports FilePath | AvailableModules
instance FromJSON ListType where
parseJSON = withObject "ListType" $ \o -> do
- (listType' :: String) <- o .: "type"
+ (listType' :: Text) <- o .: "type"
case listType' of
"import" -> Imports <$> o .: "file"
"loadedModules" -> pure LoadedModules
@@ -94,7 +89,7 @@ instance FromJSON ListType where
instance FromJSON Command where
parseJSON = withObject "command" $ \o -> do
- (command :: String) <- o .: "command"
+ (command :: Text) <- o .: "command"
case command of
"list" -> List <$> o .:? "params" .!= LoadedModules
"cwd" -> pure Cwd
@@ -103,11 +98,9 @@ instance FromJSON Command where
"load" -> do
params' <- o .:? "params"
case params' of
- Nothing -> pure (Load [] [])
+ Nothing -> pure (Load [])
Just params ->
- Load
- <$> params .:? "modules" .!= []
- <*> params .:? "dependencies" .!= []
+ Load <$> (map P.moduleNameFromString <$> params .:? "modules" .!= [])
"type" -> do
params <- o .: "params"
Type
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
index f120c6f..04c0e7d 100644
--- a/src/Language/PureScript/Ide/Completion.hs
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -1,32 +1,32 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.Ide.Completion
- (getCompletions, getExactMatches)
- where
+ ( getCompletions
+ , getExactMatches
+ ) where
-import Prelude ()
-import Prelude.Compat
+import Protolude
-import Data.Maybe (mapMaybe)
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Util
-- | Applies the CompletionFilters and the Matcher to the given Modules
-- and sorts the found Completions according to the Matching Score
-getCompletions :: [Filter] -> Matcher -> [Module] -> [Match]
+getCompletions
+ :: [Filter]
+ -> Matcher IdeDeclaration
+ -> [Module]
+ -> [Match IdeDeclaration]
getCompletions filters matcher modules =
- runMatcher matcher $ completionsFromModules (applyFilters filters modules)
+ runMatcher matcher (completionsFromModules discardAnn (applyFilters filters modules))
-getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Match]
+getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn]
getExactMatches search filters modules =
- completionsFromModules $
- applyFilters (equalityFilter search : filters) modules
+ completionsFromModules identity (applyFilters (equalityFilter search : filters) modules)
-completionsFromModules :: [Module] -> [Match]
-completionsFromModules = foldMap completionFromModule
+completionsFromModules :: (IdeDeclarationAnn -> a) -> [Module] -> [Match a]
+completionsFromModules f = foldMap completionFromModule
where
- completionFromModule :: Module -> [Match]
- completionFromModule (moduleIdent, decls) = mapMaybe (matchFromDecl moduleIdent) decls
-
-matchFromDecl :: ModuleIdent -> ExternDecl -> Maybe Match
-matchFromDecl mi = Just . Match mi
+ completionFromModule (moduleName, decls) =
+ map (\x -> Match (moduleName, f x)) decls
diff --git a/src/Language/PureScript/Ide/Conversions.hs b/src/Language/PureScript/Ide/Conversions.hs
new file mode 100644
index 0000000..d0a46eb
--- /dev/null
+++ b/src/Language/PureScript/Ide/Conversions.hs
@@ -0,0 +1,35 @@
+-----------------------------------------------------------------------------
+--
+-- 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 Protolude
+import Data.Text (unwords, lines, strip)
+import qualified Language.PureScript as P
+
+runProperNameT :: P.ProperName a -> Text
+runProperNameT = toS . P.runProperName
+
+runIdentT :: P.Ident -> Text
+runIdentT = toS . P.runIdent
+
+runOpNameT :: P.OpName a -> Text
+runOpNameT = toS . P.runOpName
+
+runModuleNameT :: P.ModuleName -> Text
+runModuleNameT = toS . P.runModuleName
+
+prettyTypeT :: P.Type -> Text
+prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType
+
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 58b4078..19c112a 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -14,25 +14,21 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.Ide.Error
- (ErrorMsg, PscIdeError(..), textError)
- where
+ ( PscIdeError(..)
+ ) where
-import Prelude.Compat
+import Protolude
import Data.Aeson
-import Data.Monoid
-import Data.Text (Text, pack)
import Language.PureScript.Errors.JSON
import Language.PureScript.Ide.Types (ModuleIdent)
import qualified Text.Parsec.Error as P
-type ErrorMsg = String
-
data PscIdeError
- = GeneralError ErrorMsg
+ = GeneralError Text
| NotFound Text
| ModuleNotFound ModuleIdent
| ModuleFileNotFound ModuleIdent
- | ParseError P.ParseError ErrorMsg
+ | ParseError P.ParseError Text
| RebuildError [JSONError]
instance ToJSON PscIdeError where
@@ -46,7 +42,7 @@ instance ToJSON PscIdeError where
]
textError :: PscIdeError -> Text
-textError (GeneralError msg) = pack msg
+textError (GeneralError msg) = msg
textError (NotFound ident) = "Symbol '" <> ident <> "' not found."
textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."
textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found"
@@ -54,5 +50,5 @@ textError (ParseError parseError msg) = let escape = show
-- escape newlines and other special
-- chars so we can send the error
-- over the socket as a single line
- in pack $ msg <> ": " <> show (escape parseError)
-textError (RebuildError err) = pack (show err)
+ in msg <> ": " <> escape parseError
+textError (RebuildError err) = show err
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index bf3e6bd..37f0319 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -12,115 +12,114 @@
-- Handles externs files for psc-ide
-----------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
module Language.PureScript.Ide.Externs
- ( ExternDecl(..),
- ModuleIdent,
- DeclIdent,
- readExternFile,
+ ( readExternFile,
convertExterns,
- unwrapPositioned,
- unwrapPositionedRef
+ annotateLocations
) where
-import Prelude ()
-import Prelude.Compat
+import Protolude
-import Control.Monad.Error.Class
-import Control.Monad.IO.Class
import Data.Aeson (decodeStrict)
import Data.List (nub)
-import Data.Maybe (mapMaybe)
-import Data.Monoid
-import Data.Text (Text)
-import qualified Data.Text as T
+import qualified Data.Map as Map
import qualified Data.ByteString as BS
import Language.PureScript.Ide.Error (PscIdeError (..))
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import qualified Language.PureScript as P
+import System.FilePath
readExternFile :: (MonadIO m, MonadError PscIdeError m) =>
FilePath -> m P.ExternsFile
readExternFile fp = do
parseResult <- liftIO (decodeStrict <$> BS.readFile fp)
case parseResult of
- Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed"
+ Nothing -> throwError . GeneralError $ "Parsing the extern at: " <> toS fp <> " failed"
Just externs -> pure externs
-moduleNameToText :: P.ModuleName -> Text
-moduleNameToText = T.pack . P.runModuleName
-
-identToText :: P.Ident -> Text
-identToText = T.pack . P.runIdent
-
-convertExterns :: P.ExternsFile -> Module
-convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls ++ operatorDecls ++ tyOperatorDecls)
+convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)])
+convertExterns ef =
+ ((P.efModuleName ef, decls), exportDecls)
where
- moduleName = moduleNameToText (P.efModuleName ef)
- importDecls = convertImport <$> P.efImports ef
+ decls = map
+ (IdeDeclarationAnn emptyAnn)
+ (cleanDeclarations ++ operatorDecls ++ tyOperatorDecls)
exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (P.efExports ef)
operatorDecls = convertOperator <$> P.efFixities ef
tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef
- otherDecls = mapMaybe convertDecl (P.efDeclarations ef)
+ declarations = mapMaybe convertDecl (P.efDeclarations ef)
- typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls)
- decls = nub $ appEndo typeClassFilter otherDecls
+ typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)
+ cleanDeclarations = nub $ appEndo typeClassFilter declarations
-removeTypeDeclarationsForClass :: ExternDecl -> Endo [ExternDecl]
-removeTypeDeclarationsForClass (TypeClassDeclaration n) = Endo (filter notDuplicate)
- where notDuplicate (TypeDeclaration n' _) = runProperNameT n /= runProperNameT n'
- notDuplicate (TypeSynonymDeclaration n' _) = runProperNameT n /= runProperNameT n'
+removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]
+removeTypeDeclarationsForClass (IdeTypeClass n) = Endo (filter notDuplicate)
+ where notDuplicate (IdeType n' _) = runProperNameT n /= runProperNameT n'
+ notDuplicate (IdeTypeSynonym n' _) = runProperNameT n /= runProperNameT n'
notDuplicate _ = True
removeTypeDeclarationsForClass _ = mempty
-isTypeClassDeclaration :: ExternDecl -> Bool
-isTypeClassDeclaration TypeClassDeclaration{} = True
+isTypeClassDeclaration :: IdeDeclaration -> Bool
+isTypeClassDeclaration IdeTypeClass{} = True
isTypeClassDeclaration _ = False
-convertImport :: P.ExternsImport -> ExternDecl
-convertImport ei = Dependency
- (moduleNameToText (P.eiModule ei))
- []
- (moduleNameToText <$> P.eiImportedAs ei)
-
-convertExport :: P.DeclarationRef -> Maybe ExternDecl
-convertExport (P.ModuleRef mn) = Just (Export (moduleNameToText mn))
+convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef)
+convertExport (P.ReExportRef m r) = Just (m, r)
convertExport _ = Nothing
-convertDecl :: P.ExternsDeclaration -> Maybe ExternDecl
-convertDecl P.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind
-convertDecl P.EDTypeSynonym{..} = Just $
- TypeSynonymDeclaration edTypeSynonymName edTypeSynonymType
+convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration
+convertDecl P.EDType{..} = Just (IdeType edTypeName edTypeKind)
+convertDecl P.EDTypeSynonym{..} =
+ Just (IdeTypeSynonym edTypeSynonymName edTypeSynonymType)
convertDecl P.EDDataConstructor{..} = Just $
- DataConstructor (runProperNameT edDataCtorName) edDataCtorTypeCtor edDataCtorType
+ IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType
convertDecl P.EDValue{..} = Just $
- ValueDeclaration (identToText edValueName) edValueType
-convertDecl P.EDClass{..} = Just $ TypeClassDeclaration edClassName
+ IdeValue edValueName edValueType
+convertDecl P.EDClass{..} = Just (IdeTypeClass edClassName)
convertDecl P.EDInstance{} = Nothing
-convertOperator :: P.ExternsFixity -> ExternDecl
+convertOperator :: P.ExternsFixity -> IdeDeclaration
convertOperator P.ExternsFixity{..} =
- ValueOperator
+ IdeValueOperator
efOperator
- (T.pack (P.showQualified (either P.runIdent P.runProperName) efAlias))
+ (toS (P.showQualified (either P.runIdent P.runProperName) efAlias))
efPrecedence
efAssociativity
-convertTypeOperator :: P.ExternsTypeFixity -> ExternDecl
+convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration
convertTypeOperator P.ExternsTypeFixity{..} =
- TypeOperator
+ IdeTypeOperator
efTypeOperator
- (T.pack (P.showQualified P.runProperName efTypeAlias))
+ (toS (P.showQualified P.runProperName efTypeAlias))
efTypePrecedence
efTypeAssociativity
-unwrapPositioned :: P.Declaration -> P.Declaration
-unwrapPositioned (P.PositionedDeclaration _ _ x) = x
-unwrapPositioned x = x
-
-unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
-unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x
-unwrapPositionedRef x = x
+annotateLocations :: Map (Either Text Text) P.SourceSpan -> Module -> Module
+annotateLocations ast (moduleName, decls) =
+ (moduleName, map convertDeclaration decls)
+ where
+ convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
+ convertDeclaration (IdeDeclarationAnn ann d) = case d of
+ IdeValue i t ->
+ annotateValue (runIdentT i) (IdeValue i t)
+ IdeType i k ->
+ annotateType (runProperNameT i) (IdeType i k)
+ IdeTypeSynonym i t ->
+ annotateType (runProperNameT i) (IdeTypeSynonym i t)
+ IdeDataConstructor i tn t ->
+ annotateValue (runProperNameT i) (IdeDataConstructor i tn t)
+ IdeTypeClass i ->
+ annotateType (runProperNameT i) (IdeTypeClass i)
+ IdeValueOperator n i p a ->
+ annotateValue i (IdeValueOperator n i p a)
+ IdeTypeOperator n i p a ->
+ annotateType i (IdeTypeOperator n i p a)
+ where
+ annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) ast})
+ annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) ast})
diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs
index c1c91cb..e0b79a4 100644
--- a/src/Language/PureScript/Ide/Filter.hs
+++ b/src/Language/PureScript/Ide/Filter.hs
@@ -20,22 +20,16 @@ module Language.PureScript.Ide.Filter
, moduleFilter
, prefixFilter
, equalityFilter
- , dependencyFilter
- , runFilter
, applyFilters
) where
-import Prelude ()
-import Prelude.Compat
+import Protolude hiding (isPrefixOf)
-import Control.Monad
import Data.Aeson
-import Data.Foldable
-import Data.Maybe (listToMaybe, mapMaybe)
-import Data.Monoid
-import Data.Text (Text, isPrefixOf)
+import Data.Text (isPrefixOf)
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
+import qualified Language.PureScript as P
newtype Filter = Filter (Endo [Module]) deriving(Monoid)
@@ -43,69 +37,46 @@ mkFilter :: ([Module] -> [Module]) -> Filter
mkFilter = Filter . Endo
-- | Only keeps the given Modules
-moduleFilter :: [ModuleIdent] -> Filter
+moduleFilter :: [P.ModuleName] -> Filter
moduleFilter =
mkFilter . moduleFilter'
-moduleFilter' :: [ModuleIdent] -> [Module] -> [Module]
+moduleFilter' :: [P.ModuleName] -> [Module] -> [Module]
moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst)
--- | Only keeps the given Modules and all of their dependencies
-dependencyFilter :: [ModuleIdent] -> Filter
-dependencyFilter = mkFilter . dependencyFilter'
-
-dependencyFilter' :: [ModuleIdent] -> [Module] -> [Module]
-dependencyFilter' moduleIdents mods =
- moduleFilter' (concatMap (getDepForModule mods) moduleIdents) mods
- where
- getDepForModule :: [Module] -> ModuleIdent -> [ModuleIdent]
- getDepForModule ms moduleIdent =
- moduleIdent : maybe [] extractDeps (findModule moduleIdent ms)
-
- findModule :: ModuleIdent -> [Module] -> Maybe Module
- findModule i ms = listToMaybe $ filter go ms
- where go (mn, _) = i == mn
-
- extractDeps :: Module -> [ModuleIdent]
- extractDeps = mapMaybe extractDep . snd
- where extractDep (Dependency n _ _) = Just n
- extractDep _ = Nothing
-
-- | Only keeps Identifiers that start with the given prefix
prefixFilter :: Text -> Filter
-prefixFilter "" = mkFilter id
+prefixFilter "" = mkFilter identity
prefixFilter t = mkFilter $ identFilter prefix t
where
- prefix :: ExternDecl -> Text -> Bool
- prefix Export{} _ = False
- prefix Dependency{} _ = False
- prefix ed search = search `isPrefixOf` identifierFromExternDecl ed
-
+ prefix :: IdeDeclaration -> Text -> Bool
+ prefix ed search = search `isPrefixOf` identifierFromIdeDeclaration ed
-- | Only keeps Identifiers that are equal to the search string
equalityFilter :: Text -> Filter
equalityFilter = mkFilter . identFilter equality
where
- equality :: ExternDecl -> Text -> Bool
- equality ed search = identifierFromExternDecl ed == search
+ equality :: IdeDeclaration -> Text -> Bool
+ equality ed search = identifierFromIdeDeclaration ed == search
-identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module]
+identFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Module]
identFilter predicate search =
filter (not . null . snd) . fmap filterModuleDecls
where
filterModuleDecls :: Module -> Module
- filterModuleDecls (moduleIdent,decls) =
- (moduleIdent, filter (`predicate` search) decls)
+ filterModuleDecls (moduleIdent, decls) =
+ (moduleIdent, filter (flip predicate search . getDeclaration) decls)
+ getDeclaration (IdeDeclarationAnn _ d) = d
runFilter :: Filter -> [Module] -> [Module]
-runFilter (Filter f)= appEndo f
+runFilter (Filter f) = appEndo f
applyFilters :: [Filter] -> [Module] -> [Module]
applyFilters = runFilter . fold
instance FromJSON Filter where
parseJSON = withObject "filter" $ \o -> do
- (filter' :: String) <- o .: "filter"
+ (filter' :: Text) <- o .: "filter"
case filter' of
"exact" -> do
params <- o .: "params"
@@ -117,10 +88,6 @@ instance FromJSON Filter where
return $ prefixFilter search
"modules" -> do
params <- o .: "params"
- modules <- params .: "modules"
+ modules <- map P.moduleNameFromString <$> params .: "modules"
return $ moduleFilter modules
- "dependencies" -> do
- params <- o .: "params"
- deps <- params .: "modules"
- return $ dependencyFilter deps
_ -> mzero
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index 7d24af7..e26796e 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -13,7 +13,6 @@
-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
module Language.PureScript.Ide.Imports
( addImplicitImport
@@ -30,28 +29,18 @@ module Language.PureScript.Ide.Imports
)
where
-import Prelude.Compat
-import Control.Applicative ((<|>))
-import Control.Monad.Error.Class
-import Control.Monad.IO.Class
-import "monad-logger" Control.Monad.Logger
-import Data.Bifunctor (first, second)
-import Data.Function (on)
-import qualified Data.List as List
-import Data.Maybe (isNothing)
-import Data.Monoid ((<>))
-import Data.Text (Text)
+import Protolude
import qualified Data.Text as T
+import Data.List (nubBy, findIndex)
import qualified Data.Text.IO as TIO
import qualified Language.PureScript as P
import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Error
-import Language.PureScript.Ide.Externs (unwrapPositioned,
- unwrapPositionedRef)
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
+import System.FilePath
data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
deriving (Eq, Show)
@@ -87,7 +76,7 @@ parseImportsFromFile fp = do
Right res -> pure res
Left err -> throwError (GeneralError err)
-parseImportsWithModuleName :: [Text] -> Either String (P.ModuleName, [Import])
+parseImportsWithModuleName :: [Text] -> Either Text (P.ModuleName, [Import])
parseImportsWithModuleName ls = do
(P.Module _ _ mn decls _) <- moduleParse ls
pure (mn, concatMap mkImport (unwrapPositioned <$> decls))
@@ -97,13 +86,13 @@ parseImportsWithModuleName ls = do
mkImport (P.ImportDeclaration mn it qual) = [Import mn it qual]
mkImport _ = []
-sliceImportSection :: [Text] -> Either String (P.ModuleName, [Text], [Import], [Text])
+sliceImportSection :: [Text] -> Either Text (P.ModuleName, [Text], [Import], [Text])
sliceImportSection ts =
case foldl step (ModuleHeader 0) (zip [0..] ts) of
Res start end ->
let
(moduleHeader, (importSection, remainingFile)) =
- List.splitAt (succ (end - start)) `second` List.splitAt start ts
+ splitAt (succ (end - start)) `second` splitAt start ts
in
(\(mn, is) -> (mn, moduleHeader, is, remainingFile)) <$>
parseImportsWithModuleName (moduleHeader <> importSection)
@@ -111,7 +100,7 @@ sliceImportSection ts =
-- If we don't find any imports, we insert a newline after the module
-- declaration and begin a new importsection
ModuleHeader ix ->
- let (moduleHeader, remainingFile) = List.splitAt (succ ix) ts
+ let (moduleHeader, remainingFile) = splitAt (succ ix) ts
in
(\(mn, is) -> (mn, moduleHeader ++ [""], is, remainingFile)) <$>
parseImportsWithModuleName moduleHeader
@@ -153,7 +142,7 @@ step (ImportSection start lastImportLine) (ix, l)
| otherwise = Res start lastImportLine
step (Res start end) _ = Res start end
-moduleParse :: [Text] -> Either String P.Module
+moduleParse :: [Text] -> Either Text P.Module
moduleParse t = first show $ do
tokens <- (P.lex "" . T.unpack . T.unlines) t
P.runTokenParser "<psc-ide>" P.parseModule tokens
@@ -182,8 +171,8 @@ addImplicitImport' imports mn =
-- 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, MonadLogger m) =>
- FilePath -> ExternDecl -> P.ModuleName -> m [Text]
+addExplicitImport :: (MonadIO m, MonadError PscIdeError m) =>
+ FilePath -> IdeDeclaration -> P.ModuleName -> m [Text]
addExplicitImport fp decl moduleName = do
(mn, pre, imports, post) <- parseImportsFromFile fp
let newImportSection =
@@ -194,7 +183,7 @@ addExplicitImport fp decl moduleName = do
else addExplicitImport' decl moduleName imports
pure (pre ++ prettyPrintImportSection newImportSection ++ post)
-addExplicitImport' :: ExternDecl -> P.ModuleName -> [Import] -> [Import]
+addExplicitImport' :: IdeDeclaration -> P.ModuleName -> [Import] -> [Import]
addExplicitImport' decl moduleName imports =
let
isImplicitlyImported =
@@ -209,37 +198,34 @@ addExplicitImport' decl moduleName imports =
then imports
else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports
where
- refFromDeclaration (TypeClassDeclaration n) =
+ refFromDeclaration (IdeTypeClass n) =
P.TypeClassRef n
- refFromDeclaration (DataConstructor n tn _) =
- P.TypeRef tn (Just [P.ProperName (T.unpack n)])
- refFromDeclaration (TypeDeclaration n _) =
+ refFromDeclaration (IdeDataConstructor n tn _) =
+ P.TypeRef tn (Just [n])
+ refFromDeclaration (IdeType n _) =
P.TypeRef n (Just [])
- refFromDeclaration (ValueOperator op _ _ _) =
+ refFromDeclaration (IdeValueOperator op _ _ _) =
P.ValueOpRef op
- refFromDeclaration (TypeOperator op _ _ _) =
+ refFromDeclaration (IdeTypeOperator op _ _ _) =
P.TypeOpRef op
refFromDeclaration d =
- P.ValueRef $ P.Ident $ T.unpack (identifierFromExternDecl d)
+ P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)
-- | Adds a declaration to an import:
-- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)
- insertDeclIntoImport :: ExternDecl -> Import -> Import
+ insertDeclIntoImport :: IdeDeclaration -> Import -> Import
insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =
Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing
insertDeclIntoImport _ is = is
- insertDeclIntoRefs :: ExternDecl -> [P.DeclarationRef] -> [P.DeclarationRef]
- insertDeclIntoRefs (DataConstructor dtor tn _) refs =
- let
- dtor' = P.ProperName (T.unpack dtor)
- in
- updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs
- insertDeclIntoRefs dr refs = List.nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)
+ insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef]
+ insertDeclIntoRefs (IdeDataConstructor dtor tn _) refs =
+ updateAtFirstOrPrepend (matchType tn) (insertDtor dtor) (P.TypeRef tn (Just [dtor])) refs
+ insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)
insertDtor dtor (P.TypeRef tn' dtors) =
case dtors of
- Just dtors' -> P.TypeRef tn' (Just (List.nub (dtor : dtors')))
+ Just dtors' -> P.TypeRef tn' (Just (ordNub (dtor : dtors')))
-- This means the import was opened. We don't add anything in this case
-- import Data.Maybe (Maybe(..)) -> import Data.Maybe (Maybe(Just))
Nothing -> P.TypeRef tn' Nothing
@@ -251,10 +237,10 @@ addExplicitImport' decl moduleName imports =
updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a]
updateAtFirstOrPrepend p t d l =
- case List.findIndex p l of
+ case findIndex p l of
Nothing -> d : l
Just ix ->
- let (x, a : y) = List.splitAt ix l
+ let (x, a : y) = splitAt ix l
in x ++ [t a] ++ y
-- | Looks up the given identifier in the currently loaded modules.
@@ -265,30 +251,30 @@ updateAtFirstOrPrepend p t d l =
--
-- * If more than one possible imports are found, reports the possibilities as a
-- list of completions.
-addImportForIdentifier :: (PscIde m, MonadError PscIdeError m, MonadLogger m)
+addImportForIdentifier :: (Ide m, MonadError PscIdeError m)
=> FilePath -- ^ The Sourcefile to read from
-> Text -- ^ The identifier to import
-> [Filter] -- ^ Filters to apply before searching for
-- the identifier
- -> m (Either [Match] [Text])
+ -> m (Either [Match IdeDeclaration] [Text])
addImportForIdentifier fp ident filters = do
- modules <- getAllModulesWithReexports
- case getExactMatches ident filters modules of
+ modules <- getAllModules Nothing
+ case map (fmap discardAnn) (getExactMatches ident filters modules) of
[] ->
throwError (NotFound "Couldn't find the given identifier. \
\Have you loaded the corresponding module?")
-- Only one match was found for the given identifier, so we can insert it
-- right away
- [Match m decl] ->
- Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m))
+ [Match (m, decl)] ->
+ Right <$> addExplicitImport fp decl m
-- This case comes up for newtypes and dataconstructors. Because values and
-- types don't share a namespace we can get multiple matches from the same
-- module. This also happens for parameterized types, as these generate both
-- a type aswell as a type synonym.
- ms@[Match m1 d1, Match m2 d2] ->
+ ms@[Match (m1, d1), Match (m2, d2)] ->
if m1 /= m2
-- If the modules don't line up we just ask the user to specify the
-- module
@@ -298,7 +284,7 @@ addImportForIdentifier fp ident filters = do
-- dataconstructor as that will give us an unnecessary import warning at
-- worst
Just decl ->
- Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m1))
+ Right <$> addExplicitImport fp decl m1
-- Here we need the user to specify whether he wanted a dataconstructor
-- or a type
Nothing ->
@@ -309,9 +295,9 @@ addImportForIdentifier fp ident filters = do
xs ->
pure $ Left xs
where
- decideRedundantCase dtor@(DataConstructor _ t _) (TypeDeclaration t' _) =
+ decideRedundantCase dtor@(IdeDataConstructor _ t _) (IdeType t' _) =
if t == t' then Just dtor else Nothing
- decideRedundantCase TypeDeclaration{} ts@TypeSynonymDeclaration{} =
+ decideRedundantCase IdeType{} ts@IdeTypeSynonym{} =
Just ts
decideRedundantCase _ _ = Nothing
@@ -323,7 +309,7 @@ prettyPrintImport' (Import mn idt qual) =
T.pack $ "import " ++ P.prettyPrintImport mn idt qual
prettyPrintImportSection :: [Import] -> [Text]
-prettyPrintImportSection imports = map prettyPrintImport' (List.sort imports)
+prettyPrintImportSection imports = map prettyPrintImport' (sort imports)
-- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@,
-- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the
diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs
index ad71ff6..a2fb0db 100644
--- a/src/Language/PureScript/Ide/Matcher.hs
+++ b/src/Language/PureScript/Ide/Matcher.hs
@@ -14,23 +14,18 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
module Language.PureScript.Ide.Matcher
( Matcher
- , flexMatcher
, runMatcher
+ -- for tests
+ , flexMatcher
) where
-import Prelude ()
-import Prelude.Compat
+import Protolude
-import Control.Monad
import Data.Aeson
-import Data.Function (on)
-import Data.List (sortBy)
-import Data.Maybe (mapMaybe)
-import Data.Monoid
-import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Language.PureScript.Ide.Types
@@ -39,23 +34,22 @@ import Text.EditDistance
import Text.Regex.TDFA ((=~))
-type ScoredMatch = (Match, Double)
+type ScoredMatch a = (Match a, Double)
-newtype Matcher = Matcher (Endo [Match]) deriving(Monoid)
+newtype Matcher a = Matcher (Endo [Match a]) deriving (Monoid)
-instance FromJSON Matcher where
+instance FromJSON (Matcher IdeDeclaration) where
parseJSON = withObject "matcher" $ \o -> do
- (matcher :: Maybe String) <- o .:? "matcher"
+ (matcher :: Maybe Text) <- o .:? "matcher"
case matcher of
Just "flex" -> do
params <- o .: "params"
- search <- params .: "search"
- pure $ flexMatcher search
+ flexMatcher <$> params .: "search"
Just "distance" -> do
params <- o .: "params"
- search <- params .: "search"
- maxDist <- params .: "maximumDistance"
- pure $ distanceMatcher search maxDist
+ distanceMatcher
+ <$> params .: "search"
+ <*> params .: "maximumDistance"
Just _ -> mzero
Nothing -> return mempty
@@ -66,37 +60,37 @@ instance FromJSON Matcher where
-- Examples:
-- flMa matches flexMatcher. Score: 14.28
-- sons matches sortCompletions. Score: 6.25
-flexMatcher :: Text -> Matcher
+flexMatcher :: Text -> Matcher IdeDeclaration
flexMatcher p = mkMatcher (flexMatch p)
-distanceMatcher :: Text -> Int -> Matcher
+distanceMatcher :: Text -> Int -> Matcher IdeDeclaration
distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist)
-distanceMatcher' :: Text -> Int -> [Match] -> [ScoredMatch]
+distanceMatcher' :: Text -> Int -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration]
distanceMatcher' q maxDist = mapMaybe go
where
go m = let d = dist (T.unpack y)
- y = identifierFromMatch m
+ y = identifierFromIdeDeclaration (unwrapMatch m)
in if d <= maxDist
then Just (m, 1 / fromIntegral d)
else Nothing
dist = levenshteinDistance defaultEditCosts (T.unpack q)
-mkMatcher :: ([Match] -> [ScoredMatch]) -> Matcher
+mkMatcher :: ([Match a] -> [ScoredMatch a]) -> Matcher a
mkMatcher matcher = Matcher . Endo $ fmap fst . sortCompletions . matcher
-runMatcher :: Matcher -> [Match] -> [Match]
+runMatcher :: Matcher a -> [Match a] -> [Match a]
runMatcher (Matcher m)= appEndo m
-sortCompletions :: [ScoredMatch] -> [ScoredMatch]
+sortCompletions :: [ScoredMatch a] -> [ScoredMatch a]
sortCompletions = sortBy (flip compare `on` snd)
-flexMatch :: Text -> [Match] -> [ScoredMatch]
+flexMatch :: Text -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration]
flexMatch = mapMaybe . flexRate
-flexRate :: Text -> Match -> Maybe ScoredMatch
+flexRate :: Text -> Match IdeDeclaration -> Maybe (ScoredMatch IdeDeclaration)
flexRate p c = do
- score <- flexScore p (identifierFromMatch c)
+ score <- flexScore p (identifierFromIdeDeclaration (unwrapMatch c))
return (c, score)
-- FlexMatching ala Sublime.
@@ -105,11 +99,11 @@ flexRate p c = do
-- By string =~ pattern we'll get the start of the match and the length of
-- the matchas a (start, length) tuple if there's a match.
-- If match fails then it would be (-1,0)
-flexScore :: Text -> DeclIdent -> Maybe Double
+flexScore :: Text -> Text -> Maybe Double
flexScore pat str =
case T.uncons pat of
Nothing -> Nothing
- Just (first, p) ->
+ Just (first', p) ->
case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of
(-1,0) -> Nothing
(start,len) -> Just $ calcScore start (start + len)
@@ -120,11 +114,11 @@ flexScore pat str =
-- escape prepends a backslash to "regexy" characters to prevent the
-- matcher from crashing when trying to build the regex
escape :: Char -> Text
- escape c = if c `elem` ("[\\^$.|?*+(){}" :: String)
+ escape c = if c `elem` T.unpack "[\\^$.|?*+(){}"
then T.pack ['\\', c]
else T.singleton c
-- This just interleaves the search pattern with .*
-- abcd[*] -> a.*b.*c.*d.*[*]
- pat' = escape first <> foldMap (<> ".*") escapedPattern
+ pat' = escape first' <> foldMap (<> ".*") escapedPattern
calcScore start end =
100.0 / fromIntegral ((1 + start) * (end - start + 1))
diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs
index b8a8b50..9032a34 100644
--- a/src/Language/PureScript/Ide/Pursuit.hs
+++ b/src/Language/PureScript/Ide/Pursuit.hs
@@ -14,20 +14,17 @@
{-# LANGUAGE OverloadedStrings #-}
-module Language.PureScript.Ide.Pursuit where
+module Language.PureScript.Ide.Pursuit
+ ( searchPursuitForDeclarations
+ , findPackagesForModuleIdent
+ ) where
-import Prelude ()
-import Prelude.Compat
+import Protolude
import qualified Control.Exception as E
import Data.Aeson
-import Data.ByteString (ByteString)
import Data.ByteString.Lazy (fromStrict)
-import Data.Foldable (toList)
-import Data.Maybe (mapMaybe)
-import Data.Monoid ((<>))
import Data.String
-import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.Ide.Types
import Network.HTTP.Types.Header (hAccept)
@@ -41,12 +38,12 @@ queryPursuit q = do
let qClean = T.dropWhileEnd (== '.') q
req' <- parseUrl "http://pursuit.purescript.org/search"
let req = req'
- { queryString=("q=" <> (fromString . T.unpack) qClean)
+ { queryString= "q=" <> (fromString . T.unpack) qClean
, requestHeaders=[(hAccept, "application/json")]
}
m <- newManager tlsManagerSettings
withHTTP req m $ \resp ->
- P.fold (<>) "" id $ responseBody resp
+ P.fold (<>) "" identity (responseBody resp)
handler :: HttpException -> IO [a]
@@ -59,7 +56,7 @@ searchPursuitForDeclarations query =
let results' = decode (fromStrict r) :: Maybe Array
case results' of
Nothing -> pure []
- Just results -> pure (mapMaybe isDeclarationResponse (map fromJSON (toList results)))) `E.catch`
+ Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch`
handler
where
isDeclarationResponse (Success a@DeclarationResponse{}) = Just a
@@ -71,7 +68,7 @@ findPackagesForModuleIdent query =
let results' = decode (fromStrict r) :: Maybe Array
case results' of
Nothing -> pure []
- Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch`
+ Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch`
handler
where
isModuleResponse (Success a@ModuleResponse{}) = Just a
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index e03cc9d..9dad7a6 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -8,14 +8,12 @@ module Language.PureScript.Ide.Rebuild
( rebuildFile
) where
-import Control.Monad.Error.Class
-import Control.Monad.IO.Class
+import Protolude
+
import "monad-logger" Control.Monad.Logger
-import Control.Monad.Reader
-import Control.Monad.Trans.Except
+import qualified Data.List as List
import qualified Data.Map.Lazy as M
-import Data.Maybe (fromJust, mapMaybe)
-import Data.Monoid ((<>))
+import Data.Maybe (fromJust)
import qualified Data.Set as S
import qualified Language.PureScript as P
import Language.PureScript.Errors.JSON
@@ -23,8 +21,8 @@ import Language.PureScript.Ide.Error
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import Prelude.Compat
import System.IO.UTF8 (readUTF8File)
+import System.FilePath
-- | Given a filepath performs the following steps:
--
@@ -42,14 +40,14 @@ import System.IO.UTF8 (readUTF8File)
-- warnings, and if rebuilding fails, returns a @RebuildError@ with the
-- generated errors.
rebuildFile
- :: (PscIde m, MonadLogger m, MonadError PscIdeError m)
+ :: (Ide m, MonadLogger m, MonadError PscIdeError m)
=> FilePath
-> m Success
rebuildFile path = do
input <- liftIO (readUTF8File path)
- m <- case snd <$> P.parseModuleFromFile id (path, input) of
+ m <- case snd <$> P.parseModuleFromFile identity (path, input) of
Left parseError -> throwError
. RebuildError
. toJSONErrors False P.Error
@@ -60,7 +58,7 @@ rebuildFile path = do
-- correctly to the 'Environment'.
externs <- sortExterns m =<< getExternFiles
- outputDirectory <- confOutputPath . envConfiguration <$> ask
+ outputDirectory <- confOutputPath . ideConfiguration <$> ask
-- For rebuilding, we want to 'RebuildAlways', but for inferring foreign
-- modules using their file paths, we need to specify the path in the 'Map'.
@@ -82,7 +80,7 @@ rebuildFile path = do
-- | Rebuilds a module but opens up its export list first and stores the result
-- inside the rebuild cache
rebuildModuleOpen
- :: (PscIde m, MonadLogger m, MonadError PscIdeError m)
+ :: (Ide m, MonadLogger m, MonadError PscIdeError m)
=> MakeActionsEnv
-> [P.ExternsFile]
-> P.Module
@@ -100,14 +98,14 @@ rebuildModuleOpen makeEnv externs m = do
Right result -> do
$(logDebug)
("Setting Rebuild cache: " <> runModuleNameT (P.efModuleName result))
- setCachedRebuild result
+ cacheRebuild result
-- | Parameters we can access while building our @MakeActions@
data MakeActionsEnv =
MakeActionsEnv
{ maeOutputDirectory :: FilePath
- , maeFilePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
- , maeForeignPathMap :: M.Map P.ModuleName FilePath
+ , maeFilePathMap :: Map P.ModuleName (Either P.RebuildPolicy FilePath)
+ , maeForeignPathMap :: Map P.ModuleName FilePath
, maePrefixComment :: Bool
}
@@ -135,9 +133,9 @@ shushCodegen ma MakeActionsEnv{..} =
-- module. Throws an error if there is a cyclic dependency within the
-- ExternsFiles
sortExterns
- :: (PscIde m, MonadError PscIdeError m)
+ :: (Ide m, MonadError PscIdeError m)
=> P.Module
- -> M.Map P.ModuleName P.ExternsFile
+ -> Map P.ModuleName P.ExternsFile
-> m [P.ExternsFile]
sortExterns m ex = do
sorted' <- runExceptT
@@ -149,11 +147,11 @@ sortExterns m ex = do
case sorted' of
Left _ -> throwError (GeneralError "There was a cycle in the dependencies")
Right (sorted, graph) -> do
- let deps = fromJust (lookup (P.getModuleName m) graph)
+ let deps = fromJust (List.lookup (P.getModuleName m) graph)
pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)
where
mkShallowModule P.ExternsFile{..} =
- P.Module undefined [] efModuleName (map mkImport efImports) Nothing
+ P.Module (P.internalModuleSourceSpan "<rebuild>") [] efModuleName (map mkImport efImports) Nothing
mkImport (P.ExternsImport mn it iq) =
P.ImportDeclaration mn it iq
getExtern mn = M.lookup mn ex
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index 4bcce8e..807f3d7 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -14,76 +14,105 @@
-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
-module Language.PureScript.Ide.Reexports where
+module Language.PureScript.Ide.Reexports
+ ( resolveReexports
+ , prettyPrintReexportResult
+ , reexportHasFailures
+ , ReexportResult(..)
+ ) where
+import Protolude
-import Prelude ()
-import Prelude.Compat
-
-import Data.List (union)
-import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe
import Language.PureScript.Ide.Types
-
-getReexports :: Module -> [ExternDecl]
-getReexports (mn, decls)= concatMap getExport decls
- where getExport d
- | (Export mn') <- d
- , mn /= mn' = replaceExportWithAliases decls mn'
- | otherwise = []
-
-dependencyToExport :: ExternDecl -> ExternDecl
-dependencyToExport (Dependency m _ _) = Export m
-dependencyToExport decl = decl
-
-replaceExportWithAliases :: [ExternDecl] -> ModuleIdent -> [ExternDecl]
-replaceExportWithAliases decls ident =
- case filter isMatch decls of
- [] -> [Export ident]
- aliases -> map dependencyToExport aliases
- where isMatch d
- | Dependency _ _ (Just alias) <- d
- , alias == ident = True
- | otherwise = False
-
-replaceReexport :: ExternDecl -> Module -> Module -> Module
-replaceReexport e@(Export _) (m, decls) (_, newDecls) =
- (m, filter (/= e) decls `union` newDecls)
-replaceReexport _ _ _ = error "Should only get Exports here."
-
-emptyModule :: Module
-emptyModule = ("Empty", [])
-
-isExport :: ExternDecl -> Bool
-isExport (Export _) = True
-isExport _ = False
-
-removeExportDecls :: Module -> Module
-removeExportDecls = fmap (filter (not . isExport))
-
-replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module
-replaceReexports m db = result
+import Language.PureScript.Ide.Util
+import qualified Language.PureScript as P
+
+-- | Contains the module with resolved reexports, and eventual 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
+-- failures
+prettyPrintReexportResult
+ :: (a -> Text)
+ -- ^ Formatter for the resolved result
+ -> ReexportResult a
+ -- ^ The Result to be pretty printed
+ -> Text
+prettyPrintReexportResult f ReexportResult{..}
+ | null reFailed =
+ "Successfully resolved reexports for " <> f reResolved
+ | otherwise =
+ "Failed to resolve reexports for "
+ <> f reResolved
+ <> foldMap (\(mn, ref) -> runModuleNameT mn <> show ref) reFailed
+
+-- | Whether any Refs couldn't be resolved
+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
+resolveReexports
+ :: Map P.ModuleName [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
where
- reexports = getReexports m
- result = foldl go (removeExportDecls m) reexports
+ (failedRefs, resolvedRefs) = partitionEithers (resolveRef' <$> refs)
+ resolveRef' x@(mn, r) = case Map.lookup mn modules of
+ Nothing -> Left x
+ Just decls' -> first (mn,) (resolveRef decls' r)
+
+resolveRef
+ :: [IdeDeclarationAnn]
+ -> P.DeclarationRef
+ -> Either P.DeclarationRef [IdeDeclarationAnn]
+resolveRef decls ref = case ref of
+ P.TypeRef tn mdtors ->
+ case findRef (\case IdeType name _ -> name == tn; _ -> False) of
+ Nothing -> Left ref
+ Just d -> Right $ d : case mdtors of
+ Nothing ->
+ -- If the dataconstructor field inside the TypeRef is Nothing, that
+ -- means that all data constructors are exported, so we need to look
+ -- those up ourselfes
+ findDtors tn
+ Just dtors -> mapMaybe lookupDtor dtors
+ P.ValueRef i ->
+ findWrapped (\case IdeValue i' _ -> i' == i; _ -> False)
+ P.TypeOpRef name ->
+ findWrapped (\case IdeTypeOperator n _ _ _ -> n == name; _ -> False)
+ P.ValueOpRef name ->
+ findWrapped (\case IdeValueOperator n _ _ _ -> n == name; _ -> False)
+ P.TypeClassRef name ->
+ findWrapped (\case IdeTypeClass n -> n == name; _ -> False)
+ _ ->
+ Left ref
+ where
+ findWrapped = wrapSingle . findRef
+ wrapSingle = maybe (Left ref) (Right . pure)
+ findRef f = find (f . discardAnn) decls
- go :: Module -> ExternDecl -> Module
- go m' re@(Export name) = replaceReexport re m' (getModule name)
- go _ _ = error "partiality! woohoo"
+ lookupDtor name =
+ findRef (\case IdeDataConstructor name' _ _ -> name == name'
+ _ -> False)
- getModule :: ModuleIdent -> Module
- getModule name = clean res
+ findDtors tn = filter (f . discardAnn) decls
where
- res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db
- -- we have to do this because keeping self exports in will result in
- -- infinite loops
- clean (mn, decls) = (mn,) (filter (/= Export mn) decls)
-
-resolveReexports :: Map ModuleIdent [ExternDecl] -> Module -> Module
-resolveReexports modules m =
- let replaced = replaceReexports m modules
- in if null (getReexports replaced)
- then replaced
- else resolveReexports modules replaced
+ f :: IdeDeclaration -> Bool
+ f decl
+ | (IdeDataConstructor _ tn' _) <- decl
+ , tn == tn' = True
+ | otherwise = False
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index 8297a20..6e9ba0c 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -14,107 +14,92 @@
{-# LANGUAGE OverloadedStrings #-}
-module Language.PureScript.Ide.SourceFile where
+module Language.PureScript.Ide.SourceFile
+ ( parseModule
+ , getImportsForFile
+ , extractSpans
+ ) where
-import Prelude
+import Protolude
-import Control.Monad.Error.Class
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Except
-import Data.Maybe (mapMaybe)
-import Data.Monoid
-import qualified Data.Text as T
-import qualified Language.PureScript.AST.Declarations as D
-import qualified Language.PureScript.AST.SourcePos as SP
+import qualified Language.PureScript as P
import Language.PureScript.Ide.Error
-import Language.PureScript.Ide.Externs (unwrapPositioned,
- unwrapPositionedRef)
+import Language.PureScript.Ide.Util
import Language.PureScript.Ide.Types
-import qualified Language.PureScript.Names as N
-import qualified Language.PureScript.Parser as P
-import System.Directory
+import System.FilePath
import System.IO.UTF8 (readUTF8File)
-parseModuleFromFile :: (MonadIO m, MonadError PscIdeError m) =>
- FilePath -> m D.Module
-parseModuleFromFile fp = do
- exists <- liftIO (doesFileExist fp)
- if exists
- then do
- content <- liftIO (readUTF8File fp)
- let m = do tokens <- P.lex fp content
- P.runTokenParser "" P.parseModule tokens
- either (throwError . (`ParseError` "File could not be parsed.")) pure m
- else throwError (NotFound "File does not exist.")
+parseModule
+ :: (MonadIO m)
+ => FilePath
+ -> m (Either FilePath (FilePath, P.Module) )
+parseModule path = do
+ contents <- liftIO (readUTF8File path)
+ case P.parseModuleFromFile identity (path, contents) of
+ Left _ -> pure (Left path)
+ Right m -> pure (Right m)
--- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
-
-getDeclarations :: D.Module -> [D.Declaration]
-getDeclarations (D.Module _ _ _ declarations _) = declarations
-
-getImports :: D.Module -> [D.Declaration]
-getImports (D.Module _ _ _ declarations _) =
+getImports :: P.Module -> [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)]
+getImports (P.Module _ _ _ declarations _) =
mapMaybe isImport declarations
where
- isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i
+ isImport (P.PositionedDeclaration _ _ (P.ImportDeclaration a b c)) = Just (a, b, c)
isImport _ = Nothing
getImportsForFile :: (MonadIO m, MonadError PscIdeError m) =>
FilePath -> m [ModuleImport]
getImportsForFile fp = do
- module' <- parseModuleFromFile fp
- let imports = getImports module'
- pure (mkModuleImport . unwrapPositionedImport <$> imports)
- where
- mkModuleImport (D.ImportDeclaration mn importType' qualifier) =
- ModuleImport
- (T.pack (N.runModuleName mn))
- importType'
- (T.pack . N.runModuleName <$> qualifier)
- mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"
- unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier) =
- D.ImportDeclaration mn (unwrapImportType importType') qualifier
- unwrapPositionedImport x = x
- unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)
- unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls)
- unwrapImportType D.Implicit = D.Implicit
-
-getPositionedImports :: D.Module -> [D.Declaration]
-getPositionedImports (D.Module _ _ _ declarations _) =
- mapMaybe isImport declarations
- where
- isImport i@(D.PositionedDeclaration _ _ D.ImportDeclaration{}) = Just i
- isImport _ = Nothing
+ moduleE <- parseModule fp
+ case moduleE of
+ Left _ -> throwError (GeneralError "Failed to parse sourcefile.")
+ Right (_, module') ->
+ pure (mkModuleImport . unwrapPositionedImport <$> getImports module')
+ where
+ mkModuleImport (mn, importType', qualifier) =
+ ModuleImport
+ (runModuleNameT mn)
+ importType'
+ (runModuleNameT <$> qualifier)
+ unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q)
+ unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls)
+ unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls)
+ unwrapImportType P.Implicit = P.Implicit
-getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan
-getDeclPosition m ident = getFirst (foldMap (match ident) decls)
+-- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts
+-- definition sites inside that Declaration.
+extractSpans
+ :: P.SourceSpan
+ -- ^ The surrounding span
+ -> P.Declaration
+ -- ^ The declaration to extract spans from
+ -> [(Either Text Text, P.SourceSpan)]
+ -- ^ A @Right@ corresponds to a type level declaration, and a @Left@ to a
+ -- value level one
+extractSpans ss d = case d of
+ P.PositionedDeclaration ss' _ d' ->
+ extractSpans ss' d'
+ P.ValueDeclaration i _ _ _ ->
+ [(Left (runIdentT i), ss)]
+ P.TypeSynonymDeclaration name _ _ ->
+ [(Right (runProperNameT name), ss)]
+ P.TypeClassDeclaration name _ _ members ->
+ (Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members
+ P.DataDeclaration _ name _ ctors ->
+ (Right (runProperNameT name), ss)
+ : map (\(cname, _) -> (Left (runProperNameT cname), ss)) ctors
+ P.ExternDeclaration ident _ ->
+ [(Left (runIdentT ident), ss)]
+ P.ExternDataDeclaration name _ ->
+ [(Right (runProperNameT name), ss)]
+ _ -> []
where
- decls = getDeclarations m
- match q (D.PositionedDeclaration ss _ decl) = First (if go q decl
- then Just ss
- else Nothing)
- match _ _ = First Nothing
-
- go q (D.DataDeclaration _ name _ constructors) =
- properEqual name q || any (\(x,_) -> properEqual x q) constructors
- go q (D.DataBindingGroupDeclaration decls') = any (go q) decls'
- go q (D.TypeSynonymDeclaration name _ _) = properEqual name q
- go q (D.TypeDeclaration ident' _) = identEqual ident' q
- go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q
- go q (D.ExternDeclaration ident' _) = identEqual ident' q
- go q (D.ExternDataDeclaration name _) = properEqual name q
- go q (D.TypeClassDeclaration name _ _ members) =
- properEqual name q || any (go q . unwrapPositioned) members
- go q (D.TypeInstanceDeclaration ident' _ _ _ _) =
- identEqual ident' q
- go _ _ = False
-
- properEqual x q = N.runProperName x == q
- identEqual x q = N.runIdent x == q
-
-goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan)
-goToDefinition q fp = do
- m <- runExceptT (parseModuleFromFile fp)
- case m of
- Right module' -> pure (getDeclPosition module' q)
- Left _ -> pure Nothing
+ -- We need this special case to be able to also get the position info for
+ -- typeclass member functions. Typedeclaratations would clash with value
+ -- declarations for non-typeclass members, which is why we can't handle them
+ -- in extractSpans.
+ extractSpans' ssP dP = case dP of
+ P.PositionedDeclaration ssP' _ dP' ->
+ extractSpans' ssP' dP'
+ P.TypeDeclaration ident _ ->
+ [(Left (runIdentT ident), ssP)]
+ _ -> []
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 325a4b1..4621d39 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -17,127 +17,198 @@
{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Ide.State
- ( getPscIdeState
+ ( getLoadedModulenames
, getExternFiles
- , getModule
- , getModuleWithReexports
- , getAllModulesWithReexports
- , getAllModulesWithReexportsAndCache
+ , resetIdeState
+ , cacheRebuild
+ , insertExterns
, insertModule
- , insertModuleSTM
- , getCachedRebuild
- , resetPscIdeState
- , setCachedRebuild
+ , insertExternsSTM
+ , getAllModules
+ , populateStage2
+ , populateStage3
+ , populateStage3STM
) where
-import Prelude ()
-import Prelude.Compat
+import Protolude
+import qualified Prelude
import Control.Concurrent.STM
-import Control.Monad.IO.Class
import "monad-logger" Control.Monad.Logger
-import Control.Monad.Reader.Class
import qualified Data.Map.Lazy as M
-import Data.Maybe (mapMaybe)
-import Data.Monoid
import Language.PureScript.Externs
import Language.PureScript.Ide.Externs
import Language.PureScript.Ide.Reexports
+import Language.PureScript.Ide.SourceFile
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import qualified Language.PureScript as P
+import System.Clock
+import System.FilePath
--- | Resets the PscIdeState to emptyPscIdeState
-resetPscIdeState :: PscIde m => m ()
-resetPscIdeState = do
- stateVar <- envStateVar <$> ask
- liftIO $ atomically (writeTVar stateVar emptyPscIdeState)
+-- | Resets all State inside psc-ide
+resetIdeState :: Ide m => m ()
+resetIdeState = do
+ ideVar <- ideStateVar <$> ask
+ liftIO . atomically $ do
+ writeTVar ideVar emptyIdeState
+ setStage3STM ideVar emptyStage3
--- | Gets the entire PscIdeState
-getPscIdeState :: PscIde m => m PscIdeState
-getPscIdeState = do
- stateVar <- envStateVar <$> ask
- liftIO (readTVarIO stateVar)
+-- | Gets the loaded Modulenames
+getLoadedModulenames :: Ide m => m [P.ModuleName]
+getLoadedModulenames = M.keys <$> getExternFiles
-- | Gets all loaded ExternFiles
-getExternFiles :: (PscIde m) => m (M.Map P.ModuleName ExternsFile)
-getExternFiles = do
- stateVar <- envStateVar <$> ask
- liftIO (pscIdeStateExternsFiles <$> readTVarIO stateVar)
+getExternFiles :: Ide m => m (M.Map P.ModuleName ExternsFile)
+getExternFiles = s1Externs <$> getStage1
--- | Gets all loaded Modules and resolves Reexports
-getAllModulesWithReexports :: (PscIde m) => m [Module]
-getAllModulesWithReexports = getAllModulesWithReexports' <$> getPscIdeState
+-- | Insert a Module into Stage1 of the State
+insertModule :: Ide m => (FilePath, P.Module) -> m ()
+insertModule module' = do
+ stateVar <- ideStateVar <$> ask
+ liftIO . atomically $ insertModuleSTM stateVar module'
--- | Pure version of @getAllModulesWithReexports@
-getAllModulesWithReexports' :: PscIdeState -> [Module]
-getAllModulesWithReexports' state =
- mapMaybe (getModuleWithReexports' state) (M.keys (pscIdeStateModules state))
+-- | STM version of insertModule
+insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM ()
+insertModuleSTM ref (fp, module') =
+ modifyTVar ref $ \x ->
+ x { ideStage1 = (ideStage1 x) {
+ s1Modules = M.insert
+ (P.getModuleName module')
+ (module', fp)
+ (s1Modules (ideStage1 x))}}
+
+-- | Retrieves Stage1 from the State.
+-- This includes loaded Externfiles
+getStage1 :: Ide m => m Stage1
+getStage1 = do
+ st <- ideStateVar <$> ask
+ fmap ideStage1 . liftIO . readTVarIO $ st
+
+-- | STM version of getStage1
+getStage1STM :: TVar IdeState -> STM Stage1
+getStage1STM ref = ideStage1 <$> readTVar ref
+
+-- | Retrieves Stage2 from the State.
+getStage2 :: Ide m => m Stage2
+getStage2 = do
+ st <- ideStateVar <$> ask
+ liftIO (atomically (getStage2STM st))
+
+getStage2STM :: TVar IdeState -> STM Stage2
+getStage2STM ref = ideStage2 <$> readTVar ref
+
+-- | STM version of setStage2
+setStage2STM :: TVar IdeState -> Stage2 -> STM ()
+setStage2STM ref s2 = do
+ modifyTVar ref $ \x ->
+ x {ideStage2 = s2}
+ pure ()
+
+-- | Retrieves Stage3 from the State.
+-- This includes the denormalized Declarations and cached rebuilds
+getStage3 :: Ide m => m Stage3
+getStage3 = do
+ st <- ideStateVar <$> ask
+ fmap ideStage3 . liftIO . readTVarIO $ st
+
+-- | Sets Stage3 inside the compiler
+setStage3STM :: TVar IdeState -> Stage3 -> STM ()
+setStage3STM ref s3 = do
+ modifyTVar ref $ \x ->
+ x {ideStage3 = s3}
+ pure ()
-- | Checks if the given ModuleName matches the last rebuild cache and if it
--- does, runs @getAllModulesWithReexports@ with the cached module replacing the
--- loaded module
-getAllModulesWithReexportsAndCache
- :: (PscIde m)
- => Maybe P.ModuleName
- -> m [Module]
-getAllModulesWithReexportsAndCache Nothing = getAllModulesWithReexports
-getAllModulesWithReexportsAndCache (Just mn) = do
- state <- getPscIdeState
- cachedRebuild <- getCachedRebuild
- case cachedRebuild of
- Just (cachedIdent, ef) | cachedIdent == mn ->
- pure (getAllModulesWithReexports' (insertModule' ef state))
- _ -> getAllModulesWithReexports
-
--- | Looks up a single Module inside the loaded Modules
-getModule :: (PscIde m, MonadLogger m) => ModuleIdent -> m (Maybe Module)
-getModule m = getModule' <$> getPscIdeState <*> pure m
-
--- | Pure version of @getModule@
-getModule' :: PscIdeState -> ModuleIdent -> Maybe Module
-getModule' ps mi = (mi,) <$> M.lookup mi (pscIdeStateModules ps)
-
--- | Looks up a single Module and resolves its Reexports
-getModuleWithReexports :: PscIde m => ModuleIdent -> m (Maybe Module)
-getModuleWithReexports i = getModuleWithReexports' <$> getPscIdeState <*> pure i
-
--- | Pure version of @getModuleWithReexports@
-getModuleWithReexports' :: PscIdeState -> ModuleIdent -> Maybe Module
-getModuleWithReexports' ps mi =
- resolveReexports (pscIdeStateModules ps) <$> getModule' ps mi
-
--- | Inserts an @ExternsFile@ into the PscIdeState. Also converts the
--- ExternsFile into psc-ide's internal Declaration format
-insertModule :: (PscIde m, MonadLogger m) =>
- ExternsFile -> m ()
-insertModule externsFile = do
- stateVar <- envStateVar <$> ask
- let moduleName = efModuleName externsFile
- $(logDebug) $ "Inserting Module: " <> runModuleNameT moduleName
- liftIO . atomically $ insertModuleSTM stateVar externsFile
-
--- | STM version of insertModule
-insertModuleSTM :: TVar PscIdeState -> ExternsFile -> STM ()
-insertModuleSTM st ef = modifyTVar st (insertModule' ef)
-
--- | Pure version of insertModule
-insertModule' :: ExternsFile -> PscIdeState -> PscIdeState
-insertModule' ef state =
- state
- { pscIdeStateExternsFiles =
- M.insert (efModuleName ef) ef (pscIdeStateExternsFiles state)
- , pscIdeStateModules = let (mn, decls) = convertExterns ef
- in M.insert mn decls (pscIdeStateModules state)
- }
+-- does returns all loaded definitions + the definitions inside the rebuild
+-- cache
+getAllModules :: Ide m => Maybe P.ModuleName -> m [Module]
+getAllModules mmoduleName = do
+ declarations <- s3Declarations <$> getStage3
+ rebuild <- cachedRebuild
+ case mmoduleName of
+ Nothing -> pure (M.toList declarations)
+ Just moduleName ->
+ case rebuild of
+ Just (cachedModulename, ef)
+ | cachedModulename == moduleName -> do
+ (AstData asts) <- s2AstData <$> getStage2
+ let ast = fromMaybe M.empty (M.lookup moduleName asts)
+ pure . M.toList $
+ M.insert moduleName
+ (snd . annotateLocations ast . fst . convertExterns $ ef) declarations
+ _ -> pure (M.toList declarations)
+
+-- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the
+-- following Stages, which needs to be done after all the necessary Exterms have
+-- been loaded.
+insertExterns :: Ide m => ExternsFile -> m ()
+insertExterns ef = do
+ st <- ideStateVar <$> ask
+ liftIO (atomically (insertExternsSTM st ef))
+
+-- | STM version of insertExterns
+insertExternsSTM :: TVar IdeState -> ExternsFile -> STM ()
+insertExternsSTM ref ef =
+ modifyTVar ref $ \x ->
+ x { ideStage1 = (ideStage1 x) {
+ s1Externs = M.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}
-- | Sets rebuild cache to the given ExternsFile
-setCachedRebuild :: PscIde m => ExternsFile -> m ()
-setCachedRebuild ef = do
- st <- envStateVar <$> ask
+cacheRebuild :: Ide m => ExternsFile -> m ()
+cacheRebuild ef = do
+ st <- ideStateVar <$> ask
liftIO . atomically . modifyTVar st $ \x ->
- x { pscIdeStateCachedRebuild = Just (efModuleName ef, ef) }
+ x { ideStage3 = (ideStage3 x) {
+ s3CachedRebuild = Just (efModuleName ef, ef)}}
-- | Retrieves the rebuild cache
-getCachedRebuild :: PscIde m => m (Maybe (P.ModuleName, ExternsFile))
-getCachedRebuild = pscIdeStateCachedRebuild <$> getPscIdeState
+cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile))
+cachedRebuild = s3CachedRebuild <$> getStage3
+
+-- | Extracts source spans from the parsed ASTs
+populateStage2 :: (Ide m, MonadLogger m) => m ()
+populateStage2 = do
+ st <- ideStateVar <$> ask
+ duration <- liftIO $ do
+ start <- getTime Monotonic
+ atomically (populateStage2STM st)
+ end <- getTime Monotonic
+ pure (Prelude.show (diffTimeSpec start end))
+ $(logDebug) $ "Finished populating Stage2 in " <> toS duration
+
+-- | STM version of populateStage2
+populateStage2STM :: TVar IdeState -> STM ()
+populateStage2STM ref = do
+ modules <- s1Modules <$> getStage1STM ref
+ let spans = map (\((P.Module ss _ _ decls _), _) -> M.fromList (concatMap (extractSpans ss) decls)) modules
+ setStage2STM ref (Stage2 (AstData spans))
+
+-- | Resolves reexports and populates Stage3 with data to be used in queries.
+populateStage3 :: (Ide m, MonadLogger m) => m ()
+populateStage3 = do
+ st <- ideStateVar <$> ask
+ (duration, results) <- liftIO $ do
+ start <- getTime Monotonic
+ results <- atomically (populateStage3STM st)
+ end <- getTime Monotonic
+ pure (Prelude.show (diffTimeSpec start end), results)
+ traverse_
+ (logWarnN . prettyPrintReexportResult (runModuleNameT . fst))
+ (filter reexportHasFailures results)
+ $(logDebug) $ "Finished populating Stage3 in " <> toS duration
+
+-- | STM version of populateStage3
+populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]
+populateStage3STM ref = do
+ externs <- s1Externs <$> getStage1STM ref
+ (AstData asts) <- s2AstData <$> getStage2STM ref
+ let modules = M.map convertExterns externs
+ nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])
+ nModules = M.mapWithKey
+ (\moduleName (m, refs) ->
+ (fromMaybe m $ annotateLocations <$> M.lookup moduleName asts <*> pure m, refs)) modules
+ -- resolves reexports and discards load failures for now
+ result = resolveReexports (M.map (snd . fst) nModules) <$> M.elems nModules
+ setStage3STM ref (Stage3 (M.fromList (map reResolved result)) Nothing)
+ pure result
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 49fb2de..6bcfc7e 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -12,101 +12,123 @@
-- Type definitions for psc-ide
-----------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveFoldable #-}
module Language.PureScript.Ide.Types where
-import Prelude ()
-import Prelude.Compat
+import Protolude
import Control.Concurrent.STM
-import Control.Monad
-import Control.Monad.Reader.Class
-import Control.Monad.Trans
import Data.Aeson
import Data.Map.Lazy as M
-import Data.Maybe (maybeToList)
-import Data.Text (Text (), pack, unpack)
-import qualified Language.PureScript.AST.Declarations as D
-import Language.PureScript.Externs
import qualified Language.PureScript.Errors.JSON as P
-import qualified Language.PureScript.Names as N
import qualified Language.PureScript as P
-
-import Text.Parsec
+import Language.PureScript.Ide.Conversions
+import System.FilePath
+import Text.Parsec as Parsec
import Text.Parsec.Text
-type Ident = Text
-type DeclIdent = Text
type ModuleIdent = Text
-data ExternDecl
- -- | A function/value declaration
- = ValueDeclaration Ident P.Type
- | TypeDeclaration (P.ProperName 'P.TypeName) P.Kind
- | TypeSynonymDeclaration (P.ProperName 'P.TypeName) P.Type
- -- | A Dependency onto another Module
- | Dependency
- ModuleIdent -- name of the dependency
- [Text] -- explicit imports
- (Maybe Text) -- An eventual qualifier
- -- | A module declaration
- | ModuleDecl
- ModuleIdent -- The modules name
- [DeclIdent] -- The exported identifiers
- -- | A data/newtype declaration
- | DataConstructor
- DeclIdent -- The type name
- (P.ProperName 'P.TypeName)
- P.Type -- The "type"
- -- | An exported module
- | TypeClassDeclaration (P.ProperName 'P.ClassName)
- | ValueOperator (P.OpName 'P.ValueOpName) Ident P.Precedence P.Associativity
- | TypeOperator (P.OpName 'P.TypeOpName) Ident P.Precedence P.Associativity
- | Export ModuleIdent -- The exported Modules name
- deriving (Show,Eq,Ord)
-
-type Module = (ModuleIdent, [ExternDecl])
+data IdeDeclaration
+ = IdeValue P.Ident P.Type
+ | IdeType (P.ProperName 'P.TypeName) P.Kind
+ | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type
+ | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type
+ | IdeTypeClass (P.ProperName 'P.ClassName)
+ | IdeValueOperator (P.OpName 'P.ValueOpName) Text P.Precedence P.Associativity
+ | IdeTypeOperator (P.OpName 'P.TypeOpName) Text P.Precedence P.Associativity
+ deriving (Show, Eq, Ord)
+
+data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration
+ deriving (Show, Eq, Ord)
+
+data Annotation
+ = Annotation
+ { annLocation :: Maybe P.SourceSpan
+ , annExportedFrom :: Maybe P.ModuleName
+ } deriving (Show, Eq, Ord)
+
+emptyAnn :: Annotation
+emptyAnn = Annotation Nothing Nothing
+
+type Module = (P.ModuleName, [IdeDeclarationAnn])
+
+newtype AstData a =
+ AstData (Map P.ModuleName (Map (Either Text Text) a))
+ deriving (Show, Eq, Ord, Functor, Foldable)
data Configuration =
Configuration
{ confOutputPath :: FilePath
, confDebug :: Bool
+ , confGlobs :: [FilePath]
}
-data PscIdeEnvironment =
- PscIdeEnvironment
- { envStateVar :: TVar PscIdeState
- , envConfiguration :: Configuration
+data IdeEnvironment =
+ IdeEnvironment
+ { ideStateVar :: TVar IdeState
+ , ideConfiguration :: Configuration
}
-type PscIde m = (MonadIO m, MonadReader PscIdeEnvironment m)
+type Ide m = (MonadIO m, MonadReader IdeEnvironment m)
+
+data IdeState = IdeState
+ { ideStage1 :: Stage1
+ , ideStage2 :: Stage2
+ , ideStage3 :: Stage3
+ }
-data PscIdeState =
- PscIdeState
- { pscIdeStateModules :: M.Map Text [ExternDecl]
- , pscIdeStateExternsFiles :: M.Map P.ModuleName ExternsFile
- , pscIdeStateCachedRebuild :: Maybe (P.ModuleName, ExternsFile)
- } deriving Show
+emptyIdeState :: IdeState
+emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3
-emptyPscIdeState :: PscIdeState
-emptyPscIdeState = PscIdeState M.empty M.empty Nothing
+emptyStage1 :: Stage1
+emptyStage1 = Stage1 M.empty M.empty
-data Match = Match ModuleIdent ExternDecl
- deriving (Show, Eq)
+emptyStage2 :: Stage2
+emptyStage2 = Stage2 (AstData M.empty)
+
+emptyStage3 :: Stage3
+emptyStage3 = Stage3 M.empty Nothing
+
+data Stage1 = Stage1
+ { s1Externs :: M.Map P.ModuleName P.ExternsFile
+ , s1Modules :: M.Map P.ModuleName (P.Module, FilePath)
+ }
+
+data Stage2 = Stage2
+ { s2AstData :: AstData P.SourceSpan
+ }
+
+data Stage3 = Stage3
+ { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]
+ , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)
+ }
+
+newtype Match a = Match (P.ModuleName, a)
+ deriving (Show, Eq, Functor)
newtype Completion =
- Completion (ModuleIdent, DeclIdent, Text)
+ Completion (Text, Text, Text)
+ deriving (Show,Eq)
+
+newtype Info =
+ Info (Text, Text, Text, Maybe P.SourceSpan)
deriving (Show,Eq)
+instance ToJSON Info where
+ toJSON (Info (m, d, t, sourceSpan)) =
+ object ["module" .= m, "identifier" .= d, "type" .= t, "definedAt" .= sourceSpan]
+
instance ToJSON Completion where
- toJSON (Completion (m,d,t)) =
+ toJSON (Completion (m, d, t)) =
object ["module" .= m, "identifier" .= d, "type" .= t]
data ModuleImport =
ModuleImport
{ importModuleName :: ModuleIdent
- , importType :: D.ImportDeclarationType
+ , importType :: P.ImportDeclarationType
, importQualifier :: Maybe Text
} deriving(Show)
@@ -116,29 +138,30 @@ instance Eq ModuleImport where
&& importQualifier mi1 == importQualifier mi2
instance ToJSON ModuleImport where
- toJSON (ModuleImport mn D.Implicit qualifier) =
+ toJSON (ModuleImport mn P.Implicit qualifier) =
object $ [ "module" .= mn
, "importType" .= ("implicit" :: Text)
] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)
- toJSON (ModuleImport mn (D.Explicit refs) _) =
+ toJSON (ModuleImport mn (P.Explicit refs) _) =
object [ "module" .= mn
, "importType" .= ("explicit" :: Text)
, "identifiers" .= (identifierFromDeclarationRef <$> refs)
]
- toJSON (ModuleImport mn (D.Hiding refs) _) =
+ toJSON (ModuleImport mn (P.Hiding refs) _) =
object [ "module" .= mn
, "importType" .= ("hiding" :: Text)
, "identifiers" .= (identifierFromDeclarationRef <$> refs)
]
-identifierFromDeclarationRef :: D.DeclarationRef -> String
-identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name
-identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident
-identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name
+identifierFromDeclarationRef :: P.DeclarationRef -> Text
+identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name
+identifierFromDeclarationRef (P.ValueRef ident) = runIdentT ident
+identifierFromDeclarationRef (P.TypeClassRef name) = runProperNameT name
identifierFromDeclarationRef _ = ""
data Success =
CompletionResult [Completion]
+ | InfoResult [Info]
| TextResult Text
| MultilineTextResult [Text]
| PursuitResult [PursuitResponse]
@@ -153,6 +176,7 @@ encodeSuccess res =
instance ToJSON Success where
toJSON (CompletionResult cs) = encodeSuccess cs
+ toJSON (InfoResult i) = encodeSuccess i
toJSON (TextResult t) = encodeSuccess t
toJSON (MultilineTextResult ts) = encodeSuccess ts
toJSON (PursuitResult resp) = encodeSuccess resp
@@ -182,14 +206,14 @@ data PursuitResponse =
ModuleResponse ModuleIdent Text
-- | A Pursuit Response for a declaration. Consist of the declarations type,
-- module, name and package
- | DeclarationResponse Text ModuleIdent DeclIdent Text
+ | DeclarationResponse Text ModuleIdent Text Text
deriving (Show,Eq)
instance FromJSON PursuitResponse where
parseJSON (Object o) = do
package <- o .: "package"
info <- o .: "info"
- (type' :: String) <- info .: "type"
+ (type' :: Text) <- info .: "type"
case type' of
"module" -> do
name <- info .: "module"
@@ -204,26 +228,26 @@ instance FromJSON PursuitResponse where
typeParse :: Text -> Either Text (Text, Text)
typeParse t = case parse parseType "" t of
- Right (x,y) -> Right (pack x, pack y)
- Left err -> Left (pack (show err))
+ Right (x,y) -> Right (x, y)
+ Left err -> Left (show err)
where
- parseType :: Parser (String, String)
+ parseType :: Parser (Text, Text)
parseType = do
name <- identifier
_ <- string "::"
spaces
type' <- many1 anyChar
- pure (unpack name, type')
+ pure (name, toS type')
identifier :: Parser Text
identifier = do
spaces
ident <-
-- necessary for being able to parse the following ((++), concat)
- between (char '(') (char ')') (many1 (noneOf ", )")) <|>
+ between (char '(') (char ')') (many1 (noneOf ", )")) Parsec.<|>
many1 (noneOf ", )")
spaces
- pure (pack ident)
+ pure (toS ident)
instance ToJSON PursuitResponse where
toJSON (ModuleResponse name package) =
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index 839bfc2..4e4c235 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -9,75 +9,87 @@
-- Stability : experimental
--
-- |
--- Generally useful functions and conversions
+-- Generally useful functions
-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
-module Language.PureScript.Ide.Util where
+module Language.PureScript.Ide.Util
+ ( identifierFromIdeDeclaration
+ , unwrapMatch
+ , unwrapPositioned
+ , unwrapPositionedRef
+ , completionFromMatch
+ , infoFromMatch
+ , encodeT
+ , decodeT
+ , discardAnn
+ , module Language.PureScript.Ide.Conversions
+ ) where
-import Prelude.Compat
+import Protolude
import Data.Aeson
-import Data.Text (Text)
import qualified Data.Text as T
-import Data.Text.Lazy (fromStrict, toStrict)
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
import qualified Language.PureScript as P
import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Conversions
-runProperNameT :: P.ProperName a -> Text
-runProperNameT = T.pack . P.runProperName
+identifierFromIdeDeclaration :: IdeDeclaration -> Text
+identifierFromIdeDeclaration d = case d of
+ IdeValue name _ -> runIdentT name
+ IdeType name _ -> runProperNameT name
+ IdeTypeSynonym name _ -> runProperNameT name
+ IdeDataConstructor name _ _ -> runProperNameT name
+ IdeTypeClass name -> runProperNameT name
+ IdeValueOperator op _ _ _ -> runOpNameT op
+ IdeTypeOperator op _ _ _ -> runOpNameT op
-runIdentT :: P.Ident -> Text
-runIdentT = T.pack . P.runIdent
+discardAnn :: IdeDeclarationAnn -> IdeDeclaration
+discardAnn (IdeDeclarationAnn _ d) = d
-runOpNameT :: P.OpName a -> Text
-runOpNameT = T.pack . P.runOpName
+unwrapMatch :: Match a -> a
+unwrapMatch (Match (_, ed)) = ed
-runModuleNameT :: P.ModuleName -> Text
-runModuleNameT = T.pack . P.runModuleName
+completionFromMatch :: Match IdeDeclaration -> Completion
+completionFromMatch = Completion . completionFromMatch'
-prettyTypeT :: P.Type -> Text
-prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType
-
-identifierFromExternDecl :: ExternDecl -> Text
-identifierFromExternDecl (ValueDeclaration name _) = name
-identifierFromExternDecl (TypeDeclaration name _) = runProperNameT name
-identifierFromExternDecl (TypeSynonymDeclaration name _) = runProperNameT name
-identifierFromExternDecl (DataConstructor name _ _) = name
-identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name
-identifierFromExternDecl (ModuleDecl name _) = name
-identifierFromExternDecl (ValueOperator op _ _ _) = runOpNameT op
-identifierFromExternDecl (TypeOperator op _ _ _) = runOpNameT op
-identifierFromExternDecl Dependency{} = "~Dependency~"
-identifierFromExternDecl Export{} = "~Export~"
-
-identifierFromMatch :: Match -> Text
-identifierFromMatch (Match _ ed) = identifierFromExternDecl ed
-
-completionFromMatch :: Match -> Maybe Completion
-completionFromMatch (Match m d) = case d of
- ValueDeclaration name type' -> Just $ Completion (m, name, prettyTypeT type')
- TypeDeclaration name kind -> Just $ Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind)
- TypeSynonymDeclaration name kind -> Just $ Completion (m, runProperNameT name, prettyTypeT kind)
- DataConstructor name _ type' -> Just $ Completion (m, name, prettyTypeT type')
- TypeClassDeclaration name -> Just $ Completion (m, runProperNameT name, "class")
- ModuleDecl name _ -> Just $ Completion ("module", name, "module")
- ValueOperator op ref precedence associativity -> Just $ Completion (m, runOpNameT op, showFixity precedence associativity ref op)
- TypeOperator op ref precedence associativity -> Just $ Completion (m, runOpNameT op, showFixity precedence associativity ref op)
- Dependency{} -> Nothing
- Export{} -> Nothing
+completionFromMatch' :: Match IdeDeclaration -> (Text, Text, Text)
+completionFromMatch' (Match (m', d)) = case d of
+ IdeValue name type' -> (m, runIdentT name, prettyTypeT type')
+ IdeType name kind -> (m, runProperNameT name, toS (P.prettyPrintKind kind))
+ IdeTypeSynonym name kind -> (m, runProperNameT name, prettyTypeT kind)
+ IdeDataConstructor name _ type' -> (m, runProperNameT name, prettyTypeT type')
+ IdeTypeClass name -> (m, runProperNameT name, "class")
+ IdeValueOperator op ref precedence associativity ->
+ (m, runOpNameT op, showFixity precedence associativity ref op)
+ IdeTypeOperator op ref precedence associativity ->
+ (m, runOpNameT op, showFixity precedence associativity ref op)
where
+ m = runModuleNameT m'
showFixity p a r o =
let asso = case a of
P.Infix -> "infix"
P.Infixl -> "infixl"
P.Infixr -> "infixr"
- in T.unwords [asso, T.pack (show p), r, "as", runOpNameT o]
+ in T.unwords [asso, show p, r, "as", runOpNameT o]
+infoFromMatch :: Match IdeDeclarationAnn -> Info
+infoFromMatch (Match (m, (IdeDeclarationAnn ann d))) =
+ Info (a, b, c, annLocation ann)
+ where
+ (a, b, c) = completionFromMatch' (Match (m, d))
encodeT :: (ToJSON a) => a -> Text
-encodeT = toStrict . decodeUtf8 . encode
+encodeT = toS . decodeUtf8 . encode
decodeT :: (FromJSON a) => Text -> Maybe a
-decodeT = decode . encodeUtf8 . fromStrict
+decodeT = decode . encodeUtf8 . toS
+
+unwrapPositioned :: P.Declaration -> P.Declaration
+unwrapPositioned (P.PositionedDeclaration _ _ x) = x
+unwrapPositioned x = x
+
+unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
+unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x
+unwrapPositionedRef x = x
diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs
index 4ebe68e..8ae6213 100644
--- a/src/Language/PureScript/Ide/Watcher.hs
+++ b/src/Language/PureScript/Ide/Watcher.hs
@@ -12,35 +12,35 @@
-- File watcher for externs files
-----------------------------------------------------------------------------
-module Language.PureScript.Ide.Watcher where
+module Language.PureScript.Ide.Watcher
+ ( watcher
+ ) where
+
+import Protolude
-import Control.Concurrent (threadDelay)
import Control.Concurrent.STM
-import Control.Monad
-import Control.Monad.Trans.Except
import Language.PureScript.Ide.Externs
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
-import Prelude
import System.FilePath
import System.FSNotify
-- | Reloads an ExternsFile from Disc. If the Event indicates the ExternsFile
-- was deleted we don't do anything.
-reloadFile :: TVar PscIdeState -> Event -> IO ()
+reloadFile :: TVar IdeState -> Event -> IO ()
reloadFile _ Removed{} = pure ()
-reloadFile stateVar ev = do
+reloadFile ref ev = do
let fp = eventPath ev
ef' <- runExceptT (readExternFile fp)
case ef' of
Left _ -> pure ()
Right ef -> do
- atomically (insertModuleSTM stateVar ef)
+ void $ atomically (insertExternsSTM ref ef *> populateStage3STM ref)
putStrLn ("Reloaded File at: " ++ fp)
-- | Installs filewatchers for the given directory and reloads ExternsFiles when
-- they change on disc
-watcher :: TVar PscIdeState -> FilePath -> IO ()
+watcher :: TVar IdeState -> FilePath -> IO ()
watcher stateVar fp =
withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do
_ <- watchTree mgr fp
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index 766099f..f39f90e 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DataKinds #-}
@@ -19,6 +17,7 @@ import Prelude ()
import Prelude.Compat
import Data.List (intercalate, nub, sort, find, foldl')
+import Data.Maybe (mapMaybe)
import qualified Data.Map as M
import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -39,8 +38,7 @@ import Language.PureScript.Interactive.Parser as Interactive
import Language.PureScript.Interactive.Printer as Interactive
import Language.PureScript.Interactive.Types as Interactive
-import System.Exit
-import System.Process (readProcessWithExitCode)
+import System.FilePath ((</>))
-- | Pretty-print errors
printErrors :: MonadIO m => P.MultipleErrors -> m ()
@@ -92,25 +90,28 @@ make ms = do
-- | Performs a PSCi command
handleCommand
:: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
- => Command
+ => (String -> m ())
-> m ()
-handleCommand ShowHelp = liftIO $ putStrLn helpMessage
-handleCommand ResetState = handleResetState
-handleCommand (Expression val) = handleExpression val
-handleCommand (Import im) = handleImport im
-handleCommand (Decls l) = handleDecls l
-handleCommand (TypeOf val) = handleTypeOf val
-handleCommand (KindOf typ) = handleKindOf typ
-handleCommand (BrowseModule moduleName) = handleBrowse moduleName
-handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
-handleCommand (ShowInfo QueryImport) = handleShowImportedModules
-handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
+ -> Command
+ -> m ()
+handleCommand _ _ ShowHelp = liftIO $ putStrLn helpMessage
+handleCommand _ r ResetState = handleResetState r
+handleCommand c _ (Expression val) = handleExpression c val
+handleCommand _ _ (Import im) = handleImport im
+handleCommand _ _ (Decls l) = handleDecls l
+handleCommand _ _ (TypeOf val) = handleTypeOf val
+handleCommand _ _ (KindOf typ) = handleKindOf typ
+handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName
+handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules
+handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules
+handleCommand _ _ QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
-- | Reset the application state
handleResetState
:: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
=> m ()
-handleResetState = do
+ -> m ()
+handleResetState reload = do
modify $ updateImportedModules (const [])
. updateLets (const [])
files <- asks psciLoadedFiles
@@ -120,30 +121,25 @@ handleResetState = do
return (map snd modules, externs)
case e of
Left errs -> printErrors errs
- Right (modules, externs) -> modify (updateLoadedExterns (const (zip modules externs)))
+ Right (modules, externs) -> do
+ modify (updateLoadedExterns (const (zip modules externs)))
+ reload
-- | Takes a value expression and evaluates it with the current state.
---
--- TODO: factor out the Node process runner, so that we can use PSCi in other settings.
handleExpression
:: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
- => P.Expr
+ => (String -> m ())
+ -> P.Expr
-> m ()
-handleExpression val = do
+handleExpression evaluate val = do
st <- get
let m = createTemporaryModule True st val
- nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags)
e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
case e of
Left errs -> printErrors errs
Right _ -> do
- liftIO $ writeFile indexFile "require('$PSCI')['$main']();"
- process <- liftIO findNodeProcess
- result <- liftIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
- case result of
- Just (ExitSuccess, out, _) -> liftIO $ putStrLn out
- Just (ExitFailure _, _, err) -> liftIO $ putStrLn err
- Nothing -> liftIO $ putStrLn "Couldn't find node.js"
+ js <- liftIO $ readFile (modulesDir </> "$PSCI" </> "index.js")
+ evaluate js
-- |
-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
@@ -188,17 +184,27 @@ handleShowImportedModules = do
showDeclType P.Implicit = ""
showDeclType (P.Explicit refs) = refsList refs
showDeclType (P.Hiding refs) = " hiding " ++ refsList refs
- refsList refs = " (" ++ commaList (map showRef refs) ++ ")"
+ refsList refs = " (" ++ commaList (mapMaybe showRef refs) ++ ")"
- showRef :: P.DeclarationRef -> String
- showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
- showRef (P.TypeOpRef op) = "type " ++ N.showOp op
- showRef (P.ValueRef ident) = N.runIdent ident
- showRef (P.ValueOpRef op) = N.showOp op
- showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn
- showRef (P.TypeInstanceRef ident) = N.runIdent ident
- showRef (P.ModuleRef name) = "module " ++ N.runModuleName name
- showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
+ showRef :: P.DeclarationRef -> Maybe String
+ showRef (P.TypeRef pn dctors) =
+ Just $ N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
+ showRef (P.TypeOpRef op) =
+ Just $ "type " ++ N.showOp op
+ showRef (P.ValueRef ident) =
+ Just $ N.runIdent ident
+ showRef (P.ValueOpRef op) =
+ Just $ N.showOp op
+ showRef (P.TypeClassRef pn) =
+ Just $ "class " ++ N.runProperName pn
+ showRef (P.TypeInstanceRef ident) =
+ Just $ N.runIdent ident
+ showRef (P.ModuleRef name) =
+ Just $ "module " ++ N.runModuleName name
+ showRef (P.ReExportRef _ _) =
+ Nothing
+ showRef (P.PositionedDeclarationRef _ _ ref) =
+ showRef ref
commaList :: [String] -> String
commaList = intercalate ", "
diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs
index 1c20721..deae8c6 100644
--- a/src/Language/PureScript/Interactive/Types.hs
+++ b/src/Language/PureScript/Interactive/Types.hs
@@ -13,7 +13,6 @@ import qualified Language.PureScript as P
--
data PSCiConfig = PSCiConfig
{ psciLoadedFiles :: [FilePath]
- , psciNodeFlags :: [String]
, psciEnvironment :: P.Environment
} deriving Show
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index 782af1c..768bd0c 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -140,7 +140,7 @@ missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (Obj
where
fm = fromMaybe e
- compBS :: Eq a => b -> a -> Maybe b -> Maybe b -> (a, (b, b))
+ compBS :: b -> a -> Maybe b -> Maybe b -> (a, (b, b))
compBS e s b b' = (s, compB e b b')
(sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'
@@ -274,7 +274,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step (
--
-- The binder information is provided so that it can be embedded in the constraint,
-- and then included in the error message.
- addPartialConstraint :: MonadSupply m => ([[Binder]], Bool) -> Expr -> m Expr
+ addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr
addPartialConstraint (bss, complete) e = do
tyVar <- ("p" ++) . show <$> fresh
var <- freshName
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index df4cda0..41def96 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -169,8 +169,7 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do
go (q, name) = M.alter (Just . maybe [name] (name :)) q
extractByQual
- :: Eq a
- => ModuleName
+ :: ModuleName
-> M.Map (Qualified a) [ImportRecord a]
-> (a -> Name)
-> [(ModuleName, Qualified Name)]
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 7192f74..d4dc6e3 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -132,7 +132,7 @@ data RebuildPolicy
| RebuildAlways deriving (Show, Read, Eq, Ord)
-- | Rebuild a single module
-rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [ExternsFile]
-> Module
@@ -159,7 +159,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
-- 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, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [Module]
-> m [ExternsFile]
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index c98ce2e..b7f530e 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -72,7 +72,7 @@ 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
--
-fold :: 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
+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
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 71d6b18..ea526ca 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -114,7 +114,7 @@ blockIndent = 4
-- |
-- Pretty print with a new indentation level
--
-withIndent :: (Emit gen) => StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen
+withIndent :: StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen
withIndent action = do
modify $ \st -> st { indent = indent st + blockIndent }
result <- action
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 682e85a..d2bfc8c 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -21,6 +21,7 @@ module Language.PureScript.Publish
, getResolvedDependencies
) where
+import Prelude ()
import Prelude.Compat hiding (userError)
import Control.Arrow ((***))
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index d8cd571..717b418 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -144,7 +144,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)
toTuple (PositionedDeclaration _ _ d) = toTuple d
toTuple _ = internalError "Not a value declaration"
-makeCaseDeclaration :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
+makeCaseDeclaration :: forall m. (MonadSupply m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
makeCaseDeclaration ident alternatives = do
let namedArgs = map findName . fst <$> alternatives
argNames = foldl1 resolveNames namedArgs
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index d8a8a78..052934a 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -10,7 +10,7 @@ module Language.PureScript.Sugar.Names
import Prelude.Compat
-import Control.Arrow (first, second)
+import Control.Arrow (first)
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Lazy
@@ -84,16 +84,19 @@ desugarImportsWithEnv externs modules = do
toExportedType _ = Nothing
exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName
- exportedTypeOps = M.fromList $ (, efModuleName) <$> mapMaybe getTypeOpRef efExports
+ exportedTypeOps = exportedRefs getTypeOpRef
exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName
- exportedTypeClasses = M.fromList $ (, efModuleName) <$> mapMaybe getTypeClassRef efExports
+ exportedTypeClasses = exportedRefs getTypeClassRef
exportedValues :: M.Map Ident ModuleName
- exportedValues = M.fromList $ (, efModuleName) <$> mapMaybe getValueRef efExports
+ exportedValues = exportedRefs getValueRef
exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName
- exportedValueOps = M.fromList $ (, efModuleName) <$> mapMaybe getValueOpRef efExports
+ exportedValueOps = exportedRefs getValueOpRef
+
+ exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ModuleName
+ exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports
updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)
updateEnv (ms, env) m@(Module ss _ mn _ refs) =
@@ -110,9 +113,10 @@ desugarImportsWithEnv externs modules = do
renameInModule' env m@(Module _ _ mn _ _) =
warnAndRethrow (addHint (ErrorInModule mn)) $ do
let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env
- (m', used) <- flip runStateT M.empty $ renameInModule imps (elaborateExports exps m)
- lintImports m' env used
- return m'
+ (m', used) <- flip runStateT M.empty $ renameInModule imps m
+ let m'' = elaborateExports exps m'
+ lintImports m'' env used
+ return m''
-- |
-- Make all exports for a module explicit. This may still effect modules that
@@ -121,24 +125,25 @@ desugarImportsWithEnv externs modules = do
--
elaborateExports :: Exports -> Module -> Module
elaborateExports exps (Module ss coms mn decls refs) =
- Module ss coms mn decls $
- Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) myTypes ++
- map TypeOpRef (my exportedTypeOps) ++
- map TypeClassRef (my exportedTypeClasses) ++
- map ValueRef (my exportedValues) ++
- map ValueOpRef (my exportedValueOps) ++
- maybe [] (filter isModuleRef) refs
+ Module ss coms mn decls $ Just
+ $ elaboratedTypeRefs
+ ++ go TypeOpRef exportedTypeOps
+ ++ go TypeClassRef exportedTypeClasses
+ ++ go ValueRef exportedValues
+ ++ go ValueOpRef exportedValueOps
+ ++ maybe [] (filter isModuleRef) refs
where
- -- Extracts a list of values from the exports and filters out any values that
- -- are re-exports from other modules.
- my :: (Exports -> M.Map a ModuleName) -> [a]
- my = map fst <$> filt (== mn)
- myTypes :: [(ProperName 'TypeName, [ProperName 'ConstructorName])]
- myTypes = second fst <$> filt ((== mn) . snd) exportedTypes
+ elaboratedTypeRefs :: [DeclarationRef]
+ elaboratedTypeRefs =
+ flip map (M.toList (exportedTypes exps)) $ \(tctor, (dctors, mn')) ->
+ let ref = TypeRef tctor (Just dctors)
+ in if mn == mn' then ref else ReExportRef mn' ref
- filt :: (b -> Bool) -> (Exports -> M.Map a b) -> [(a, b)]
- filt predicate f = M.toList $ predicate `M.filter` f exps
+ go :: (a -> DeclarationRef) -> (Exports -> M.Map a ModuleName) -> [DeclarationRef]
+ go toRef select =
+ flip map (M.toList (select exps)) $ \(export, mn') ->
+ if mn == mn' then toRef export else ReExportRef mn' (toRef export)
-- |
-- Replaces all local names with qualified names within a module and checks that all existing
@@ -292,7 +297,7 @@ renameInModule imports (Module ss coms mn decls exps) =
-- qualified references are replaced with their canoncial qualified names
-- (e.g. M.Map -> Data.Map.Map).
update
- :: (Ord a, Show a)
+ :: (Ord a)
=> M.Map (Qualified a) [ImportRecord a]
-> (a -> Name)
-> Qualified a
@@ -329,5 +334,5 @@ renameInModule imports (Module ss coms mn decls exps) =
_ -> throwUnknown
where
- positioned err = maybe err (`rethrowWithPosition` err) pos
+ positioned err = maybe err (`warnAndRethrowWithPosition` err) pos
throwUnknown = throwError . errorMessage . UnknownName . fmap toName $ qname
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
index 14a34f5..de29d11 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -375,7 +375,7 @@ getExports env mn =
--
checkImportConflicts
:: forall m a
- . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> (a -> Name)
-> [ImportRecord a]
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
index cf9bcf3..b210b00 100644
--- a/src/Language/PureScript/Sugar/Names/Exports.hs
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -117,8 +117,7 @@ resolveExports env ss mn imps exps refs =
-- Extracts a list of values for a module based on a lookup table. If the
-- boolean is true the values are filtered by the qualification
extract
- :: (Show a, Ord a)
- => Bool
+ :: Bool
-> ModuleName
-> (a -> Name)
-> M.Map (Qualified a) [ImportRecord a]
diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs
index b8640a9..616921b 100644
--- a/src/Language/PureScript/Sugar/Names/Imports.hs
+++ b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -207,6 +207,7 @@ resolveImport importModule exps imps impQual = resolveByType
return $ imp { importedTypeClasses = typeClasses' }
importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef"
importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef"
+ importRef _ _ ReExportRef{} = internalError "ReExportRef in importRef"
-- Find all exported data constructors for a given type
allExportedDataConstructors
@@ -218,7 +219,7 @@ resolveImport importModule exps imps impQual = resolveByType
-- Add something to an import resolution list
updateImports
- :: (Ord a)
+ :: Ord a
=> M.Map (Qualified a) [ImportRecord a]
-> M.Map a b
-> (b -> ModuleName)
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 8b56bd9..95ffb95 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -53,7 +53,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
addDataConstructor moduleName dtype name (map fst args) dctor tys
addDataConstructor
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m)
=> ModuleName
-> DataDeclType
-> ProperName 'TypeName
@@ -71,7 +71,7 @@ addDataConstructor moduleName dtype name args dctor tys = do
putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
addTypeSynonym
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m)
=> ModuleName
-> ProperName 'TypeName
-> [(String, Maybe Kind)]
@@ -85,7 +85,7 @@ addTypeSynonym moduleName name args ty kind = do
, typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
valueIsNotDefined
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m)
=> ModuleName
-> Ident
-> m ()
@@ -96,7 +96,7 @@ valueIsNotDefined moduleName name = do
Nothing -> return ()
addValue
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m)
=> ModuleName
-> Ident
-> Type
@@ -107,7 +107,7 @@ addValue moduleName name ty nameKind = do
putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
addTypeClass
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m)
=> ModuleName
-> ProperName 'ClassName
-> [(String, Maybe Kind)]
@@ -123,7 +123,7 @@ addTypeClass moduleName pn args implies ds =
toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
addTypeClassDictionaries
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m)
=> Maybe ModuleName
-> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)
-> m ()
@@ -132,7 +132,7 @@ addTypeClassDictionaries mn entries =
where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)
checkDuplicateTypeArguments
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m)
=> [String]
-> m ()
checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
@@ -159,7 +159,7 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
-- Check that type synonyms are fully-applied in a type
--
checkTypeSynonyms
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m)
=> Type
-> m ()
checkTypeSynonyms = void . replaceAllTypeSynonyms
diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs
index 0267da9..850ae12 100644
--- a/src/Language/PureScript/TypeChecker/Rows.hs
+++ b/src/Language/PureScript/TypeChecker/Rows.hs
@@ -9,17 +9,15 @@ import Prelude.Compat
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.State.Class (MonadState(..))
import Data.List
import Language.PureScript.AST
import Language.PureScript.Errors
-import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Types
-- | Ensure rows do not contain duplicate labels
-checkDuplicateLabels :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m ()
+checkDuplicateLabels :: forall m. (MonadError MultipleErrors m) => Expr -> m ()
checkDuplicateLabels =
let (_, f, _) = everywhereOnValuesM def go def
in void . f
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index 603b902..62d6108 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -89,7 +89,7 @@ skolemizeTypesInValue ident sko scope ss =
-- |
-- Ensure skolem variables do not escape their scope
--
-skolemEscapeCheck :: (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m ()
+skolemEscapeCheck :: (MonadError MultipleErrors m) => Expr -> m ()
skolemEscapeCheck (TypedValue False _ _) = return ()
skolemEscapeCheck root@TypedValue{} =
-- Every skolem variable is created when a ForAll type is skolemized.
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index c24b62d..e405537 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -133,7 +133,7 @@ type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
type UntypedData = [(Ident, Type)]
typeDictionaryForBindingGroup ::
- (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadState CheckState m) =>
ModuleName ->
[(Ident, Expr)] ->
m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
@@ -206,7 +206,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
-- | Check the kind of a type, failing if it is not of kind *.
checkTypeKind ::
- (MonadState CheckState m, MonadError MultipleErrors m) =>
+ (MonadError MultipleErrors m) =>
Type ->
Kind ->
m ()
diff --git a/stack.yaml b/stack.yaml
index 5a35886..304ee4c 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,8 +1,5 @@
-resolver: lts-5.4
+resolver: lts-6.1
packages:
- '.'
-extra-deps:
-- bower-json-0.8.0
-- language-javascript-0.6.0.4
-- parsec-3.1.11
+extra-deps: []
flags: {}
diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs
index 6415ec0..cc705f8 100644
--- a/tests/Language/PureScript/Ide/FilterSpec.hs
+++ b/tests/Language/PureScript/Ide/FilterSpec.hs
@@ -1,32 +1,31 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
module Language.PureScript.Ide.FilterSpec where
-import Data.Text (Text)
+import Protolude
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Types
import qualified Language.PureScript as P
import Test.Hspec
-value :: Text -> ExternDecl
-value s = ValueDeclaration s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0)
+value :: Text -> IdeDeclarationAnn
+value s = IdeDeclarationAnn emptyAnn (IdeValue (P.Ident (toS s)) P.REmpty)
+
+moduleA, moduleB :: Module
+moduleA = (P.moduleNameFromString "Module.A", [value "function1"])
+moduleB = (P.moduleNameFromString "Module.B", [value "data1"])
modules :: [Module]
-modules =
- [
- ("Module.A", [value "function1"]),
- ("Module.B", [value "data1"]),
- ("Module.C", [ModuleDecl "Module.C" []]),
- ("Module.D", [Dependency "Module.C" [] Nothing, value "asd"])
- ]
+modules = [moduleA, moduleB]
runEq :: Text -> [Module]
-runEq s = runFilter (equalityFilter s) modules
+runEq s = applyFilters [equalityFilter s] modules
+
runPrefix :: Text -> [Module]
-runPrefix s = runFilter (prefixFilter s) modules
-runModule :: [ModuleIdent] -> [Module]
-runModule ms = runFilter (moduleFilter ms) modules
-runDependency :: [ModuleIdent] -> [Module]
-runDependency ms = runFilter (dependencyFilter ms) modules
+runPrefix s = applyFilters [prefixFilter s] modules
+
+runModule :: [P.ModuleName] -> [Module]
+runModule ms = applyFilters [moduleFilter ms] modules
spec :: Spec
spec = do
@@ -34,30 +33,20 @@ spec = do
it "removes empty modules" $
runEq "test" `shouldBe` []
it "keeps function declarations that are equal" $
- runEq "function1" `shouldBe` [head modules]
- -- TODO: It would be more sensible to match Constructors
+ runEq "function1" `shouldBe` [moduleA]
it "keeps data declarations that are equal" $
- runEq "data1" `shouldBe` [modules !! 1]
+ runEq "data1" `shouldBe` [moduleB]
describe "prefixFilter" $ do
it "keeps everything on empty string" $
runPrefix "" `shouldBe` modules
it "keeps functionname prefix matches" $
- runPrefix "fun" `shouldBe` [head modules]
+ runPrefix "fun" `shouldBe` [moduleA]
it "keeps data decls prefix matches" $
- runPrefix "dat" `shouldBe` [modules !! 1]
- it "keeps module decl prefix matches" $
- runPrefix "Mod" `shouldBe` [modules !! 2]
+ runPrefix "dat" `shouldBe` [moduleB]
describe "moduleFilter" $ do
it "removes everything on empty input" $
runModule [] `shouldBe` []
it "only keeps the specified modules" $
- runModule ["Module.A", "Module.C"] `shouldBe` [head modules, modules !! 2]
+ runModule [P.moduleNameFromString "Module.A"] `shouldBe` [moduleA]
it "ignores modules that are not in scope" $
- runModule ["Module.A", "Module.C", "Unknown"] `shouldBe` [head modules, modules !! 2]
- describe "dependencyFilter" $ do
- it "removes everything on empty input" $
- runDependency [] `shouldBe` []
- it "only keeps the specified modules if they have no imports" $
- runDependency ["Module.A", "Module.B"] `shouldBe` [head modules, modules !! 1]
- it "keeps the specified modules and their imports" $
- runDependency ["Module.A", "Module.D"] `shouldBe` [head modules, modules !! 2, modules !! 3]
+ runModule (P.moduleNameFromString <$> ["Module.A", "Unknown"]) `shouldBe` [moduleA]
diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
index ef56ccb..1d7abbb 100644
--- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
+++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
module Language.PureScript.Ide.Imports.IntegrationSpec where
-import Control.Monad (void)
-import Data.Text (Text)
+
+import Protolude
+
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Language.PureScript.Ide.Integration as Integration
@@ -12,9 +14,7 @@ import System.Directory
import System.FilePath
setup :: IO ()
-setup = do
- Integration.reset
- mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"]
+setup = void (Integration.reset *> Integration.loadAll)
withSupportFiles :: (FilePath -> FilePath -> IO a) -> IO ()
withSupportFiles test = do
@@ -35,52 +35,41 @@ spec = beforeAll_ setup . describe "Adding imports" $ do
let
sourceFileSkeleton :: [Text] -> [Text]
sourceFileSkeleton importSection =
- [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId = id"]
+ [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"]
it "adds an implicit import" $ do
withSupportFiles (Integration.addImplicitImport "ImportsSpec1")
outputFileShouldBe (sourceFileSkeleton
[ "import ImportsSpec1"
- , "import Main (id)"
])
it "adds an explicit unqualified import" $ do
withSupportFiles (Integration.addImport "exportedFunction")
outputFileShouldBe (sourceFileSkeleton
[ "import ImportsSpec1 (exportedFunction)"
- , "import Main (id)"
])
it "adds an explicit unqualified import (type)" $ do
withSupportFiles (Integration.addImport "MyType")
- outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyType)"
- , "import Main (id)"
- ])
+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyType)"])
it "adds an explicit unqualified import (parameterized type)" $ do
withSupportFiles (Integration.addImport "MyParamType")
- outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyParamType)"
- , "import Main (id)"
- ])
+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyParamType)"])
it "adds an explicit unqualified import (typeclass)" $ do
withSupportFiles (Integration.addImport "ATypeClass")
- outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (class ATypeClass)"
- , "import Main (id)"])
+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (class ATypeClass)"])
it "adds an explicit unqualified import (dataconstructor)" $ do
withSupportFiles (Integration.addImport "MyJust")
- outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyMaybe(MyJust))"
- , "import Main (id)"])
+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(MyJust))"])
it "adds an explicit unqualified import (newtype)" $ do
withSupportFiles (Integration.addImport "MyNewtype")
- outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyNewtype(MyNewtype))"
- , "import Main (id)"])
+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(MyNewtype))"])
it "adds an explicit unqualified import (typeclass member function)" $ do
withSupportFiles (Integration.addImport "typeClassFun")
- outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (typeClassFun)"
- , "import Main (id)"])
+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (typeClassFun)"])
it "doesn't add a newtypes constructor if only the type is exported" $ do
withSupportFiles (Integration.addImport "OnlyTypeExported")
- outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (OnlyTypeExported)"
- , "import Main (id)"])
+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (OnlyTypeExported)"])
it "doesn't add an import if the identifier is defined in the module itself" $ do
withSupportFiles (Integration.addImport "myId")
- outputFileShouldBe (sourceFileSkeleton [ "import Main (id)"])
+ outputFileShouldBe (sourceFileSkeleton [])
it "responds with an error if it's undecidable whether we want a type or constructor" $
withSupportFiles (\sourceFp outFp -> do
r <- Integration.addImport "SpecialCase" sourceFp outFp
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index e78fcb9..5b5ba32 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
module Language.PureScript.Ide.ImportsSpec where
-import Data.Maybe (fromJust)
-import Data.Text (Text)
+import Protolude
+import Unsafe (fromJust)
+
import qualified Language.PureScript as P
import Language.PureScript.Ide.Imports
import Language.PureScript.Ide.Types
@@ -17,11 +19,9 @@ simpleFile =
]
splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text])
-splitSimpleFile = fromRight $ sliceImportSection simpleFile
+splitSimpleFile = fromRight (sliceImportSection simpleFile)
where
- fromRight (Right r) = r
- fromRight (Left _) = error "fromRight"
-
+ fromRight = fromJust . rightToMaybe
withImports :: [Text] -> [Text]
withImports is =
take 2 simpleFile ++ is ++ drop 2 simpleFile
@@ -68,11 +68,11 @@ spec = do
describe "import commands" $ do
let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i
addValueImport i mn is =
- prettyPrintImportSection (addExplicitImport' (ValueDeclaration i wildcard) mn is)
+ prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is)
addOpImport op mn is =
- prettyPrintImportSection (addExplicitImport' (ValueOperator op "" 2 P.Infix) mn is)
+ prettyPrintImportSection (addExplicitImport' (IdeValueOperator op "" 2 P.Infix) mn is)
addDtorImport i t mn is =
- prettyPrintImportSection (addExplicitImport' (DataConstructor i t wildcard) mn is)
+ prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is)
it "adds an implicit unqualified import" $
shouldBe
(addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))
diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs
index 876eb21..4f55441 100644
--- a/tests/Language/PureScript/Ide/Integration.hs
+++ b/tests/Language/PureScript/Ide/Integration.hs
@@ -14,6 +14,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude #-}
module Language.PureScript.Ide.Integration
(
-- managing the server process
@@ -29,33 +30,33 @@ module Language.PureScript.Ide.Integration
-- sending commands
, addImport
, addImplicitImport
+ , loadAll
, loadModule
- , loadModuleWithDeps
+ , loadModules
, getCwd
, getFlexCompletions
, getFlexCompletionsInModule
, getType
+ , getInfo
, rebuildModule
, reset
-- checking results
, resultIsSuccess
, parseCompletions
+ , parseInfo
, parseTextResult
) where
-import Control.Concurrent (threadDelay)
-import Control.Exception
-import Control.Monad (join, when)
+import Protolude
+import Unsafe (fromJust)
+
import Data.Aeson
import Data.Aeson.Types
-import qualified Data.ByteString.Lazy.UTF8 as BSL
-import Data.Either (isRight)
-import Data.Maybe (fromJust, isNothing, fromMaybe)
import qualified Data.Text as T
import qualified Data.Vector as V
import Language.PureScript.Ide.Util
+import qualified Language.PureScript as P
import System.Directory
-import System.Exit
import System.FilePath
import System.IO.Error (mkIOError, userErrorType)
import System.Process
@@ -70,8 +71,8 @@ startServer = do
pdir <- projectDirectory
-- Turn off filewatching since it creates race condition in a testing environment
(_, _, _, procHandle) <- createProcess $
- (shell "psc-ide-server --no-watch") {cwd = Just pdir}
- threadDelay 500000 -- give the server 500ms to start up
+ (shell "psc-ide-server --no-watch src/*.purs") {cwd = Just pdir}
+ threadDelay 2000000 -- give the server 2s to start up
return procHandle
stopServer :: ProcessHandle -> IO ()
@@ -80,26 +81,20 @@ stopServer = terminateProcess
withServer :: IO a -> IO a
withServer s = do
_ <- startServer
- started <- tryNTimes 5 (shush <$> (try getCwd :: IO (Either SomeException String)))
+ started <- tryNTimes 5 (rightToMaybe <$> (try getCwd :: IO (Either SomeException Text)))
when (isNothing started) $
throwIO (mkIOError userErrorType "psc-ide-server didn't start in time" Nothing Nothing)
r <- s
quitServer
pure r
-shush :: Either a b -> Maybe b
-shush = either (const Nothing) Just
-
-- project management utils
compileTestProject :: IO Bool
compileTestProject = do
pdir <- projectDirectory
(_, _, _, procHandle) <- createProcess $
- (shell $ "psc " ++ fileGlob) { cwd = Just pdir
- , std_out = CreatePipe
- , std_err = CreatePipe
- }
+ (shell . toS $ "psc " <> fileGlob) { cwd = Just pdir }
r <- tryNTimes 5 (getProcessExitCode procHandle)
pure (fromMaybe False (isSuccess <$> r))
@@ -121,24 +116,17 @@ deleteOutputFolder = do
deleteFileIfExists :: FilePath -> IO ()
deleteFileIfExists fp = whenM (doesFileExist fp) (removeFile fp)
-whenM :: Monad m => m Bool -> m () -> m ()
-whenM p f = do
- x <- p
- when x f
-
isSuccess :: ExitCode -> Bool
isSuccess ExitSuccess = True
isSuccess (ExitFailure _) = False
-fileGlob :: String
-fileGlob = unwords
- [ "\"src/**/*.purs\""
- ]
+fileGlob :: Text
+fileGlob = "\"src/**/*.purs\""
-- Integration Testing API
-sendCommand :: Value -> IO String
-sendCommand v = readCreateProcess
+sendCommand :: Value -> IO Text
+sendCommand v = toS <$> readCreateProcess
((shell "psc-ide-client") { std_out=CreatePipe
, std_err=CreatePipe
})
@@ -146,65 +134,71 @@ sendCommand v = readCreateProcess
quitServer :: IO ()
quitServer = do
- let quitCommand = object ["command" .= ("quit" :: String)]
- _ <- try $ sendCommand quitCommand :: IO (Either SomeException String)
+ let quitCommand = object ["command" .= ("quit" :: Text)]
+ _ <- try $ sendCommand quitCommand :: IO (Either SomeException Text)
return ()
reset :: IO ()
reset = do
- let resetCommand = object ["command" .= ("reset" :: String)]
- _ <- try $ sendCommand resetCommand :: IO (Either SomeException String)
+ let resetCommand = object ["command" .= ("reset" :: Text)]
+ _ <- try $ sendCommand resetCommand :: IO (Either SomeException Text)
return ()
-getCwd :: IO String
+getCwd :: IO Text
getCwd = do
- let cwdCommand = object ["command" .= ("cwd" :: String)]
+ let cwdCommand = object ["command" .= ("cwd" :: Text)]
sendCommand cwdCommand
-loadModuleWithDeps :: String -> IO String
-loadModuleWithDeps m = sendCommand $ load [] [m]
+loadModule :: Text -> IO Text
+loadModule m = loadModules [m]
+
+loadModules :: [Text] -> IO Text
+loadModules = sendCommand . load
-loadModule :: String -> IO String
-loadModule m = sendCommand $ load [m] []
+loadAll :: IO Text
+loadAll = sendCommand (load [])
-getFlexCompletions :: String -> IO [(String, String, String)]
+getFlexCompletions :: Text -> IO [(Text, Text, Text)]
getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing)
-getFlexCompletionsInModule :: String -> String -> IO [(String, String, String)]
+getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text)]
getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m))
-getType :: String -> IO [(String, String, String)]
+getType :: Text -> IO [(Text, Text, Text)]
getType q = parseCompletions <$> sendCommand (typeC q [])
-addImport :: String -> FilePath -> FilePath -> IO String
+getInfo :: Text -> IO [P.SourceSpan]
+getInfo q = parseInfo <$> sendCommand (typeC q [])
+
+addImport :: Text -> FilePath -> FilePath -> IO Text
addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp)
-addImplicitImport :: String -> FilePath -> FilePath -> IO String
+addImplicitImport :: Text -> FilePath -> FilePath -> IO Text
addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp)
-rebuildModule :: FilePath -> IO String
+rebuildModule :: FilePath -> IO Text
rebuildModule m = sendCommand (rebuildC m Nothing)
-- Command Encoding
-commandWrapper :: String -> Value -> Value
+commandWrapper :: Text -> Value -> Value
commandWrapper c p = object ["command" .= c, "params" .= p]
-load :: [String] -> [String] -> Value
-load ms ds = commandWrapper "load" (object ["modules" .= ms, "dependencies" .= ds])
+load :: [Text] -> Value
+load ms = commandWrapper "load" (object ["modules" .= ms])
-typeC :: String -> [Value] -> Value
+typeC :: Text -> [Value] -> Value
typeC q filters = commandWrapper "type" (object ["search" .= q, "filters" .= filters])
-addImportC :: String -> FilePath -> FilePath -> Value
+addImportC :: Text -> FilePath -> FilePath -> Value
addImportC identifier = addImportW $
- object [ "importCommand" .= ("addImport" :: String)
+ object [ "importCommand" .= ("addImport" :: Text)
, "identifier" .= identifier
]
-addImplicitImportC :: String -> FilePath -> FilePath -> Value
+addImplicitImportC :: Text -> FilePath -> FilePath -> Value
addImplicitImportC mn = addImportW $
- object [ "importCommand" .= ("addImplicitImport" :: String)
+ object [ "importCommand" .= ("addImplicitImport" :: Text)
, "module" .= mn
]
@@ -222,7 +216,7 @@ addImportW importCommand fp outfp =
])
-completion :: [Value] -> Maybe Value -> Maybe String -> Value
+completion :: [Value] -> Maybe Value -> Maybe Text -> Value
completion filters matcher currentModule =
let
matcher' = case matcher of
@@ -234,16 +228,16 @@ completion filters matcher currentModule =
in
commandWrapper "complete" (object $ "filters" .= filters : matcher' ++ currentModule' )
-flexMatcher :: String -> Value
-flexMatcher q = object [ "matcher" .= ("flex" :: String)
+flexMatcher :: Text -> Value
+flexMatcher q = object [ "matcher" .= ("flex" :: Text)
, "params" .= object ["search" .= q]
]
-- Result parsing
-unwrapResult :: Value -> Parser (Either String Value)
+unwrapResult :: Value -> Parser (Either Text Value)
unwrapResult = withObject "result" $ \o -> do
- (rt :: String) <- o .: "resultType"
+ (rt :: Text) <- o .: "resultType"
case rt of
"error" -> do
res <- o .: "result"
@@ -251,16 +245,16 @@ unwrapResult = withObject "result" $ \o -> do
"success" -> do
res <- o .: "result"
pure (Right res)
- _ -> fail "lol"
+ _ -> mzero
-withResult :: (Value -> Parser a) -> Value -> Parser (Either String a)
+withResult :: (Value -> Parser a) -> Value -> Parser (Either Text a)
withResult p v = do
r <- unwrapResult v
case r of
Left err -> pure (Left err)
Right res -> Right <$> p res
-completionParser :: Value -> Parser [(String, String, String)]
+completionParser :: Value -> Parser [(Text, Text, Text)]
completionParser = withArray "res" $ \cs ->
mapM (withObject "completion" $ \o -> do
ident <- o .: "identifier"
@@ -268,22 +262,24 @@ completionParser = withArray "res" $ \cs ->
ty <- o .: "type"
pure (module', ident, ty)) (V.toList cs)
-valueFromString :: String -> Value
-valueFromString = fromJust . decode . BSL.fromString
+infoParser :: Value -> Parser [P.SourceSpan]
+infoParser = withArray "res" $ \cs ->
+ mapM (withObject "info" $ \o -> o .: "definedAt") (V.toList cs)
-resultIsSuccess :: String -> Bool
-resultIsSuccess = isRight . join . parseEither unwrapResult . valueFromString
+valueFromText :: Text -> Value
+valueFromText = fromJust . decode . toS
-parseCompletions :: String -> [(String, String, String)]
-parseCompletions s = fromJust $ do
- cs <- parseMaybe (withResult completionParser) (valueFromString s)
- case cs of
- Left _ -> error "Failed to parse completions"
- Right cs' -> pure cs'
+resultIsSuccess :: Text -> Bool
+resultIsSuccess = isRight . join . first toS . parseEither unwrapResult . valueFromText
-parseTextResult :: String -> String
-parseTextResult s = fromJust $ do
- r <- parseMaybe (withResult (withText "tr" pure)) (valueFromString s)
- case r of
- Left _ -> error "Failed to parse textResult"
- Right r' -> pure (T.unpack r')
+parseCompletions :: Text -> [(Text, Text, Text)]
+parseCompletions s =
+ fromJust $ join (rightToMaybe <$> parseMaybe (withResult completionParser) (valueFromText s))
+
+parseInfo :: Text -> [P.SourceSpan]
+parseInfo s =
+ fromJust $ join (rightToMaybe <$> parseMaybe (withResult infoParser) (valueFromText s))
+
+parseTextResult :: Text -> Text
+parseTextResult s =
+ fromJust $ join (rightToMaybe <$> parseMaybe (withResult (withText "tr" pure)) (valueFromText s))
diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs
index 954ded1..04d0ae5 100644
--- a/tests/Language/PureScript/Ide/MatcherSpec.hs
+++ b/tests/Language/PureScript/Ide/MatcherSpec.hs
@@ -1,33 +1,32 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
module Language.PureScript.Ide.MatcherSpec where
-import Control.Monad (void)
-import Data.Text (Text)
+import Protolude
+
import qualified Language.PureScript as P
import Language.PureScript.Ide.Integration
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
import Test.Hspec
-value :: Text -> ExternDecl
-value s = ValueDeclaration s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0)
+value :: Text -> IdeDeclaration
+value s = IdeValue (P.Ident (toS s)) P.REmpty
-completions :: [Match]
-completions =
- [ Match "" (value "firstResult")
- , Match "" (value "secondResult")
- , Match "" (value "fiult")
- ]
+firstResult, secondResult, fiult :: Match IdeDeclaration
+firstResult = Match (P.moduleNameFromString "Match", value "firstResult")
+secondResult = Match (P.moduleNameFromString "Match", value "secondResult")
+fiult = Match (P.moduleNameFromString "Match", value "fiult")
-mkResult :: [Int] -> [Match]
-mkResult = map (completions !!)
+completions :: [Match IdeDeclaration]
+completions = [firstResult, secondResult, fiult]
-runFlex :: Text -> [Match]
+runFlex :: Text -> [Match IdeDeclaration]
runFlex s = runMatcher (flexMatcher s) completions
setup :: IO ()
-setup = reset *> void (loadModuleWithDeps "Main")
+setup = reset *> void loadAll
spec :: Spec
spec = do
@@ -35,9 +34,9 @@ spec = do
it "doesn't match on an empty string" $
runFlex "" `shouldBe` []
it "matches on equality" $
- runFlex "firstResult" `shouldBe` mkResult [0]
+ runFlex "firstResult" `shouldBe` [firstResult]
it "scores short matches higher and sorts accordingly" $
- runFlex "filt" `shouldBe` mkResult [2, 0]
+ runFlex "filt" `shouldBe` [fiult, firstResult]
beforeAll_ setup . describe "Integration Tests: Flex Matcher" $ do
it "doesn't match on an empty string" $ do
@@ -45,4 +44,4 @@ spec = do
cs `shouldBe` []
it "matches on equality" $ do
cs <- getFlexCompletions "const"
- cs `shouldBe` [("Main", "const", "forall a b. a -> b -> a")]
+ cs `shouldBe` [("MatcherSpec", "const", "forall a b. a -> b -> a")]
diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs
index f78cd1b..f924190 100644
--- a/tests/Language/PureScript/Ide/RebuildSpec.hs
+++ b/tests/Language/PureScript/Ide/RebuildSpec.hs
@@ -1,19 +1,23 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.Ide.RebuildSpec where
+import Protolude
+
import qualified Language.PureScript.Ide.Integration as Integration
import System.FilePath
import Test.Hspec
-shouldBeSuccess :: String -> IO ()
+shouldBeSuccess :: Text -> IO ()
shouldBeSuccess = shouldBe True . Integration.resultIsSuccess
-shouldBeFailure :: String -> IO ()
+shouldBeFailure :: Text -> IO ()
shouldBeFailure = shouldBe False . Integration.resultIsSuccess
spec :: Spec
spec = before_ Integration.reset . describe "Rebuilding single modules" $ do
it "rebuilds a correct module without dependencies successfully" $ do
- _ <- Integration.loadModuleWithDeps "RebuildSpecSingleModule"
+ _ <- Integration.loadModule "RebuildSpecSingleModule"
pdir <- Integration.projectDirectory
let file = pdir </> "src" </> "RebuildSpecSingleModule.purs"
Integration.rebuildModule file >>= shouldBeSuccess
@@ -22,12 +26,12 @@ spec = before_ Integration.reset . describe "Rebuilding single modules" $ do
let file = pdir </> "src" </> "RebuildSpecSingleModule.fail"
Integration.rebuildModule file >>= shouldBeFailure
it "rebuilds a correct module with its dependencies successfully" $ do
- _ <- Integration.loadModuleWithDeps "RebuildSpecWithDeps"
+ _ <- Integration.loadModules ["RebuildSpecWithDeps", "RebuildSpecDep"]
pdir <- Integration.projectDirectory
let file = pdir </> "src" </> "RebuildSpecWithDeps.purs"
Integration.rebuildModule file >>= shouldBeSuccess
it "rebuilds a correct module that has reverse dependencies" $ do
- _ <- Integration.loadModuleWithDeps "RebuildSpecWithDeps"
+ _ <- Integration.loadModule "RebuildSpecWithDeps"
pdir <- Integration.projectDirectory
let file = pdir </> "src" </> "RebuildSpecDep.purs"
Integration.rebuildModule file >>= shouldBeSuccess
@@ -37,7 +41,7 @@ spec = before_ Integration.reset . describe "Rebuilding single modules" $ do
let file = pdir </> "src" </> "RebuildSpecWithDeps.purs"
Integration.rebuildModule file >>= shouldBeFailure
it "rebuilds a correct module with a foreign file" $ do
- _ <- Integration.loadModuleWithDeps "RebuildSpecWithForeign"
+ _ <- Integration.loadModule "RebuildSpecWithForeign"
pdir <- Integration.projectDirectory
let file = pdir </> "src" </> "RebuildSpecWithForeign.purs"
Integration.rebuildModule file >>= shouldBeSuccess
diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs
index 5633d60..c9a59ff 100644
--- a/tests/Language/PureScript/Ide/ReexportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -1,81 +1,64 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
module Language.PureScript.Ide.ReexportsSpec where
-import Control.Exception (evaluate)
-import Data.List (sort)
-import qualified Data.Map as Map
+import qualified Prelude as Prelude
+import Protolude
+
+import qualified Data.Map as Map
import Language.PureScript.Ide.Reexports
import Language.PureScript.Ide.Types
import qualified Language.PureScript as P
import Test.Hspec
-wildcard :: P.Type
-wildcard = P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0)
-
-decl1 :: ExternDecl
-decl1 = ValueDeclaration "filter" wildcard
-decl2 :: ExternDecl
-decl2 = ValueDeclaration "map" wildcard
-decl3 :: ExternDecl
-decl3 = ValueDeclaration "catMaybe" wildcard
-dep1 :: ExternDecl
-dep1 = Dependency "Test.Foo" [] (Just "T")
-dep2 :: ExternDecl
-dep2 = Dependency "Test.Bar" [] (Just "T")
-
-circularModule :: Module
-circularModule = ("Circular", [Export "Circular"])
-
-module1 :: Module
-module1 = ("Module1", [Export "Module2", Export "Module3", decl1])
-
-module2 :: Module
-module2 = ("Module2", [decl2])
-
-module3 :: Module
-module3 = ("Module3", [decl3])
-
-module4 :: Module
-module4 = ("Module4", [Export "T", decl1, dep1, dep2])
-
-result :: Module
-result = ("Module1", [decl1, decl2, Export "Module3"])
-
-db :: Map.Map ModuleIdent [ExternDecl]
-db = Map.fromList [module1, module2, module3]
-
-shouldBeEqualSorted :: Module -> Module -> Expectation
-shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2)
+m :: Prelude.String -> P.ModuleName
+m = P.moduleNameFromString
+
+d :: IdeDeclaration -> IdeDeclarationAnn
+d = IdeDeclarationAnn emptyAnn
+
+valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn
+valueA = d (IdeValue (P.Ident "valueA") P.REmpty)
+typeA = d (IdeType (P.ProperName "TypeA") P.Star)
+classA = d (IdeTypeClass (P.ProperName "ClassA"))
+dtorA1 = d (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)
+dtorA2 = d (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)
+
+env :: Map P.ModuleName [IdeDeclarationAnn]
+env = Map.fromList
+ [ (m "A", [valueA, typeA, classA, dtorA1, dtorA2])
+ ]
+
+type Refs = [(P.ModuleName, P.DeclarationRef)]
+
+succTestCases :: [(Text, Module, Refs, Module)]
+succTestCases =
+ [ ("resolves a value reexport", (m "C", []), [(m "A", P.ValueRef (P.Ident "valueA"))], (m "C", [valueA]))
+ , ("resolves a type reexport with explicit data constructors"
+ , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], (m "C", [typeA, dtorA1]))
+ , ("resolves a type reexport with implicit data constructors"
+ , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], (m "C", [typeA, dtorA1, dtorA2]))
+ , ("resolves a class reexport", (m "C", []), [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], (m "C", [classA]))
+ ]
+
+failTestCases :: [(Text, Module, Refs)]
+failTestCases =
+ [ ("fails to resolve a non existing value", (m "C", []), [(m "A", P.ValueRef (P.Ident "valueB"))])
+ , ("fails to resolve a non existing type reexport" , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)])
+ , ("fails to resolve a non existing class reexport", (m "C", []), [(m "A", P.TypeClassRef (P.ProperName "ClassB"))])
+ ]
spec :: Spec
-spec =
- describe "Reexports" $ do
- it "finds all reexports" $
- getReexports module1 `shouldBe` [Export "Module2", Export "Module3"]
-
- it "replaces a reexport with another module" $
- replaceReexport (Export "Module2") module1 module2 `shouldBeEqualSorted` result
-
- it "adds another module even if there is no export statement" $
- replaceReexport (Export "Module2") ("Module1", [decl1, Export "Module3"]) module2
- `shouldBeEqualSorted` result
-
- it "only adds a declaration once" $
- let replaced = replaceReexport (Export "Module2") module1 module2
- in replaceReexport (Export "Module2") replaced module2 `shouldBeEqualSorted` result
-
- it "should error when given a non-Export to replace" $
- evaluate (replaceReexport decl1 module1 module2)
- `shouldThrow` errorCall "Should only get Exports here."
- it "replaces all Exports with their corresponding declarations" $
- replaceReexports module1 db `shouldBe` ("Module1", [decl1, decl2, decl3])
-
- it "does not list itself as a reexport" $
- getReexports circularModule `shouldBe` []
-
- it "does not include circular references when replacing reexports" $
- replaceReexports circularModule (uncurry Map.singleton circularModule )
- `shouldBe` ("Circular", [])
-
- it "replaces exported aliases with imported module" $
- getReexports module4 `shouldBe` [Export "Test.Foo", Export "Test.Bar"]
+spec = do
+ describe "Successful Reexports" $
+ for_ succTestCases $ \(desc, initial, refs, result) ->
+ it (toS desc) $ do
+ let reResult = resolveReexports env (initial, refs)
+ reResolved reResult `shouldBe` result
+ reResult `shouldSatisfy` not . reexportHasFailures
+ describe "Failed Reexports" $
+ for_ failTestCases $ \(desc, initial, refs) ->
+ it (toS desc) $ do
+ let reResult = resolveReexports env (initial, refs)
+ reFailed reResult `shouldBe` refs
+ reResult `shouldSatisfy` reexportHasFailures
diff --git a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs
new file mode 100644
index 0000000..a16a9b5
--- /dev/null
+++ b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Language.PureScript.Ide.SourceFile.IntegrationSpec where
+
+
+import Protolude
+
+import qualified Data.Text as T
+import qualified Language.PureScript.Ide.Integration as Integration
+import qualified Language.PureScript as P
+import Test.Hspec
+
+setup :: IO ()
+setup = void (Integration.reset *> Integration.loadAll)
+
+spec :: Spec
+spec = beforeAll_ setup $ do
+ describe "Sourcefile Integration" $ do
+ it "finds a value declaration" $ do
+ testCase "sfValue" (3, 1)
+ it "finds a type declaration" $ do
+ testCase "SFType" (5, 1)
+ it "finds a data declaration" $ do
+ testCase "SFData" (7, 1)
+ it "finds a data constructor" $ do
+ testCase "SFOne" (7, 1)
+ it "finds a typeclass" $ do
+ testCase "SFClass" (9, 1)
+ it "finds a typeclass member" $ do
+ testCase "sfShow" (10, 3)
+
+testCase :: Text -> (Int, Int) -> IO ()
+testCase s (x, y) = do
+ (P.SourceSpan f (P.SourcePos l c) _):_ <- Integration.getInfo s
+ toS f `shouldSatisfy` T.isSuffixOf "SourceFileSpec.purs"
+ (l, c) `shouldBe` (x, y)
diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs
new file mode 100644
index 0000000..26a2dba
--- /dev/null
+++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Language.PureScript.Ide.SourceFileSpec where
+
+import Protolude
+
+import qualified Language.PureScript as P
+import Language.PureScript.Ide.SourceFile
+import Test.Hspec
+
+span0, span1, span2 :: P.SourceSpan
+span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1)
+span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2)
+span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3)
+
+value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration
+value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left [])
+synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty
+class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] []
+class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] []
+ [P.PositionedDeclaration span2 [] member1]
+data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] []
+data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])]
+foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty
+foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.Star
+member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty
+
+spec :: Spec
+spec = do
+ describe "Extracting Spans" $ do
+ it "extracts a span for a value declaration" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(Left "value1", span1)]
+ it "extracts a span for a type synonym declaration" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(Right "Synonym1", span1)]
+ it "extracts a span for a typeclass declaration" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(Right "Class1", span1)]
+ it "extracts spans for a typeclass declaration and its members" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(Right "Class2", span1), (Left "member1", span2)]
+ it "extracts a span for a data declaration" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(Right "Data1", span1)]
+ it "extracts spans for a data declaration and its constructors" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(Right "Data2", span1), (Left "Cons1", span1)]
+ it "extracts a span for a foreign declaration" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)]
+ it "extracts a span for a data foreign declaration" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)]
diff --git a/tests/Language/PureScript/IdeSpec.hs b/tests/Language/PureScript/IdeSpec.hs
deleted file mode 100644
index 8ceedb1..0000000
--- a/tests/Language/PureScript/IdeSpec.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Language.PureScript.IdeSpec where
-
-import Control.Concurrent.STM
-import Control.Monad.Reader
-import Data.List
-import qualified Data.Map as Map
-import Language.PureScript.Ide
-import Language.PureScript.Ide.Types
-import Test.Hspec
-
-testState :: PscIdeState
-testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) Map.empty Nothing
-
-defaultConfig :: Configuration
-defaultConfig =
- Configuration
- {
- confOutputPath = "output/"
- , confDebug = False
- }
-
-spec :: SpecWith ()
-spec =
- describe "list" $
- describe "loadedModules" $ do
- it "returns an empty list when no modules are loaded" $ do
- st <- newTVarIO emptyPscIdeState
- result <- runReaderT printModules (PscIdeEnvironment st defaultConfig)
- result `shouldBe` ModuleList []
- it "returns the list of loaded modules" $ do
- st <- newTVarIO testState
- ModuleList result <- runReaderT printModules (PscIdeEnvironment st defaultConfig)
- sort result `shouldBe` sort ["Data.Array", "Control.Monad.Eff"]
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index 1f01d03..49e9c2a 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -12,6 +12,8 @@ import Control.Exception
import System.Process
import System.Directory
import System.Info
+import System.Exit (exitFailure)
+import System.IO (stderr, hPutStrLn)
findNodeProcess :: IO (Maybe String)
findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
@@ -33,10 +35,17 @@ updateSupportCode = do
then callProcess "setup-win.cmd" []
else do
callProcess "npm" ["install"]
+ -- bower uses shebang "/usr/bin/env node", but we might have nodejs
+ node <- maybe cannotFindNode pure =<< findNodeProcess
-- Sometimes we run as a root (e.g. in simple docker containers)
-- And we are non-interactive: https://github.com/bower/bower/issues/1162
- callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]
+ callProcess node ["node_modules/.bin/bower", "--allow-root", "install", "--config.interactive=false"]
setCurrentDirectory "../.."
+ where
+ cannotFindNode :: IO a
+ cannotFindNode = do
+ hPutStrLn stderr "Cannot find node (or nodejs) executable"
+ exitFailure
-- |
-- The support modules that should be cached between test cases, to avoid
diff --git a/tests/support/pscide/src/ImportsSpec.purs b/tests/support/pscide/src/ImportsSpec.purs
index 04a7227..b48e246 100644
--- a/tests/support/pscide/src/ImportsSpec.purs
+++ b/tests/support/pscide/src/ImportsSpec.purs
@@ -1,5 +1,3 @@
module ImportsSpec where
-import Main (id)
-
-myId = id
+myId x = x
diff --git a/tests/support/pscide/src/Main.purs b/tests/support/pscide/src/MatcherSpec.purs
index ca67938..b9fbe0e 100644
--- a/tests/support/pscide/src/Main.purs
+++ b/tests/support/pscide/src/MatcherSpec.purs
@@ -1,4 +1,4 @@
-module Main where
+module MatcherSpec where
id :: forall a. a -> a
id x = x
diff --git a/tests/support/pscide/src/RebuildSpecSingleModule.purs b/tests/support/pscide/src/RebuildSpecSingleModule.purs
index 4059629..9a1fe7e 100644
--- a/tests/support/pscide/src/RebuildSpecSingleModule.purs
+++ b/tests/support/pscide/src/RebuildSpecSingleModule.purs
@@ -1,4 +1,4 @@
module RebuildSpecSingleModule where
id x = x
-const x y = x
+lulz x y = x
diff --git a/tests/support/pscide/src/RebuildSpecWithForeign.js b/tests/support/pscide/src/RebuildSpecWithForeign.js
index 7c82dc8..8ea453f 100644
--- a/tests/support/pscide/src/RebuildSpecWithForeign.js
+++ b/tests/support/pscide/src/RebuildSpecWithForeign.js
@@ -1,3 +1 @@
-// module RebuildSpecWithForeign
-
exports.f = 5;
diff --git a/tests/support/pscide/src/SourceFileSpec.purs b/tests/support/pscide/src/SourceFileSpec.purs
new file mode 100644
index 0000000..e3484fa
--- /dev/null
+++ b/tests/support/pscide/src/SourceFileSpec.purs
@@ -0,0 +1,10 @@
+module SourceFileSpec where
+
+sfValue = "sfValue"
+
+type SFType = String
+
+data SFData = SFOne | SFTwo | SFThree
+
+class SFClass a where
+ sfShow :: a -> String