summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2017-06-05 01:48:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-06-05 01:48:00 (GMT)
commit365104aef9239bb6b25980ffbeba1a1b5682ba78 (patch)
treebe7808de4b20ecf3d1390ad2ce42dab3847908ef
parentdfc751175a388290a125b6eb4dcde53a2795e7ab (diff)
version 0.11.50.11.5
-rw-r--r--CONTRIBUTING.md2
-rw-r--r--CONTRIBUTORS.md4
-rw-r--r--app/Command/Compile.hs7
-rw-r--r--app/Command/Ide.hs19
-rw-r--r--app/Command/REPL.hs15
-rw-r--r--examples/docs/src/Desugar.purs8
-rw-r--r--examples/failing/2874-forall.purs8
-rw-r--r--examples/failing/2874-forall2.purs10
-rw-r--r--examples/failing/2874-wildcard.purs11
-rw-r--r--examples/failing/InstanceSigsBodyIncorrect.purs10
-rw-r--r--examples/failing/InstanceSigsDifferentTypes.purs10
-rw-r--r--examples/failing/InstanceSigsIncorrectType.purs10
-rw-r--r--examples/failing/InstanceSigsOrphanTypeDeclaration.purs10
-rw-r--r--examples/passing/InstanceSigs.purs12
-rw-r--r--examples/passing/InstanceSigsGeneral.purs12
-rw-r--r--examples/passing/NewtypeInstance.purs20
-rw-r--r--examples/warning/NewtypeInstance.purs8
-rw-r--r--examples/warning/NewtypeInstance2.purs16
-rw-r--r--examples/warning/NewtypeInstance3.purs22
-rw-r--r--examples/warning/NewtypeInstance4.purs24
-rw-r--r--purescript.cabal32
-rw-r--r--src/Language/PureScript/AST/Declarations.hs2
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs7
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/TCO.hs10
-rw-r--r--src/Language/PureScript/Docs/Convert.hs5
-rw-r--r--src/Language/PureScript/Environment.hs6
-rw-r--r--src/Language/PureScript/Errors.hs46
-rw-r--r--src/Language/PureScript/Errors/JSON.hs2
-rw-r--r--src/Language/PureScript/Ide.hs34
-rw-r--r--src/Language/PureScript/Ide/Command.hs8
-rw-r--r--src/Language/PureScript/Ide/Completion.hs122
-rw-r--r--src/Language/PureScript/Ide/Error.hs4
-rw-r--r--src/Language/PureScript/Ide/Filter.hs39
-rw-r--r--src/Language/PureScript/Ide/Imports.hs85
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs7
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs8
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs50
-rw-r--r--src/Language/PureScript/Ide/State.hs136
-rw-r--r--src/Language/PureScript/Ide/Types.hs85
-rw-r--r--src/Language/PureScript/Ide/Util.hs62
-rw-r--r--src/Language/PureScript/Ide/Watcher.hs2
-rw-r--r--src/Language/PureScript/Interactive.hs5
-rw-r--r--src/Language/PureScript/Interactive/Module.hs4
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs10
-rw-r--r--src/Language/PureScript/Parser/Types.hs11
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs110
-rw-r--r--src/Language/PureScript/Types.hs7
-rw-r--r--src/System/IO/UTF8.hs11
-rw-r--r--tests/Language/PureScript/Ide/CompletionSpec.hs34
-rw-r--r--tests/Language/PureScript/Ide/FilterSpec.hs51
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs38
-rw-r--r--tests/Language/PureScript/Ide/RebuildSpec.hs3
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs9
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs26
-rw-r--r--tests/Language/PureScript/Ide/Test.hs18
-rw-r--r--tests/TestCompiler.hs81
-rw-r--r--tests/TestDocs.hs4
-rw-r--r--tests/TestPsci/CompletionTest.hs26
-rw-r--r--tests/TestUtils.hs144
-rw-r--r--tests/support/bower.json2
60 files changed, 1037 insertions, 547 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index c76781e..da40134 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -23,7 +23,7 @@ To build and run a specific test in `examples/passing/` or `examples/failing/`,
``` bash
# Build
-stack exec psc -- 'tests/support/bower_components/purescript-*/src/**/*.purs' examples/blah/Blah.purs
+stack exec purs -- compile 'tests/support/bower_components/purescript-*/src/**/*.purs' examples/blah/Blah.purs
# Run
node -e "require('./output/Main/').main()"
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index b81f07f..e653c77 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -36,6 +36,7 @@ If you would prefer to use different terms, please use the section below instead
| [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license](http://opensource.org/licenses/MIT) |
| [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) |
| [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license](http://opensource.org/licenses/MIT) |
+| [@kleeneplus](https://github.com/dgendill) | Dominick Gendill | [MIT license](http://opensource.org/licenses/MIT) |
| [@eamelink](https://github.com/eamelink) | Erik Bakker | MIT license |
| [@epost](https://github.com/epost) | Erik Post | MIT license |
| [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license](http://opensource.org/licenses/MIT) |
@@ -45,6 +46,7 @@ If you would prefer to use different terms, please use the section below instead
| [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license](http://opensource.org/licenses/MIT) |
| [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license](http://opensource.org/licenses/MIT) |
| [@hdgarrood](https://github.com/hdgarrood) | Harry Garrood | [MIT license](http://opensource.org/licenses/MIT) |
+| [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license](http://opensource.org/licenses/MIT) |
| [@ianbollinger](https://github.com/ianbollinger) | Ian D. Bollinger | [MIT license](http://opensource.org/licenses/MIT) |
| [@ilovezfs](https://github.com/ilovezfs) | ilovezfs | MIT license |
| [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license](http://opensource.org/licenses/MIT) |
@@ -86,11 +88,13 @@ If you would prefer to use different terms, please use the section below instead
| [@rvion](https://github.com/rvion) | Rémi Vion | [MIT license](http://opensource.org/licenses/MIT) |
| [@RyanGlScott](https://github.com/RyanGlScott) | Ryan Scott | [MIT license](http://opensource.org/licenses/MIT) |
| [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | MIT license |
+| [@sectore](https://github.com/sectore) | Jens Krause | [MIT license](http://opensource.org/licenses/MIT) |
| [@senju](https://github.com/senju) | senju | [MIT license](http://opensource.org/licenses/MIT) |
| [@seungha-kim](https://github.com/seungha-kim) | Seungha Kim | [MIT license](http://opensource.org/licenses/MIT) |
| [@simonyangme](https://github.com/simonyangme) | Simon Yang | [MIT license](http://opensource.org/licenses/MIT) |
| [@sharkdp](https://github.com/sharkdp) | David Peter | [MIT license](http://opensource.org/licenses/MIT) |
| [@soupi](https://github.com/soupi) | Gil Mizrahi | [MIT license](http://opensource.org/licenses/MIT) |
+| [@stefanholzmueller](https://github.com/stefanholzmueller) | Stefan Holzmüller | [MIT license](http://opensource.org/licenses/MIT) |
| [@sztupi](https://github.com/sztupi) | Attila Sztupak | [MIT license](http://opensource.org/licenses/MIT) |
| [@taktoa](https://github.com/taktoa) | Remy Goldschmidt | [MIT license](http://opensource.org/licenses/MIT) |
| [@taku0](https://github.com/taku0) | taku0 | [MIT license](http://opensource.org/licenses/MIT) |
diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
index 04c9520..b5baa59 100644
--- a/app/Command/Compile.hs
+++ b/app/Command/Compile.hs
@@ -22,7 +22,6 @@ import qualified Options.Applicative as Opts
import qualified System.Console.ANSI as ANSI
import System.Exit (exitSuccess, exitFailure)
import System.Directory (getCurrentDirectory)
-import System.FilePath (makeRelative)
import System.FilePath.Glob (glob)
import System.IO (hPutStr, hPutStrLn, stderr)
import System.IO.UTF8 (readUTF8FileT)
@@ -38,8 +37,9 @@ data PSCMakeOptions = PSCMakeOptions
-- | Argumnets: verbose, use JSON, warnings, errors
printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
printWarningsAndErrors verbose False warnings errors = do
+ pwd <- getCurrentDirectory
cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr
- let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose }
+ let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd }
when (P.nonEmpty warnings) $
hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings)
case errors of
@@ -55,7 +55,6 @@ printWarningsAndErrors verbose True warnings errors = do
compile :: PSCMakeOptions -> IO ()
compile PSCMakeOptions{..} = do
- pwd <- getCurrentDirectory
input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput
when (null input && not pscmJSONErrors) $ do
hPutStr stderr $ unlines [ "purs compile: No input files."
@@ -64,7 +63,7 @@ compile PSCMakeOptions{..} = do
exitFailure
moduleFiles <- readInput input
(makeErrors, makeWarnings) <- runMake pscmOpts $ do
- ms <- P.parseModulesFromFiles (makeRelative pwd) moduleFiles
+ ms <- P.parseModulesFromFiles id moduleFiles
let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms
foreigns <- inferForeignModules filePathMap
let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs
index 59780de..76ad796 100644
--- a/app/Command/Ide.hs
+++ b/app/Command/Ide.hs
@@ -120,7 +120,7 @@ command = Opts.helper <*> subcommands where
unless noWatch $
void (forkFinally (watcher polling logLevel ideState fullOutputPath) print)
- let conf = Configuration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs}
+ let conf = IdeConfiguration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs}
env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}
startServer port env
@@ -164,15 +164,16 @@ startServer port env = withSocketsDo $ do
case decodeT cmd of
Just cmd' -> do
let message duration =
- "Command " <> commandName cmd'
- <> " took "
- <> displayTimeSpec duration
- result <- logPerf message (runExceptT (handleCommand cmd'))
- -- $(logDebug) ("Answer was: " <> T.pack (show result))
+ "Command "
+ <> commandName cmd'
+ <> " took "
+ <> displayTimeSpec duration
+ logPerf message $ do
+ result <- runExceptT (handleCommand cmd')
+ liftIO $ catchGoneHandle $ BSL8.hPutStrLn h $ case result of
+ Right r -> Aeson.encode r
+ Left err -> Aeson.encode err
liftIO (hFlush stdout)
- case result of
- Right r -> liftIO $ catchGoneHandle (BSL8.hPutStrLn h (Aeson.encode r))
- Left err -> liftIO $ catchGoneHandle (BSL8.hPutStrLn h (Aeson.encode err))
Nothing -> do
$(logError) ("Parsing the command failed. Command: " <> cmd)
liftIO $ do
diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs
index bb2e493..9b8ad12 100644
--- a/app/Command/REPL.hs
+++ b/app/Command/REPL.hs
@@ -53,6 +53,7 @@ import System.Directory (doesFileExist, getCurrentDirectory)
import System.FilePath ((</>))
import System.FilePath.Glob (glob)
import System.Process (readProcessWithExitCode)
+import qualified Data.ByteString.Lazy.UTF8 as U
-- | Command line options
data PSCiOptions = PSCiOptions
@@ -206,12 +207,12 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
case Wai.pathInfo req of
[] ->
respond $ Wai.responseLBS status200
- [(hContentType, "text/html")]
- indexPage
+ [(hContentType, "text/html; charset=UTF-8")]
+ (U.fromString indexPage)
["js", "index.js"] ->
respond $ Wai.responseLBS status200
[(hContentType, "application/javascript")]
- indexJS
+ (U.fromString indexJS)
["js", "latest.js"] -> do
may <- readTVarIO indexJs
case may of
@@ -224,7 +225,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
, (hPragma, "no-cache")
, (hExpires, "0")
]
- (fromString js)
+ (U.fromString js)
["js", "bundle.js"] -> do
may <- readTVarIO bundleJs
case may of
@@ -233,7 +234,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
Just js ->
respond $ Wai.responseLBS status200
[ (hContentType, "application/javascript")]
- (fromString js)
+ (U.fromString js)
_ -> respond $ Wai.responseLBS status404 [] "Not found"
let browserState = BrowserState cmdChan shutdownVar indexJs bundleJs
@@ -323,7 +324,9 @@ command = loop <$> options
case psciBackend of
Backend setup eval reload (shutdown :: state -> IO ()) ->
case e of
- Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
+ Left errs -> do
+ pwd <- getCurrentDirectory
+ putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd} errs) >> exitFailure
Right (modules, externs, env) -> do
historyFilename <- getHistoryFilename
let settings = defaultSettings { historyFile = Just historyFilename }
diff --git a/examples/docs/src/Desugar.purs b/examples/docs/src/Desugar.purs
new file mode 100644
index 0000000..cc6061a
--- /dev/null
+++ b/examples/docs/src/Desugar.purs
@@ -0,0 +1,8 @@
+module Desugar where
+
+data X a b = X a b
+
+test :: forall a b. X (a -> b) a -> b
+test x =
+ let X a b = x
+ in a b
diff --git a/examples/failing/2874-forall.purs b/examples/failing/2874-forall.purs
new file mode 100644
index 0000000..0bb935e
--- /dev/null
+++ b/examples/failing/2874-forall.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith ErrorParsingModule
+module Main where
+
+class T a b | a -> b
+instance tT :: (T Int (forall a. a)) => T Int String
+
+ddd :: Int
+ddd = 0 :: forall t. T Int t => Int
diff --git a/examples/failing/2874-forall2.purs b/examples/failing/2874-forall2.purs
new file mode 100644
index 0000000..704aca2
--- /dev/null
+++ b/examples/failing/2874-forall2.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith ErrorParsingModule
+module Main where
+
+class X a b | a -> b
+class X a (forall t. t) <= Y a b | a -> b
+instance tX :: X Int String
+instance tY :: Y Int Boolean
+
+ggg :: Int
+ggg = 0 :: forall t. Y Int t => Int
diff --git a/examples/failing/2874-wildcard.purs b/examples/failing/2874-wildcard.purs
new file mode 100644
index 0000000..d5f001e
--- /dev/null
+++ b/examples/failing/2874-wildcard.purs
@@ -0,0 +1,11 @@
+-- @shouldFailWith ErrorParsingModule
+module Main where
+
+class Foo a where
+ foo :: a
+
+class Baz b where
+ baz :: b
+
+instance bazFoo :: (Baz _) => Foo b where
+ foo = baz
diff --git a/examples/failing/InstanceSigsBodyIncorrect.purs b/examples/failing/InstanceSigsBodyIncorrect.purs
new file mode 100644
index 0000000..fd3c437
--- /dev/null
+++ b/examples/failing/InstanceSigsBodyIncorrect.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith TypesDoNotUnify
+
+module Main where
+
+class Foo a where
+ foo :: a
+
+instance fooNumber :: Foo Number where
+ foo :: Number
+ foo = true
diff --git a/examples/failing/InstanceSigsDifferentTypes.purs b/examples/failing/InstanceSigsDifferentTypes.purs
new file mode 100644
index 0000000..0de2109
--- /dev/null
+++ b/examples/failing/InstanceSigsDifferentTypes.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith TypesDoNotUnify
+
+module Main where
+
+class Foo a where
+ foo :: a
+
+instance fooNumber :: Foo Number where
+ foo :: Int
+ foo = 0.0
diff --git a/examples/failing/InstanceSigsIncorrectType.purs b/examples/failing/InstanceSigsIncorrectType.purs
new file mode 100644
index 0000000..f452f2e
--- /dev/null
+++ b/examples/failing/InstanceSigsIncorrectType.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith TypesDoNotUnify
+
+module Main where
+
+class Foo a where
+ foo :: a
+
+instance fooNumber :: Foo Number where
+ foo :: Boolean
+ foo = true
diff --git a/examples/failing/InstanceSigsOrphanTypeDeclaration.purs b/examples/failing/InstanceSigsOrphanTypeDeclaration.purs
new file mode 100644
index 0000000..0871119
--- /dev/null
+++ b/examples/failing/InstanceSigsOrphanTypeDeclaration.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith OrphanTypeDeclaration
+
+module Main where
+
+class Foo a where
+ foo :: a
+
+instance fooNumber :: Foo Number where
+ bar :: Int
+ foo = 0.0
diff --git a/examples/passing/InstanceSigs.purs b/examples/passing/InstanceSigs.purs
new file mode 100644
index 0000000..b3975a2
--- /dev/null
+++ b/examples/passing/InstanceSigs.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+class Foo a where
+ foo :: a
+
+instance fooNumber :: Foo Number where
+ foo :: Number
+ foo = 0.0
+
+main = log "Done"
diff --git a/examples/passing/InstanceSigsGeneral.purs b/examples/passing/InstanceSigsGeneral.purs
new file mode 100644
index 0000000..05901ad
--- /dev/null
+++ b/examples/passing/InstanceSigsGeneral.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+class Eq a where
+ eq :: a -> a -> Boolean
+
+instance eqNumber :: Eq Number where
+ eq :: forall x y. x -> y -> Boolean
+ eq _ _ = true
+
+main = log "Done"
diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs
index f7b9ea8..1e01f71 100644
--- a/examples/passing/NewtypeInstance.purs
+++ b/examples/passing/NewtypeInstance.purs
@@ -3,15 +3,15 @@ module Main where
import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
+import Data.Monoid
+import Data.Tuple
type MyString = String
newtype X = X MyString
derive newtype instance showX :: Show X
-
derive newtype instance eqX :: Eq X
-
derive newtype instance ordX :: Ord X
newtype Y a = Y (Array a)
@@ -29,13 +29,27 @@ derive newtype instance singletonY :: Singleton a (Y a)
newtype MyArray a = MyArray (Array a)
derive newtype instance showMyArray :: Show a => Show (MyArray a)
-
derive newtype instance functorMyArray :: Functor MyArray
newtype ProxyArray x a = ProxyArray (Array a)
derive newtype instance functorProxyArray :: Functor (ProxyArray x)
+class (Monad m, Monoid w) <= MonadWriter w m | m -> w where
+ tell :: w -> m Unit
+
+instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where
+ tell w = Tuple w unit
+
+newtype MyWriter w a = MyWriter (Tuple w a)
+
+derive newtype instance functorMyWriter :: Functor (MyWriter w)
+derive newtype instance applyMyWriter :: Semigroup w => Apply (MyWriter w)
+derive newtype instance applicativeMyWriter :: Monoid w => Applicative (MyWriter w)
+derive newtype instance bindMyWriter :: Semigroup w => Bind (MyWriter w)
+derive newtype instance monadMyWriter :: Monoid w => Monad (MyWriter w)
+derive newtype instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w)
+
main = do
logShow (X "test")
logShow (singleton "test" :: Y String)
diff --git a/examples/warning/NewtypeInstance.purs b/examples/warning/NewtypeInstance.purs
new file mode 100644
index 0000000..944ee45
--- /dev/null
+++ b/examples/warning/NewtypeInstance.purs
@@ -0,0 +1,8 @@
+-- @shouldWarnWith MissingNewtypeSuperclassInstance
+module Main where
+
+import Prelude
+
+newtype X = X String
+
+derive newtype instance ordX :: Ord X
diff --git a/examples/warning/NewtypeInstance2.purs b/examples/warning/NewtypeInstance2.purs
new file mode 100644
index 0000000..de5f56b
--- /dev/null
+++ b/examples/warning/NewtypeInstance2.purs
@@ -0,0 +1,16 @@
+-- @shouldWarnWith MissingNewtypeSuperclassInstance
+module Main where
+
+import Prelude
+import Data.Monoid (class Monoid)
+import Data.Tuple (Tuple(..))
+
+class (Monad m, Monoid w) <= MonadWriter w m | m -> w where
+ tell :: w -> m Unit
+
+instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where
+ tell w = Tuple w unit
+
+newtype MyWriter w a = MyWriter (Tuple w a)
+
+derive newtype instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w)
diff --git a/examples/warning/NewtypeInstance3.purs b/examples/warning/NewtypeInstance3.purs
new file mode 100644
index 0000000..7357d5b
--- /dev/null
+++ b/examples/warning/NewtypeInstance3.purs
@@ -0,0 +1,22 @@
+-- @shouldWarnWith MissingNewtypeSuperclassInstance
+module Main where
+
+import Prelude
+import Data.Monoid (class Monoid)
+import Data.Tuple (Tuple(..))
+
+class (Monad m, Monoid w) <= MonadTell w m | m -> w where
+ tell :: w -> m Unit
+
+class (MonadTell w m) <= MonadWriter w m | m -> w where
+ listen :: forall a. m a -> m (Tuple w a)
+
+instance monadTellTuple :: Monoid w => MonadTell w (Tuple w) where
+ tell w = Tuple w unit
+
+instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where
+ listen (Tuple w a) = Tuple w (Tuple w a)
+
+newtype MyWriter w a = MyWriter (Tuple w a)
+
+derive newtype instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w)
diff --git a/examples/warning/NewtypeInstance4.purs b/examples/warning/NewtypeInstance4.purs
new file mode 100644
index 0000000..625d1d3
--- /dev/null
+++ b/examples/warning/NewtypeInstance4.purs
@@ -0,0 +1,24 @@
+-- @shouldWarnWith UnverifiableSuperclassInstance
+module Main where
+
+import Prelude
+import Data.Monoid (class Monoid)
+import Data.Tuple (Tuple(..))
+
+class Monoid w <= MonadTell w m where
+ tell :: w -> m Unit
+
+class (MonadTell w m) <= MonadWriter w m where
+ listen :: forall a. m a -> m (Tuple w a)
+
+instance monadTellTuple :: Monoid w => MonadTell w (Tuple w) where
+ tell w = Tuple w unit
+
+instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where
+ listen (Tuple w a) = Tuple w (Tuple w a)
+
+newtype MyWriter w a = MyWriter (Tuple w a)
+
+-- No fundep means this is unverifiable
+derive newtype instance monadTellMyWriter :: Monoid w => MonadTell w (MyWriter w)
+derive newtype instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w)
diff --git a/purescript.cabal b/purescript.cabal
index b11f327..159e03c 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -3,16 +3,16 @@
-- see: https://github.com/sol/hpack
name: purescript
-version: 0.11.4
+version: 0.11.5
cabal-version: >= 1.10
build-type: Simple
license: BSD3
license-file: LICENSE
-copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess
+copyright: (c) 2013-17 Phil Freeman, (c) 2014-17 Gary Burgess
maintainer: Phil Freeman <paf31@cantab.net>
stability: experimental
homepage: http://www.purescript.org/
-bug-reports: https://github.com/purescript/purescript.git/issues
+bug-reports: https://github.com/purescript/purescript/issues
synopsis: PureScript Programming Language Compiler
description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript.
category: Language
@@ -35,6 +35,7 @@ extra-source-files:
examples/docs/src/Clash2.purs
examples/docs/src/Clash2a.purs
examples/docs/src/ConstrainedArgument.purs
+ examples/docs/src/Desugar.purs
examples/docs/src/DocComments.purs
examples/docs/src/DuplicateNames.purs
examples/docs/src/Example.purs
@@ -85,6 +86,9 @@ extra-source-files:
examples/failing/2601.purs
examples/failing/2616.purs
examples/failing/2806.purs
+ examples/failing/2874-forall.purs
+ examples/failing/2874-forall2.purs
+ examples/failing/2874-wildcard.purs
examples/failing/365.purs
examples/failing/438.purs
examples/failing/881.purs
@@ -184,6 +188,10 @@ extra-source-files:
examples/failing/InfiniteType.purs
examples/failing/InstanceExport.purs
examples/failing/InstanceExport/InstanceExport.purs
+ examples/failing/InstanceSigsBodyIncorrect.purs
+ examples/failing/InstanceSigsDifferentTypes.purs
+ examples/failing/InstanceSigsIncorrectType.purs
+ examples/failing/InstanceSigsOrphanTypeDeclaration.purs
examples/failing/IntOutOfRange.purs
examples/failing/InvalidDerivedInstance.purs
examples/failing/InvalidDerivedInstance2.purs
@@ -398,6 +406,8 @@ extra-source-files:
examples/passing/ImportQualified/M1.purs
examples/passing/InferRecFunWithConstrainedArgument.purs
examples/passing/InstanceBeforeClass.purs
+ examples/passing/InstanceSigs.purs
+ examples/passing/InstanceSigsGeneral.purs
examples/passing/IntAndChar.purs
examples/passing/iota.purs
examples/passing/JSReserved.purs
@@ -596,6 +606,10 @@ extra-source-files:
examples/warning/ImplicitImport.purs
examples/warning/ImplicitQualifiedImport.purs
examples/warning/MissingTypeDeclaration.purs
+ examples/warning/NewtypeInstance.purs
+ examples/warning/NewtypeInstance2.purs
+ examples/warning/NewtypeInstance3.purs
+ examples/warning/NewtypeInstance4.purs
examples/warning/OverlappingInstances.purs
examples/warning/OverlappingPattern.purs
examples/warning/ScopeShadowing.purs
@@ -638,7 +652,7 @@ extra-source-files:
source-repository head
type: git
- location: https://github.com/purescript/purescript.git
+ location: https://github.com/purescript/purescript
flag release
description: Mark this build as a release build: prevents inclusion of extra info e.g. commit SHA in --version output)
@@ -662,7 +676,7 @@ library
, containers
, data-ordlist >=0.4.7.0
, deepseq
- , directory >=1.2
+ , directory >=1.2.3
, dlist
, edit-distance
, filepath
@@ -692,6 +706,7 @@ library
, spdx ==0.2.*
, split
, stm >=0.2.4.0
+ , stringsearch
, syb
, text
, time
@@ -870,7 +885,7 @@ executable purs
, containers
, data-ordlist >=0.4.7.0
, deepseq
- , directory >=1.2
+ , directory >=1.2.3
, dlist
, edit-distance
, filepath
@@ -900,6 +915,7 @@ executable purs
, spdx ==0.2.*
, split
, stm >=0.2.4.0
+ , stringsearch
, syb
, text
, time
@@ -958,7 +974,7 @@ test-suite tests
, containers
, data-ordlist >=0.4.7.0
, deepseq
- , directory >=1.2
+ , directory >=1.2.3
, dlist
, edit-distance
, filepath
@@ -988,6 +1004,7 @@ test-suite tests
, spdx ==0.2.*
, split
, stm >=0.2.4.0
+ , stringsearch
, syb
, text
, time
@@ -1006,6 +1023,7 @@ test-suite tests
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules:
+ Language.PureScript.Ide.CompletionSpec
Language.PureScript.Ide.FilterSpec
Language.PureScript.Ide.ImportsSpec
Language.PureScript.Ide.MatcherSpec
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 97a6843..c067e5a 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -109,6 +109,8 @@ data SimpleErrorMessage
| InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [Type] Int
| ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [Type] Type
| InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
+ | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [Type]
+ | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [Type]
| CannotFindDerivingType (ProperName 'TypeName)
| DuplicateLabel Label (Maybe Expr)
| DuplicateValueDeclaration Ident
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index 4c6d571..55bcc23 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -13,6 +13,7 @@ import qualified Data.Aeson as A
import Data.Monoid
import qualified Data.Text as T
import Data.Text (Text)
+import System.FilePath (makeRelative)
-- |
-- Source position information
@@ -65,9 +66,9 @@ displayStartEndPos sp =
displaySourcePos (spanStart sp) <> " - " <>
displaySourcePos (spanEnd sp)
-displaySourceSpan :: SourceSpan -> Text
-displaySourceSpan sp =
- T.pack (spanName sp) <> " " <>
+displaySourceSpan :: FilePath -> SourceSpan -> Text
+displaySourceSpan relPath sp =
+ T.pack (makeRelative relPath (spanName sp)) <> " " <>
displayStartEndPos sp
instance A.ToJSON SourceSpan where
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index ab7a69d..0a5d949 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -13,19 +13,19 @@ import Safe (headDef, tailSafe)
tco :: AST -> AST
tco = everywhere convert where
tcoVar :: Text -> Text
- tcoVar arg = "__tco_" <> arg
+ tcoVar arg = "$tco_var_" <> arg
copyVar :: Text -> Text
- copyVar arg = "__copy_" <> arg
+ copyVar arg = "$copy_" <> arg
tcoDone :: Text
- tcoDone = tcoVar "done"
+ tcoDone = "$tco_done"
tcoLoop :: Text
- tcoLoop = tcoVar "loop"
+ tcoLoop = "$tco_loop"
tcoResult :: Text
- tcoResult = tcoVar "result"
+ tcoResult = "$tco_result"
convert :: AST -> AST
convert (VariableIntroduction ss name (Just fn@Function {}))
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index a564e0a..8aaf43c 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -58,7 +58,7 @@ convertModulesInPackageWithEnv modules modulesDeps =
Nothing -> Local mn
isLocal :: P.ModuleName -> Bool
- isLocal = not . flip Map.member modulesDeps
+ isLocal = not . flip Map.member modulesDeps
-- |
-- Convert a group of modules to the intermediate format, designed for
@@ -208,7 +208,8 @@ partiallyDesugar = P.evalSupplyT 0 . desugar'
where
desugar' =
traverse P.desugarDoModule
- >=> traverse P.desugarCasesModule
+ >=> map P.desugarLetPatternModule
+ >>> traverse P.desugarCasesModule
>=> traverse P.desugarTypeDeclarationsModule
>=> ignoreWarnings . P.desugarImportsWithEnv []
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 7d11443..2a22a1b 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -377,9 +377,9 @@ primClasses =
-- class RowCons (l :: Symbol) (a :: Type) (i :: # Type) (o :: # Type) | l i a -> o, l o -> a i
, (primName "RowCons", (makeTypeClassData
[ ("l", Just kindSymbol)
- , ("a", Just (Row kindType))
- , ("i", Just kindType)
- , ("o", Just kindType)
+ , ("a", Just kindType)
+ , ("i", Just (Row kindType))
+ , ("o", Just (Row kindType))
] [] []
[ FunctionalDependency [0, 1, 2] [3]
, FunctionalDependency [0, 3] [1, 2]
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 1314b7a..742640a 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -121,6 +121,8 @@ errorCode em = case unwrapErrorMessage em of
PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"
CannotDerive{} -> "CannotDerive"
InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"
+ MissingNewtypeSuperclassInstance{} -> "MissingNewtypeSuperclassInstance"
+ UnverifiableSuperclassInstance{} -> "UnverifiableSuperclassInstance"
InvalidDerivedInstance{} -> "InvalidDerivedInstance"
ExpectedTypeConstructor{} -> "ExpectedTypeConstructor"
CannotFindDerivingType{} -> "CannotFindDerivingType"
@@ -262,6 +264,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts
+ gSimple (MissingNewtypeSuperclassInstance cl1 cl2 ts) = MissingNewtypeSuperclassInstance cl1 cl2 <$> traverse f ts
+ gSimple (UnverifiableSuperclassInstance cl1 cl2 ts) = UnverifiableSuperclassInstance cl1 cl2 <$> traverse f ts
gSimple (InvalidDerivedInstance cl ts n) = InvalidDerivedInstance cl <$> traverse f ts <*> pure n
gSimple (ExpectedTypeConstructor cl ts ty) = ExpectedTypeConstructor cl <$> traverse f ts <*> f ty
gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
@@ -362,24 +366,26 @@ defaultCodeColor = (ANSI.Dull, ANSI.Yellow)
-- | `prettyPrintSingleError` Options
data PPEOptions = PPEOptions
- { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not
- , ppeFull :: Bool -- ^ Should write a full error message?
- , ppeLevel :: Level -- ^ Should this report an error or a warning?
- , ppeShowDocs :: Bool -- ^ Should show a link to error message's doc page?
+ { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not
+ , ppeFull :: Bool -- ^ Should write a full error message?
+ , ppeLevel :: Level -- ^ Should this report an error or a warning?
+ , ppeShowDocs :: Bool -- ^ Should show a link to error message's doc page?
+ , ppeRelativeDirectory :: FilePath -- ^ FilePath to which the errors are relative
}
-- | Default options for PPEOptions
defaultPPEOptions :: PPEOptions
defaultPPEOptions = PPEOptions
- { ppeCodeColor = Just defaultCodeColor
- , ppeFull = False
- , ppeLevel = Error
- , ppeShowDocs = True
+ { ppeCodeColor = Just defaultCodeColor
+ , ppeFull = False
+ , ppeLevel = Error
+ , ppeShowDocs = True
+ , ppeRelativeDirectory = mempty
}
-- | Pretty print a single error, simplifying if necessary
prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box
-prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do
+prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = flip evalState defaultUnknownMap $ do
em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
um <- get
return (prettyPrintErrorMessage um em)
@@ -522,7 +528,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
line $ "Export for " <> printName new <> " conflicts with " <> runName existing
renderSimpleErrorMessage (DuplicateModule mn ss) =
paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:")
- , indent . paras $ map (line . displaySourceSpan) ss
+ , indent . paras $ map (line . displaySourceSpan relPath) ss
]
renderSimpleErrorMessage (CycleInDeclaration nm) =
line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed."
@@ -551,7 +557,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
]
renderSimpleErrorMessage (EscapedSkolem name (Just srcSpan) ty) =
paras [ line $ "The type variable " <> markCode name <> ", bound at"
- , indent $ line $ displaySourceSpan srcSpan
+ , indent $ line $ displaySourceSpan relPath srcSpan
, line "has escaped its scope, appearing in the type"
, markCodeBox $ indent $ typeAsBox ty
]
@@ -671,6 +677,22 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
]
, line "Make sure this is a newtype."
]
+ renderSimpleErrorMessage (MissingNewtypeSuperclassInstance su cl ts) =
+ paras [ line "The derived newtype instance for"
+ , markCodeBox $ indent $ Box.hsep 1 Box.left
+ [ line (showQualified runProperName cl)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ , line $ "does not include a derived superclass instance for " <> markCode (showQualified runProperName su) <> "."
+ ]
+ renderSimpleErrorMessage (UnverifiableSuperclassInstance su cl ts) =
+ paras [ line "The derived newtype instance for"
+ , markCodeBox $ indent $ Box.hsep 1 Box.left
+ [ line (showQualified runProperName cl)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ , line $ "implies an superclass instance for " <> markCode (showQualified runProperName su) <> " which could not be verified."
+ ]
renderSimpleErrorMessage (InvalidDerivedInstance nm ts argCount) =
paras [ line "Cannot derive the type class instance"
, markCodeBox $ indent $ Box.hsep 1 Box.left
@@ -1053,7 +1075,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
]
]
renderHint (PositionedError srcSpan) detail =
- paras [ line $ "at " <> displaySourceSpan srcSpan
+ paras [ line $ "at " <> displaySourceSpan relPath srcSpan
, detail
]
diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs
index c7f085c..d013235 100644
--- a/src/Language/PureScript/Errors/JSON.hs
+++ b/src/Language/PureScript/Errors/JSON.hs
@@ -50,7 +50,7 @@ toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErro
toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError
toJSONError verbose level e =
JSONError (toErrorPosition <$> sspan)
- (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False) (P.stripModuleAndSpan e)))
+ (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False mempty) (P.stripModuleAndSpan e)))
(P.errorCode e)
(P.errorDocUri e)
(P.spanName <$> sspan)
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 020208e..7d232e6 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -56,8 +56,8 @@ handleCommand c = case c of
loadModulesSync modules
Type search filters currentModule ->
findType search filters currentModule
- Complete filters matcher currentModule ->
- findCompletions filters matcher currentModule
+ Complete filters matcher currentModule complOptions ->
+ findCompletions filters matcher currentModule complOptions
Pursuit query Package ->
findPursuitPackages query
Pursuit query Identifier ->
@@ -75,12 +75,15 @@ handleCommand c = case c of
Import fp outfp _ (AddImplicitImport mn) -> do
rs <- addImplicitImport fp mn
answerRequest outfp rs
+ Import fp outfp _ (AddQualifiedImport mn qual) -> do
+ rs <- addQualifiedImport fp mn qual
+ 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 . map withEmptyAnn) question))
+ pure (CompletionResult (map (completionFromMatch . simpleExport . map withEmptyAnn) question))
Rebuild file ->
rebuildFileAsync file
RebuildSync file ->
@@ -92,17 +95,22 @@ handleCommand c = case c of
Quit ->
liftIO exitSuccess
-findCompletions :: Ide m =>
- [Filter] -> Matcher IdeDeclarationAnn -> Maybe P.ModuleName -> m Success
-findCompletions filters matcher currentModule = do
+findCompletions
+ :: Ide m
+ => [Filter]
+ -> Matcher IdeDeclarationAnn
+ -> Maybe P.ModuleName
+ -> CompletionOptions
+ -> m Success
+findCompletions filters matcher currentModule complOptions = do
modules <- getAllModules currentModule
- pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules
+ pure (CompletionResult (getCompletions filters matcher complOptions modules))
findType :: Ide m =>
Text -> [Filter] -> Maybe P.ModuleName -> m Success
findType search filters currentModule = do
modules <- getAllModules currentModule
- pure . CompletionResult . map completionFromMatch . getExactMatches search filters $ modules
+ pure (CompletionResult (getExactCompletions search filters modules))
findPursuitCompletions :: MonadIO m =>
PursuitQuery -> m Success
@@ -167,7 +175,7 @@ findAllSourceFiles = do
-- | 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.
+-- populates the VolatileState.
loadModulesAsync
:: (Ide m, MonadError IdeError m, MonadLogger m)
=> [P.ModuleName]
@@ -179,9 +187,9 @@ loadModulesAsync moduleNames = do
-- successfully parsed modules.
env <- ask
let ll = confLogLevel (ideConfiguration env)
- -- populateStage2 and 3 return Unit for now, so it's fine to discard this
+ -- populateVolatileState return Unit for now, so it's fine to discard this
-- result. We might want to block on this in a benchmarking situation.
- _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env)))
+ _ <- liftIO (async (runLogger ll (runReaderT populateVolatileState env)))
pure tr
loadModulesSync
@@ -190,7 +198,7 @@ loadModulesSync
-> m Success
loadModulesSync moduleNames = do
tr <- loadModules moduleNames
- populateStage2 *> populateStage3
+ populateVolatileState
pure tr
loadModules
@@ -208,7 +216,7 @@ loadModules moduleNames = do
-- We parse all source files, log eventual parse failures and insert the
-- successful parses into the state.
(failures, allModules) <-
- partitionEithers <$> (traverse parseModule =<< findAllSourceFiles)
+ partitionEithers <$> (parseModulesFromFiles =<< findAllSourceFiles)
unless (null failures) $
$(logWarn) ("Failed to parse: " <> show failures)
traverse_ insertModule allModules
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index e9999a8..5763fcb 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -19,6 +19,7 @@ import Protolude
import Data.Aeson
import qualified Language.PureScript as P
import Language.PureScript.Ide.CaseSplit
+import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
@@ -35,6 +36,7 @@ data Command
{ completeFilters :: [Filter]
, completeMatcher :: Matcher IdeDeclarationAnn
, completeCurrentModule :: Maybe P.ModuleName
+ , completeOptions :: CompletionOptions
}
| Pursuit
{ pursuitQuery :: PursuitQuery
@@ -79,6 +81,7 @@ commandName c = case c of
data ImportCommand
= AddImplicitImport P.ModuleName
+ | AddQualifiedImport P.ModuleName P.ModuleName
| AddImportForIdentifier Text
deriving (Show, Eq)
@@ -88,6 +91,10 @@ instance FromJSON ImportCommand where
case command of
"addImplicitImport" ->
AddImplicitImport <$> (P.moduleNameFromString <$> o .: "module")
+ "addQualifiedImport" ->
+ AddQualifiedImport
+ <$> (P.moduleNameFromString <$> o .: "module")
+ <*> (P.moduleNameFromString <$> o .: "qualifier")
"addImport" ->
AddImportForIdentifier <$> o .: "identifier"
_ -> mzero
@@ -129,6 +136,7 @@ instance FromJSON Command where
<$> params .:? "filters" .!= []
<*> params .:? "matcher" .!= mempty
<*> (fmap P.moduleNameFromString <$> params .:? "currentModule")
+ <*> params .:? "options" .!= defaultCompletionOptions
"pursuit" -> do
params <- o .: "params"
Pursuit
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
index 81f68d7..0b81812 100644
--- a/src/Language/PureScript/Ide/Completion.hs
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -1,14 +1,26 @@
module Language.PureScript.Ide.Completion
( getCompletions
, getExactMatches
+ , getExactCompletions
+ , simpleExport
+ , completionFromMatch
+ , CompletionOptions(..)
+ , defaultCompletionOptions
+ , applyCompletionOptions
) where
import Protolude
+import Control.Lens hiding ((&), op)
+import Data.Aeson
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import qualified Language.PureScript as P
+import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
-import qualified Language.PureScript as P
+import Language.PureScript.Ide.Util
type Module = (P.ModuleName, [IdeDeclarationAnn])
@@ -17,17 +29,113 @@ type Module = (P.ModuleName, [IdeDeclarationAnn])
getCompletions
:: [Filter]
-> Matcher IdeDeclarationAnn
+ -> CompletionOptions
-> [Module]
- -> [Match IdeDeclarationAnn]
-getCompletions filters matcher modules =
- runMatcher matcher (completionsFromModules (applyFilters filters modules))
+ -> [Completion]
+getCompletions filters matcher options modules =
+ modules
+ & applyFilters filters
+ & matchesFromModules
+ & runMatcher matcher
+ & applyCompletionOptions options
+ <&> completionFromMatch
getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn]
getExactMatches search filters modules =
- completionsFromModules (applyFilters (equalityFilter search : filters) modules)
+ modules
+ & applyFilters (equalityFilter search : filters)
+ & matchesFromModules
+
+getExactCompletions :: Text -> [Filter] -> [Module] -> [Completion]
+getExactCompletions search filters modules =
+ modules
+ & getExactMatches search filters
+ <&> simpleExport
+ <&> completionFromMatch
-completionsFromModules :: [Module] -> [Match IdeDeclarationAnn]
-completionsFromModules = foldMap completionFromModule
+matchesFromModules :: [Module] -> [Match IdeDeclarationAnn]
+matchesFromModules = foldMap completionFromModule
where
completionFromModule (moduleName, decls) =
map (\x -> Match (moduleName, x)) decls
+
+data CompletionOptions = CompletionOptions
+ { coMaxResults :: Maybe Int
+ , coGroupReexports :: Bool
+ }
+
+instance FromJSON CompletionOptions where
+ parseJSON = withObject "CompletionOptions" $ \o -> do
+ maxResults <- o .:? "maxResults"
+ groupReexports <- o .:? "groupReexports" .!= False
+ pure (CompletionOptions { coMaxResults = maxResults
+ , coGroupReexports = groupReexports
+ })
+
+defaultCompletionOptions :: CompletionOptions
+defaultCompletionOptions = CompletionOptions { coMaxResults = Nothing, coGroupReexports = False }
+
+applyCompletionOptions :: CompletionOptions -> [Match IdeDeclarationAnn] -> [(Match IdeDeclarationAnn, [P.ModuleName])]
+applyCompletionOptions co decls =
+ maybe identity take (coMaxResults co) decls
+ & if coGroupReexports co
+ then groupCompletionReexports
+ else map simpleExport
+
+simpleExport :: Match a -> (Match a, [P.ModuleName])
+simpleExport match@(Match (moduleName, _)) = (match, [moduleName])
+
+groupCompletionReexports :: [Match IdeDeclarationAnn] -> [(Match IdeDeclarationAnn, [P.ModuleName])]
+groupCompletionReexports initial =
+ Map.elems (foldr go Map.empty initial)
+ where
+ go (Match (moduleName, d@(IdeDeclarationAnn ann decl))) =
+ let
+ origin = fromMaybe moduleName (ann^.annExportedFrom)
+ in
+ Map.alter
+ (insertDeclaration moduleName origin d)
+ (Namespaced (namespaceForDeclaration decl)
+ (P.runModuleName origin <> "." <> identifierFromIdeDeclaration decl))
+ insertDeclaration moduleName origin d old = case old of
+ Nothing -> Just ( Match (origin, d & idaAnnotation.annExportedFrom .~ Nothing)
+ , [moduleName]
+ )
+ Just x -> Just (second (moduleName :) x)
+
+data Namespaced a = Namespaced IdeNamespace a
+ deriving (Show, Eq, Ord)
+
+completionFromMatch :: (Match IdeDeclarationAnn, [P.ModuleName]) -> Completion
+completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) =
+ Completion {..}
+ where
+ (complIdentifier, complExpandedType) = case decl of
+ IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyPrintTypeSingleLine)
+ IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind)
+ IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyPrintTypeSingleLine)
+ IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyPrintTypeSingleLine)
+ IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, d ^. ideTCKind & P.prettyPrintKind)
+ IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->
+ (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyPrintTypeSingleLine typeP)
+ IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->
+ (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind)
+ IdeDeclKind k -> (P.runProperName k, "kind")
+
+ complExportedFrom = mns
+
+ complModule = P.runModuleName m
+
+ complType = maybe complExpandedType prettyPrintTypeSingleLine (_annTypeAnnotation ann)
+
+ complLocation = _annLocation ann
+
+ complDocumentation = Nothing
+
+ showFixity p a r o =
+ let asso = case a of
+ P.Infix -> "infix"
+ P.Infixl -> "infixl"
+ P.Infixr -> "infixr"
+ in T.unwords [asso, show p, r, "as", P.runOpName o]
+
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 7fa4133..4f1a453 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -66,9 +66,9 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors
insertTSCompletions _ _ _ v = v
identCompletion (P.Qualified mn i, ty) =
- Completion (maybe "" P.runModuleName mn) i (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing
+ Completion (maybe "" P.runModuleName mn) i (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing (maybe [] (\x -> [x]) mn)
fieldCompletion (label, ty) =
- Completion "" ("_." <> P.prettyPrintLabel label) (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing
+ Completion "" ("_." <> P.prettyPrintLabel label) (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing []
textError :: IdeError -> Text
textError (GeneralError msg) = msg
diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs
index b15120c..ae469d6 100644
--- a/src/Language/PureScript/Ide/Filter.hs
+++ b/src/Language/PureScript/Ide/Filter.hs
@@ -16,6 +16,7 @@
module Language.PureScript.Ide.Filter
( Filter
+ , namespaceFilter
, moduleFilter
, prefixFilter
, equalityFilter
@@ -25,18 +26,28 @@ module Language.PureScript.Ide.Filter
import Protolude hiding (isPrefixOf)
import Data.Aeson
+import Data.List.NonEmpty (NonEmpty)
import Data.Text (isPrefixOf)
-import qualified Language.PureScript as P
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
+import qualified Language.PureScript as P
-newtype Filter = Filter (Endo [Module]) deriving(Monoid)
+newtype Filter = Filter (Endo [Module])
+ deriving (Monoid)
type Module = (P.ModuleName, [IdeDeclarationAnn])
mkFilter :: ([Module] -> [Module]) -> Filter
mkFilter = Filter . Endo
+-- | Only keeps Identifiers in the given Namespaces
+namespaceFilter :: NonEmpty IdeNamespace -> Filter
+namespaceFilter namespaces =
+ mkFilter (filterModuleDecls filterNamespaces)
+ where
+ filterNamespaces :: IdeDeclaration -> Bool
+ filterNamespaces decl = elem (namespaceForDeclaration decl) namespaces
+
-- | Only keeps the given Modules
moduleFilter :: [P.ModuleName] -> Filter
moduleFilter =
@@ -48,25 +59,29 @@ moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst)
-- | Only keeps Identifiers that start with the given prefix
prefixFilter :: Text -> Filter
prefixFilter "" = mkFilter identity
-prefixFilter t = mkFilter $ identFilter prefix t
+prefixFilter t =
+ mkFilter $ declarationFilter prefix t
where
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
+equalityFilter =
+ mkFilter . declarationFilter equality
where
equality :: IdeDeclaration -> Text -> Bool
equality ed search = identifierFromIdeDeclaration ed == search
-identFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Module]
-identFilter predicate search =
- filter (not . null . snd) . fmap filterModuleDecls
+declarationFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Module]
+declarationFilter predicate search =
+ filterModuleDecls (flip predicate search)
+
+filterModuleDecls :: (IdeDeclaration -> Bool) -> [Module] -> [Module]
+filterModuleDecls predicate =
+ filter (not . null . snd) . fmap filterDecls
where
- filterModuleDecls :: Module -> Module
- filterModuleDecls (moduleIdent, decls) =
- (moduleIdent, filter (flip predicate search . discardAnn) decls)
+ filterDecls (moduleIdent, decls) = (moduleIdent, filter (predicate . discardAnn) decls)
runFilter :: Filter -> [Module] -> [Module]
runFilter (Filter f) = appEndo f
@@ -90,4 +105,8 @@ instance FromJSON Filter where
params <- o .: "params"
modules <- map P.moduleNameFromString <$> params .: "modules"
return $ moduleFilter modules
+ "namespace" -> do
+ params <- o .: "params"
+ namespaces <- params .: "namespaces"
+ return $ namespaceFilter namespaces
_ -> mzero
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index fd14946..a38f56d 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -14,6 +14,7 @@
module Language.PureScript.Ide.Imports
( addImplicitImport
+ , addQualifiedImport
, addImportForIdentifier
, answerRequest
, parseImportsFromFile
@@ -21,6 +22,7 @@ module Language.PureScript.Ide.Imports
, parseImport
, prettyPrintImportSection
, addImplicitImport'
+ , addQualifiedImport'
, addExplicitImport'
, sliceImportSection
, prettyPrintImport'
@@ -31,7 +33,7 @@ module Language.PureScript.Ide.Imports
import Protolude
import Control.Lens ((^.), (%~), ix)
-import Data.List (findIndex, nubBy)
+import Data.List (findIndex, nubBy, partition)
import qualified Data.Text as T
import qualified Language.PureScript as P
import Language.PureScript.Ide.Completion
@@ -46,27 +48,6 @@ import qualified Text.Parsec as Parsec
data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
deriving (Eq, Show)
-instance Ord Import where
- compare = compImport
-
-compImportType :: P.ImportDeclarationType -> P.ImportDeclarationType -> Ordering
-compImportType P.Implicit P.Implicit = EQ
-compImportType P.Implicit _ = LT
-compImportType (P.Explicit _) (P.Hiding _) = LT
-compImportType (P.Explicit _) (P.Explicit _) = EQ
-compImportType (P.Explicit _) P.Implicit = GT
-compImportType (P.Hiding _) (P.Hiding _) = EQ
-compImportType (P.Hiding _) _ = GT
-
-compImport :: Import -> Import -> Ordering
-compImport (Import n i q) (Import n' i' q')
- | compImportType i i' /= EQ = compImportType i i'
- -- This means that for a stable sort, the first implicit import will stay
- -- the first implicit import
- | not (P.isExplicit i) && isNothing q = LT
- | not (P.isExplicit i) && isNothing q' = GT
- | otherwise = compare n n'
-
-- | Reads a file and returns the parsed modulename as well as the parsed
-- imports, while ignoring eventual parse errors that aren't relevant to the
-- import section
@@ -85,7 +66,7 @@ parseImportsFromFile file = do
parseImportsFromFile' :: (MonadIO m, MonadError IdeError m) =>
FilePath -> m (P.ModuleName, [Text], [Import], [Text])
parseImportsFromFile' fp = do
- file <- ideReadTextFile fp
+ file <- ideReadFile fp
case sliceImportSection (T.lines file) of
Right res -> pure res
Left err -> throwError (GeneralError err)
@@ -143,10 +124,11 @@ sliceImportSection fileLines = first show $ do
& ix (l2 - l1) %~ T.take c2
-- | Adds an implicit import like @import Prelude@ to a Sourcefile.
-addImplicitImport :: (MonadIO m, MonadError IdeError m)
- => FilePath -- ^ The Sourcefile read from
- -> P.ModuleName -- ^ The module to import
- -> m [Text]
+addImplicitImport
+ :: (MonadIO m, MonadError IdeError m)
+ => FilePath -- ^ The source file read from
+ -> P.ModuleName -- ^ The module to import
+ -> m [Text]
addImplicitImport fp mn = do
(_, pre, imports, post) <- parseImportsFromFile' fp
let newImportSection = addImplicitImport' imports mn
@@ -154,10 +136,26 @@ addImplicitImport fp mn = do
addImplicitImport' :: [Import] -> P.ModuleName -> [Text]
addImplicitImport' imports mn =
- -- We need to append the new import, because there could already be implicit
- -- imports and we need to preserve the order on these, as the first implicit
- -- import is the one that doesn't generate warnings.
- prettyPrintImportSection ( imports ++ [Import mn P.Implicit Nothing])
+ prettyPrintImportSection (Import mn P.Implicit Nothing : imports)
+
+-- | Adds a qualified import like @import Data.Map as Map@ to a source file.
+addQualifiedImport
+ :: (MonadIO m, MonadError IdeError m)
+ => FilePath
+ -- ^ The sourcefile read from
+ -> P.ModuleName
+ -- ^ The module to import
+ -> P.ModuleName
+ -- ^ The qualifier under which to import
+ -> m [Text]
+addQualifiedImport fp mn qualifier = do
+ (_, pre, imports, post) <- parseImportsFromFile' fp
+ let newImportSection = addQualifiedImport' imports mn qualifier
+ pure (pre ++ newImportSection ++ post)
+
+addQualifiedImport' :: [Import] -> P.ModuleName -> P.ModuleName -> [Text]
+addQualifiedImport' imports mn qualifier =
+ prettyPrintImportSection (Import mn P.Implicit (Just qualifier) : imports)
-- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an
-- explicit import already exists for the given module, it adds the identifier
@@ -203,6 +201,8 @@ addExplicitImport' decl moduleName imports =
P.ValueOpRef (op ^. ideValueOpName)
refFromDeclaration (IdeDeclTypeOperator op) =
P.TypeOpRef (op ^. ideTypeOpName)
+ refFromDeclaration (IdeDeclKind kn) =
+ P.KindRef kn
refFromDeclaration d =
P.ValueRef (P.Ident (identifierFromIdeDeclaration d))
@@ -272,7 +272,7 @@ addImportForIdentifier fp ident filters = do
if m1 /= m2
-- If the modules don't line up we just ask the user to specify the
-- module
- then pure $ Left ms
+ then pure (Left ms)
else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of
-- If dataconstructor and type line up we just import the
-- dataconstructor as that will give us an unnecessary import warning at
@@ -281,13 +281,16 @@ addImportForIdentifier fp ident filters = do
Right <$> addExplicitImport fp decl m1
-- Here we need the user to specify whether he wanted a dataconstructor
-- or a type
+
+ -- TODO: With the new namespace filter, this can actually be a
+ -- request for the user to specify which of the two was wanted.
Nothing ->
throwError (GeneralError "Undecidable between type and dataconstructor")
-- Multiple matches were found so we need to ask the user to clarify which
-- module he meant
xs ->
- pure $ Left xs
+ pure (Left xs)
where
decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) =
if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing
@@ -300,7 +303,21 @@ prettyPrintImport' (Import mn idt qual) =
"import " <> P.prettyPrintImport mn idt qual
prettyPrintImportSection :: [Import] -> [Text]
-prettyPrintImportSection imports = map prettyPrintImport' (sort imports)
+prettyPrintImportSection imports =
+ let
+ (implicitImports, explicitImports) = partition isImplicitImport imports
+ in
+ sort (map prettyPrintImport' implicitImports)
+ -- Only add the extra spacing if both implicit as well as
+ -- explicit/qualified imports exist
+ <> (guard (not (null explicitImports || null implicitImports)) $> "")
+ <> sort (map prettyPrintImport' explicitImports)
+ where
+ isImplicitImport :: Import -> Bool
+ isImplicitImport i = case i of
+ Import _ P.Implicit Nothing -> True
+ _ -> False
+
-- | 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/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 2ad2cd8..a26f4e5 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -20,8 +20,6 @@ import Language.PureScript.Ide.Logging
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import System.Directory (getCurrentDirectory)
-import System.FilePath (makeRelative)
-- | Given a filepath performs the following steps:
--
@@ -48,15 +46,14 @@ rebuildFile
rebuildFile path runOpenBuild = do
input <- ideReadFile path
- pwd <- liftIO getCurrentDirectory
- m <- case snd <$> P.parseModuleFromFile (makeRelative pwd) (path, input) of
+ m <- case snd <$> P.parseModuleFromFile identity (path, input) of
Left parseError ->
throwError (RebuildError (P.MultipleErrors [P.toPositionedError parseError]))
Right m -> pure m
-- Externs files must be sorted ahead of time, so that they get applied
- -- correctly to the 'Environment'.
+ -- in the right order (bottom up) to the 'Environment'.
externs <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles)
outputDirectory <- confOutputPath . ideConfiguration <$> ask
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index e26ee48..f36f04e 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -93,8 +93,10 @@ resolveRef
-> Either P.DeclarationRef [IdeDeclarationAnn]
resolveRef decls ref = case ref of
P.TypeRef tn mdtors ->
- case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn)) of
- Nothing -> Left ref
+ case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn))
+ <|> findRef (anyOf (_IdeDeclTypeSynonym . ideSynonymName) (== tn)) of
+ Nothing ->
+ Left ref
Just d -> Right $ d : case mdtors of
Nothing ->
-- If the dataconstructor field inside the TypeRef is Nothing, that
@@ -110,6 +112,8 @@ resolveRef decls ref = case ref of
findWrapped (anyOf (_IdeDeclTypeOperator . ideTypeOpName) (== name))
P.TypeClassRef name ->
findWrapped (anyOf (_IdeDeclTypeClass . ideTCName) (== name))
+ P.KindRef name ->
+ findWrapped (anyOf _IdeDeclKind (== name))
_ ->
Left ref
where
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index bad912f..23ec014 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -14,6 +14,7 @@
module Language.PureScript.Ide.SourceFile
( parseModule
+ , parseModulesFromFiles
, extractAstInformation
-- for tests
, extractSpans
@@ -22,24 +23,37 @@ module Language.PureScript.Ide.SourceFile
import Protolude
+import Control.Parallel.Strategies (withStrategy, parList, rseq)
import qualified Data.Map as Map
import qualified Language.PureScript as P
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import System.Directory (getCurrentDirectory)
-import System.FilePath (makeRelative)
parseModule
:: (MonadIO m, MonadError IdeError m)
=> FilePath
-> m (Either FilePath (FilePath, P.Module))
parseModule path = do
- pwd <- liftIO getCurrentDirectory
contents <- ideReadFile path
- case P.parseModuleFromFile (makeRelative pwd) (path, contents) of
- Left _ -> pure (Left path)
- Right m -> pure (Right m)
+ pure (parseModule' path contents)
+
+parseModule' :: FilePath -> Text -> Either FilePath (FilePath, P.Module)
+parseModule' path file =
+ case P.parseModuleFromFile identity (path, file) of
+ Left _ -> Left path
+ Right m -> Right m
+
+parseModulesFromFiles
+ :: (MonadIO m, MonadError IdeError m)
+ => [FilePath]
+ -> m [Either FilePath (FilePath, P.Module)]
+parseModulesFromFiles paths = do
+ files <- traverse (\p -> (p,) <$> ideReadFile p) paths
+ pure (inParallel (map (uncurry parseModule') files))
+ where
+ inParallel :: [Either e (k, a)] -> [Either e (k, a)]
+ inParallel = withStrategy (parList rseq)
-- | Extracts AST information from a parsed module
extractAstInformation
@@ -67,30 +81,30 @@ extractSpans
-- ^ The surrounding span
-> P.Declaration
-- ^ The declaration to extract spans from
- -> [(IdeDeclNamespace, P.SourceSpan)]
+ -> [(IdeNamespaced, P.SourceSpan)]
-- ^ Declarations and their source locations
extractSpans ss d = case d of
P.PositionedDeclaration ss' _ d' ->
extractSpans ss' d'
P.ValueDeclaration i _ _ _ ->
- [(IdeNSValue (P.runIdent i), ss)]
+ [(IdeNamespaced IdeNSValue (P.runIdent i), ss)]
P.TypeSynonymDeclaration name _ _ ->
- [(IdeNSType (P.runProperName name), ss)]
+ [(IdeNamespaced IdeNSType (P.runProperName name), ss)]
P.TypeClassDeclaration name _ _ _ members ->
- (IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members
+ (IdeNamespaced IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members
P.DataDeclaration _ name _ ctors ->
- (IdeNSType (P.runProperName name), ss)
- : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors
+ (IdeNamespaced IdeNSType (P.runProperName name), ss)
+ : map (\(cname, _) -> (IdeNamespaced IdeNSValue (P.runProperName cname), ss)) ctors
P.FixityDeclaration (Left (P.ValueFixity _ _ opName)) ->
- [(IdeNSValue (P.runOpName opName), ss)]
+ [(IdeNamespaced IdeNSValue (P.runOpName opName), ss)]
P.FixityDeclaration (Right (P.TypeFixity _ _ opName)) ->
- [(IdeNSType (P.runOpName opName), ss)]
+ [(IdeNamespaced IdeNSType (P.runOpName opName), ss)]
P.ExternDeclaration ident _ ->
- [(IdeNSValue (P.runIdent ident), ss)]
+ [(IdeNamespaced IdeNSValue (P.runIdent ident), ss)]
P.ExternDataDeclaration name _ ->
- [(IdeNSType (P.runProperName name), ss)]
+ [(IdeNamespaced IdeNSType (P.runProperName name), ss)]
P.ExternKindDeclaration name ->
- [(IdeNSKind (P.runProperName name), ss)]
+ [(IdeNamespaced IdeNSKind (P.runProperName name), ss)]
_ -> []
where
-- We need this special case to be able to also get the position info for
@@ -101,5 +115,5 @@ extractSpans ss d = case d of
P.PositionedDeclaration ssP' _ dP' ->
extractSpans' ssP' dP'
P.TypeDeclaration ident _ ->
- [(IdeNSValue (P.runIdent ident), ssP)]
+ [(IdeNamespaced IdeNSValue (P.runIdent ident), ssP)]
_ -> []
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 4f6df70..86d30fa 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -25,9 +25,8 @@ module Language.PureScript.Ide.State
, insertModule
, insertExternsSTM
, getAllModules
- , populateStage2
- , populateStage3
- , populateStage3STM
+ , populateVolatileState
+ , populateVolatileStateSTM
-- for tests
, resolveOperatorsForModule
, resolveInstances
@@ -52,9 +51,7 @@ import Language.PureScript.Ide.Util
resetIdeState :: Ide m => m ()
resetIdeState = do
ideVar <- ideStateVar <$> ask
- liftIO . atomically $ do
- writeTVar ideVar emptyIdeState
- setStage3STM ideVar emptyStage3
+ liftIO (atomically (writeTVar ideVar emptyIdeState))
-- | Gets the loaded Modulenames
getLoadedModulenames :: Ide m => m [P.ModuleName]
@@ -62,7 +59,7 @@ getLoadedModulenames = Map.keys <$> getExternFiles
-- | Gets all loaded ExternFiles
getExternFiles :: Ide m => m (ModuleMap ExternsFile)
-getExternFiles = s1Externs <$> getStage1
+getExternFiles = fsExterns <$> getFileState
-- | Insert a Module into Stage1 of the State
insertModule :: Ide m => (FilePath, P.Module) -> m ()
@@ -74,51 +71,35 @@ insertModule module' = do
insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM ()
insertModuleSTM ref (fp, module') =
modifyTVar ref $ \x ->
- x { ideStage1 = (ideStage1 x) {
- s1Modules = Map.insert
+ x { ideFileState = (ideFileState x) {
+ fsModules = Map.insert
(P.getModuleName module')
(module', fp)
- (s1Modules (ideStage1 x))}}
+ (fsModules (ideFileState x))}}
--- | Retrieves Stage1 from the State.
--- This includes loaded Externfiles
-getStage1 :: Ide m => m Stage1
-getStage1 = do
+-- | Retrieves the FileState from the State. This includes loaded Externfiles
+-- and parsed Modules
+getFileState :: Ide m => m IdeFileState
+getFileState = do
st <- ideStateVar <$> ask
- fmap ideStage1 . liftIO . readTVarIO $ st
+ fmap ideFileState . liftIO . readTVarIO $ st
--- | STM version of getStage1
-getStage1STM :: TVar IdeState -> STM Stage1
-getStage1STM ref = ideStage1 <$> readTVar ref
+-- | STM version of getFileState
+getFileStateSTM :: TVar IdeState -> STM IdeFileState
+getFileStateSTM ref = ideFileState <$> readTVar ref
--- | Retrieves Stage2 from the State.
-getStage2 :: Ide m => m Stage2
-getStage2 = do
- st <- ideStateVar <$> ask
- liftIO (atomically (getStage2STM st))
-
-getStage2STM :: TVar IdeState -> STM Stage2
-getStage2STM ref = ideStage2 <$> readTVar ref
-
--- | STM version of setStage2
-setStage2STM :: TVar IdeState -> Stage2 -> STM ()
-setStage2STM ref s2 = do
- modifyTVar ref $ \x ->
- x {ideStage2 = s2}
- pure ()
-
--- | Retrieves Stage3 from the State.
+-- | Retrieves VolatileState from the State.
-- This includes the denormalized Declarations and cached rebuilds
-getStage3 :: Ide m => m Stage3
-getStage3 = do
+getVolatileState :: Ide m => m IdeVolatileState
+getVolatileState = do
st <- ideStateVar <$> ask
- fmap ideStage3 . liftIO . readTVarIO $ st
+ fmap ideVolatileState . liftIO . readTVarIO $ st
--- | Sets Stage3 inside the compiler
-setStage3STM :: TVar IdeState -> Stage3 -> STM ()
-setStage3STM ref s3 = do
+-- | Sets the VolatileState inside Ide's state
+setVolatileStateSTM :: TVar IdeState -> IdeVolatileState -> STM ()
+setVolatileStateSTM ref vs = do
modifyTVar ref $ \x ->
- x {ideStage3 = s3}
+ x {ideVolatileState = vs}
pure ()
-- | Checks if the given ModuleName matches the last rebuild cache and if it
@@ -126,7 +107,7 @@ setStage3STM ref s3 = do
-- cache
getAllModules :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclarationAnn])]
getAllModules mmoduleName = do
- declarations <- s3Declarations <$> getStage3
+ declarations <- vsDeclarations <$> getVolatileState
rebuild <- cachedRebuild
case mmoduleName of
Nothing -> pure (Map.toList declarations)
@@ -134,7 +115,7 @@ getAllModules mmoduleName = do
case rebuild of
Just (cachedModulename, ef)
| cachedModulename == moduleName -> do
- (AstData asts) <- s2AstData <$> getStage2
+ AstData asts <- vsAstData <$> getVolatileState
let
ast =
fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
@@ -148,9 +129,9 @@ getAllModules mmoduleName = do
pure (Map.toList resolved)
_ -> pure (Map.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.
+-- | Adds an ExternsFile into psc-ide's FileState. This does not populate the
+-- VolatileState, which needs to be done after all the necessary Externs and
+-- SourceFiles have been loaded.
insertExterns :: Ide m => ExternsFile -> m ()
insertExterns ef = do
st <- ideStateVar <$> ask
@@ -160,62 +141,47 @@ insertExterns ef = do
insertExternsSTM :: TVar IdeState -> ExternsFile -> STM ()
insertExternsSTM ref ef =
modifyTVar ref $ \x ->
- x { ideStage1 = (ideStage1 x) {
- s1Externs = Map.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}
+ x { ideFileState = (ideFileState x) {
+ fsExterns = Map.insert (efModuleName ef) ef (fsExterns (ideFileState x))}}
-- | Sets rebuild cache to the given ExternsFile
cacheRebuild :: Ide m => ExternsFile -> m ()
cacheRebuild ef = do
st <- ideStateVar <$> ask
liftIO . atomically . modifyTVar st $ \x ->
- x { ideStage3 = (ideStage3 x) {
- s3CachedRebuild = Just (efModuleName ef, ef)}}
+ x { ideVolatileState = (ideVolatileState x) {
+ vsCachedRebuild = Just (efModuleName ef, ef)}}
-- | Retrieves the rebuild cache
cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile))
-cachedRebuild = s3CachedRebuild <$> getStage3
+cachedRebuild = vsCachedRebuild <$> getVolatileState
--- | Extracts source spans from the parsed ASTs
-populateStage2 :: (Ide m, MonadLogger m) => m ()
-populateStage2 = do
- st <- ideStateVar <$> ask
- let message duration = "Finished populating Stage2 in " <> displayTimeSpec duration
- logPerf message (liftIO (atomically (populateStage2STM st)))
-
--- | STM version of populateStage2
-populateStage2STM :: TVar IdeState -> STM ()
-populateStage2STM ref = do
- modules <- s1Modules <$> getStage1STM ref
- let astData = map (extractAstInformation . fst) modules
- setStage2STM ref (Stage2 (AstData astData))
-
--- | Resolves reexports and populates Stage3 with data to be used in queries.
-populateStage3 :: (Ide m, MonadLogger m) => m ()
-populateStage3 = do
+-- | Resolves reexports and populates VolatileState with data to be used in queries.
+populateVolatileState :: (Ide m, MonadLogger m) => m ()
+populateVolatileState = do
st <- ideStateVar <$> ask
let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration
- results <- logPerf message (liftIO (atomically (populateStage3STM st)))
+ results <- logPerf message (liftIO (atomically (populateVolatileStateSTM st)))
void $ Map.traverseWithKey
(\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))
(Map.filter reexportHasFailures results)
--- | STM version of populateStage3
-populateStage3STM
+-- | STM version of populateVolatileState
+populateVolatileStateSTM
:: TVar IdeState
-> STM (ModuleMap (ReexportResult [IdeDeclarationAnn]))
-populateStage3STM ref = do
- externs <- s1Externs <$> getStage1STM ref
- (AstData asts) <- s2AstData <$> getStage2STM ref
- let (modules, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs)
+populateVolatileStateSTM ref = do
+ IdeFileState{fsExterns = externs, fsModules = modules} <- getFileStateSTM ref
+ let asts = map (extractAstInformation . fst) modules
+ let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs)
results =
- resolveLocations asts modules
+ resolveLocations asts moduleDeclarations
& resolveInstances externs
& resolveOperators
& resolveReexports reexportRefs
- setStage3STM ref (Stage3 (map reResolved results) Nothing)
+ setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) Nothing)
pure results
-
resolveLocations
:: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)
-> ModuleMap [IdeDeclarationAnn]
@@ -250,12 +216,12 @@ resolveLocationsForModule (defs, types) decls =
IdeDeclKind i ->
annotateKind (i ^. properNameT) (IdeDeclKind i)
where
- annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs
+ annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs
, _annTypeAnnotation = Map.lookup x types
})
- annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSValue x) defs})
- annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSType x) defs})
- annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSKind x) defs})
+ annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs})
+ annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs})
+ annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs})
resolveInstances
:: ModuleMap P.ExternsFile
@@ -276,8 +242,8 @@ resolveInstances externs declarations =
_ -> Nothing
extractInstances _ _ = Nothing
- go ::
- (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName)
+ go
+ :: (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName)
-> ModuleMap [IdeDeclarationAnn]
-> ModuleMap [IdeDeclarationAnn]
go (ideInstance, classModule, className) acc' =
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 332da88..2a7a93a 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -22,9 +22,9 @@ import Protolude
import Control.Concurrent.STM
import Control.Lens.TH
import Data.Aeson
-import qualified Data.Map.Lazy as M
-import qualified Language.PureScript as P
-import qualified Language.PureScript.Errors.JSON as P
+import qualified Data.Map.Lazy as M
+import qualified Language.PureScript as P
+import qualified Language.PureScript.Errors.JSON as P
type ModuleIdent = Text
type ModuleMap a = Map P.ModuleName a
@@ -119,18 +119,18 @@ makeLenses ''IdeDeclarationAnn
emptyAnn :: Annotation
emptyAnn = Annotation Nothing Nothing Nothing
-type DefinitionSites a = Map IdeDeclNamespace a
+type DefinitionSites a = Map IdeNamespaced a
type TypeAnnotations = Map P.Ident P.Type
newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations))
- -- ^ SourceSpans for the definition sites of Values and Types aswell as type
+ -- ^ SourceSpans for the definition sites of values and types as well as type
-- annotations found in a module
deriving (Show, Eq, Ord, Functor, Foldable)
data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone
deriving (Show, Eq)
-data Configuration =
- Configuration
+data IdeConfiguration =
+ IdeConfiguration
{ confOutputPath :: FilePath
, confLogLevel :: IdeLogLevel
, confGlobs :: [FilePath]
@@ -139,41 +139,47 @@ data Configuration =
data IdeEnvironment =
IdeEnvironment
{ ideStateVar :: TVar IdeState
- , ideConfiguration :: Configuration
+ , ideConfiguration :: IdeConfiguration
}
type Ide m = (MonadIO m, MonadReader IdeEnvironment m)
data IdeState = IdeState
- { ideStage1 :: Stage1
- , ideStage2 :: Stage2
- , ideStage3 :: Stage3
+ { ideFileState :: IdeFileState
+ , ideVolatileState :: IdeVolatileState
} deriving (Show)
emptyIdeState :: IdeState
-emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3
+emptyIdeState = IdeState emptyFileState emptyVolatileState
-emptyStage1 :: Stage1
-emptyStage1 = Stage1 M.empty M.empty
+emptyFileState :: IdeFileState
+emptyFileState = IdeFileState M.empty M.empty
-emptyStage2 :: Stage2
-emptyStage2 = Stage2 (AstData M.empty)
+emptyVolatileState :: IdeVolatileState
+emptyVolatileState = IdeVolatileState (AstData M.empty) M.empty Nothing
-emptyStage3 :: Stage3
-emptyStage3 = Stage3 M.empty Nothing
-data Stage1 = Stage1
- { s1Externs :: ModuleMap P.ExternsFile
- , s1Modules :: ModuleMap (P.Module, FilePath)
+-- | @IdeFileState@ holds data that corresponds 1-to-1 to an entity on the
+-- filesystem. Externs correspond to the ExternsFiles the compiler emits into
+-- the output folder, and modules are parsed ASTs from source files. This means,
+-- that we can update single modules or ExternsFiles inside this state whenever
+-- the corresponding entity changes on the file system.
+data IdeFileState = IdeFileState
+ { fsExterns :: ModuleMap P.ExternsFile
+ , fsModules :: ModuleMap (P.Module, FilePath)
} deriving (Show)
-data Stage2 = Stage2
- { s2AstData :: AstData P.SourceSpan
- } deriving (Show, Eq)
-
-data Stage3 = Stage3
- { s3Declarations :: ModuleMap [IdeDeclarationAnn]
- , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)
+-- | @IdeVolatileState@ is derived from the @IdeFileState@ and needs to be
+-- invalidated and refreshed carefully. It holds @AstData@, which is the data we
+-- extract from the parsed ASTs, as well as the IdeDeclarations, which contain
+-- lots of denormalized data, so they need to fully rebuilt whenever
+-- @IdeFileState@ changes. The vsCachedRebuild field can hold a rebuild result
+-- with open imports which is used to provide completions for module private
+-- declarations
+data IdeVolatileState = IdeVolatileState
+ { vsAstData :: AstData P.SourceSpan
+ , vsDeclarations :: ModuleMap [IdeDeclarationAnn]
+ , vsCachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)
} deriving (Show)
newtype Match a = Match (P.ModuleName, a)
@@ -187,6 +193,7 @@ data Completion = Completion
, complExpandedType :: Text
, complLocation :: Maybe P.SourceSpan
, complDocumentation :: Maybe Text
+ , complExportedFrom :: [P.ModuleName]
} deriving (Show, Eq, Ord)
instance ToJSON Completion where
@@ -197,6 +204,7 @@ instance ToJSON Completion where
, "expandedType" .= complExpandedType
, "definedAt" .= complLocation
, "documentation" .= complDocumentation
+ , "exportedFrom" .= complExportedFrom
]
identifierFromDeclarationRef :: P.DeclarationRef -> Text
@@ -305,11 +313,18 @@ instance ToJSON PursuitResponse where
, "text" .= text
]
-data IdeDeclNamespace =
- -- | An identifier in the value namespace
- IdeNSValue Text
- -- | An identifier in the type namespace
- | IdeNSType Text
- -- | An identifier in the kind namespace
- | IdeNSKind Text
+-- | Denotes the different namespaces a name in PureScript can reside in.
+data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind
+ deriving (Show, Eq, Ord)
+
+instance FromJSON IdeNamespace where
+ parseJSON (String s) = case s of
+ "value" -> pure IdeNSValue
+ "type" -> pure IdeNSType
+ "kind" -> pure IdeNSKind
+ _ -> mzero
+ parseJSON _ = mzero
+
+-- | A name tagged with a namespace
+data IdeNamespaced = IdeNamespaced IdeNamespace Text
deriving (Show, Eq, Ord)
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index 0d8bee9..1d8f68f 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -17,7 +17,7 @@ module Language.PureScript.Ide.Util
, unwrapMatch
, unwrapPositioned
, unwrapPositionedRef
- , completionFromMatch
+ , namespaceForDeclaration
, encodeT
, decodeT
, discardAnn
@@ -28,7 +28,6 @@ module Language.PureScript.Ide.Util
, identT
, opNameT
, ideReadFile
- , ideReadTextFile
, module Language.PureScript.Ide.Logging
) where
@@ -38,11 +37,10 @@ import Protolude hiding (decodeUtf8,
import Control.Lens hiding ((&), op)
import Data.Aeson
import qualified Data.Text as T
-import qualified Data.Text.IO as TIO
import qualified Data.Text.Lazy as TL
-import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
+import Data.Text.Lazy.Encoding as TLE
import qualified Language.PureScript as P
-import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine, IdeError(..))
+import Language.PureScript.Ide.Error (IdeError(..))
import Language.PureScript.Ide.Logging
import Language.PureScript.Ide.Types
import System.IO.UTF8 (readUTF8FileT)
@@ -58,6 +56,17 @@ identifierFromIdeDeclaration d = case d of
IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName
IdeDeclKind name -> P.runProperName name
+namespaceForDeclaration :: IdeDeclaration -> IdeNamespace
+namespaceForDeclaration d = case d of
+ IdeDeclValue _ -> IdeNSValue
+ IdeDeclType _ -> IdeNSType
+ IdeDeclTypeSynonym _ -> IdeNSType
+ IdeDeclDataConstructor _ -> IdeNSValue
+ IdeDeclTypeClass _ -> IdeNSType
+ IdeDeclValueOperator _ -> IdeNSValue
+ IdeDeclTypeOperator _ -> IdeNSType
+ IdeDeclKind _ -> IdeNSKind
+
discardAnn :: IdeDeclarationAnn -> IdeDeclaration
discardAnn (IdeDeclarationAnn _ d) = d
@@ -67,37 +76,6 @@ withEmptyAnn = IdeDeclarationAnn emptyAnn
unwrapMatch :: Match a -> a
unwrapMatch (Match (_, ed)) = ed
-completionFromMatch :: Match IdeDeclarationAnn -> Completion
-completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
- Completion {..}
- where
- (complIdentifier, complExpandedType) = case decl of
- IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyPrintTypeSingleLine)
- IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind)
- IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyPrintTypeSingleLine)
- IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyPrintTypeSingleLine)
- IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, d ^. ideTCKind & P.prettyPrintKind)
- IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->
- (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyPrintTypeSingleLine typeP)
- IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->
- (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind)
- IdeDeclKind k -> (P.runProperName k, "kind")
-
- complModule = P.runModuleName m
-
- complType = maybe complExpandedType prettyPrintTypeSingleLine (_annTypeAnnotation ann)
-
- complLocation = _annLocation ann
-
- complDocumentation = Nothing
-
- showFixity p a r o =
- let asso = case a of
- P.Infix -> "infix"
- P.Infixl -> "infixl"
- P.Infixr -> "infixr"
- in T.unwords [asso, show p, r, "as", P.runOpName o]
-
valueOperatorAliasT
:: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text
valueOperatorAliasT i =
@@ -109,10 +87,10 @@ typeOperatorAliasT i =
P.showQualified P.runProperName i
encodeT :: (ToJSON a) => a -> Text
-encodeT = TL.toStrict . decodeUtf8 . encode
+encodeT = TL.toStrict . TLE.decodeUtf8 . encode
decodeT :: (FromJSON a) => Text -> Maybe a
-decodeT = decode . encodeUtf8 . TL.fromStrict
+decodeT = decode . TLE.encodeUtf8 . TL.fromStrict
unwrapPositioned :: P.Declaration -> P.Declaration
unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x
@@ -145,11 +123,3 @@ ideReadFile' fileReader fp = do
ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text
ideReadFile = ideReadFile' readUTF8FileT
-
--- | This function is to be used over @ideReadFile@ when the result is not just
--- passed on to the PureScript parser, but also needs to be treated as lines of
--- text. Because @ideReadFile@ reads the file as ByteString in @BinaryMode@
--- rather than @TextMode@ line endings get mangled on Windows otherwise. This is
--- irrelevant for parsing, because the Lexer strips these additional @\r@'s.
-ideReadTextFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text
-ideReadTextFile = ideReadFile' TIO.readFile
diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs
index a966679..9d42ef9 100644
--- a/src/Language/PureScript/Ide/Watcher.hs
+++ b/src/Language/PureScript/Ide/Watcher.hs
@@ -39,7 +39,7 @@ reloadFile logLevel ref ev = runLogger logLevel $ do
Left err ->
logErrorN ("Failed to reload file at: " <> toS fp <> " with error: " <> show err)
Right ef -> do
- lift $ void $ atomically (insertExternsSTM ref ef *> populateStage3STM ref)
+ lift $ void $ atomically (insertExternsSTM ref ef *> populateVolatileStateSTM ref)
logDebugN ("Reloaded File at: " <> toS fp)
-- | Installs filewatchers for the given directory and reloads ExternsFiles when
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index ce075fc..9d91c24 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -38,11 +38,14 @@ import Language.PureScript.Interactive.Parser as Interactive
import Language.PureScript.Interactive.Printer as Interactive
import Language.PureScript.Interactive.Types as Interactive
+import System.Directory (getCurrentDirectory)
import System.FilePath ((</>))
-- | Pretty-print errors
printErrors :: MonadIO m => P.MultipleErrors -> m ()
-printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors P.defaultPPEOptions
+printErrors errs = liftIO $ do
+ pwd <- getCurrentDirectory
+ putStrLn $ P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd} errs
-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
-- options and ignores the warning messages.
diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs
index 34ac66c..a69448a 100644
--- a/src/Language/PureScript/Interactive/Module.hs
+++ b/src/Language/PureScript/Interactive/Module.hs
@@ -27,8 +27,8 @@ loadModule filename = do
pwd <- getCurrentDirectory
content <- readUTF8FileT filename
return $
- either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $
- P.parseModulesFromFiles (makeRelative pwd) [(filename, content)]
+ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd}) (Right . map snd) $
+ P.parseModulesFromFiles id [(filename, content)]
-- | Load all modules.
loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index a66370c..e72f534 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -195,7 +195,7 @@ parseTypeClassDeclaration = do
parseConstraint :: TokenParser Constraint
parseConstraint = Constraint <$> parseQualified properName
- <*> P.many (noWildcards parseTypeAtom)
+ <*> P.many (noWildcards $ noForAll parseTypeAtom)
<*> pure Nothing
parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
@@ -216,8 +216,14 @@ parseTypeInstanceDeclaration = do
instanceDecl <- parseInstanceDeclaration
members <- P.option [] $ do
indented *> reserved "where"
- mark (P.many (same *> positioned parseValueDeclaration))
+ mark (P.many (same *> positioned declsInInstance))
return $ instanceDecl (ExplicitInstance members)
+ where
+ declsInInstance :: TokenParser Declaration
+ declsInInstance = P.choice
+ [ parseTypeDeclaration
+ , parseValueDeclaration
+ ] P.<?> "type declaration or value declaration in instance"
parseDerivingInstanceDeclaration :: TokenParser Declaration
parseDerivingInstanceDeclaration = do
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 2cf90da..3a9803c 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -1,6 +1,7 @@
module Language.PureScript.Parser.Types
( parseType
, parsePolyType
+ , noForAll
, noWildcards
, parseTypeAtom
) where
@@ -52,6 +53,16 @@ parseForAll :: TokenParser Type
parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot)
<*> parseType
+
+-- |
+-- Parse an atomic type with no `forall`
+--
+noForAll :: TokenParser Type -> TokenParser Type
+noForAll p = do
+ ty <- p
+ when (containsForAll ty) $ P.unexpected "forall"
+ return ty
+
-- |
-- Parse a type as it appears in e.g. a data constructor
--
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index 68f48df..7bfe373 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -1,19 +1,21 @@
--- |
--- This module implements the generic deriving elaboration that takes place during desugaring.
---
+-- | This module implements the generic deriving elaboration that takes place during desugaring.
module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Arrow (second)
-import Control.Monad (replicateM, zipWithM)
+import Control.Monad (replicateM, zipWithM, unless, when)
import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Supply.Class (MonadSupply)
+import Data.Foldable (for_)
import Data.List (foldl', find, sortBy, unzip5)
import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord (comparing)
+import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.AST
@@ -30,15 +32,47 @@ import Language.PureScript.Types
import Language.PureScript.TypeChecker (checkNewtype)
import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM)
+-- | When deriving an instance for a newtype, we must ensure that all superclass
+-- instances were derived in the same way. This data structure is used to ensure
+-- this property.
+data NewtypeDerivedInstances = NewtypeDerivedInstances
+ { ndiClasses :: M.Map (ModuleName, ProperName 'ClassName) ([Text], [Constraint], [FunctionalDependency])
+ -- ^ A list of superclass constraints for each type class. Since type classes
+ -- have not been desugared here, we need to track this.
+ , ndiDerivedInstances :: S.Set ((ModuleName, ProperName 'ClassName), (ModuleName, ProperName 'TypeName))
+ -- ^ A list of newtype instances which were derived in this module.
+ } deriving Show
+
+instance Monoid NewtypeDerivedInstances where
+ mempty = NewtypeDerivedInstances mempty mempty
+ mappend x y =
+ NewtypeDerivedInstances { ndiClasses = ndiClasses x <> ndiClasses y
+ , ndiDerivedInstances = ndiDerivedInstances x <> ndiDerivedInstances y
+ }
+
+-- | Extract the name of the newtype appearing in the last type argument of
+-- a derived newtype instance.
+--
+-- Note: since newtypes in newtype instances can only be applied to type arguments
+-- (no flexible instances allowed), we don't need to bother with unification when
+-- looking for matching superclass instances, which saves us a lot of work. Instead,
+-- we just match the newtype name.
+extractNewtypeName :: ModuleName -> [Type] -> Maybe (ModuleName, ProperName 'TypeName)
+extractNewtypeName _ [] = Nothing
+extractNewtypeName mn xs = go (last xs) where
+ go (TypeApp ty (TypeVar _)) = go ty
+ go (TypeConstructor name) = Just (qualify mn name)
+ go _ = Nothing
+
-- | Elaborates deriving instance declarations by code generation.
deriveInstances
:: forall m
- . (MonadError MultipleErrors m, MonadSupply m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
=> [ExternsFile]
-> Module
-> m Module
deriveInstances externs (Module ss coms mn ds exts) =
- Module ss coms mn <$> mapM (deriveInstance mn synonyms ds) ds <*> pure exts
+ Module ss coms mn <$> mapM (deriveInstance mn synonyms instanceData ds) ds <*> pure exts
where
-- We need to collect type synonym information, since synonyms will not be
-- removed until later, during type checking.
@@ -55,16 +89,34 @@ deriveInstances externs (Module ss coms mn ds exts) =
fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d
fromLocalDecl _ = Nothing
+ instanceData :: NewtypeDerivedInstances
+ instanceData =
+ foldMap (\ExternsFile{..} -> foldMap (fromExternsDecl efModuleName) efDeclarations) externs <> foldMap fromLocalDecl ds
+ where
+ fromExternsDecl mn' EDClass{..} =
+ NewtypeDerivedInstances (M.singleton (mn', edClassName) (map fst edClassTypeArguments, edClassConstraints, edFunctionalDependencies)) mempty
+ fromExternsDecl mn' EDInstance{..} =
+ foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn' edInstanceClassName, nm))) (extractNewtypeName mn' edInstanceTypes)
+ fromExternsDecl _ _ = mempty
+
+ fromLocalDecl (TypeClassDeclaration cl args cons deps _) =
+ NewtypeDerivedInstances (M.singleton (mn, cl) (map fst args, cons, deps)) mempty
+ fromLocalDecl (TypeInstanceDeclaration _ _ cl tys _) =
+ foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn cl, nm))) (extractNewtypeName mn tys)
+ fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d
+ fromLocalDecl _ = mempty
+
-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
-- elaborates that into an instance declaration via code generation.
deriveInstance
- :: (MonadError MultipleErrors m, MonadSupply m)
+ :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
=> ModuleName
-> SynonymMap
+ -> NewtypeDerivedInstances
-> [Declaration]
-> Declaration
-> m Declaration
-deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys DerivedInstance)
+deriveInstance mn syns _ ds (TypeInstanceDeclaration nm deps className tys DerivedInstance)
| className == Qualified (Just dataGeneric) (ProperName C.generic)
= case tys of
[ty] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
@@ -112,15 +164,15 @@ deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys Derived
| otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys actualTy
_ -> throwError . errorMessage $ InvalidDerivedInstance className tys 2
| otherwise = throwError . errorMessage $ CannotDerive className tys
-deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys NewtypeInstance) =
+deriveInstance mn syns ndis ds (TypeInstanceDeclaration nm deps className tys NewtypeInstance) =
case tys of
_ : _ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys)
, mn == fromMaybe mn mn'
- -> TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance syns className ds tys tyCon args
+ -> TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance mn syns ndis className ds tys tyCon args
| otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys (last tys)
_ -> throwError . errorMessage $ InvalidNewtypeInstance className tys
-deriveInstance mn syns ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ds d
-deriveInstance _ _ _ e = return e
+deriveInstance mn syns ndis ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ndis ds d
+deriveInstance _ _ _ _ e = return e
unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])
unwrapTypeConstructor = fmap (second reverse) . go
@@ -133,15 +185,18 @@ unwrapTypeConstructor = fmap (second reverse) . go
deriveNewtypeInstance
:: forall m
- . MonadError MultipleErrors m
- => SynonymMap
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> SynonymMap
+ -> NewtypeDerivedInstances
-> Qualified (ProperName 'ClassName)
-> [Declaration]
-> [Type]
-> ProperName 'TypeName
-> [Type]
-> m Expr
-deriveNewtypeInstance syns className ds tys tyConNm dargs = do
+deriveNewtypeInstance mn syns ndis className ds tys tyConNm dargs = do
+ verifySuperclasses
tyCon <- findTypeDecl tyConNm ds
go tyCon
where
@@ -171,6 +226,31 @@ deriveNewtypeInstance syns className ds tys tyConNm dargs = do
| arg == arg' = stripRight args t
stripRight _ _ = Nothing
+ verifySuperclasses :: m ()
+ verifySuperclasses =
+ for_ (M.lookup (qualify mn className) (ndiClasses ndis)) $ \(args, superclasses, _) ->
+ for_ superclasses $ \Constraint{..} -> do
+ let constraintClass' = qualify (error "verifySuperclasses: unknown class module") constraintClass
+ for_ (M.lookup constraintClass' (ndiClasses ndis)) $ \(_, _, deps) ->
+ -- We need to check whether the newtype is mentioned, because of classes like MonadWriter
+ -- with its Monoid superclass constraint.
+ when (not (null args) && any ((last args `elem`) . usedTypeVariables) constraintArgs) $ do
+ -- For now, we only verify superclasses where the newtype is the only argument,
+ -- or for which all other arguments are determined by functional dependencies.
+ -- Everything else raises a UnverifiableSuperclassInstance warning.
+ -- This covers pretty much all cases we're interested in, but later we might want to do
+ -- more work to extend this to other superclass relationships.
+ let determined = map (TypeVar . (args !!)) . ordNub . concatMap fdDetermined . filter ((== [length args - 1]) . fdDeterminers) $ deps
+ if last constraintArgs == TypeVar (last args) && all (`elem` determined) (init constraintArgs)
+ then do
+ -- Now make sure that a superclass instance was derived. Again, this is not a complete
+ -- check, since the superclass might have multiple type arguments, so overlaps might still
+ -- be possible, so we warn again.
+ for_ (extractNewtypeName mn tys) $ \nm ->
+ unless ((constraintClass', nm) `S.member` ndiDerivedInstances ndis) $
+ tell . errorMessage $ MissingNewtypeSuperclassInstance constraintClass className tys
+ else tell . errorMessage $ UnverifiableSuperclassInstance constraintClass className tys
+
dataGeneric :: ModuleName
dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 3bc2899..d600bf4 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -216,6 +216,13 @@ containsWildcards = everythingOnTypes (||) go where
go TypeWildcard{} = True
go _ = False
+-- | Check if a type contains `forall`
+containsForAll :: Type -> Bool
+containsForAll = everythingOnTypes (||) go where
+ go :: Type -> Bool
+ go ForAll{} = True
+ go _ = False
+
everywhereOnTypes :: (Type -> Type) -> Type -> Type
everywhereOnTypes f = go where
go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs
index ec5088e..f3c1838 100644
--- a/src/System/IO/UTF8.hs
+++ b/src/System/IO/UTF8.hs
@@ -3,13 +3,20 @@ module System.IO.UTF8 where
import Prelude.Compat
import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Search as BSS
import qualified Data.ByteString.UTF8 as UTF8
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
+-- | Unfortunately ByteString's readFile does not convert line endings on
+-- Windows, so we have to do it ourselves
+fixCRLF :: BS.ByteString -> BS.ByteString
+fixCRLF = BSL.toStrict . BSS.replace "\r\n" ("\n" :: BS.ByteString)
+
readUTF8FileT :: FilePath -> IO Text
readUTF8FileT inFile =
- fmap TE.decodeUtf8 (BS.readFile inFile)
+ fmap (TE.decodeUtf8 . fixCRLF) (BS.readFile inFile)
writeUTF8FileT :: FilePath -> Text -> IO ()
writeUTF8FileT inFile text =
@@ -17,7 +24,7 @@ writeUTF8FileT inFile text =
readUTF8File :: FilePath -> IO String
readUTF8File inFile =
- fmap UTF8.toString (BS.readFile inFile)
+ fmap (UTF8.toString . fixCRLF) (BS.readFile inFile)
writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File inFile text =
diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs
new file mode 100644
index 0000000..623a58e
--- /dev/null
+++ b/tests/Language/PureScript/Ide/CompletionSpec.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Language.PureScript.Ide.CompletionSpec where
+
+import Protolude
+
+import Language.PureScript as P
+import Language.PureScript.Ide.Completion
+import Language.PureScript.Ide.Test
+import Language.PureScript.Ide.Types
+import Test.Hspec
+
+reexportMatches :: [Match IdeDeclarationAnn]
+reexportMatches =
+ map (\d -> Match (mn "A", d)) moduleA
+ ++ map (\d -> Match (mn "B", d)) moduleB
+ where
+ moduleA = [ideKind "Kind"]
+ moduleB = [ideKind "Kind" `annExp` "A"]
+
+matches :: [(Match IdeDeclarationAnn, [P.ModuleName])]
+matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing ]
+
+spec :: Spec
+spec = describe "Applying completion options" $ do
+ it "keeps all matches if maxResults is not specified" $ do
+ applyCompletionOptions (defaultCompletionOptions { coMaxResults = Nothing })
+ (map fst matches) `shouldMatchList` matches
+ it "keeps only the specified amount of maxResults" $ do
+ applyCompletionOptions (defaultCompletionOptions { coMaxResults = Just 1 })
+ (map fst matches) `shouldMatchList` take 1 matches
+ it "groups reexports for a single identifier" $ do
+ applyCompletionOptions (defaultCompletionOptions { coGroupReexports = True })
+ reexportMatches `shouldBe` [(Match (mn "A", ideKind "Kind"), [mn "A", mn "B"])]
diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs
index f129b18..2e1c8f9 100644
--- a/tests/Language/PureScript/Ide/FilterSpec.hs
+++ b/tests/Language/PureScript/Ide/FilterSpec.hs
@@ -3,19 +3,20 @@
module Language.PureScript.Ide.FilterSpec where
import Protolude
+import Data.List.NonEmpty
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Test as T
import qualified Language.PureScript as P
import Test.Hspec
type Module = (P.ModuleName, [IdeDeclarationAnn])
-value :: Text -> IdeDeclarationAnn
-value s = IdeDeclarationAnn emptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty))
-
-moduleA, moduleB :: Module
-moduleA = (P.moduleNameFromString "Module.A", [value "function1"])
-moduleB = (P.moduleNameFromString "Module.B", [value "data1"])
+moduleA, moduleB, moduleC, moduleD :: Module
+moduleA = (P.moduleNameFromString "Module.A", [T.ideValue "function1" Nothing])
+moduleB = (P.moduleNameFromString "Module.B", [T.ideValue "data1" Nothing])
+moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing])
+moduleD = (P.moduleNameFromString "Module.D", [T.ideKind "kind1"])
modules :: [Module]
modules = [moduleA, moduleB]
@@ -29,6 +30,9 @@ runPrefix s = applyFilters [prefixFilter s] modules
runModule :: [P.ModuleName] -> [Module]
runModule ms = applyFilters [moduleFilter ms] modules
+runNamespace :: NonEmpty IdeNamespace -> [Module] -> [Module]
+runNamespace namespaces = applyFilters [namespaceFilter namespaces]
+
spec :: Spec
spec = do
describe "equality Filter" $ do
@@ -52,3 +56,38 @@ spec = do
runModule [P.moduleNameFromString "Module.A"] `shouldBe` [moduleA]
it "ignores modules that are not in scope" $
runModule (P.moduleNameFromString <$> ["Module.A", "Unknown"]) `shouldBe` [moduleA]
+ describe "namespaceFilter" $ do
+ it "extracts modules by filtering `value` namespaces" $
+ runNamespace (fromList [IdeNSValue])
+ [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB]
+ it "extracts no modules by filtering `value` namespaces" $
+ runNamespace (fromList [IdeNSValue])
+ [moduleD] `shouldBe` []
+ it "extracts modules by filtering `type` namespaces" $
+ runNamespace (fromList [IdeNSType])
+ [moduleA, moduleB, moduleC] `shouldBe` [moduleC]
+ it "extracts no modules by filtering `type` namespaces" $
+ runNamespace (fromList [IdeNSType])
+ [moduleA, moduleB] `shouldBe` []
+ it "extracts modules by filtering `kind` namespaces" $
+ runNamespace (fromList [IdeNSKind])
+ [moduleA, moduleB, moduleD] `shouldBe` [moduleD]
+ it "extracts no modules by filtering `kind` namespaces" $
+ runNamespace (fromList [IdeNSKind])
+ [moduleA, moduleB] `shouldBe` []
+ it "extracts modules by filtering `value` and `type` namespaces" $
+ runNamespace (fromList [ IdeNSValue, IdeNSType])
+ [moduleA, moduleB, moduleC, moduleD]
+ `shouldBe` [moduleA, moduleB, moduleC]
+ it "extracts modules by filtering `value` and `kind` namespaces" $
+ runNamespace (fromList [ IdeNSValue, IdeNSKind])
+ [moduleA, moduleB, moduleC, moduleD]
+ `shouldBe` [moduleA, moduleB, moduleD]
+ it "extracts modules by filtering `type` and `kind` namespaces" $
+ runNamespace (fromList [ IdeNSType, IdeNSKind])
+ [moduleA, moduleB, moduleC, moduleD]
+ `shouldBe` [moduleC, moduleD]
+ it "extracts modules by filtering `value`, `type` and `kind` namespaces" $
+ runNamespace (fromList [ IdeNSValue, IdeNSType, IdeNSKind])
+ [moduleA, moduleB, moduleC, moduleD]
+ `shouldBe` [moduleA, moduleB, moduleC, moduleD]
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index bb67e7d..908531b 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -44,7 +44,7 @@ splitSimpleFile = fromRight (sliceImportSection simpleFile)
withImports :: [Text] -> [Text]
withImports is =
- take 2 simpleFile ++ is ++ drop 2 simpleFile
+ take 2 simpleFile ++ [""] ++ is ++ drop 2 simpleFile
testParseImport :: Text -> Import
testParseImport = fromJust . parseImport
@@ -108,6 +108,8 @@ spec = do
prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn is)
addTypeImport i mn is =
prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing)) mn is)
+ addKindImport i mn is =
+ prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideKind i)) mn is)
it "adds an implicit unqualified import to a file without any imports" $
shouldBe
(addImplicitImport' [] (P.moduleNameFromString "Data.Map"))
@@ -115,8 +117,15 @@ spec = do
it "adds an implicit unqualified import" $
shouldBe
(addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))
+ [ "import Data.Map"
+ , "import Prelude"
+ ]
+ it "adds a qualified import" $
+ shouldBe
+ (addQualifiedImport' simpleFileImports (Test.mn "Data.Map") (Test.mn "Map"))
[ "import Prelude"
- , "import Data.Map"
+ , ""
+ , "import Data.Map as Map"
]
it "adds an explicit unqualified import to a file without any imports" $
shouldBe
@@ -126,6 +135,7 @@ spec = do
shouldBe
(addValueImport "head" (P.moduleNameFromString "Data.Array") simpleFileImports)
[ "import Prelude"
+ , ""
, "import Data.Array (head)"
]
it "doesn't add an import if the containing module is imported implicitly" $
@@ -137,24 +147,35 @@ spec = do
shouldBe
(addValueImport "head" (P.moduleNameFromString "Data.Array") explicitImports)
[ "import Prelude"
+ , ""
, "import Data.Array (head, tail)"
]
+ it "adds a kind to an explicit import list" $
+ shouldBe
+ (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") simpleFileImports)
+ [ "import Prelude"
+ , ""
+ , "import Control.Monad.Eff (kind Effect)"
+ ]
it "adds an operator to an explicit import list" $
shouldBe
(addOpImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports)
[ "import Prelude"
+ , ""
, "import Data.Array (tail, (<~>))"
]
it "adds a type with constructors without automatically adding an open import of said constructors " $
shouldBe
(addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports)
[ "import Prelude"
+ , ""
, "import Data.Maybe (Maybe)"
]
it "adds the type for a given DataConstructor" $
shouldBe
(addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports)
[ "import Prelude"
+ , ""
, "import Data.Maybe (Maybe(..))"
]
it "adds a dataconstructor to an existing type import" $ do
@@ -162,6 +183,7 @@ spec = do
shouldBe
(addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports)
[ "import Prelude"
+ , ""
, "import Data.Maybe (Maybe(..))"
]
it "doesn't add a dataconstructor to an existing type import with open dtors" $ do
@@ -169,12 +191,14 @@ spec = do
shouldBe
(addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports)
[ "import Prelude"
+ , ""
, "import Data.Maybe (Maybe(..))"
]
it "doesn't add an identifier to an explicit import list if it's already imported" $
shouldBe
(addValueImport "tail" (P.moduleNameFromString "Data.Array") explicitImports)
[ "import Prelude"
+ , ""
, "import Data.Array (tail)"
]
@@ -195,23 +219,23 @@ spec = do
[expected]
it "sorts class" $
expectSorted (map classImport ["Applicative", "Bind"])
- ["import Prelude", "import Control.Monad (class Applicative, class Bind, ap)"]
+ ["import Prelude", "", "import Control.Monad (class Applicative, class Bind, ap)"]
it "sorts value" $
expectSorted (map valueImport ["unless", "where"])
- ["import Prelude", "import Control.Monad (ap, unless, where)"]
+ ["import Prelude", "", "import Control.Monad (ap, unless, where)"]
it "sorts type, value" $
expectSorted
((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]))
- ["import Prelude", "import Control.Monad (Bar, Foo, ap, unless, where)"]
+ ["import Prelude", "", "import Control.Monad (Bar, Foo, ap, unless, where)"]
it "sorts class, type, value" $
expectSorted
((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]) ++ (map classImport ["Applicative", "Bind"]))
- ["import Prelude", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"]
+ ["import Prelude", "", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"]
it "sorts types with constructors, using open imports for the constructors" $
expectSorted
-- the imported names don't actually have to exist!
(map (uncurry dtorImport) [("Just", "Maybe"), ("Nothing", "Maybe"), ("SomeOtherConstructor", "SomeDataType")])
- ["import Prelude", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"]
+ ["import Prelude", "", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"]
describe "importing from a loaded IdeState" importFromIdeState
implImport :: Text -> Command
diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs
index 801c3b6..9c00312 100644
--- a/tests/Language/PureScript/Ide/RebuildSpec.hs
+++ b/tests/Language/PureScript/Ide/RebuildSpec.hs
@@ -5,6 +5,7 @@ module Language.PureScript.Ide.RebuildSpec where
import Protolude
import Language.PureScript.Ide.Command
+import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
import qualified Language.PureScript.Ide.Test as Test
@@ -57,5 +58,5 @@ spec = describe "Rebuilding single modules" $ do
it "completes a hidden identifier after rebuilding" $ do
([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
Test.runIde [ rebuildSync "RebuildSpecWithHiddenIdent.purs"
- , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent"))]
+ , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions]
complIdentifier result `shouldBe` "hidden"
diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs
index 198a08f..2a6952e 100644
--- a/tests/Language/PureScript/Ide/ReexportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -11,16 +11,18 @@ import Language.PureScript.Ide.Test
import qualified Language.PureScript as P
import Test.Hspec
-valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn
+valueA, typeA, synonymA, classA, dtorA1, dtorA2, kindA :: IdeDeclarationAnn
valueA = ideValue "valueA" Nothing
typeA = ideType "TypeA" Nothing
+synonymA = ideSynonym "SynonymA" Nothing Nothing
classA = ideTypeClass "ClassA" P.kindType []
dtorA1 = ideDtor "DtorA1" "TypeA" Nothing
dtorA2 = ideDtor "DtorA2" "TypeA" Nothing
+kindA = ideKind "KindA"
env :: ModuleMap [IdeDeclarationAnn]
env = Map.fromList
- [ (mn "A", [valueA, typeA, classA, dtorA1, dtorA2])
+ [ (mn "A", [valueA, typeA, synonymA, classA, dtorA1, dtorA2, kindA])
]
type Refs = [(P.ModuleName, P.DeclarationRef)]
@@ -32,7 +34,10 @@ succTestCases =
, [(mn "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA `annExp` "A", dtorA1 `annExp` "A"])
, ("resolves a type reexport with implicit data constructors"
, [(mn "A", P.TypeRef (P.ProperName "TypeA") Nothing)], map (`annExp` "A") [typeA, dtorA1, dtorA2])
+ , ("resolves a synonym reexport"
+ , [(mn "A", P.TypeRef (P.ProperName "SynonymA") Nothing)], [synonymA `annExp` "A"])
, ("resolves a class reexport", [(mn "A", P.TypeClassRef (P.ProperName "ClassA"))], [classA `annExp` "A"])
+ , ("resolves a kind reexport", [(mn "A", P.KindRef (P.ProperName "KindA"))], [kindA `annExp` "A"])
]
failTestCases :: [(Text, Refs)]
diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs
index 50db451..7937c0f 100644
--- a/tests/Language/PureScript/Ide/SourceFileSpec.hs
+++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs
@@ -44,27 +44,27 @@ spec :: Spec
spec = do
describe "Extracting Spans" $ do
it "extracts a span for a value declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNSValue "value1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNamespaced IdeNSValue "value1", span1)]
it "extracts a span for a type synonym declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNSType "Synonym1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNamespaced IdeNSType "Synonym1", span1)]
it "extracts a span for a typeclass declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNSType "Class1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNamespaced IdeNSType "Class1", span1)]
it "extracts spans for a typeclass declaration and its members" $
- extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNSType "Class2", span1), (IdeNSValue "member1", span2)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNamespaced IdeNSType "Class2", span1), (IdeNamespaced IdeNSValue "member1", span2)]
it "extracts a span for a data declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNSType "Data1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNamespaced IdeNSType "Data1", span1)]
it "extracts spans for a data declaration and its constructors" $
- extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNamespaced IdeNSType "Data2", span1), (IdeNamespaced IdeNSValue "Cons1", span1)]
it "extracts a span for a value operator fixity declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] valueFixity) `shouldBe` [(IdeNSValue "<$>", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] valueFixity) `shouldBe` [(IdeNamespaced IdeNSValue "<$>", span1)]
it "extracts a span for a type operator fixity declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] typeFixity) `shouldBe` [(IdeNSType "~>", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] typeFixity) `shouldBe` [(IdeNamespaced IdeNSType "~>", span1)]
it "extracts a span for a foreign declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNamespaced IdeNSValue "foreign1", span1)]
it "extracts a span for a data foreign declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNSType "Foreign2", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNamespaced IdeNSType "Foreign2", span1)]
it "extracts a span for a foreign kind declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNSKind "Foreign3", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNamespaced IdeNSKind "Foreign3", span1)]
describe "Type annotations" $ do
it "extracts a type annotation" $
extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)]
@@ -94,10 +94,10 @@ getLocation s = do
runIde' defConfig ideState [Type s [] Nothing]
pure (complLocation c)
where
- ideState = emptyIdeState `s3`
+ ideState = emptyIdeState `volatileState`
[ ("Test",
[ ideValue "sfValue" Nothing `annLoc` valueSS
- , ideSynonym "SFType" P.tyString P.kindType `annLoc` synonymSS
+ , ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS
, ideType "SFData" Nothing `annLoc` typeSS
, ideDtor "SFOne" "SFData" Nothing `annLoc` typeSS
, ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS
diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs
index ba5908f..8cb8d3e 100644
--- a/tests/Language/PureScript/Ide/Test.hs
+++ b/tests/Language/PureScript/Ide/Test.hs
@@ -17,14 +17,14 @@ import System.Process
import qualified Language.PureScript as P
-defConfig :: Configuration
+defConfig :: IdeConfiguration
defConfig =
- Configuration { confLogLevel = LogNone
+ IdeConfiguration { confLogLevel = LogNone
, confOutputPath = "output/"
, confGlobs = ["src/*.purs"]
}
-runIde' :: Configuration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState)
+runIde' :: IdeConfiguration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState)
runIde' conf s cs = do
stateVar <- newTVarIO s
let env' = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = conf}
@@ -35,11 +35,11 @@ runIde' conf s cs = do
runIde :: [Command] -> IO ([Either IdeError Success], IdeState)
runIde = runIde' defConfig emptyIdeState
-s3 :: IdeState -> [(Text, [IdeDeclarationAnn])] -> IdeState
-s3 s ds =
- s {ideStage3 = stage3}
+volatileState :: IdeState -> [(Text, [IdeDeclarationAnn])] -> IdeState
+volatileState s ds =
+ s {ideVolatileState = vs}
where
- stage3 = Stage3 (Map.fromList decls) Nothing
+ vs = IdeVolatileState (AstData Map.empty) (Map.fromList decls) Nothing
decls = map (first P.moduleNameFromString) ds
-- | Adding Annotations to IdeDeclarations
@@ -66,8 +66,8 @@ ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty
ideType :: Text -> Maybe P.Kind -> IdeDeclarationAnn
ideType pn ki = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki)))
-ideSynonym :: Text -> P.Type -> P.Kind -> IdeDeclarationAnn
-ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) ty kind))
+ideSynonym :: Text -> Maybe P.Type -> Maybe P.Kind -> IdeDeclarationAnn
+ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) (fromMaybe P.tyString ty) (fromMaybe P.kindType kind)))
ideTypeClass :: Text -> P.Kind -> [IdeInstance] -> IdeDeclarationAnn
ideTypeClass pn kind instances = ida (IdeDeclTypeClass (IdeTypeClass (P.ProperName pn) kind instances))
diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs
index 86a6ef3..de8f19f 100644
--- a/tests/TestCompiler.hs
+++ b/tests/TestCompiler.hs
@@ -61,26 +61,23 @@ main = hspec spec
spec :: Spec
spec = do
- (supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do
+ (supportModules, supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do
cwd <- getCurrentDirectory
let passing = cwd </> "examples" </> "passing"
let warning = cwd </> "examples" </> "warning"
let failing = cwd </> "examples" </> "failing"
- let supportDir = cwd </> "tests" </> "support" </> "bower_components"
- let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir
passingFiles <- getTestFiles passing <$> testGlob passing
warningFiles <- getTestFiles warning <$> testGlob warning
failingFiles <- getTestFiles failing <$> testGlob failing
- supportPurs <- supportFiles "purs"
- supportPursFiles <- readInput supportPurs
+ ms <- getSupportModuleTuples
+ let modules = map snd ms
supportExterns <- runExceptT $ do
- modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles
- foreigns <- inferForeignModules modules
- externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)
- return (zip (map snd modules) externs, foreigns)
+ foreigns <- inferForeignModules ms
+ externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) modules
+ return (externs, foreigns)
case supportExterns of
Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
- Right (externs, foreigns) -> return (externs, foreigns, passingFiles, warningFiles, failingFiles)
+ Right (externs, foreigns) -> return (modules, externs, foreigns, passingFiles, warningFiles, failingFiles)
outputFile <- runIO $ do
tmp <- getTemporaryDirectory
@@ -90,21 +87,21 @@ spec = do
context "Passing examples" $
forM_ passingTestCases $ \testPurs ->
it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $
- assertCompiles supportExterns supportForeigns testPurs outputFile
+ assertCompiles supportModules supportExterns supportForeigns testPurs outputFile
context "Warning examples" $
forM_ warningTestCases $ \testPurs -> do
let mainPath = getTestMain testPurs
expectedWarnings <- runIO $ getShouldWarnWith mainPath
it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $
- assertCompilesWithWarnings supportExterns supportForeigns testPurs expectedWarnings
+ assertCompilesWithWarnings supportModules supportExterns supportForeigns testPurs expectedWarnings
context "Failing examples" $
forM_ failingTestCases $ \testPurs -> do
let mainPath = getTestMain testPurs
expectedFailures <- runIO $ getShouldFailWith mainPath
it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $
- assertDoesNotCompile supportExterns supportForeigns testPurs expectedFailures
+ assertDoesNotCompile supportModules supportExterns supportForeigns testPurs expectedFailures
where
@@ -168,18 +165,18 @@ trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
modulesDir :: FilePath
modulesDir = ".test_modules" </> "node_modules"
-makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
-makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
- { P.getInputTimestamp = getInputTimestamp
- , P.getOutputTimestamp = getOutputTimestamp
- }
+makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make
+makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
+ { P.getInputTimestamp = getInputTimestamp
+ , P.getOutputTimestamp = getOutputTimestamp
+ }
where
getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
getInputTimestamp mn
- | isSupportModule (T.unpack (P.runModuleName mn)) = return (Left P.RebuildNever)
+ | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
| otherwise = return (Left P.RebuildAlways)
where
- isSupportModule = flip elem supportModules
+ isSupportModule = flip elem (map (P.runModuleName . P.getModuleName) modules)
getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
getOutputTimestamp mn = do
@@ -187,39 +184,36 @@ makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActi
exists <- liftIO $ doesDirectoryExist filePath
return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
-readInput :: [FilePath] -> IO [(FilePath, T.Text)]
-readInput inputFiles = forM inputFiles $ \inputFile -> do
- text <- readUTF8FileT inputFile
- return (inputFile, text)
-
runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)
runTest = P.runMake P.defaultOptions
compile
- :: [(P.Module, P.ExternsFile)]
+ :: [P.Module]
+ -> [P.ExternsFile]
-> M.Map P.ModuleName FilePath
-> [FilePath]
-> ([P.Module] -> IO ())
-> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
-compile supportExterns supportForeigns inputFiles check = silence $ runTest $ do
+compile supportModules supportExterns supportForeigns inputFiles check = silence $ runTest $ do
fs <- liftIO $ readInput inputFiles
ms <- P.parseModulesFromFiles id fs
foreigns <- inferForeignModules ms
liftIO (check (map snd ms))
- let actions = makeActions (foreigns `M.union` supportForeigns)
+ let actions = makeActions supportModules (foreigns `M.union` supportForeigns)
case ms of
- [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)
- _ -> P.make actions (map fst supportExterns ++ map snd ms)
+ [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule)
+ _ -> P.make actions (supportModules ++ map snd ms)
assert
- :: [(P.Module, P.ExternsFile)]
+ :: [P.Module]
+ -> [P.ExternsFile]
-> M.Map P.ModuleName FilePath
-> [FilePath]
-> ([P.Module] -> IO ())
-> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))
-> Expectation
-assert supportExterns supportForeigns inputFiles check f = do
- (e, w) <- compile supportExterns supportForeigns inputFiles check
+assert supportModules supportExterns supportForeigns inputFiles check f = do
+ (e, w) <- compile supportModules supportExterns supportForeigns inputFiles check
maybeErr <- f (const w <$> e)
maybe (return ()) expectationFailure maybeErr
@@ -236,13 +230,14 @@ checkShouldFailWith expected errs =
else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
assertCompiles
- :: [(P.Module, P.ExternsFile)]
+ :: [P.Module]
+ -> [P.ExternsFile]
-> M.Map P.ModuleName FilePath
-> [FilePath]
-> Handle
-> Expectation
-assertCompiles supportExterns supportForeigns inputFiles outputFile =
- assert supportExterns supportForeigns inputFiles checkMain $ \e ->
+assertCompiles supportModules supportExterns supportForeigns inputFiles outputFile =
+ assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e ->
case e of
Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
Right _ -> do
@@ -262,13 +257,14 @@ assertCompiles supportExterns supportForeigns inputFiles outputFile =
Nothing -> return $ Just "Couldn't find node.js executable"
assertCompilesWithWarnings
- :: [(P.Module, P.ExternsFile)]
+ :: [P.Module]
+ -> [P.ExternsFile]
-> M.Map P.ModuleName FilePath
-> [FilePath]
-> [String]
-> Expectation
-assertCompilesWithWarnings supportExterns supportForeigns inputFiles shouldWarnWith =
- assert supportExterns supportForeigns inputFiles checkMain $ \e ->
+assertCompilesWithWarnings supportModules supportExterns supportForeigns inputFiles shouldWarnWith =
+ assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e ->
case e of
Left errs ->
return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
@@ -282,13 +278,14 @@ assertCompilesWithWarnings supportExterns supportForeigns inputFiles shouldWarnW
(<> "\n\n" <> P.prettyPrintMultipleErrors P.defaultPPEOptions warnings)
assertDoesNotCompile
- :: [(P.Module, P.ExternsFile)]
+ :: [P.Module]
+ -> [P.ExternsFile]
-> M.Map P.ModuleName FilePath
-> [FilePath]
-> [String]
-> Expectation
-assertDoesNotCompile supportExterns supportForeigns inputFiles shouldFailWith =
- assert supportExterns supportForeigns inputFiles noPreCheck $ \e ->
+assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles shouldFailWith =
+ assert supportModules supportExterns supportForeigns inputFiles noPreCheck $ \e ->
case e of
Left errs ->
return $ if null shouldFailWith
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 788ef88..0237bfe 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -402,6 +402,10 @@ testCases =
, ("TypeLevelString",
[ ShouldBeDocumented (n "TypeLevelString") "Foo" ["fooBar"]
])
+
+ , ("Desugar",
+ [ ValueShouldHaveTypeSignature (n "Desugar") "test" (renderedType "forall a b. X (a -> b) a -> b")
+ ])
]
where
diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs
index 47f57ca..fef5f7b 100644
--- a/tests/TestPsci/CompletionTest.hs
+++ b/tests/TestPsci/CompletionTest.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
module TestPsci.CompletionTest where
import Prelude ()
@@ -13,17 +14,18 @@ import qualified Language.PureScript as P
import Language.PureScript.Interactive
import System.Console.Haskeline
import TestPsci.TestEnv (initTestPSCiEnv)
-import TestUtils (supportModules)
+import TestUtils (getSupportModuleNames)
completionTests :: Spec
-completionTests = context "completionTests" $
- mapM_ assertCompletedOk completionTestData
+completionTests = context "completionTests" $ do
+ mns <- runIO $ getSupportModuleNames
+ mapM_ assertCompletedOk (completionTestData mns)
-- If the cursor is at the right end of the line, with the 1st element of the
-- pair as the text in the line, then pressing tab should offer all the
-- elements of the list (which is the 2nd element) as completions.
-completionTestData :: [(String, [String])]
-completionTestData =
+completionTestData :: [T.Text] -> [(String, [String])]
+completionTestData supportModuleNames =
-- basic directives
[ (":h", [":help"])
, (":r", [":reload"])
@@ -32,12 +34,12 @@ completionTestData =
, (":b", [":browse"])
-- :browse should complete module names
- , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
- , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
+ , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried"])
+ , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried"])
-- import should complete module names
- , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
- , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
+ , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried"])
+ , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried"])
-- :quit, :help, :reload, :clear should not complete
, (":help ", [])
@@ -65,7 +67,7 @@ completionTestData =
-- a few other import tests
, ("impor", ["import"])
- , ("import ", map ("import " ++) supportModules)
+ , ("import ", map (T.unpack . mappend "import ") supportModuleNames)
, ("import Prelude ", [])
-- String and number literals should not be completed
@@ -99,10 +101,10 @@ runCM act = do
getPSCiStateForCompletion :: IO PSCiState
getPSCiStateForCompletion = do
(PSCiState _ bs es, _) <- initTestPSCiEnv
- let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)]
+ let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
return $ PSCiState imports bs es
controlMonadSTasST :: ImportedModule
controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
where
- s = P.moduleNameFromString . T.pack
+ s = P.moduleNameFromString
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index 86a99f6..9c3a692 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -5,14 +5,21 @@ module TestUtils where
import Prelude ()
import Prelude.Compat
+import qualified Language.PureScript as P
+
import Control.Monad
+import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Exception
-
+import Data.List (sort)
+import qualified Data.Text as T
import System.Process
import System.Directory
import System.Info
+import System.IO.UTF8 (readUTF8FileT)
import System.Exit (exitFailure)
+import System.FilePath ((</>))
+import qualified System.FilePath.Glob as Glob
import System.IO (stderr, hPutStrLn)
findNodeProcess :: IO (Maybe String)
@@ -47,127 +54,28 @@ updateSupportCode = do
hPutStrLn stderr "Cannot find node (or nodejs) executable"
exitFailure
+readInput :: [FilePath] -> IO [(FilePath, T.Text)]
+readInput inputFiles = forM inputFiles $ \inputFile -> do
+ text <- readUTF8FileT inputFile
+ return (inputFile, text)
+
-- |
-- The support modules that should be cached between test cases, to avoid
-- excessive rebuilding.
--
-supportModules :: [String]
-supportModules =
- [ "Control.Alt"
- , "Control.Alternative"
- , "Control.Applicative"
- , "Control.Apply"
- , "Control.Biapplicative"
- , "Control.Biapply"
- , "Control.Bind"
- , "Control.Category"
- , "Control.Comonad"
- , "Control.Extend"
- , "Control.Lazy"
- , "Control.Monad"
- , "Control.Monad.Eff"
- , "Control.Monad.Eff.Class"
- , "Control.Monad.Eff.Console"
- , "Control.Monad.Eff.Unsafe"
- , "Control.Monad.Rec.Class"
- , "Control.Monad.ST"
- , "Control.MonadPlus"
- , "Control.MonadZero"
- , "Control.Plus"
- , "Control.Semigroupoid"
- , "Data.Array"
- , "Data.Array.Partial"
- , "Data.Array.ST"
- , "Data.Array.ST.Iterator"
- , "Data.Bifoldable"
- , "Data.Bifunctor"
- , "Data.Bifunctor.Clown"
- , "Data.Bifunctor.Flip"
- , "Data.Bifunctor.Join"
- , "Data.Bifunctor.Joker"
- , "Data.Bifunctor.Product"
- , "Data.Bifunctor.Wrap"
- , "Data.Bitraversable"
- , "Data.Boolean"
- , "Data.BooleanAlgebra"
- , "Data.Bounded"
- , "Data.Char"
- , "Data.CommutativeRing"
- , "Data.Either"
- , "Data.Either.Nested"
- , "Data.Eq"
- , "Data.EuclideanRing"
- , "Data.Field"
- , "Data.Foldable"
- , "Data.Function"
- , "Data.Function.Uncurried"
- , "Data.Functor"
- , "Data.Functor.Invariant"
- , "Data.Generic"
- , "Data.Generic.Rep"
- , "Data.Generic.Rep.Bounded"
- , "Data.Generic.Rep.Eq"
- , "Data.Generic.Rep.Monoid"
- , "Data.Generic.Rep.Ord"
- , "Data.Generic.Rep.Semigroup"
- , "Data.Generic.Rep.Show"
- , "Data.HeytingAlgebra"
- , "Data.Identity"
- , "Data.Lazy"
- , "Data.List"
- , "Data.List.Lazy"
- , "Data.List.Lazy.NonEmpty"
- , "Data.List.Lazy.Types"
- , "Data.List.NonEmpty"
- , "Data.List.Partial"
- , "Data.List.Types"
- , "Data.List.ZipList"
- , "Data.Maybe"
- , "Data.Maybe.First"
- , "Data.Maybe.Last"
- , "Data.Monoid"
- , "Data.Monoid.Additive"
- , "Data.Monoid.Alternate"
- , "Data.Monoid.Conj"
- , "Data.Monoid.Disj"
- , "Data.Monoid.Dual"
- , "Data.Monoid.Endo"
- , "Data.Monoid.Multiplicative"
- , "Data.NaturalTransformation"
- , "Data.Newtype"
- , "Data.NonEmpty"
- , "Data.Ord"
- , "Data.Ord.Unsafe"
- , "Data.Ordering"
- , "Data.Ring"
- , "Data.Semigroup"
- , "Data.Semiring"
- , "Data.Show"
- , "Data.String"
- , "Data.String.CaseInsensitive"
- , "Data.String.Regex"
- , "Data.String.Regex.Flags"
- , "Data.String.Regex.Unsafe"
- , "Data.String.Unsafe"
- , "Data.Symbol"
- , "Data.Traversable"
- , "Data.Tuple"
- , "Data.Tuple.Nested"
- , "Data.Unfoldable"
- , "Data.Unit"
- , "Data.Void"
- , "PSCI.Support"
- , "Partial"
- , "Partial.Unsafe"
- , "Prelude"
- , "Test.Assert"
- , "Type.Data.Ordering"
- , "Type.Data.Symbol"
- , "Type.Equality"
- , "Type.Prelude"
- , "Type.Proxy"
- , "Unsafe.Coerce"
- ]
+getSupportModuleTuples :: IO [(FilePath, P.Module)]
+getSupportModuleTuples = do
+ cd <- getCurrentDirectory
+ let supportDir = cd </> "tests" </> "support" </> "bower_components"
+ supportPurs <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") supportDir
+ supportPursFiles <- readInput supportPurs
+ modules <- runExceptT $ ExceptT . return $ P.parseModulesFromFiles id supportPursFiles
+ case modules of
+ Right ms -> return ms
+ Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
+
+getSupportModuleNames :: IO [T.Text]
+getSupportModuleNames = sort . map (P.runModuleName . P.getModuleName . snd) <$> getSupportModuleTuples
pushd :: forall a. FilePath -> IO a -> IO a
pushd dir act = do
diff --git a/tests/support/bower.json b/tests/support/bower.json
index bdee017..6b67afd 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -4,7 +4,7 @@
"purescript-arrays": "4.0.0",
"purescript-assert": "3.0.0",
"purescript-console": "3.0.0",
- "purescript-eff": "3.0.0",
+ "purescript-eff": "3.1.0",
"purescript-functions": "3.0.0",
"purescript-generics": "4.0.0",
"purescript-generics-rep": "5.0.0",