diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -72,6 +72,7 @@ - [@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 --- a/LICENSE +++ b/LICENSE @@ -46,6 +46,7 @@ bytestring-builder case-insensitive cereal + clock conduit conduit-extra connection @@ -56,8 +57,10 @@ deepseq directory dlist + easy-file edit-distance exceptions + fail fast-logger filepath fsnotify @@ -82,6 +85,7 @@ network network-uri old-locale + old-time optparse-applicative parallel parsec @@ -91,6 +95,7 @@ pipes-http primitive process + protolude random regex-base regex-tdfa @@ -105,6 +110,7 @@ stm stm-chans streaming-commons + string-conv syb tagged template-haskell @@ -117,6 +123,7 @@ transformers-compat unix unix-compat + unix-time unordered-containers utf8-string vector @@ -955,6 +962,41 @@ 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 @@ 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 @@ (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 @@ 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-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 @@ 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 @@ ----------------------------------------------------------------------------- +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 @@ 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 @@ -3288,6 +3516,38 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +unix-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: diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -15,7 +15,7 @@ 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) @@ -36,14 +36,6 @@ , optionsMainModule :: Maybe String , 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 diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -5,16 +5,15 @@ 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 @@ ("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 --- 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.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 @@ 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 @@ -- $(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 @@ 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 --- 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 @@ 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.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 @@ 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 @@ 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 @@ 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 --- /dev/null +++ b/psci/static/index.html @@ -0,0 +1,10 @@ + + + + PureScript Interactive + + + + + + diff --git a/psci/static/index.js b/psci/static/index.js new file mode 100644 --- /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 --- 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 @@ , 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ mtl -any, network -any, optparse-applicative >= 0.12.1, + protolude >= 0.1.5, stm -any, text -any, transformers -any, @@ -446,6 +463,7 @@ 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 @@ optparse-applicative -any, parsec -any, process -any, + protolude >= 0.1.5, silently -any, stm -any, text -any, @@ -498,6 +517,7 @@ 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 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -80,19 +80,25 @@ -- | 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 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 --- 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 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 @@ -57,6 +60,14 @@ 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. diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -39,12 +39,12 @@ -- | -- 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 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -216,7 +216,7 @@ 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 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -391,5 +391,8 @@ 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 --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -44,7 +44,7 @@ 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 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -15,7 +15,7 @@ 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 @@ 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 @@ -- 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 --- 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.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 +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 :: (PscIde m, MonadLogger m) => - [Filter] -> Matcher -> Maybe P.ModuleName -> m Success +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 :: (PscIde m) => m Success -printModules = printModules' . pscIdeStateModules <$> getPscIdeState +printModules :: Ide m => m Success +printModules = ModuleList . map runModuleNameT <$> getLoadedModulenames -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 +-- | 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 + -- 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 = oDir d "externs.json" + doesFileExist file -getDependenciesForModule :: Module -> [ModuleIdent] -getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls - where getDependencyName (Dependency dependencyName _ _) = Just dependencyName - getDependencyName _ = Nothing +-- | 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) -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) +-- | 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 -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.") - where - getExternsPath :: FilePath -> FilePath -> IO (Maybe FilePath) - getExternsPath outputDirectory d - | d `elem` [".", ".."] = pure Nothing - | otherwise = do - let file = outputDirectory d "externs.json" - ex <- doesFileExist file - if ex - then pure (Just file) - else pure Nothing + -- 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 -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) + -- 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 --- 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 @@ , 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 @@ 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 @@ 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 "" s >>= P.runTokenParser "" (P.parseType <* Parsec.eof) of + case P.lex "" (toS s) >>= P.runTokenParser "" (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) + 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], P.Type) -splitFunctionType t = (arguments, returns) +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 --- 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 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 @@ 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 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 @@ "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 --- 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 --- /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 +-- 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 --- 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 @@ ] 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 @@ -- 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 --- 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 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -20,22 +20,16 @@ , 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 = 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 @@ 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 --- 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 @@ ) 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 @@ 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 @@ 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 @@ -- 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 @@ | 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 "" P.parseModule tokens @@ -182,8 +171,8 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ -- -- * 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 @@ -- 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 @@ 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 @@ 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 --- 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.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 @@ -- 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 @@ -- 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 @@ -- 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 --- 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 @@ 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 @@ 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 @@ 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 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -8,14 +8,12 @@ ( 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.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 @@ -- 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 @@ -- 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 @@ -- | 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 @@ 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 @@ -- 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 @@ 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 "") [] 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 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -14,76 +14,105 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} - -module Language.PureScript.Ide.Reexports where +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +module Language.PureScript.Ide.Reexports + ( resolveReexports + , prettyPrintReexportResult + , reexportHasFailures + , ReexportResult(..) + ) where -import Prelude () -import Prelude.Compat +import Protolude -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 +import Language.PureScript.Ide.Util +import qualified Language.PureScript as P -replaceReexport :: ExternDecl -> Module -> Module -> Module -replaceReexport e@(Export _) (m, decls) (_, newDecls) = - (m, filter (/= e) decls `union` newDecls) -replaceReexport _ _ _ = error "Should only get Exports here." +-- | Contains the module with resolved reexports, and eventual failures +data ReexportResult a + = ReexportResult + { reResolved :: a + , reFailed :: [(P.ModuleName, P.DeclarationRef)] + } deriving (Show, Eq, Functor) -emptyModule :: Module -emptyModule = ("Empty", []) +-- | 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 -isExport :: ExternDecl -> Bool -isExport (Export _) = True -isExport _ = False +-- | Whether any Refs couldn't be resolved +reexportHasFailures :: ReexportResult a -> Bool +reexportHasFailures = not . null . reFailed -removeExportDecls :: Module -> Module -removeExportDecls = fmap (filter (not . isExport)) +-- | 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 + (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) -replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module -replaceReexports m db = result +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 - reexports = getReexports m - result = foldl go (removeExportDecls m) reexports + 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 --- 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.") - --- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) - -getDeclarations :: D.Module -> [D.Declaration] -getDeclarations (D.Module _ _ _ declarations _) = declarations +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) -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 --- 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))}} --- | 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 +-- | Retrieves Stage1 from the State. +-- This includes loaded Externfiles +getStage1 :: Ide m => m Stage1 +getStage1 = do + st <- ideStateVar <$> ask + fmap ideStage1 . liftIO . readTVarIO $ st --- | Looks up a single Module inside the loaded Modules -getModule :: (PscIde m, MonadLogger m) => ModuleIdent -> m (Maybe Module) -getModule m = getModule' <$> getPscIdeState <*> pure m +-- | STM version of getStage1 +getStage1STM :: TVar IdeState -> STM Stage1 +getStage1STM ref = ideStage1 <$> readTVar ref --- | Pure version of @getModule@ -getModule' :: PscIdeState -> ModuleIdent -> Maybe Module -getModule' ps mi = (mi,) <$> M.lookup mi (pscIdeStateModules ps) +-- | Retrieves Stage2 from the State. +getStage2 :: Ide m => m Stage2 +getStage2 = do + st <- ideStateVar <$> ask + liftIO (atomically (getStage2STM st)) --- | Looks up a single Module and resolves its Reexports -getModuleWithReexports :: PscIde m => ModuleIdent -> m (Maybe Module) -getModuleWithReexports i = getModuleWithReexports' <$> getPscIdeState <*> pure i +getStage2STM :: TVar IdeState -> STM Stage2 +getStage2STM ref = ideStage2 <$> readTVar ref --- | Pure version of @getModuleWithReexports@ -getModuleWithReexports' :: PscIdeState -> ModuleIdent -> Maybe Module -getModuleWithReexports' ps mi = - resolveReexports (pscIdeStateModules ps) <$> getModule' ps mi +-- | STM version of setStage2 +setStage2STM :: TVar IdeState -> Stage2 -> STM () +setStage2STM ref s2 = do + modifyTVar ref $ \x -> + x {ideStage2 = s2} + pure () --- | 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 +-- | 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 --- | STM version of insertModule -insertModuleSTM :: TVar PscIdeState -> ExternsFile -> STM () -insertModuleSTM st ef = modifyTVar st (insertModule' ef) +-- | Sets Stage3 inside the compiler +setStage3STM :: TVar IdeState -> Stage3 -> STM () +setStage3STM ref s3 = do + modifyTVar ref $ \x -> + x {ideStage3 = s3} + pure () --- | 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) - } +-- | Checks if the given ModuleName matches the last rebuild cache and if it +-- does returns all loaded definitions + the definitions inside the rebuild +-- cache +getAllModules :: Ide m => Maybe P.ModuleName -> m [Module] +getAllModules 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 --- 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) +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) -type Module = (ModuleIdent, [ExternDecl]) +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 PscIdeState = - PscIdeState - { pscIdeStateModules :: M.Map Text [ExternDecl] - , pscIdeStateExternsFiles :: M.Map P.ModuleName ExternsFile - , pscIdeStateCachedRebuild :: Maybe (P.ModuleName, ExternsFile) - } deriving Show +data IdeState = IdeState + { ideStage1 :: Stage1 + , ideStage2 :: Stage2 + , ideStage3 :: Stage3 + } -emptyPscIdeState :: PscIdeState -emptyPscIdeState = PscIdeState M.empty M.empty Nothing +emptyIdeState :: IdeState +emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3 -data Match = Match ModuleIdent ExternDecl - deriving (Show, Eq) +emptyStage1 :: Stage1 +emptyStage1 = Stage1 M.empty M.empty +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 @@ && 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 @@ 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 @@ 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 @@ 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 --- 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 - -runProperNameT :: P.ProperName a -> Text -runProperNameT = T.pack . P.runProperName - -runIdentT :: P.Ident -> Text -runIdentT = T.pack . P.runIdent - -runOpNameT :: P.OpName a -> Text -runOpNameT = T.pack . P.runOpName +import Language.PureScript.Ide.Conversions -runModuleNameT :: P.ModuleName -> Text -runModuleNameT = T.pack . P.runModuleName +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 -prettyTypeT :: P.Type -> Text -prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType +discardAnn :: IdeDeclarationAnn -> IdeDeclaration +discardAnn (IdeDeclarationAnn _ d) = d -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~" +unwrapMatch :: Match a -> a +unwrapMatch (Match (_, ed)) = ed -identifierFromMatch :: Match -> Text -identifierFromMatch (Match _ ed) = identifierFromExternDecl ed +completionFromMatch :: Match IdeDeclaration -> Completion +completionFromMatch = Completion . completionFromMatch' -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 --- 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 Control.Concurrent (threadDelay) +import Protolude + 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 --- 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.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.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 @@ -- | 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 @@ 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 @@ 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 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -13,7 +13,6 @@ -- 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 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -140,7 +140,7 @@ 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 @@ -- -- 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 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -169,8 +169,7 @@ 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 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -132,7 +132,7 @@ | 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 @@ -- 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 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -72,7 +72,7 @@ -- | -- 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 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -114,7 +114,7 @@ -- | -- 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 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -21,6 +21,7 @@ , 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 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -144,7 +144,7 @@ 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 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -10,7 +10,7 @@ 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,17 +84,20 @@ 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) = case mn `M.lookup` env of @@ -110,9 +113,10 @@ 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 @@ -- 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 @@ -- 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 @@ _ -> 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 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -375,7 +375,7 @@ -- 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 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -117,8 +117,7 @@ -- 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 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -207,6 +207,7 @@ 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 @@ -- 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 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -53,7 +53,7 @@ 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 @@ 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 @@ , 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 @@ Nothing -> return () addValue - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m) => ModuleName -> Ident -> Type @@ -107,7 +107,7 @@ 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 @@ 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 @@ 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 @@ -- 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 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -9,17 +9,15 @@ 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 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -89,7 +89,7 @@ -- | -- 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 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -133,7 +133,7 @@ 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 @@ -- | 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 --- 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 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -1,63 +1,52 @@ {-# 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 describe "equality Filter" $ 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 --- 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.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 @@ 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 --- 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 @@ ] 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 @@ 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 --- 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 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ 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] -loadModule :: String -> IO String -loadModule m = sendCommand $ load [m] [] +loadModules :: [Text] -> IO Text +loadModules = sendCommand . load -getFlexCompletions :: String -> IO [(String, String, String)] +loadAll :: IO Text +loadAll = sendCommand (load []) + +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 @@ ]) -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 @@ 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 @@ "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 @@ 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 --- 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 @@ 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 @@ 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 --- 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 @@ 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 @@ 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 --- 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]) +m :: Prelude.String -> P.ModuleName +m = P.moduleNameFromString -module2 :: Module -module2 = ("Module2", [decl2]) +d :: IdeDeclaration -> IdeDeclarationAnn +d = IdeDeclarationAnn emptyAnn -module3 :: Module -module3 = ("Module3", [decl3]) +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) -module4 :: Module -module4 = ("Module4", [Export "T", decl1, dep1, dep2]) +env :: Map P.ModuleName [IdeDeclarationAnn] +env = Map.fromList + [ (m "A", [valueA, typeA, classA, dtorA1, dtorA2]) + ] -result :: Module -result = ("Module1", [decl1, decl2, Export "Module3"]) +type Refs = [(P.ModuleName, P.DeclarationRef)] -db :: Map.Map ModuleIdent [ExternDecl] -db = Map.fromList [module1, module2, module3] +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])) + ] -shouldBeEqualSorted :: Module -> Module -> Expectation -shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2) +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 --- /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 --- /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 --- 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 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -12,6 +12,8 @@ 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 @@ 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 --- 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/Main.purs deleted file mode 100644 --- a/tests/support/pscide/src/Main.purs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -id :: forall a. a -> a -id x = x - -const :: forall a b. a -> b -> a -const x _ = x diff --git a/tests/support/pscide/src/MatcherSpec.purs b/tests/support/pscide/src/MatcherSpec.purs new file mode 100644 --- /dev/null +++ b/tests/support/pscide/src/MatcherSpec.purs @@ -0,0 +1,7 @@ +module MatcherSpec where + +id :: forall a. a -> a +id x = x + +const :: forall a b. a -> b -> a +const x _ = x diff --git a/tests/support/pscide/src/RebuildSpecSingleModule.purs b/tests/support/pscide/src/RebuildSpecSingleModule.purs --- 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 --- a/tests/support/pscide/src/RebuildSpecWithForeign.js +++ b/tests/support/pscide/src/RebuildSpecWithForeign.js @@ -1,3 +1,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 --- /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