summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorhdgarrood <>2019-04-07 23:15:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-04-07 23:15:00 (GMT)
commit6abf0b97f82d952273a42d25cf9af3ed3516de93 (patch)
treec06f002ac56f3e19e7768ed806f5f4cf668a6fb7
parent0217be29c9135a585d4b554ed7e84e45ce974bf9 (diff)
version 0.12.40.12.4
-rw-r--r--CONTRIBUTORS.md3
-rw-r--r--app/Command/Ide.hs49
-rw-r--r--purescript.cabal199
-rw-r--r--src/Language/PureScript/AST/Declarations.hs3
-rw-r--r--src/Language/PureScript/AST/Traversals.hs4
-rw-r--r--src/Language/PureScript/Bundle.hs97
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs17
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs5
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/RenderType.hs29
-rw-r--r--src/Language/PureScript/Errors.hs112
-rw-r--r--src/Language/PureScript/Ide.hs12
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs31
-rw-r--r--src/Language/PureScript/Ide/Completion.hs17
-rw-r--r--src/Language/PureScript/Ide/Error.hs2
-rw-r--r--src/Language/PureScript/Ide/Externs.hs3
-rw-r--r--src/Language/PureScript/Ide/Filter.hs154
-rw-r--r--src/Language/PureScript/Ide/Filter/Declaration.hs40
-rw-r--r--src/Language/PureScript/Ide/Imports.hs10
-rw-r--r--src/Language/PureScript/Ide/Prim.hs4
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs7
-rw-r--r--src/Language/PureScript/Ide/State.hs29
-rw-r--r--src/Language/PureScript/Ide/Types.hs12
-rw-r--r--src/Language/PureScript/Ide/Usage.hs3
-rw-r--r--src/Language/PureScript/Ide/Util.hs2
-rw-r--r--src/Language/PureScript/Interactive.hs2
-rw-r--r--src/Language/PureScript/Interactive/Printer.hs10
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs10
-rw-r--r--src/Language/PureScript/Pretty/Types.hs130
-rw-r--r--src/Language/PureScript/Pretty/Values.hs6
-rw-r--r--src/Language/PureScript/Publish.hs239
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs109
-rw-r--r--src/Language/PureScript/Sugar/Names.hs2
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs2
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs34
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs20
-rw-r--r--src/Language/PureScript/TypeChecker.hs21
-rw-r--r--stack.yaml6
-rw-r--r--tests/Language/PureScript/Ide/CompletionSpec.hs7
-rw-r--r--tests/Language/PureScript/Ide/FilterSpec.hs96
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs11
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs6
-rw-r--r--tests/Language/PureScript/Ide/Test.hs6
-rw-r--r--tests/Main.hs7
-rw-r--r--tests/TestBundle.hs95
-rw-r--r--tests/TestCompiler.hs146
-rw-r--r--tests/TestDocs.hs14
-rw-r--r--tests/TestPrimDocs.hs54
-rw-r--r--tests/TestPscPublish.hs25
-rw-r--r--tests/TestUtils.hs158
-rw-r--r--tests/purs/bundle/PSasConstructor.purs11
-rw-r--r--tests/purs/failing/Superclasses2.purs3
-rw-r--r--tests/purs/publish/basic-example/bower.json13
-rw-r--r--tests/purs/publish/basic-example/resolutions-legacy.json640
-rw-r--r--tests/purs/publish/basic-example/resolutions.json17
-rw-r--r--tests/purs/publish/basic-example/src/Main.purs16
-rw-r--r--tests/support/package-lock.json16
-rw-r--r--tests/support/package.json2
-rw-r--r--tests/support/prelude-resolutions.json8
-rw-r--r--tests/support/pscide/src/CompletionSpecDocs.purs1
59 files changed, 1887 insertions, 900 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 30b7de3..eee955b 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -68,6 +68,7 @@ If you would prefer to use different terms, please use the section below instead
| [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) |
| [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) |
| [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) |
+| [@mhcurylo](https://github.com/mhcurylo) | Mateusz Curylo | [MIT license](http://opensource.org/licenses/MIT) |
| [@MiracleBlue](https://github.com/MiracleBlue) | Nicholas Kircher | [MIT license](http://opensource.org/licenses/MIT) |
| [@mrkgnao](https://github.com/mrkgnao) | Soham Chowdhury | [MIT license](http://opensource.org/licenses/MIT) |
| [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) |
@@ -92,6 +93,7 @@ If you would prefer to use different terms, please use the section below instead
| [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) |
| [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) |
| [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) |
+| [@rhendric](https://github.com/rhendric) | Ryan Hendrickson | [MIT license](http://opensource.org/licenses/MIT) |
| [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) |
| [@rndnoise](https://www.github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) |
| [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) |
@@ -128,6 +130,7 @@ If you would prefer to use different terms, please use the section below instead
| [@gabejohnson](https://github.com/gabejohnson) | Gabe Johnson | [MIT license](http://opensource.org/licenses/MIT) |
| [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license](http://opensource.org/licenses/MIT) |
| [@jordanmartinez](https://github.com/jordanmartinez) | Jordan Martinez | [MIT license](http://opensource.org/licenses/MIT) |
+| [@Saulukass](https://github.com/Saulukass) | Saulius Skliutas | [MIT license](http://opensource.org/licenses/MIT) |
### Contributors using Modified Terms
diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs
index a33c33d..73d7ecc 100644
--- a/app/Command/Ide.hs
+++ b/app/Command/Ide.hs
@@ -37,10 +37,7 @@ import Language.PureScript.Ide.Util
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Watcher
-import Network hiding (socketPort, accept)
-import Network.BSD (getProtocolNumber)
-import Network.Socket hiding (PortNumber, Type,
- sClose)
+import qualified Network.Socket as Network
import qualified Options.Applicative as Opts
import System.Directory
import System.Info as SysInfo
@@ -48,24 +45,23 @@ import System.FilePath
import System.IO hiding (putStrLn, print)
import System.IO.Error (isEOFError)
-listenOnLocalhost :: PortNumber -> IO Socket
+listenOnLocalhost :: Network.PortNumber -> IO Network.Socket
listenOnLocalhost port = do
- proto <- getProtocolNumber "tcp"
- localhost <- inet_addr "127.0.0.1"
+ addr:_ <- Network.getAddrInfo Nothing (Just "127.0.0.1") (Just (show port))
bracketOnError
- (socket AF_INET Stream proto)
- sClose
+ (Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr))
+ Network.close
(\sock -> do
- setSocketOption sock ReuseAddr 1
- bind sock (SockAddrInet port localhost)
- listen sock maxListenQueue
+ Network.setSocketOption sock Network.ReuseAddr 1
+ Network.bind sock (Network.addrAddress addr)
+ Network.listen sock Network.maxListenQueue
pure sock)
data ServerOptions = ServerOptions
{ _serverDirectory :: Maybe FilePath
, _serverGlobs :: [FilePath]
, _serverOutputPath :: FilePath
- , _serverPort :: PortNumber
+ , _serverPort :: Network.PortNumber
, _serverNoWatch :: Bool
, _serverPolling :: Bool
, _serverLoglevel :: IdeLogLevel
@@ -73,7 +69,7 @@ data ServerOptions = ServerOptions
} deriving (Show)
data ClientOptions = ClientOptions
- { clientPort :: PortID
+ { clientPort :: Network.PortNumber
}
command :: Opts.Parser (IO ())
@@ -96,15 +92,18 @@ command = Opts.helper <*> subcommands where
T.putStrLn ("Couldn't connect to purs ide server on port " <> show clientPort <> ":")
print e
exitFailure
- h <- connectTo "127.0.0.1" clientPort `catch` handler
+ addr:_ <- Network.getAddrInfo Nothing (Just "127.0.0.1") (Just (show clientPort))
+ sock <- Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr)
+ Network.connect sock (Network.addrAddress addr) `catch` handler
+ h <- Network.socketToHandle sock ReadWriteMode
T.hPutStrLn h =<< T.getLine
BS8.putStrLn =<< BS8.hGetLine h
hFlush stdout
hClose h
clientOptions :: Opts.Parser ClientOptions
- clientOptions = ClientOptions . PortNumber . fromIntegral <$>
- Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer))
+ clientOptions = ClientOptions . fromIntegral <$>
+ Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))
server :: ServerOptions -> IO ()
server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel editorMode) = do
@@ -159,12 +158,12 @@ command = Opts.helper <*> subcommands where
-- #2209 and #2414 for explanations
flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity)
-startServer :: PortNumber -> IdeEnvironment -> IO ()
-startServer port env = withSocketsDo $ do
+startServer :: Network.PortNumber -> IdeEnvironment -> IO ()
+startServer port env = Network.withSocketsDo $ do
sock <- listenOnLocalhost port
runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env)
where
- loop :: (Ide m, MonadLogger m) => Socket -> m ()
+ loop :: (Ide m, MonadLogger m) => Network.Socket -> m ()
loop sock = do
accepted <- runExceptT (acceptCommand sock)
case accepted of
@@ -197,8 +196,10 @@ catchGoneHandle =
putText ("[Error] psc-ide-server tried interact with the handle, but the connection was already gone.")
_ -> throwIO e)
-acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)
- => Socket -> m (Text, Handle)
+acceptCommand
+ :: (MonadIO m, MonadLogger m, MonadError Text m)
+ => Network.Socket
+ -> m (Text, Handle)
acceptCommand sock = do
h <- acceptConnection
$(logDebug) "Accepted a connection"
@@ -216,8 +217,8 @@ acceptCommand sock = do
where
acceptConnection = liftIO $ do
-- Use low level accept to prevent accidental reverse name resolution
- (s,_) <- accept sock
- h <- socketToHandle s ReadWriteMode
+ (s,_) <- Network.accept sock
+ h <- Network.socketToHandle s ReadWriteMode
hSetEncoding h utf8
hSetBuffering h LineBuffering
pure h
diff --git a/purescript.cabal b/purescript.cabal
index 065f80c..4a37444 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -4,10 +4,10 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
--- hash: 5d1735c5c26a07ecb7e0a4d8033e3083d74c2f22263e67ada418c4e61cae4d3e
+-- hash: d36dcc914da2b1127258e1605150e6d890890d1e0b28f747c62284638526d74d
name: purescript
-version: 0.12.3
+version: 0.12.4
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:
tests/purs/passing/RowUnion.js
tests/purs/warning/UnnecessaryFFIModule.js
tests/purs/warning/UnusedFFIImplementations.js
+ tests/purs/bundle/PSasConstructor.purs
tests/purs/docs/bower_components/purescript-prelude/src/Prelude.purs
tests/purs/docs/src/Ado.purs
tests/purs/docs/src/ChildDeclOrder.purs
@@ -658,6 +659,7 @@ extra-source-files:
tests/purs/passing/WildcardType.purs
tests/purs/psci/BasicEval.purs
tests/purs/psci/Multiline.purs
+ tests/purs/publish/basic-example/src/Main.purs
tests/purs/warning/2140.purs
tests/purs/warning/2383.purs
tests/purs/warning/2411.purs
@@ -700,6 +702,9 @@ extra-source-files:
tests/purs/warning/WildcardInferredType2.purs
tests/purs/docs/bower.json
tests/purs/docs/resolutions.json
+ tests/purs/publish/basic-example/bower.json
+ tests/purs/publish/basic-example/resolutions-legacy.json
+ tests/purs/publish/basic-example/resolutions.json
tests/json-compat/v0.11.3/generics-4.0.0.json
tests/json-compat/v0.11.3/symbols-3.0.0.json
tests/json-compat/v0.12.1/typelevel-prelude-3.0.0.json
@@ -745,62 +750,6 @@ flag release
default: False
library
- hs-source-dirs:
- src
- default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses NoImplicitPrelude PatternGuards PatternSynonyms RankNTypes RecordWildCards OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns
- ghc-options: -Wall -O2
- build-depends:
- Cabal >=2.2
- , Glob >=0.9 && <0.10
- , aeson >=1.0 && <1.4
- , aeson-better-errors >=0.8
- , ansi-terminal >=0.7.1 && <0.9
- , base >=4.8 && <4.12
- , base-compat >=0.6.0
- , blaze-html >=0.8.1 && <0.10
- , bower-json >=1.0.0.1 && <1.1
- , boxes >=0.1.4 && <0.2.0
- , bytestring
- , cheapskate >=0.1 && <0.2
- , clock
- , containers
- , data-ordlist >=0.4.7.0
- , deepseq
- , directory >=1.2.3
- , dlist
- , edit-distance
- , file-embed
- , filepath
- , fsnotify >=0.2.1
- , haskeline >=0.7.0.0
- , language-javascript >=0.6.0.9 && <0.7
- , lifted-base >=0.2.3 && <0.2.4
- , microlens-platform >=0.3.9.0 && <0.4
- , monad-control >=1.0.0.0 && <1.1
- , monad-logger >=0.3 && <0.4
- , mtl >=2.1.0 && <2.3.0
- , parallel >=3.2 && <3.3
- , parsec >=3.1.10
- , pattern-arrows >=0.0.2 && <0.1
- , process >=1.2.0 && <1.7
- , protolude >=0.1.6
- , regex-tdfa
- , safe >=0.3.9 && <0.4
- , scientific >=0.3.4.9 && <0.4
- , semigroups >=0.16.2 && <0.19
- , sourcemap >=0.1.6
- , split
- , stm >=0.2.4.0
- , stringsearch
- , syb
- , text
- , time
- , transformers >=0.3.0 && <0.6
- , transformers-base >=0.4.0 && <0.5
- , transformers-compat >=0.3.0
- , unordered-containers
- , utf8-string >=1 && <2
- , vector
exposed-modules:
Control.Monad.Logger
Control.Monad.Supply
@@ -959,21 +908,18 @@ library
System.IO.UTF8
other-modules:
Paths_purescript
- default-language: Haskell2010
-
-executable purs
- main-is: Main.hs
hs-source-dirs:
- app
- ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
+ src
+ default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses NoImplicitPrelude PatternGuards PatternSynonyms RankNTypes RecordWildCards OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns NoMonadFailDesugaring
+ ghc-options: -Wall -O2
build-depends:
Cabal >=2.2
, Glob >=0.9 && <0.10
- , aeson >=1.0 && <1.4
+ , aeson >=1.0 && <1.5
, aeson-better-errors >=0.8
, ansi-terminal >=0.7.1 && <0.9
- , ansi-wl-pprint
- , base >=4.8 && <4.12
+ , array
+ , base >=4.8 && <4.13
, base-compat >=0.6.0
, blaze-html >=0.8.1 && <0.10
, bower-json >=1.0.0.1 && <1.1
@@ -991,21 +937,17 @@ executable purs
, filepath
, fsnotify >=0.2.1
, haskeline >=0.7.0.0
- , http-types
, language-javascript >=0.6.0.9 && <0.7
, lifted-base >=0.2.3 && <0.2.4
, microlens-platform >=0.3.9.0 && <0.4
, monad-control >=1.0.0.0 && <1.1
, monad-logger >=0.3 && <0.4
, mtl >=2.1.0 && <2.3.0
- , network
- , optparse-applicative >=0.13.0
, parallel >=3.2 && <3.3
, parsec >=3.1.10
, pattern-arrows >=0.0.2 && <0.1
, process >=1.2.0 && <1.7
, protolude >=0.1.6
- , purescript
, regex-tdfa
, safe >=0.3.9 && <0.4
, scientific >=0.3.4.9 && <0.4
@@ -1023,15 +965,10 @@ executable purs
, unordered-containers
, utf8-string >=1 && <2
, vector
- , wai ==3.*
- , wai-websockets ==3.*
- , warp ==3.*
- , websockets >=0.9 && <0.13
- if flag(release)
- cpp-options: -DRELEASE
- else
- build-depends:
- gitrev >=1.2.0 && <1.4
+ default-language: Haskell2010
+
+executable purs
+ main-is: Main.hs
other-modules:
Command.Bundle
Command.Compile
@@ -1043,23 +980,18 @@ executable purs
Command.REPL
Paths_purescript
Version
- default-language: Haskell2010
-
-test-suite tests
- type: exitcode-stdio-1.0
- main-is: Main.hs
hs-source-dirs:
- tests
- default-extensions: NoImplicitPrelude
- ghc-options: -Wall
+ app
+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
build-depends:
Cabal >=2.2
, Glob >=0.9 && <0.10
- , HUnit
- , aeson >=1.0 && <1.4
+ , aeson >=1.0 && <1.5
, aeson-better-errors >=0.8
, ansi-terminal >=0.7.1 && <0.9
- , base >=4.8 && <4.12
+ , ansi-wl-pprint
+ , array
+ , base >=4.8 && <4.13
, base-compat >=0.6.0
, blaze-html >=0.8.1 && <0.10
, bower-json >=1.0.0.1 && <1.1
@@ -1077,14 +1009,15 @@ test-suite tests
, filepath
, fsnotify >=0.2.1
, haskeline >=0.7.0.0
- , hspec
- , hspec-discover
+ , http-types
, language-javascript >=0.6.0.9 && <0.7
, lifted-base >=0.2.3 && <0.2.4
, microlens-platform >=0.3.9.0 && <0.4
, monad-control >=1.0.0.0 && <1.1
, monad-logger >=0.3 && <0.4
, mtl >=2.1.0 && <2.3.0
+ , network
+ , optparse-applicative >=0.13.0
, parallel >=3.2 && <3.3
, parsec >=3.1.10
, pattern-arrows >=0.0.2 && <0.1
@@ -1100,8 +1033,6 @@ test-suite tests
, stm >=0.2.4.0
, stringsearch
, syb
- , tasty
- , tasty-hspec
, text
, time
, transformers >=0.3.0 && <0.6
@@ -1110,6 +1041,20 @@ test-suite tests
, unordered-containers
, utf8-string >=1 && <2
, vector
+ , wai ==3.*
+ , wai-websockets ==3.*
+ , warp ==3.*
+ , websockets >=0.9 && <0.13
+ if flag(release)
+ cpp-options: -DRELEASE
+ else
+ build-depends:
+ gitrev >=1.2.0 && <1.4
+ default-language: Haskell2010
+
+test-suite tests
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
other-modules:
Language.PureScript.Ide.CompletionSpec
Language.PureScript.Ide.FilterSpec
@@ -1122,6 +1067,7 @@ test-suite tests
Language.PureScript.Ide.Test
Language.PureScript.Ide.UsageSpec
PscIdeSpec
+ TestBundle
TestCompiler
TestCoreFn
TestDocs
@@ -1136,4 +1082,67 @@ test-suite tests
TestPscPublish
TestUtils
Paths_purescript
+ hs-source-dirs:
+ tests
+ default-extensions: NoImplicitPrelude
+ ghc-options: -Wall
+ build-depends:
+ Cabal >=2.2
+ , Glob >=0.9 && <0.10
+ , HUnit
+ , aeson >=1.0 && <1.5
+ , aeson-better-errors >=0.8
+ , ansi-terminal >=0.7.1 && <0.9
+ , array
+ , base >=4.8 && <4.13
+ , base-compat >=0.6.0
+ , blaze-html >=0.8.1 && <0.10
+ , bower-json >=1.0.0.1 && <1.1
+ , boxes >=0.1.4 && <0.2.0
+ , bytestring
+ , cheapskate >=0.1 && <0.2
+ , clock
+ , containers
+ , data-ordlist >=0.4.7.0
+ , deepseq
+ , directory >=1.2.3
+ , dlist
+ , edit-distance
+ , file-embed
+ , filepath
+ , fsnotify >=0.2.1
+ , haskeline >=0.7.0.0
+ , hspec
+ , hspec-discover
+ , language-javascript >=0.6.0.9 && <0.7
+ , lifted-base >=0.2.3 && <0.2.4
+ , microlens-platform >=0.3.9.0 && <0.4
+ , monad-control >=1.0.0.0 && <1.1
+ , monad-logger >=0.3 && <0.4
+ , mtl >=2.1.0 && <2.3.0
+ , parallel >=3.2 && <3.3
+ , parsec >=3.1.10
+ , pattern-arrows >=0.0.2 && <0.1
+ , process >=1.2.0 && <1.7
+ , protolude >=0.1.6
+ , purescript
+ , regex-tdfa
+ , safe >=0.3.9 && <0.4
+ , scientific >=0.3.4.9 && <0.4
+ , semigroups >=0.16.2 && <0.19
+ , sourcemap >=0.1.6
+ , split
+ , stm >=0.2.4.0
+ , stringsearch
+ , syb
+ , tasty
+ , tasty-hspec
+ , text
+ , time
+ , transformers >=0.3.0 && <0.6
+ , transformers-base >=0.4.0 && <0.5
+ , transformers-compat >=0.3.0
+ , unordered-containers
+ , utf8-string >=1 && <2
+ , vector
default-language: Haskell2010
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 53bb061..f2e6a2e 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -100,6 +100,7 @@ data SimpleErrorMessage
| InvalidDoLet
| CycleInDeclaration Ident
| CycleInTypeSynonym (Maybe (ProperName 'TypeName))
+ | CycleInTypeClassDeclaration [(ProperName 'ClassName)]
| CycleInModules [ModuleName]
| NameIsUndefined Ident
| UndefinedTypeVariable (ProperName 'TypeName)
@@ -485,7 +486,7 @@ data Declaration
-- |
-- A data type declaration (data or newtype, name, arguments, data constructors)
--
- = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [SourceType])]
+ = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [(Ident, SourceType)])]
-- |
-- A minimal mutually recursive set of data type declarations
--
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index a6ede54..5367925 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -629,7 +629,7 @@ accumTypes
)
accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
where
- forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap f . snd) dctors)
+ forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap (f . snd) . snd) dctors)
forDecls (ExternDeclaration _ _ ty) = f ty
forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies)
forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) <> mconcat (fmap f tys)
@@ -655,7 +655,7 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con
where
forDecls (DataDeclaration _ _ _ args dctors) =
foldMap (foldMap f . snd) args <>
- foldMap (foldMap forTypes . snd) dctors
+ foldMap (foldMap (forTypes . snd) . snd) dctors
forDecls (TypeClassDeclaration _ _ args implies _ _) =
foldMap (foldMap f . snd) args <>
foldMap (foldMap forTypes . constraintArgs) implies
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 5ba1ad5..d92d566 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -23,12 +23,15 @@ import Control.Monad
import Control.Monad.Error.Class
import Control.Arrow ((&&&))
+import Data.Array ((!))
import Data.Char (chr, digitToInt)
-import Data.Generics (everything, everywhere, mkQ, mkT)
+import Data.Foldable (fold)
+import Data.Generics (GenericM, everything, everywhere, gmapMo, mkMp, mkQ, mkT)
import Data.Graph
import Data.List (stripPrefix)
-import Data.Maybe (mapMaybe, catMaybes)
+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Version (showVersion)
+import qualified Data.Map as M
import qualified Data.Set as S
import Language.JavaScript.Parser
@@ -398,7 +401,7 @@ compile :: [Module] -> [ModuleIdentifier] -> [Module]
compile modules [] = modules
compile modules entryPoints = filteredModules
where
- (graph, _, vertexFor) = graphFromEdges verts
+ (graph, vertexToNode, vertexFor) = graphFromEdges verts
-- | The vertex set
verts :: [(ModuleElement, Key, [Key])]
@@ -435,6 +438,13 @@ compile modules entryPoints = filteredModules
reachableSet :: S.Set Vertex
reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)
+ -- | A map from modules to the modules that are used by its reachable members.
+ moduleReferenceMap :: M.Map ModuleIdentifier (S.Set ModuleIdentifier)
+ moduleReferenceMap = M.fromAscListWith mappend $ map (vertToModule &&& vertToModuleRefs) $ S.toList reachableSet
+ where
+ vertToModuleRefs v = foldMap (S.singleton . vertToModule) $ graph ! v
+ vertToModule v = m where (_, (m, _), _) = vertexToNode v
+
filteredModules :: [Module]
filteredModules = map filterUsed modules
where
@@ -461,6 +471,7 @@ compile modules entryPoints = filteredModules
isDeclUsed :: ModuleElement -> Bool
isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)
+ isDeclUsed (Require _ _ (Right midRef)) = midRef `S.member` modulesReferenced
isDeclUsed _ = True
isKeyUsed :: Key -> Bool
@@ -468,6 +479,9 @@ compile modules entryPoints = filteredModules
| Just me <- vertexFor k = me `S.member` reachableSet
| otherwise = False
+ modulesReferenced :: S.Set ModuleIdentifier
+ modulesReferenced = fold $ M.lookup mid moduleReferenceMap
+
-- | Topologically sort the module dependency graph, so that when we generate code, modules can be
-- defined in the right order.
sortModules :: [Module] -> [Module]
@@ -556,7 +570,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
modulesJS = map moduleToJS ms
moduleToJS :: Module -> ([JSStatement], [Either Int Int])
- moduleToJS (Module mn _ ds) = (wrap (moduleName mn) (indent (concat jsDecls)), lengths)
+ moduleToJS (Module mid _ ds) = (wrap mid (indent (concat jsDecls)), lengths)
where
(jsDecls, lengths) = unzip $ map declToJS ds
@@ -572,7 +586,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
JSVariable lfsp
(cList [
JSVarInitExpression (JSIdentifier sp nm)
- (JSVarInit sp $ either require (moduleReference sp . moduleName) req )
+ (JSVarInit sp $ either require (innerModuleReference sp . moduleName) req )
]) (JSSemi JSNoAnnot)
]
declToJS (ExportsList exps) = withLength $ map toExport exps
@@ -628,6 +642,12 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot
(str mn) JSNoAnnot
+ innerModuleReference :: JSAnnot -> String -> JSExpression
+ innerModuleReference a mn =
+ JSMemberSquare (JSIdentifier a "$PS") JSNoAnnot
+ (str mn) JSNoAnnot
+
+
str :: String -> JSExpression
str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\""
@@ -635,31 +655,54 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
emptyObj :: JSAnnot -> JSExpression
emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot
- wrap :: String -> [JSStatement] -> [JSStatement]
- wrap mn ds =
- [
- JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot
- (JSLOne (JSIdentName JSNoAnnot "exports")) JSNoAnnot
- (JSBlock sp (lfHead ds) lf)) -- \n not quite in right place
- JSNoAnnot)
- JSNoAnnot
- (JSLOne (JSAssignExpression (moduleReference JSNoAnnot mn) (JSAssign sp)
- (JSExpressionBinary (moduleReference sp mn) (JSBinOpOr sp) (emptyObj sp))))
- JSNoAnnot
- (JSSemi JSNoAnnot)
- ]
+ initializeObject :: JSAnnot -> (JSAnnot -> String -> JSExpression) -> String -> JSExpression
+ initializeObject a makeReference mn =
+ JSAssignExpression (makeReference a mn) (JSAssign sp)
+ $ JSExpressionBinary (makeReference sp mn) (JSBinOpOr sp)
+ $ emptyObj sp
+
+ -- Like `somewhere`, but stops after the first successful transformation
+ firstwhere :: MonadPlus m => GenericM m -> GenericM m
+ firstwhere f x = f x `mplus` gmapMo (firstwhere f) x
+
+ prependWhitespace :: String -> [JSStatement] -> [JSStatement]
+ prependWhitespace val = fromMaybe <*> firstwhere (mkMp $ Just . reannotate)
where
- lfHead (h:t) = addAnn (WhiteSpace tokenPosnEmpty "\n ") h : t
- lfHead x = x
+ reannotate (JSAnnot rpos annots) = JSAnnot rpos (ws : annots)
+ reannotate _ = JSAnnot tokenPosnEmpty [ws]
- addAnn :: CommentAnnotation -> JSStatement -> JSStatement
- addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) =
- JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot)
- addAnn _ x = x
+ ws = WhiteSpace tokenPosnEmpty val
- appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a]
- appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])
- appendAnn a JSAnnotSpace = JSAnnot tokenPosnEmpty [a]
+ iife :: [JSStatement] -> String -> JSExpression -> JSStatement
+ iife body param arg =
+ JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot (JSLOne (JSIdentName JSNoAnnot param)) JSNoAnnot
+ (JSBlock sp (prependWhitespace "\n " body) lf))
+ JSNoAnnot)
+ JSNoAnnot
+ (JSLOne arg)
+ JSNoAnnot
+ (JSSemi JSNoAnnot)
+
+ wrap :: ModuleIdentifier -> [JSStatement] -> [JSStatement]
+ wrap (ModuleIdentifier mn mtype) ds =
+ case mtype of
+ Regular -> [iife (addModuleExports ds) "$PS" (JSIdentifier JSNoAnnot optionsNamespace)]
+ Foreign -> [iife ds "exports" (initializeObject JSNoAnnot moduleReference mn)]
+ where
+ -- Insert the exports var after a directive prologue, if one is present.
+ -- Per ECMA-262 5.1, "A Directive Prologue is the longest sequence of
+ -- ExpressionStatement productions [...] where each ExpressionStatement
+ -- [...] consists entirely of a StringLiteral [...]."
+ -- (http://ecma-international.org/ecma-262/5.1/#sec-14.1)
+ addModuleExports :: [JSStatement] -> [JSStatement]
+ addModuleExports (x:xs) | isDirective x = x : addModuleExports xs
+ addModuleExports xs
+ = JSExpressionStatement (initializeObject lfsp innerModuleReference mn) (JSSemi JSNoAnnot)
+ : JSVariable lfsp (JSLOne $ JSVarInitExpression (JSIdentifier sp "exports") $ JSVarInit sp (innerModuleReference sp mn)) (JSSemi JSNoAnnot)
+ : xs
+
+ isDirective (JSExpressionStatement (JSStringLiteral _ _) _) = True
+ isDirective _ = False
runMain :: String -> [JSStatement]
runMain mn =
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 59576f0..4153fbb 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -18,6 +18,7 @@ import Control.Monad.Supply.Class
import Data.List ((\\), intersect)
import qualified Data.Foldable as F
import qualified Data.Map as M
+import qualified Data.Set as S
import Data.Maybe (fromMaybe, isNothing)
import Data.String (fromString)
import Data.Text (Text)
@@ -53,11 +54,14 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
rethrow (addHint (ErrorInModule mn)) $ do
let usedNames = concatMap getNames decls
let mnLookup = renameImports usedNames imps
- jsImports <- traverse (importToJs mnLookup)
- . (\\ (mn : C.primModules)) $ ordNub $ map snd imps
let decls' = renameModules mnLookup decls
jsDecls <- mapM bindToJs decls'
optimized <- traverse (traverse optimize) jsDecls
+ let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
+ let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
+ jsImports <- traverse (importToJs mnLookup)
+ . filter (flip S.member usedModuleNames)
+ . (\\ (mn : C.primModules)) $ ordNub $ map snd imps
F.traverse_ (F.traverse_ checkIntegers) optimized
comments <- not <$> asks optionsNoComments
let strict = AST.StringLiteral Nothing "use strict"
@@ -127,6 +131,15 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
renameQual q = q
-- |
+ -- Find the set of ModuleNames referenced by an AST.
+ --
+ findModules :: M.Map Text ModuleName -> AST -> S.Set ModuleName
+ findModules mnReverseLookup = AST.everything mappend go
+ where
+ go (AST.Var _ name) = foldMap S.singleton $ M.lookup name mnReverseLookup
+ go _ = mempty
+
+ -- |
-- Generate code in the simplified JavaScript intermediate representation for a declaration
--
bindToJs :: Bind Ann -> m [AST]
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index 608c02f..b4ed0b3 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -122,9 +122,10 @@ convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title =
Just (Right (mkDeclaration sa title info) { declChildren = children })
where
info = DataDeclaration dtype (fmap (fmap (fmap ($> ()))) args)
- children = map convertCtor (fmap (fmap (fmap ($> ()))) ctors)
+ children = map convertCtor ctors
+ convertCtor :: (P.ProperName 'P.ConstructorName, [(P.Ident, P.SourceType)]) -> ChildDeclaration
convertCtor (ctor', tys) =
- ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
+ ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor (fmap (($> ()) . snd) tys))
convertDeclaration (P.ExternDataDeclaration sa _ kind') title =
basicDeclaration sa title (ExternDataDeclaration (kind' $> ()))
convertDeclaration (P.ExternKindDeclaration sa _) title =
diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
index be5753d..25837ec 100644
--- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
@@ -35,18 +35,16 @@ typeLiterals = mkPattern match
Just $ maybe (syntax "_") (syntax . ("?" <>)) name
match (PPTypeVar var) =
Just (typeVar var)
- match (PPRecord row) =
+ match (PPRecord labels tail_) =
Just $ mintersperse sp
[ syntax "{"
- , renderRow row
+ , renderRow labels tail_
, syntax "}"
]
match (PPTypeConstructor n) =
Just (typeCtor n)
- match PPREmpty =
- Just (syntax "()")
- match row@PPRCons{} =
- Just (syntax "(" <> renderRow row <> syntax ")")
+ match (PPRow labels tail_) =
+ Just (syntax "(" <> renderRow labels tail_ <> syntax ")")
match (PPBinaryNoParensType op l r) =
Just $ renderTypeAtom' l <> sp <> renderTypeAtom' op <> sp <> renderTypeAtom' r
match (PPTypeOp n) =
@@ -72,13 +70,8 @@ renderConstraints con ty =
-- |
-- Render code representing a Row
--
-renderRow :: PrettyPrintType -> RenderedCode
-renderRow = uncurry renderRow' . go []
- where
- renderRow' h t = renderHead h <> renderTail t
-
- go ts (PPRCons l t r) = go ((l, t) : ts) r
- go ts t = (reverse ts, t)
+renderRow :: [(Label, PrettyPrintType)] -> Maybe PrettyPrintType -> RenderedCode
+renderRow h t = renderHead h <> renderTail t
renderHead :: [(Label, PrettyPrintType)] -> RenderedCode
renderHead = mintersperse (syntax "," <> sp) . map renderLabel
@@ -91,9 +84,9 @@ renderLabel (label, ty) =
, renderType' ty
]
-renderTail :: PrettyPrintType -> RenderedCode
-renderTail PPREmpty = mempty
-renderTail other = sp <> syntax "|" <> sp <> renderType' other
+renderTail :: Maybe PrettyPrintType -> RenderedCode
+renderTail Nothing = mempty
+renderTail (Just other) = sp <> syntax "|" <> sp <> renderType' other
typeApp :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
typeApp = mkPattern match
@@ -153,7 +146,7 @@ forall_ = mkPattern match
-- Render code representing a Type
--
renderType :: Type a -> RenderedCode
-renderType = renderType' . convertPrettyPrintType
+renderType = renderType' . convertPrettyPrintType maxBound
renderType' :: PrettyPrintType -> RenderedCode
renderType'
@@ -164,7 +157,7 @@ renderType'
-- Render code representing a Type, as it should appear inside parentheses
--
renderTypeAtom :: Type a -> RenderedCode
-renderTypeAtom = renderTypeAtom' . convertPrettyPrintType
+renderTypeAtom = renderTypeAtom' . convertPrettyPrintType maxBound
renderTypeAtom' :: PrettyPrintType -> RenderedCode
renderTypeAtom'
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index f730b60..b511c4c 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -110,6 +110,7 @@ errorCode em = case unwrapErrorMessage em of
InvalidDoLet -> "InvalidDoLet"
CycleInDeclaration{} -> "CycleInDeclaration"
CycleInTypeSynonym{} -> "CycleInTypeSynonym"
+ CycleInTypeClassDeclaration{} -> "CycleInTypeClassDeclaration"
CycleInModules{} -> "CycleInModules"
NameIsUndefined{} -> "NameIsUndefined"
UndefinedTypeVariable{} -> "UndefinedTypeVariable"
@@ -508,7 +509,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
line "The same name was used more than once in a let binding."
renderSimpleErrorMessage (InfiniteType ty) =
paras [ line "An infinite type was inferred for an expression: "
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
]
renderSimpleErrorMessage (InfiniteKind ki) =
paras [ line "An infinite kind was inferred for a type: "
@@ -574,6 +575,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
, line "Cycles are disallowed because they can lead to loops in the type checker."
, line "Consider using a 'newtype' instead."
]
+ renderSimpleErrorMessage (CycleInTypeClassDeclaration [name]) =
+ paras [ line $ "A type class '" <> markCode (runProperName name) <> "' may not have itself as a superclass." ]
+ renderSimpleErrorMessage (CycleInTypeClassDeclaration names) =
+ paras [ line $ "A cycle appears in a set of type class definitions:"
+ , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName) names)) <> "}"
+ , line "Cycles are disallowed because they can lead to loops in the type checker."
+ ]
renderSimpleErrorMessage (NameIsUndefined ident) =
line $ "Value " <> markCode (showIdent ident) <> " is undefined."
renderSimpleErrorMessage (UndefinedTypeVariable name) =
@@ -584,13 +592,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
]
renderSimpleErrorMessage (EscapedSkolem name Nothing ty) =
paras [ line $ "The type variable " <> markCode name <> " has escaped its scope, appearing in the type"
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
]
renderSimpleErrorMessage (EscapedSkolem name (Just srcSpan) ty) =
paras [ line $ "The type variable " <> markCode name <> ", bound at"
, indent $ line $ displaySourceSpan relPath srcSpan
, line "has escaped its scope, appearing in the type"
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
]
renderSimpleErrorMessage (TypesDoNotUnify u1 u2)
= let (sorted1, sorted2) = sortRows u1 u2
@@ -610,9 +618,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
, rowFromList (sort' unique2 ++ sort' common2, r2)
)
in paras [ line "Could not match type"
- , markCodeBox $ indent $ typeAsBox sorted1
+ , markCodeBox $ indent $ typeAsBox prettyDepth sorted1
, line "with type"
- , markCodeBox $ indent $ typeAsBox sorted2
+ , markCodeBox $ indent $ typeAsBox prettyDepth sorted2
]
renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
@@ -623,16 +631,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
]
renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
paras [ line "Could not match constrained type"
- , markCodeBox $ indent $ typeAsBox t1
+ , markCodeBox $ indent $ typeAsBox prettyDepth t1
, line "with type"
- , markCodeBox $ indent $ typeAsBox t2
+ , markCodeBox $ indent $ typeAsBox prettyDepth t2
]
renderSimpleErrorMessage (OverlappingInstances _ _ []) = internalError "OverlappingInstances: empty instance list"
renderSimpleErrorMessage (OverlappingInstances nm ts ds) =
paras [ line "Overlapping type class instances found for"
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName nm)
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, line "The following instances were found:"
, indent $ paras (map (line . showQualified showIdent) ds)
@@ -659,7 +667,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
]
renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard [ty] _)) =
paras [ line "A result of type"
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
, line "was implicitly discarded in a do notation block."
, line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.")
]
@@ -667,7 +675,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line "No type class instance was found for"
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName nm)
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, paras [ line "The instance head contains unknown type variables. Consider adding a type annotation."
| any containsUnknowns ts
@@ -681,14 +689,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
go _ = False
renderSimpleErrorMessage (AmbiguousTypeVariables t _) =
paras [ line "The inferred type"
- , markCodeBox $ indent $ typeAsBox t
+ , markCodeBox $ indent $ typeAsBox prettyDepth t
, line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation."
]
renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
paras [ line "Type class instance for"
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName nm)
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, line "is possibly infinite."
]
@@ -696,7 +704,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line "Cannot derive a type class instance for"
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName nm)
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, line "since instances of this type class are not derivable."
]
@@ -704,7 +712,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line "Cannot derive newtype instance for"
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName nm)
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, line "Make sure this is a newtype."
]
@@ -712,7 +720,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
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)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, line $ "does not include a derived superclass instance for " <> markCode (showQualified runProperName su) <> "."
]
@@ -720,7 +728,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
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)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, line $ "implies an superclass instance for " <> markCode (showQualified runProperName su) <> " which could not be verified."
]
@@ -728,7 +736,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line "Cannot derive the type class instance"
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName nm)
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, line $ fold $
[ "because the "
@@ -744,10 +752,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line "Cannot derive the type class instance"
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName nm)
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, "because the type"
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
, line "is not of the required form T a_1 ... a_n, where T is a type constructor defined in the same module."
]
renderSimpleErrorMessage (CannotFindDerivingType nm) =
@@ -755,7 +763,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderSimpleErrorMessage (DuplicateLabel l expr) =
paras $ [ line $ "Label " <> markCode (prettyPrintLabel l) <> " appears more than once in a row type." ]
<> foldMap (\expr' -> [ line "Relevant expression: "
- , markCodeBox $ indent $ prettyPrintValue valueDepth expr'
+ , markCodeBox $ indent $ prettyPrintValue prettyDepth expr'
]) expr
renderSimpleErrorMessage (DuplicateTypeArgument name) =
line $ "Type argument " <> markCode name <> " appears more than once."
@@ -768,7 +776,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderSimpleErrorMessage (MissingClassMember identsAndTypes) =
paras $ [ line "The following type class members have not been implemented:"
, Box.vcat Box.left
- [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> typeAsBox ty
+ [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> typeAsBox prettyDepth ty
| (ident, ty) <- NEL.toList identsAndTypes ]
]
renderSimpleErrorMessage (ExtraneousClassMember ident className) =
@@ -776,7 +784,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderSimpleErrorMessage (ExpectedType ty kind) =
paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (prettyPrintKind kindType) <> "."
, line "The error arises from the type"
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
, line "having the kind"
, indent $ line $ markCode $ prettyPrintKind kind
, line "instead."
@@ -787,9 +795,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
]
renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
paras [ line "Expression"
- , markCodeBox $ indent $ prettyPrintValue valueDepth expr
+ , markCodeBox $ indent $ prettyPrintValue prettyDepth expr
, line "does not have type"
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
]
renderSimpleErrorMessage (PropertyIsMissing prop) =
line $ "Type of expression lacks required label " <> markCode (prettyPrintLabel prop) <> "."
@@ -801,7 +809,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line $ "Orphan instance " <> markCode (showIdent nm) <> " found for "
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName cnm)
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
, Box.vcat Box.left $ case modulesToList of
[] -> [ line "There is nowhere this instance can be placed without being an orphan."
@@ -821,7 +829,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
]
renderSimpleErrorMessage (InvalidInstanceHead ty) =
paras [ line "Type class instance head is invalid due to use of type"
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
, line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies."
]
renderSimpleErrorMessage (TransitiveExportError x ys) =
@@ -846,7 +854,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
]
renderSimpleErrorMessage (WildcardInferredType ty ctx) =
paras $ [ line "Wildcard type definition has the inferred type "
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
] <> renderContext ctx
renderSimpleErrorMessage (HoleInferredType name ty ctx ts) =
let
@@ -858,7 +866,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
let
idBoxes = Box.text . T.unpack . showQualified id <$> names
tyBoxes = (\t -> BoxHelpers.indented
- (Box.text ":: " Box.<> typeAsBox t)) <$> types
+ (Box.text ":: " Box.<> typeAsBox prettyDepth t)) <$> types
longestId = maximum (map Box.cols idBoxes)
in
Box.vcat Box.top $
@@ -871,13 +879,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
_ -> []
in
paras $ [ line $ "Hole '" <> markCode name <> "' has the inferred type "
- , markCodeBox (indent (typeAsBox ty))
+ , markCodeBox (indent (typeAsBox maxBound ty))
] ++ tsResult ++ renderContext ctx
renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =
paras [ line $ "No type declaration was provided for the top-level declaration of " <> markCode (showIdent ident) <> "."
, line "It is good practice to provide type declarations as a form of documentation."
, line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
]
renderSimpleErrorMessage (OverlappingPattern bs b) =
paras $ [ line "A case expression contains unreachable cases:\n"
@@ -964,7 +972,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =
paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."
, line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"
- , markCodeBox $ indent $ typeAsBox ty
+ , markCodeBox $ indent $ typeAsBox prettyDepth ty
, line "Try adding a type signature."
]
@@ -990,7 +998,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
argsMsg = if expected > 1 then "arguments" else "argument"
renderSimpleErrorMessage (UserDefinedWarning msgTy) =
- let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in
+ let msg = fromMaybe (typeAsBox prettyDepth msgTy) (toTypelevelString msgTy) in
paras [ line "A custom warning occurred while solving type class constraints:"
, indent msg
]
@@ -1042,16 +1050,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderHint (ErrorUnifyingTypes t1 t2) detail =
paras [ detail
, Box.hsep 1 Box.top [ line "while trying to match type"
- , markCodeBox $ typeAsBox t1
+ , markCodeBox $ typeAsBox prettyDepth t1
]
, Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type"
- , markCodeBox $ typeAsBox t2
+ , markCodeBox $ typeAsBox prettyDepth t2
]
]
renderHint (ErrorInExpression expr) detail =
paras [ detail
, Box.hsep 1 Box.top [ Box.text "in the expression"
- , markCodeBox $ markCodeBox $ prettyPrintValue valueDepth expr
+ , markCodeBox $ markCodeBox $ prettyPrintValue prettyDepth expr
]
]
renderHint (ErrorInModule mn) detail =
@@ -1061,10 +1069,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderHint (ErrorInSubsumption t1 t2) detail =
paras [ detail
, Box.hsep 1 Box.top [ line "while checking that type"
- , markCodeBox $ typeAsBox t1
+ , markCodeBox $ typeAsBox prettyDepth t1
]
, Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type"
- , markCodeBox $ typeAsBox t2
+ , markCodeBox $ typeAsBox prettyDepth t2
]
]
renderHint (ErrorInInstance nm ts) detail =
@@ -1072,13 +1080,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
, line "in type class instance"
, markCodeBox $ indent $ Box.hsep 1 Box.top
[ line $ showQualified runProperName nm
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
]
renderHint (ErrorCheckingKind ty) detail =
paras [ detail
, Box.hsep 1 Box.top [ line "while checking the kind of"
- , markCodeBox $ typeAsBox ty
+ , markCodeBox $ typeAsBox prettyDepth ty
]
]
renderHint ErrorCheckingGuard detail =
@@ -1088,34 +1096,34 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderHint (ErrorInferringType expr) detail =
paras [ detail
, Box.hsep 1 Box.top [ line "while inferring the type of"
- , markCodeBox $ prettyPrintValue valueDepth expr
+ , markCodeBox $ prettyPrintValue prettyDepth expr
]
]
renderHint (ErrorCheckingType expr ty) detail =
paras [ detail
, Box.hsep 1 Box.top [ line "while checking that expression"
- , markCodeBox $ prettyPrintValue valueDepth expr
+ , markCodeBox $ prettyPrintValue prettyDepth expr
]
, Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"
- , markCodeBox $ typeAsBox ty
+ , markCodeBox $ typeAsBox prettyDepth ty
]
]
renderHint (ErrorCheckingAccessor expr prop) detail =
paras [ detail
, Box.hsep 1 Box.top [ line "while checking type of property accessor"
- , markCodeBox $ prettyPrintValue valueDepth (Accessor prop expr)
+ , markCodeBox $ prettyPrintValue prettyDepth (Accessor prop expr)
]
]
renderHint (ErrorInApplication f t a) detail =
paras [ detail
, Box.hsep 1 Box.top [ line "while applying a function"
- , markCodeBox $ prettyPrintValue valueDepth f
+ , markCodeBox $ prettyPrintValue prettyDepth f
]
, Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"
- , markCodeBox $ typeAsBox t
+ , markCodeBox $ typeAsBox prettyDepth t
]
, Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"
- , markCodeBox $ prettyPrintValue valueDepth a
+ , markCodeBox $ prettyPrintValue prettyDepth a
]
]
renderHint (ErrorInDataConstructor nm) detail =
@@ -1159,7 +1167,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
, line "while solving type class constraint"
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName nm)
- , Box.vcat Box.left (map typeAtomAsBox ts)
+ , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts)
]
]
renderHint (PositionedError srcSpan) detail =
@@ -1173,7 +1181,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
[ line "in the following context:"
, indent $ paras
[ Box.hcat Box.left [ Box.text (T.unpack (showIdent ident) ++ " :: ")
- , markCodeBox $ typeAsBox ty'
+ , markCodeBox $ typeAsBox prettyDepth ty'
]
| (ident, ty') <- take 5 ctx
]
@@ -1212,9 +1220,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
runName (Qualified _ ModName{}) =
internalError "qualified ModName in runName"
- valueDepth :: Int
- valueDepth | full = 1000
- | otherwise = 3
+ prettyDepth :: Int
+ prettyDepth | full = 1000
+ | otherwise = 3
levelText :: Text
levelText = case level of
@@ -1420,7 +1428,7 @@ toTypelevelString (TypeLevelString _ s) =
toTypelevelString (TypeApp _ (TypeConstructor _ f) x)
| f == primSubName C.typeError "Text" = toTypelevelString x
toTypelevelString (TypeApp _ (TypeConstructor _ f) x)
- | f == primSubName C.typeError "Quote" = Just (typeAsBox x)
+ | f == primSubName C.typeError "Quote" = Just (typeAsBox maxBound x)
toTypelevelString (TypeApp _ (TypeConstructor _ f) (TypeLevelString _ x))
| f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x
toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret)
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index c904a49..58aafac 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -62,7 +62,9 @@ handleCommand c = case c of
findType search filters currentModule
Complete filters matcher currentModule complOptions ->
findCompletions filters matcher currentModule complOptions
- List LoadedModules ->
+ List LoadedModules -> do
+ logWarnN
+ "Listing the loaded modules command is DEPRECATED, use the completion command and filter it to modules instead"
printModules
List AvailableModules ->
listAvailableModules
@@ -113,8 +115,8 @@ findCompletions
-> CompletionOptions
-> m Success
findCompletions filters matcher currentModule complOptions = do
- modules <- Map.toList <$> getAllModules currentModule
- let insertPrim = (++) idePrimDeclarations
+ modules <- getAllModules currentModule
+ let insertPrim = Map.union idePrimDeclarations
pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules)))
findType
@@ -124,8 +126,8 @@ findType
-> Maybe P.ModuleName
-> m Success
findType search filters currentModule = do
- modules <- Map.toList <$> getAllModules currentModule
- let insertPrim = (++) idePrimDeclarations
+ modules <- getAllModules currentModule
+ let insertPrim = Map.union idePrimDeclarations
pure (CompletionResult (getExactCompletions search filters (insertPrim modules)))
printModules :: Ide m => m Success
diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs
index 90f1da0..253ef53 100644
--- a/src/Language/PureScript/Ide/CaseSplit.hs
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -45,18 +45,24 @@ explicitAnnotations = WildcardAnnotations True
noAnnotations :: WildcardAnnotations
noAnnotations = WildcardAnnotations False
-caseSplit :: (Ide m, MonadError IdeError m) =>
- Text -> m [Constructor]
+type DataType = ([(Text, Maybe P.SourceKind)], [(P.ProperName 'P.ConstructorName, [P.SourceType])])
+
+caseSplit
+ :: (Ide m, MonadError IdeError m)
+ => Text
+ -> m [Constructor]
caseSplit q = do
type' <- parseType' q
(tc, args) <- splitTypeConstructor type'
- (EDType _ _ (P.DataType typeVars ctors)) <- findTypeDeclaration tc
+ (typeVars, ctors) <- findTypeDeclaration tc
let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args))
let appliedCtors = map (second (map applyTypeVars)) ctors
pure appliedCtors
-findTypeDeclaration :: (Ide m, MonadError IdeError m) =>
- P.ProperName 'P.TypeName -> m ExternsDeclaration
+findTypeDeclaration
+ :: (Ide m, MonadError IdeError m)
+ => P.ProperName 'P.TypeName
+ -> m DataType
findTypeDeclaration q = do
efs <- getExternFiles
efs' <- maybe efs (flip (uncurry M.insert) efs) <$> cachedRebuild
@@ -65,14 +71,15 @@ findTypeDeclaration q = do
Just mn -> pure mn
Nothing -> throwError (GeneralError "Not Found")
-findTypeDeclaration' ::
- P.ProperName 'P.TypeName
+findTypeDeclaration'
+ :: P.ProperName 'P.TypeName
-> ExternsFile
- -> First ExternsDeclaration
+ -> First DataType
findTypeDeclaration' t ExternsFile{..} =
- First $ find (\case
- EDType tn _ _ -> tn == t
- _ -> False) efDeclarations
+ First $ head $ mapMaybe (\case
+ EDType tn _ (P.DataType typeVars ctors)
+ | tn == t -> Just (typeVars, ctors)
+ _ -> Nothing) efDeclarations
splitTypeConstructor :: (MonadError IdeError m) =>
P.Type a -> m (P.ProperName 'P.TypeName, [P.Type a])
@@ -93,7 +100,7 @@ prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard
prettyPrintWildcard (WildcardAnnotations False) = const "_"
prettyWildcard :: P.Type a -> Text
-prettyWildcard t = "( _ :: " <> T.strip (T.pack (P.prettyPrintTypeAtom t)) <> ")"
+prettyWildcard t = "( _ :: " <> T.strip (T.pack (P.prettyPrintTypeAtom maxBound t)) <> ")"
-- | Constructs Patterns to insert into a sourcefile
makePattern :: Text -- ^ Current line
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
index d03ac60..56affea 100644
--- a/src/Language/PureScript/Ide/Completion.hs
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -22,15 +22,13 @@ import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import Lens.Micro.Platform hiding ((&))
-type Module = (P.ModuleName, [IdeDeclarationAnn])
-
-- | Applies the CompletionFilters and the Matcher to the given Modules
-- and sorts the found Completions according to the Matching Score
getCompletions
:: [Filter]
-> Matcher IdeDeclarationAnn
-> CompletionOptions
- -> [Module]
+ -> ModuleMap [IdeDeclarationAnn]
-> [Completion]
getCompletions filters matcher options modules =
modules
@@ -40,23 +38,23 @@ getCompletions filters matcher options modules =
& applyCompletionOptions options
<&> completionFromMatch
-getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn]
+getExactMatches :: Text -> [Filter] -> ModuleMap [IdeDeclarationAnn] -> [Match IdeDeclarationAnn]
getExactMatches search filters modules =
modules
- & applyFilters (equalityFilter search : filters)
+ & applyFilters (exactFilter search : filters)
& matchesFromModules
-getExactCompletions :: Text -> [Filter] -> [Module] -> [Completion]
+getExactCompletions :: Text -> [Filter] -> ModuleMap [IdeDeclarationAnn] -> [Completion]
getExactCompletions search filters modules =
modules
& getExactMatches search filters
<&> simpleExport
<&> completionFromMatch
-matchesFromModules :: [Module] -> [Match IdeDeclarationAnn]
-matchesFromModules = foldMap completionFromModule
+matchesFromModules :: ModuleMap [IdeDeclarationAnn] -> [Match IdeDeclarationAnn]
+matchesFromModules = Map.foldMapWithKey completionFromModule
where
- completionFromModule (moduleName, decls) =
+ completionFromModule moduleName decls =
map (\x -> Match (moduleName, x)) decls
data CompletionOptions = CompletionOptions
@@ -121,6 +119,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) =
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")
+ IdeDeclModule mn -> (P.runModuleName mn, "module")
complExportedFrom = mns
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 93d8be9..3a3645a 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -83,4 +83,4 @@ textError (ParseError parseError msg) = let escape = show
textError (RebuildError err) = show err
prettyPrintTypeSingleLine :: P.Type a -> Text
-prettyPrintTypeSingleLine = T.unwords . map T.strip . T.lines . T.pack . P.prettyPrintTypeWithUnicode
+prettyPrintTypeSingleLine = T.unwords . map T.strip . T.lines . T.pack . P.prettyPrintTypeWithUnicode maxBound
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index 8fcee52..ae5d2b5 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -61,12 +61,13 @@ convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.Decla
convertExterns ef =
(decls, exportDecls)
where
- decls = map
+ decls = moduleDecl : map
(IdeDeclarationAnn emptyAnn)
(resolvedDeclarations <> operatorDecls <> tyOperatorDecls)
exportDecls = mapMaybe convertExport (P.efExports ef)
operatorDecls = convertOperator <$> P.efFixities ef
tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef
+ moduleDecl = IdeDeclarationAnn emptyAnn (IdeDeclModule (P.efModuleName ef))
(toResolve, declarations) =
second catMaybes (partitionEithers (map convertDecl (P.efDeclarations ef)))
diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs
index b08bb06..83829a7 100644
--- a/src/Language/PureScript/Ide/Filter.hs
+++ b/src/Language/PureScript/Ide/Filter.hs
@@ -16,111 +16,129 @@
module Language.PureScript.Ide.Filter
( Filter
- , declarationTypeFilter
- , namespaceFilter
, moduleFilter
+ , namespaceFilter
+ , exactFilter
, prefixFilter
- , equalityFilter
+ , declarationTypeFilter
, applyFilters
) where
-import Protolude hiding (isPrefixOf)
+import Protolude hiding (isPrefixOf, Prefix)
+import Data.Bifunctor (first)
import Data.Aeson
-import Data.List.NonEmpty (NonEmpty)
import Data.Text (isPrefixOf)
-import qualified Language.PureScript.Ide.Filter.Declaration as D
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Language.PureScript.Ide.Filter.Declaration (DeclarationType, declarationType)
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import qualified Language.PureScript as P
-newtype Filter = Filter (Endo [Module])
- deriving (Semigroup, Monoid)
+newtype Filter = Filter (Either (Set P.ModuleName) DeclarationFilter)
+ deriving Show
-type Module = (P.ModuleName, [IdeDeclarationAnn])
+unFilter :: Filter -> Either (Set P.ModuleName) DeclarationFilter
+unFilter (Filter f) = f
-mkFilter :: ([Module] -> [Module]) -> Filter
-mkFilter = Filter . Endo
+data DeclarationFilter
+ = Prefix Text
+ | Exact Text
+ | Namespace (Set IdeNamespace)
+ | DeclType (Set DeclarationType)
+ deriving Show
--- | 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 Declarations in the given modules
+moduleFilter :: Set P.ModuleName -> Filter
+moduleFilter = Filter . Left
--- | Only keeps the given Modules
-moduleFilter :: [P.ModuleName] -> Filter
-moduleFilter =
- mkFilter . moduleFilter'
+-- | Only keeps Identifiers in the given Namespaces
+namespaceFilter :: Set IdeNamespace -> Filter
+namespaceFilter nss = Filter (Right (Namespace nss))
-moduleFilter' :: [P.ModuleName] -> [Module] -> [Module]
-moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst)
+-- | Only keeps Identifiers that are equal to the search string
+exactFilter :: Text -> Filter
+exactFilter t = Filter (Right (Exact t))
-- | Only keeps Identifiers that start with the given prefix
prefixFilter :: Text -> Filter
-prefixFilter "" = mkFilter identity
-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 . declarationFilter equality
- where
- equality :: IdeDeclaration -> Text -> Bool
- equality ed search = identifierFromIdeDeclaration ed == search
-
-declarationFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Module]
-declarationFilter predicate search =
- filterModuleDecls (flip predicate search)
+prefixFilter t = Filter (Right (Prefix t))
-- | Only keeps Identifiers in the given type declarations
-declarationTypeFilter :: [D.IdeDeclaration] -> Filter
-declarationTypeFilter [] = mkFilter identity
-declarationTypeFilter decls =
- mkFilter $ filterModuleDecls filterDecls
- where
- filterDecls :: IdeDeclaration -> Bool
- filterDecls decl = D.typeDeclarationForDeclaration decl `elem` decls
-
-filterModuleDecls :: (IdeDeclaration -> Bool) -> [Module] -> [Module]
-filterModuleDecls predicate =
- filter (not . null . snd) . fmap filterDecls
- where
- filterDecls (moduleIdent, decls) = (moduleIdent, filter (predicate . discardAnn) decls)
+declarationTypeFilter :: Set DeclarationType -> Filter
+declarationTypeFilter dts = Filter (Right (DeclType dts))
-runFilter :: Filter -> [Module] -> [Module]
-runFilter (Filter f) = appEndo f
-
-applyFilters :: [Filter] -> [Module] -> [Module]
-applyFilters = runFilter . fold
+optimizeFilters :: [Filter] -> (Maybe (Set P.ModuleName), [DeclarationFilter])
+optimizeFilters = first smashModuleFilters . partitionEithers . map unFilter
+ where
+ smashModuleFilters [] =
+ Nothing
+ smashModuleFilters (x:xs) =
+ Just (foldr Set.intersection x xs)
+
+applyFilters :: [Filter] -> ModuleMap [IdeDeclarationAnn] -> ModuleMap [IdeDeclarationAnn]
+applyFilters fs modules = case optimizeFilters fs of
+ (Nothing, declarationFilters) ->
+ applyDeclarationFilters declarationFilters modules
+ (Just moduleFilter', declarationFilters) ->
+ applyDeclarationFilters declarationFilters (Map.restrictKeys modules moduleFilter')
+
+applyDeclarationFilters
+ :: [DeclarationFilter]
+ -> ModuleMap [IdeDeclarationAnn]
+ -> ModuleMap [IdeDeclarationAnn]
+applyDeclarationFilters fs =
+ Map.filter (not . null)
+ . Map.map (foldr (.) identity (map applyDeclarationFilter fs))
+
+applyDeclarationFilter
+ :: DeclarationFilter
+ -> [IdeDeclarationAnn]
+ -> [IdeDeclarationAnn]
+applyDeclarationFilter f = case f of
+ Prefix prefix -> prefixFilter' prefix
+ Exact t -> exactFilter' t
+ Namespace namespaces -> namespaceFilter' namespaces
+ DeclType dts -> declarationTypeFilter' dts
+
+namespaceFilter' :: Set IdeNamespace -> [IdeDeclarationAnn] -> [IdeDeclarationAnn]
+namespaceFilter' namespaces =
+ filter (\decl -> elem (namespaceForDeclaration (discardAnn decl)) namespaces)
+
+exactFilter' :: Text -> [IdeDeclarationAnn] -> [IdeDeclarationAnn]
+exactFilter' search =
+ filter (\decl -> identifierFromIdeDeclaration (discardAnn decl) == search)
+
+prefixFilter' :: Text -> [IdeDeclarationAnn] -> [IdeDeclarationAnn]
+prefixFilter' prefix =
+ filter (\decl -> prefix `isPrefixOf` identifierFromIdeDeclaration (discardAnn decl))
+
+declarationTypeFilter' :: Set DeclarationType -> [IdeDeclarationAnn] -> [IdeDeclarationAnn]
+declarationTypeFilter' declTypes =
+ filter (\decl -> declarationType (discardAnn decl) `Set.member` declTypes)
instance FromJSON Filter where
parseJSON = withObject "filter" $ \o -> do
(filter' :: Text) <- o .: "filter"
case filter' of
+ "modules" -> do
+ params <- o .: "params"
+ modules <- map P.moduleNameFromString <$> params .: "modules"
+ pure (moduleFilter (Set.fromList modules))
"exact" -> do
params <- o .: "params"
search <- params .: "search"
- return $ equalityFilter search
+ pure (exactFilter search)
"prefix" -> do
params <- o.: "params"
search <- params .: "search"
- return $ prefixFilter search
- "modules" -> do
- params <- o .: "params"
- modules <- map P.moduleNameFromString <$> params .: "modules"
- return $ moduleFilter modules
+ pure (prefixFilter search)
"namespace" -> do
params <- o .: "params"
namespaces <- params .: "namespaces"
- return $ namespaceFilter namespaces
+ pure (namespaceFilter (Set.fromList namespaces))
"declarations" -> do
declarations <- o.: "params"
- return $ declarationTypeFilter declarations
+ pure (declarationTypeFilter (Set.fromList declarations))
_ -> mzero
diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs
index f92b51e..5c04fd3 100644
--- a/src/Language/PureScript/Ide/Filter/Declaration.hs
+++ b/src/Language/PureScript/Ide/Filter/Declaration.hs
@@ -1,9 +1,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.PureScript.Ide.Filter.Declaration
- ( IdeDeclaration(..)
- , DeclarationType(..)
- , typeDeclarationForDeclaration
+ ( DeclarationType(..)
+ , declarationType
) where
import Protolude hiding (isPrefixOf)
@@ -11,7 +10,8 @@ import Protolude hiding (isPrefixOf)
import Data.Aeson
import qualified Language.PureScript.Ide.Types as PI
-data DeclarationType = Value
+data DeclarationType
+ = Value
| Type
| Synonym
| DataConstructor
@@ -19,6 +19,7 @@ data DeclarationType = Value
| ValueOperator
| TypeOperator
| Kind
+ | Module
deriving (Show, Eq, Ord)
instance FromJSON DeclarationType where
@@ -32,24 +33,17 @@ instance FromJSON DeclarationType where
"valueoperator" -> pure ValueOperator
"typeoperator" -> pure TypeOperator
"kind" -> pure Kind
+ "module" -> pure Module
_ -> mzero
-newtype IdeDeclaration = IdeDeclaration
- { declarationtype :: DeclarationType
- } deriving (Show, Eq, Ord)
-
-instance FromJSON IdeDeclaration where
- parseJSON (Object o) =
- IdeDeclaration <$> o .: "declarationtype"
- parseJSON _ = mzero
-
-typeDeclarationForDeclaration :: PI.IdeDeclaration -> IdeDeclaration
-typeDeclarationForDeclaration decl = case decl of
- PI.IdeDeclValue _ -> IdeDeclaration Value
- PI.IdeDeclType _ -> IdeDeclaration Type
- PI.IdeDeclTypeSynonym _ -> IdeDeclaration Synonym
- PI.IdeDeclDataConstructor _ -> IdeDeclaration DataConstructor
- PI.IdeDeclTypeClass _ -> IdeDeclaration TypeClass
- PI.IdeDeclValueOperator _ -> IdeDeclaration ValueOperator
- PI.IdeDeclTypeOperator _ -> IdeDeclaration TypeOperator
- PI.IdeDeclKind _ -> IdeDeclaration Kind
+declarationType :: PI.IdeDeclaration -> DeclarationType
+declarationType decl = case decl of
+ PI.IdeDeclValue _ -> Value
+ PI.IdeDeclType _ -> Type
+ PI.IdeDeclTypeSynonym _ -> Synonym
+ PI.IdeDeclDataConstructor _ -> DataConstructor
+ PI.IdeDeclTypeClass _ -> TypeClass
+ PI.IdeDeclValueOperator _ -> ValueOperator
+ PI.IdeDeclTypeOperator _ -> TypeOperator
+ PI.IdeDeclKind _ -> Kind
+ PI.IdeDeclModule _ -> Module
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index f52cd63..c8af2ac 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -44,7 +44,7 @@ import Language.PureScript.Ide.State
import Language.PureScript.Ide.Prim
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import Lens.Micro.Platform ((^.), (%~), ix)
+import Lens.Micro.Platform ((^.), (%~), ix, has)
import System.IO.UTF8 (writeUTF8FileT)
import qualified Text.Parsec as Parsec
@@ -194,12 +194,14 @@ addExplicitImport' decl moduleName qualifier imports =
not (any (\case
Import C.Prim (P.Explicit _) Nothing -> True
_ -> False) imports)
+ -- We can't import Modules from other modules
+ isModule = has _IdeDeclModule decl
matches (Import mn (P.Explicit _) qualifier') = mn == moduleName && qualifier == qualifier'
matches _ = False
freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) qualifier
in
- if isImplicitlyImported || isNotExplicitlyImportedFromPrim
+ if isImplicitlyImported || isNotExplicitlyImportedFromPrim || isModule
then imports
else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports
where
@@ -273,8 +275,8 @@ addImportForIdentifier
-> [Filter] -- ^ Filters to apply before searching for the identifier
-> m (Either [Match IdeDeclaration] [Text])
addImportForIdentifier fp ident qual filters = do
- let addPrim = (++) idePrimDeclarations
- modules <- Map.toList <$> getAllModules Nothing
+ let addPrim = Map.union idePrimDeclarations
+ modules <- getAllModules Nothing
case map (fmap discardAnn) (getExactMatches ident filters (addPrim modules)) of
[] ->
throwError (NotFound "Couldn't find the given identifier. \
diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs
index 4430a12..c58550c 100644
--- a/src/Language/PureScript/Ide/Prim.hs
+++ b/src/Language/PureScript/Ide/Prim.hs
@@ -8,8 +8,8 @@ import qualified Language.PureScript.Constants as C
import qualified Language.PureScript.Environment as PEnv
import Language.PureScript.Ide.Types
-idePrimDeclarations :: [(P.ModuleName, [IdeDeclarationAnn])]
-idePrimDeclarations =
+idePrimDeclarations :: ModuleMap [IdeDeclarationAnn]
+idePrimDeclarations = Map.fromList
[ ( C.Prim
, mconcat [primTypes, primKinds, primClasses]
)
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index 37868eb..27a1725 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -59,8 +59,11 @@ parseModulesFromFiles paths = do
extractAstInformation
:: P.Module
-> (DefinitionSites P.SourceSpan, TypeAnnotations)
-extractAstInformation (P.Module _ _ _ decls _) =
- let definitions = Map.fromList (concatMap extractSpans decls)
+extractAstInformation (P.Module moduleSpan _ mn decls _) =
+ let definitions =
+ Map.insert
+ (IdeNamespaced IdeNSModule (P.runModuleName mn)) moduleSpan
+ (Map.fromList (concatMap extractSpans decls))
typeAnnotations = Map.fromList (extractTypeAnnotations decls)
in (definitions, typeAnnotations)
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 3ab0ece..d29f446 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -224,7 +224,13 @@ resolveLocationsForModule (defs, types) decls =
map convertDeclaration decls
where
convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
- convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' annotateFunction annotateValue annotateType annotateKind d
+ convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration'
+ annotateFunction
+ annotateValue
+ annotateType
+ annotateKind
+ annotateModule
+ d
where
annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs
, _annTypeAnnotation = Map.lookup x types
@@ -232,15 +238,17 @@ resolveLocationsForModule (defs, types) decls =
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})
+ annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs})
convertDeclaration'
:: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn)
-> (Text -> IdeDeclaration -> IdeDeclarationAnn)
-> (Text -> IdeDeclaration -> IdeDeclarationAnn)
-> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+ -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
-> IdeDeclaration
-> IdeDeclarationAnn
-convertDeclaration' annotateFunction annotateValue annotateType annotateKind d =
+convertDeclaration' annotateFunction annotateValue annotateType annotateKind annotateModule d =
case d of
IdeDeclValue v ->
annotateFunction (v ^. ideValueIdent) d
@@ -258,6 +266,8 @@ convertDeclaration' annotateFunction annotateValue annotateType annotateKind d =
annotateType (operator ^. ideTypeOpName . opNameT) d
IdeDeclKind i ->
annotateKind (i ^. properNameT) d
+ IdeDeclModule mn ->
+ annotateModule (P.runModuleName mn) d
resolveDocumentation
:: ModuleMap P.Module
@@ -271,26 +281,27 @@ resolveDocumentationForModule
:: P.Module
-> [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
-resolveDocumentationForModule (P.Module _ _ _ sdecls _) decls = map convertDecl decls
- where
+resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) decls = map convertDecl decls
+ where
comments :: Map P.Name [P.Comment]
- comments = Map.fromListWith (flip (<>)) $ mapMaybe (\d ->
- case name d of
+ comments = Map.insert (P.ModName moduleName) moduleComments $ Map.fromListWith (flip (<>)) $ mapMaybe (\d ->
+ case name d of
Just name' -> Just (name', snd $ P.declSourceAnn d)
_ -> Nothing)
- sdecls
+ sdecls
name :: P.Declaration -> Maybe P.Name
name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d
name decl = P.declName decl
convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn
- convertDecl (IdeDeclarationAnn ann d) =
+ convertDecl (IdeDeclarationAnn ann d) =
convertDeclaration'
(annotateValue . P.IdentName)
- (annotateValue . P.IdentName . P.Ident)
+ (annotateValue . P.IdentName . P.Ident)
(annotateValue . P.TyName . P.ProperName)
(annotateValue . P.KiName . P.ProperName)
+ (annotateValue . P.ModName . P.moduleNameFromString)
d
where
docs :: P.Name -> Text
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index cb72e17..82cfed9 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -39,6 +39,7 @@ data IdeDeclaration
| IdeDeclTypeClass IdeTypeClass
| IdeDeclValueOperator IdeValueOperator
| IdeDeclTypeOperator IdeTypeOperator
+ | IdeDeclModule P.ModuleName
| IdeDeclKind (P.ProperName 'P.KindName)
deriving (Show, Eq, Ord, Generic, NFData)
@@ -126,6 +127,10 @@ _IdeDeclKind :: Traversal' IdeDeclaration (P.ProperName 'P.KindName)
_IdeDeclKind f (IdeDeclKind x) = map IdeDeclKind (f x)
_IdeDeclKind _ x = pure x
+_IdeDeclModule :: Traversal' IdeDeclaration P.ModuleName
+_IdeDeclModule f (IdeDeclModule x) = map IdeDeclModule (f x)
+_IdeDeclModule _ x = pure x
+
anyOf :: Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf g p = getAny . getConst . g (Const . Any . p)
@@ -298,14 +303,15 @@ encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifie
] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
-- | Denotes the different namespaces a name in PureScript can reside in.
-data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind
+data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind | IdeNSModule
deriving (Show, Eq, Ord, Generic, NFData)
instance FromJSON IdeNamespace where
parseJSON (String s) = case s of
"value" -> pure IdeNSValue
- "type" -> pure IdeNSType
- "kind" -> pure IdeNSKind
+ "type" -> pure IdeNSType
+ "kind" -> pure IdeNSKind
+ "module" -> pure IdeNSModule
_ -> mzero
parseJSON _ = mzero
diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs
index 1890329..8db7f36 100644
--- a/src/Language/PureScript/Ide/Usage.hs
+++ b/src/Language/PureScript/Ide/Usage.hs
@@ -112,6 +112,9 @@ matchesRef declaration ref = case declaration of
IdeDeclKind kind -> case ref of
P.KindRef _ kindName -> kindName == kind
_ -> False
+ IdeDeclModule m -> case ref of
+ P.ModuleRef _ mn -> m == mn
+ _ -> False
eligibleModules
:: (P.ModuleName, IdeDeclaration)
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index 46824c1..d25a870 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -53,6 +53,7 @@ identifierFromIdeDeclaration d = case d of
IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName
IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName
IdeDeclKind name -> P.runProperName name
+ IdeDeclModule name -> P.runModuleName name
namespaceForDeclaration :: IdeDeclaration -> IdeNamespace
namespaceForDeclaration d = case d of
@@ -64,6 +65,7 @@ namespaceForDeclaration d = case d of
IdeDeclValueOperator _ -> IdeNSValue
IdeDeclTypeOperator _ -> IdeNSType
IdeDeclKind _ -> IdeNSKind
+ IdeDeclModule _ -> IdeNSModule
discardAnn :: IdeDeclarationAnn -> IdeDeclaration
discardAnn (IdeDeclarationAnn _ d) = d
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index 856f028..fb4f45a 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -274,7 +274,7 @@ handleTypeOf print' val = do
Left errs -> printErrors errs
Right (_, env') ->
case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of
- Just (ty, _, _) -> print' . P.prettyPrintType $ ty
+ Just (ty, _, _) -> print' . P.prettyPrintType maxBound $ ty
Nothing -> print' "Could not find type"
-- | Takes a type and prints its kind
diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs
index 7d35b08..8a7dce4 100644
--- a/src/Language/PureScript/Interactive/Printer.hs
+++ b/src/Language/PureScript/Interactive/Printer.hs
@@ -43,7 +43,7 @@ printModuleSignatures moduleName P.Environment{..} =
findNameType envNames m = (P.disqualify m, M.lookup m envNames)
showNameType :: (P.Ident, Maybe (P.SourceType, P.NameKind, P.NameVisibility)) -> Box.Box
- showNameType (mIdent, Just (mType, _, _)) = textT (P.showIdent mIdent <> " :: ") Box.<> P.typeAsBox mType
+ showNameType (mIdent, Just (mType, _, _)) = textT (P.showIdent mIdent <> " :: ") Box.<> P.typeAsBox maxBound mType
showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
findTypeClass
@@ -61,13 +61,13 @@ printModuleSignatures moduleName P.Environment{..} =
if null typeClassSuperclasses
then Box.text ""
else Box.text "("
- Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn) lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses)
+ Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn) lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map (P.typeAtomAsBox maxBound) lt)) typeClassSuperclasses)
Box.<> Box.text ") <= "
className =
textT (P.runProperName name)
Box.<> textT (foldMap ((" " <>) . fst) typeClassArguments)
classBody =
- Box.vcat Box.top (map (\(i, t) -> textT (P.showIdent i <> " ::") Box.<+> P.typeAsBox t) typeClassMembers)
+ Box.vcat Box.top (map (\(i, t) -> textT (P.showIdent i <> " ::") Box.<+> P.typeAsBox maxBound t) typeClassMembers)
in
Just $
@@ -99,7 +99,7 @@ printModuleSignatures moduleName P.Environment{..} =
else
Just $
textT ("type " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars)
- Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)
+ Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox maxBound dtType)
(Just (_, P.DataType typevars pt), _) ->
let prefix =
@@ -122,7 +122,7 @@ printModuleSignatures moduleName P.Environment{..} =
mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $
map (\(cons,idents) -> (textT (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt
- prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t
+ prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox maxBound t
mapFirstRest _ _ [] = []
mapFirstRest f g (x:xs) = f x : map g xs
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index c7b1408..33b9c0b 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -26,7 +26,7 @@ import Control.Parallel.Strategies (withStrategy, parList, rseq)
import Data.Functor (($>))
import Data.Maybe (fromMaybe)
import qualified Data.Set as S
-import Data.Text (Text)
+import Data.Text (Text, pack)
import Language.PureScript.AST
import Language.PureScript.Environment
import Language.PureScript.Errors
@@ -45,6 +45,9 @@ kindedIdent :: TokenParser (Text, Maybe SourceKind)
kindedIdent = (, Nothing) <$> identifier
<|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))
+fields :: [Ident]
+fields = [ Ident ("value" <> pack (show (n :: Integer))) | n <- [0..] ]
+
parseDataDeclaration :: TokenParser Declaration
parseDataDeclaration = withSourceAnnF $ do
dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
@@ -52,7 +55,10 @@ parseDataDeclaration = withSourceAnnF $ do
tyArgs <- many (indented *> kindedIdent)
ctors <- P.option [] $ do
indented *> equals
- P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
+ flip P.sepBy1 pipe $ do
+ ctorName <- dataConstructorName
+ tys <- P.many (indented *> noWildcards parseTypeAtom)
+ return (ctorName, zip fields tys)
return $ \sa -> DataDeclaration sa dtype name tyArgs ctors
parseTypeDeclaration :: TokenParser Declaration
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 531bffd..35445c3 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -6,15 +6,12 @@ module Language.PureScript.Pretty.Types
, PrettyPrintConstraint
, convertPrettyPrintType
, typeAsBox
- , typeAsBox'
, suggestedTypeAsBox
, prettyPrintType
, prettyPrintTypeWithUnicode
, prettyPrintSuggestedType
, typeAtomAsBox
- , typeAtomAsBox'
, prettyPrintTypeAtom
- , prettyPrintRow
, prettyPrintLabel
, prettyPrintObjectKey
) where
@@ -56,35 +53,49 @@ data PrettyPrintType
| PPParensInType PrettyPrintType
| PPForAll [Text] PrettyPrintType
| PPFunction PrettyPrintType PrettyPrintType
- | PPRecord PrettyPrintType
- | PPRCons Label PrettyPrintType PrettyPrintType
- | PPREmpty
+ | PPRecord [(Label, PrettyPrintType)] (Maybe PrettyPrintType)
+ | PPRow [(Label, PrettyPrintType)] (Maybe PrettyPrintType)
+ | PPTruncated
type PrettyPrintConstraint = (Qualified (ProperName 'ClassName), [PrettyPrintType])
-convertPrettyPrintType :: Type a -> PrettyPrintType
+convertPrettyPrintType :: Int -> Type a -> PrettyPrintType
convertPrettyPrintType = go
where
- go (TUnknown _ n) = PPTUnknown n
- go (TypeVar _ t) = PPTypeVar t
- go (TypeLevelString _ s) = PPTypeLevelString s
- go (TypeWildcard _ n) = PPTypeWildcard n
- go (TypeConstructor _ c) = PPTypeConstructor c
- go (TypeOp _ o) = PPTypeOp o
- go (Skolem _ t n _) = PPSkolem t n
- go (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go <$> args) (go ty)
- go (KindedType _ ty k) = PPKindedType (go ty) (k $> ())
- go (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go ty1) (go ty2) (go ty3)
- go (ParensInType _ ty) = PPParensInType (go ty)
- go (REmpty _) = PPREmpty
- go (RCons _ l ty1 ty2) = PPRCons l (go ty1) (go ty2)
- go (ForAll _ v ty _) = goForAll [v] ty
- go (TypeApp _ (TypeApp _ f arg) ret) | eqType f tyFunction = PPFunction (go arg) (go ret)
- go (TypeApp _ o r) | eqType o tyRecord = PPRecord (go r)
- go (TypeApp _ a b) = PPTypeApp (go a) (go b)
-
- goForAll vs (ForAll _ v ty _) = goForAll (v : vs) ty
- goForAll vs ty = PPForAll vs (go ty)
+ go d _ | d < 0 = PPTruncated
+ go _ (TUnknown _ n) = PPTUnknown n
+ go _ (TypeVar _ t) = PPTypeVar t
+ go _ (TypeLevelString _ s) = PPTypeLevelString s
+ go _ (TypeWildcard _ n) = PPTypeWildcard n
+ go _ (TypeConstructor _ c) = PPTypeConstructor c
+ go _ (TypeOp _ o) = PPTypeOp o
+ go _ (Skolem _ t n _) = PPSkolem t n
+ go d (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go (d-1) <$> args) (go (d-1) ty)
+ go d (KindedType _ ty k) = PPKindedType (go (d-1) ty) (k $> ())
+ go d (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go (d-1) ty1) (go (d-1) ty2) (go (d-1) ty3)
+ go d (ParensInType _ ty) = PPParensInType (go (d-1) ty)
+ go _ (REmpty _) = PPRow [] Nothing
+ go d ty@RCons{} = uncurry PPRow (goRow d ty)
+ go d (ForAll _ v ty _) = goForAll d [v] ty
+ go d (TypeApp _ a b) = goTypeApp d a b
+
+ goForAll d vs (ForAll _ v ty _) = goForAll d (v : vs) ty
+ goForAll d vs ty = PPForAll vs (go (d-1) ty)
+
+ goRow d ty =
+ let (items, tail_) = rowToSortedList ty
+ in ( map (\item -> (rowListLabel item, go (d-1) (rowListType item))) items
+ , case tail_ of
+ REmpty _ -> Nothing
+ _ -> Just (go (d-1) tail_)
+ )
+
+ goTypeApp d (TypeApp _ f a) b
+ | eqType f tyFunction = PPFunction (go (d-1) a) (go (d-1) b)
+ | otherwise = PPTypeApp (goTypeApp d f a) (go (d-1) b)
+ goTypeApp d o ty@RCons{}
+ | eqType o tyRecord = uncurry PPRecord (goRow d ty)
+ goTypeApp d a b = PPTypeApp (go (d-1) a) (go (d-1) b)
-- TODO(Christoph): get rid of T.unpack s
@@ -100,30 +111,27 @@ constraintAsBox (pn, tys) = typeAsBox' (foldl PPTypeApp (PPTypeConstructor (fmap
-- |
-- Generate a pretty-printed string representing a Row
--
-prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> PrettyPrintType -> Box
-prettyPrintRowWith tro open close = uncurry listToBox . toList []
+prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> [(Label, PrettyPrintType)] -> Maybe PrettyPrintType -> Box
+prettyPrintRowWith tro open close labels rest =
+ case (labels, rest) of
+ ([], Nothing) ->
+ text [open, close]
+ ([], Just _) ->
+ text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ]
+ _ ->
+ vcat left $
+ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) labels [0 :: Int ..] ++
+ [ tailToPs rest, text [close] ]
+
where
nameAndTypeToPs :: Char -> Label -> PrettyPrintType -> Box
nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " " ++ doubleColon ++ " ") <> typeAsBox' ty
doubleColon = if troUnicode tro then "∷" else "::"
- tailToPs :: PrettyPrintType -> Box
- tailToPs PPREmpty = nullBox
- tailToPs other = text "| " <> typeAsBox' other
-
- listToBox :: [(Label, PrettyPrintType)] -> PrettyPrintType -> Box
- listToBox [] PPREmpty = text [open, close]
- listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ]
- listToBox ts rest = vcat left $
- zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++
- [ tailToPs rest, text [close] ]
- toList :: [(Label, PrettyPrintType)] -> PrettyPrintType -> ([(Label, PrettyPrintType)], PrettyPrintType)
- toList tys (PPRCons name ty row) = toList ((name, ty):tys) row
- toList tys r = (reverse tys, r)
-
-prettyPrintRow :: PrettyPrintType -> String
-prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')'
+ tailToPs :: Maybe PrettyPrintType -> Box
+ tailToPs Nothing = nullBox
+ tailToPs (Just other) = text "| " <> typeAsBox' other
typeApp :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
typeApp = mkPattern match
@@ -164,7 +172,6 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
match (PPTypeWildcard name) = Just $ maybe (text "_") (text . ('?' :) . T.unpack) name
match (PPTypeVar var) = Just $ text $ T.unpack var
match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
- match (PPRecord row) = Just $ prettyPrintRowWith tro '{' '}' row
match (PPTypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor
match (PPTUnknown u)
| suggesting = Just $ text "_"
@@ -172,11 +179,12 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
match (PPSkolem name s)
| suggesting = Just $ text $ T.unpack name
| otherwise = Just $ text $ T.unpack name ++ show s
- match PPREmpty = Just $ text "()"
- match row@PPRCons{} = Just $ prettyPrintRowWith tro '(' ')' row
+ match (PPRecord labels tail_) = Just $ prettyPrintRowWith tro '{' '}' labels tail_
+ match (PPRow labels tail_) = Just $ prettyPrintRowWith tro '(' ')' labels tail_
match (PPBinaryNoParensType op l r) =
Just $ typeAsBox' l <> text " " <> typeAsBox' op <> text " " <> typeAsBox' r
match (PPTypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op
+ match PPTruncated = Just $ text "..."
match _ = Nothing
matchType :: TypeRenderOptions -> Pattern () PrettyPrintType Box
@@ -213,18 +221,18 @@ typeAtomAsBox'
= fromMaybe (internalError "Incomplete pattern")
. PA.pattern (matchTypeAtom defaultOptions) ()
-typeAtomAsBox :: Type a -> Box
-typeAtomAsBox = typeAtomAsBox' . convertPrettyPrintType
+typeAtomAsBox :: Int -> Type a -> Box
+typeAtomAsBox maxDepth = typeAtomAsBox' . convertPrettyPrintType maxDepth
-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses
-prettyPrintTypeAtom :: Type a -> String
-prettyPrintTypeAtom = render . typeAtomAsBox
+prettyPrintTypeAtom :: Int -> Type a -> String
+prettyPrintTypeAtom maxDepth = render . typeAtomAsBox maxDepth
typeAsBox' :: PrettyPrintType -> Box
typeAsBox' = typeAsBoxImpl defaultOptions
-typeAsBox :: Type a -> Box
-typeAsBox = typeAsBox' . convertPrettyPrintType
+typeAsBox :: Int -> Type a -> Box
+typeAsBox maxDepth = typeAsBox' . convertPrettyPrintType maxDepth
suggestedTypeAsBox :: PrettyPrintType -> Box
suggestedTypeAsBox = typeAsBoxImpl suggestingOptions
@@ -249,20 +257,20 @@ typeAsBoxImpl tro
. PA.pattern (matchType tro) ()
-- | Generate a pretty-printed string representing a 'Type'
-prettyPrintType :: Type a -> String
-prettyPrintType = prettyPrintType' defaultOptions
+prettyPrintType :: Int -> Type a -> String
+prettyPrintType = flip prettyPrintType' defaultOptions
-- | Generate a pretty-printed string representing a 'Type' using unicode
-- symbols where applicable
-prettyPrintTypeWithUnicode :: Type a -> String
-prettyPrintTypeWithUnicode = prettyPrintType' unicodeOptions
+prettyPrintTypeWithUnicode :: Int -> Type a -> String
+prettyPrintTypeWithUnicode = flip prettyPrintType' unicodeOptions
-- | Generate a pretty-printed string representing a suggested 'Type'
prettyPrintSuggestedType :: Type a -> String
-prettyPrintSuggestedType = prettyPrintType' suggestingOptions
+prettyPrintSuggestedType = prettyPrintType' maxBound suggestingOptions
-prettyPrintType' :: TypeRenderOptions -> Type a -> String
-prettyPrintType' tro = render . typeAsBoxImpl tro . convertPrettyPrintType
+prettyPrintType' :: Int -> TypeRenderOptions -> Type a -> String
+prettyPrintType' maxDepth tro = render . typeAsBoxImpl tro . convertPrettyPrintType maxDepth
prettyPrintLabel :: Label -> Text
prettyPrintLabel (Label s) =
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 104fca9..fe9592d 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -86,7 +86,7 @@ prettyPrintValue d (Do m els) =
prettyPrintValue d (Ado m els yield) =
textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) //
(text "in " <> prettyPrintValue (d - 1) yield)
-prettyPrintValue _ (TypeClassDictionary (Constraint _ name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys
+prettyPrintValue d (TypeClassDictionary (Constraint _ name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map (typeAtomAsBox d) tys
prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name))
prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =
text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">"
@@ -130,8 +130,8 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon
prettyPrintDeclaration :: Int -> Declaration -> Box
prettyPrintDeclaration d _ | d < 0 = ellipsis
-prettyPrintDeclaration _ (TypeDeclaration td) =
- text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox (tydeclType td)
+prettyPrintDeclaration d (TypeDeclaration td) =
+ text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox d (tydeclType td)
prettyPrintDeclaration d (ValueDecl _ ident _ [] [GuardedExpr [] val]) =
text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val
prettyPrintDeclaration d (BindingGroupDeclaration ds) =
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 7d1c630..fc14959 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -17,7 +17,6 @@ module Language.PureScript.Publish
, getVersionFromGitTag
, getManifestRepositoryInfo
, getModules
- , getResolvedDependencies
) where
import Protolude hiding (stdin)
@@ -26,7 +25,7 @@ import Control.Arrow ((***))
import Control.Category ((>>>))
import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)
-import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asString, asText)
+import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asString, withString, asText, withText)
import qualified Data.ByteString.Lazy as BL
import Data.Char (isSpace)
import Data.String (String, lines)
@@ -43,7 +42,7 @@ import System.Directory (doesFileExist)
import System.FilePath.Glob (globDir1)
import System.Process (readProcess)
-import Web.Bower.PackageMeta (PackageMeta(..), PackageName, parsePackageName, Repository(..))
+import Web.Bower.PackageMeta (PackageMeta(..), PackageName, Repository(..))
import qualified Web.Bower.PackageMeta as Bower
import Language.PureScript.Publish.ErrorsWarnings
@@ -124,22 +123,25 @@ preparePackage' manifestFile resolutionsFile opts = do
checkCleanWorkingTree opts
pkgMeta <- liftIO (Bower.decodeFile manifestFile)
- >>= flip catchLeft (userError . CouldntDecodePackageManifest)
+ >>= flip catchLeft (userError . CouldntDecodePackageManifest)
checkLicense pkgMeta
(pkgVersionTag, pkgVersion) <- publishGetVersion opts
- pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag
- pkgGithub <- getManifestRepositoryInfo pkgMeta
+ pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag
+ pkgGithub <- getManifestRepositoryInfo pkgMeta
- let declaredDeps = map fst (bowerDependencies pkgMeta ++
- bowerDevDependencies pkgMeta)
- resolvedDeps <- getResolvedDependencies resolutionsFile declaredDeps
+ resolvedDeps <- parseResolutionsFile resolutionsFile
(pkgModules, pkgModuleMap) <- getModules (map (second fst) resolvedDeps)
+ let declaredDeps = map fst $
+ Bower.bowerDependencies pkgMeta
+ ++ Bower.bowerDevDependencies pkgMeta
+ pkgResolvedDependencies <- handleDeps declaredDeps (map (second snd) resolvedDeps)
+
let pkgUploader = D.NotYetKnown
let pkgCompilerVersion = P.version
- let pkgResolvedDependencies = map (second snd) resolvedDeps
+
return D.Package{..}
@@ -269,124 +271,137 @@ readProcess' prog args stdin = do
either (otherError . ProcessFailed prog args) return out
data DependencyStatus
- = Missing
- -- ^ Listed in package manifest, but not installed.
- | NoResolution
+ = NoResolution
-- ^ In the resolutions file, there was no _resolution key.
| ResolvedOther Text
-- ^ Resolved, but to something other than a version. The Text argument
-- is the resolution type. The values it can take that I'm aware of are
- -- "commit" and "branch".
- | ResolvedVersion Text
- -- ^ Resolved to a version. The Text argument is the resolution tag (eg,
- -- "v0.1.0").
+ -- "commit" and "branch". Note: this constructor is deprecated, and is only
+ -- used when parsing legacy resolutions files.
+ | ResolvedVersion Version
+ -- ^ Resolved to a version.
deriving (Show, Eq)
--- Go through all dependencies which contain purescript code, and
--- extract their versions.
---
--- In the case where a dependency is taken from a particular version,
--- that's easy; take that version. In any other case (eg, a branch, or a commit
--- sha) we print a warning that documentation links will not work, and avoid
--- linking to documentation for any types from that package.
---
--- The rationale for this is: people will prefer to use a released version
--- where possible. If they are not using a released version, then this is
--- probably for a reason. However, docs are only ever available for released
--- versions. Therefore there will probably be no version of the docs which is
--- appropriate to link to, and we should omit links.
-getResolvedDependencies :: FilePath -> [PackageName] -> PrepareM [(PackageName, (FilePath, Version))]
-getResolvedDependencies resolutionsFile declaredDeps = do
+parseResolutionsFile :: FilePath -> PrepareM [(PackageName, (FilePath, DependencyStatus))]
+parseResolutionsFile resolutionsFile = do
unlessM (liftIO (doesFileExist resolutionsFile)) (userError ResolutionsFileNotFound)
depsBS <- liftIO (BL.readFile resolutionsFile)
- -- Check for undeclared dependencies
- toplevels <- catchJSON (parse asToplevelDependencies depsBS)
- warnUndeclared declaredDeps toplevels
-
- deps <- catchJSON (parse asResolvedDependencies depsBS)
- handleDeps deps
-
- where
- catchJSON = flip catchLeft (internalError . JSONError FromResolutions)
-
--- | Extracts all dependencies and their versions from a "resolutions" file, which
--- is based on the output of `bower list --json --offline`
-asResolvedDependencies :: Parse D.ManifestError [(PackageName, (Maybe FilePath, DependencyStatus))]
-asResolvedDependencies = nubBy ((==) `on` fst) <$> go
+ case parse asResolutions depsBS of
+ Right res ->
+ pure res
+ Left err ->
+ case parse asLegacyResolutions depsBS of
+ Right res -> do
+ warn $ LegacyResolutionsFormat resolutionsFile
+ pure res
+ Left _ ->
+ userError $ ResolutionsFileError resolutionsFile err
+
+-- | Parser for resolutions files, which contain information about the packages
+-- which this package depends on. A resolutions file should look something like
+-- this:
+--
+-- {
+-- "purescript-prelude": {
+-- "version": "4.0.0",
+-- "path": "bower_components/purescript-prelude"
+-- },
+-- "purescript-lists": {
+-- "version": "6.0.0",
+-- "path": "bower_components/purescript-lists"
+-- },
+-- ...
+-- }
+--
+-- where the version is used for generating links between packages on Pursuit,
+-- and the path is used to obtain the source files while generating
+-- documentation: all files matching the glob "src/**/*.purs" relative to the
+-- `path` directory will be picked up.
+--
+-- The "version" field is optional, but omitting it will mean that no links
+-- will be generated for any declarations from that package on Pursuit. The
+-- "path" field is required.
+asResolutions :: Parse D.PackageError [(PackageName, (FilePath, DependencyStatus))]
+asResolutions =
+ eachInObjectWithKey parsePackageName $
+ (,) <$> key "path" asString
+ <*> (maybe NoResolution ResolvedVersion <$> keyMay "version" asVersion)
+
+asVersion :: Parse D.PackageError Version
+asVersion =
+ withString (note D.InvalidVersion . D.parseVersion')
+
+-- | Extracts all dependencies and their versions from a legacy resolutions
+-- file, which is based on the output of `bower list --json --offline`.
+asLegacyResolutions :: Parse D.PackageError [(PackageName, (FilePath, DependencyStatus))]
+asLegacyResolutions =
+ nubBy ((==) `on` fst) <$> go True
where
- go =
- fmap (fromMaybe []) $
- keyMay "dependencies" $
- (++) <$> eachInObjectWithKey parsePackageName asDirectoryAndDependencyStatus
- <*> (concatMap snd <$> eachInObject asResolvedDependencies)
-
--- | Extracts only the top level dependency names from a resolutions file.
-asToplevelDependencies :: Parse D.ManifestError [PackageName]
-asToplevelDependencies =
- fmap (map fst) $
- key "dependencies" $
- eachInObjectWithKey parsePackageName (return ())
-
-asDirectoryAndDependencyStatus :: Parse e (Maybe FilePath, DependencyStatus)
-asDirectoryAndDependencyStatus = do
- isMissing <- keyOrDefault "missing" False asBool
- if isMissing
- then
- return (Nothing, Missing)
- else do
- directory <- key "canonicalDir" asString
- status <- key "pkgMeta" $
- keyOrDefault "_resolution" NoResolution $ do
- type_ <- key "type" asText
- case type_ of
- "version" -> ResolvedVersion <$> key "tag" asText
- other -> return (ResolvedOther other)
- return (Just directory, status)
-
-warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
-warnUndeclared declared actual =
- traverse_ (warn . UndeclaredDependency) (actual \\ declared)
+ go isToplevel =
+ keyDependencies isToplevel $
+ (++) <$> (takeJusts <$> eachInObjectWithKey parsePackageName asDirectoryAndDependencyStatus)
+ <*> (concatMap snd <$> eachInObject (go False))
+
+
+ keyDependencies isToplevel =
+ if isToplevel
+ then key "dependencies"
+ else fmap (fromMaybe []) . keyMay "dependencies"
+
+ takeJusts :: [(a, Maybe b)] -> [(a,b)]
+ takeJusts = mapMaybe $ \(x,y) -> (x,) <$> y
+
+ asDirectoryAndDependencyStatus :: Parse D.PackageError (Maybe (FilePath, DependencyStatus))
+ asDirectoryAndDependencyStatus = do
+ isMissing <- keyOrDefault "missing" False asBool
+ if isMissing
+ then return Nothing
+ else do
+ directory <- key "canonicalDir" asString
+ status <- key "pkgMeta" $
+ keyOrDefault "_resolution" NoResolution $ do
+ type_ <- key "type" asText
+ case type_ of
+ "version" ->
+ key "tag" $ fmap ResolvedVersion $ withText $ \tag ->
+ let
+ tag' = fromMaybe tag (T.stripPrefix "v" tag)
+ in
+ note D.InvalidVersion (D.parseVersion' (T.unpack tag'))
+ other ->
+ return (ResolvedOther other)
+ return $ Just (directory, status)
+
+parsePackageName :: Text -> Either D.PackageError PackageName
+parsePackageName = first D.ErrorInPackageMeta . Bower.parsePackageName
handleDeps
- :: [(PackageName, (Maybe FilePath, DependencyStatus))]
- -> PrepareM [(PackageName, (FilePath, Version))]
-handleDeps deps = do
- let (missing, noVersion, installed, missingPath) = partitionDeps deps
+ :: [PackageName]
+ -- ^ dependencies declared in package manifest file; we should emit
+ -- warnings for any package name in this list which is not in the
+ -- resolutions file.
+ -> [(PackageName, DependencyStatus)]
+ -- ^ Contents of resolutions file
+ -> PrepareM [(PackageName, Version)]
+handleDeps declared resolutions = do
+ let missing = declared \\ map fst resolutions
case missing of
(x:xs) ->
userError (MissingDependencies (x :| xs))
[] -> do
- traverse_ (warn . NoResolvedVersion) noVersion
- traverse_ (warn . MissingPath) missingPath
- catMaybes <$> traverse tryExtractVersion' installed
-
- where
- partitionDeps = foldr go ([], [], [], [])
- go (pkgName, (Nothing, _)) (ms, os, is, mp) =
- (ms, os, is, pkgName : mp)
- go (pkgName, (Just path, d)) (ms, os, is, mp) =
- case d of
- Missing -> (pkgName : ms, os, is, mp)
- NoResolution -> (ms, pkgName : os, is, mp)
- ResolvedOther _ -> (ms, pkgName : os, is, mp)
- ResolvedVersion v -> (ms, os, (pkgName, (path, v)) : is, mp)
-
- -- Try to extract a version, and warn if unsuccessful.
- tryExtractVersion'
- :: (PackageName, (extra, Text))
- -> PrepareM (Maybe (PackageName, (extra, Version)))
- tryExtractVersion' pair =
- maybe (warn (UnacceptableVersion (fmap snd pair)) >> return Nothing)
- (return . Just)
- (tryExtractVersion pair)
-
-tryExtractVersion
- :: (PackageName, (extra, Text))
- -> Maybe (PackageName, (extra, Version))
-tryExtractVersion (pkgName, (extra, tag)) =
- let tag' = fromMaybe tag (T.stripPrefix "v" tag)
- in (pkgName,) . (extra,) <$> D.parseVersion' (T.unpack tag')
+ pkgs <-
+ for resolutions $ \(pkgName, status) ->
+ case status of
+ NoResolution -> do
+ warn (NoResolvedVersion pkgName)
+ pure Nothing
+ ResolvedOther other -> do
+ warn (UnacceptableVersion (pkgName, other))
+ pure Nothing
+ ResolvedVersion version ->
+ pure (Just (pkgName, version))
+ pure (catMaybes pkgs)
getInputAndDepsFiles
:: [(PackageName, FilePath)]
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index 38ebc36..84ec999 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -21,18 +21,18 @@ import Data.Aeson.BetterErrors (ParseError, displayError)
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
-import Data.Monoid
+import Data.Monoid hiding (First, getFirst)
+import Data.Semigroup (First(..))
import Data.Version
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as T
-import Language.PureScript.Docs.Types (ManifestError)
-import Language.PureScript.Publish.BoxesHelpers
+import qualified Language.PureScript.Docs.Types as D
import qualified Language.PureScript as P
+import Language.PureScript.Publish.BoxesHelpers
import Web.Bower.PackageMeta (PackageName, runPackageName, showBowerError)
-import qualified Web.Bower.PackageMeta as Bower
-- | An error which meant that it was not possible to retrieve metadata for a
-- package.
@@ -44,17 +44,16 @@ data PackageError
data PackageWarning
= NoResolvedVersion PackageName
- | UndeclaredDependency PackageName
| UnacceptableVersion (PackageName, Text)
| DirtyWorkingTree_Warn
- | MissingPath PackageName
+ | LegacyResolutionsFormat FilePath
deriving (Show)
-- | An error that should be fixed by the user.
data UserError
= PackageManifestNotFound
| ResolutionsFileNotFound
- | CouldntDecodePackageManifest (ParseError ManifestError)
+ | CouldntDecodePackageManifest (ParseError D.ManifestError)
| TagMustBeCheckedOut
| AmbiguousVersions [Version] -- Invariant: should contain at least two elements
| BadRepositoryField RepositoryFieldError
@@ -63,6 +62,7 @@ data UserError
| MissingDependencies (NonEmpty PackageName)
| CompileError P.MultipleErrors
| DirtyWorkingTree
+ | ResolutionsFileError FilePath (ParseError D.PackageError)
deriving (Show)
data RepositoryFieldError
@@ -71,11 +71,9 @@ data RepositoryFieldError
| NotOnGithub
deriving (Show)
-
-- | An error that probably indicates a bug in this module.
data InternalError
- = JSONError JSONSource (ParseError ManifestError)
- | CouldntParseGitTagDate Text
+ = CouldntParseGitTagDate Text
deriving (Show)
data JSONSource
@@ -221,6 +219,10 @@ displayUserError e = case e of
"Your git working tree is dirty. Please commit, discard, or stash " ++
"your changes first."
)
+ ResolutionsFileError path err ->
+ successivelyIndented $
+ [ "Error in resolutions file (" ++ path ++ "):" ]
+ ++ map T.unpack (displayError D.displayPackageError err)
spdxExamples :: [Box]
spdxExamples =
@@ -276,21 +278,10 @@ displayRepositoryError err = case err of
displayInternalError :: InternalError -> [String]
displayInternalError e = case e of
- JSONError src r ->
- [ "Error in JSON " ++ displayJSONSource src ++ ":"
- , T.unpack (Bower.displayError r)
- ]
CouldntParseGitTagDate tag ->
[ "Unable to parse the date for a git tag: " ++ T.unpack tag
]
-displayJSONSource :: JSONSource -> String
-displayJSONSource s = case s of
- FromFile fp ->
- "in file " ++ show fp
- FromResolutions ->
- "in resolutions file"
-
displayOtherError :: OtherError -> Box
displayOtherError e = case e of
ProcessFailed prog args exc ->
@@ -303,42 +294,43 @@ displayOtherError e = case e of
[ "An IO exception occurred:", show exc ]
data CollectedWarnings = CollectedWarnings
- { noResolvedVersions :: [PackageName]
- , undeclaredDependencies :: [PackageName]
- , unacceptableVersions :: [(PackageName, Text)]
- , dirtyWorkingTree :: Any
- , missingPaths :: [PackageName]
+ { noResolvedVersions :: [PackageName]
+ , unacceptableVersions :: [(PackageName, Text)]
+ , dirtyWorkingTree :: Any
+ , legacyResolutionsFormat :: Maybe (First FilePath)
}
deriving (Show, Eq, Ord)
instance Semigroup CollectedWarnings where
- (CollectedWarnings as bs cs d es) <> (CollectedWarnings as' bs' cs' d' es') =
- CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') (es <> es')
+ (<>) (CollectedWarnings a b c d) (CollectedWarnings a' b' c' d') =
+ CollectedWarnings (a <> a') (b <> b') (c <> c') (d <> d')
instance Monoid CollectedWarnings where
- mempty = CollectedWarnings mempty mempty mempty mempty mempty
+ mempty = CollectedWarnings mempty mempty mempty mempty
collectWarnings :: [PackageWarning] -> CollectedWarnings
collectWarnings = foldMap singular
where
singular w = case w of
- NoResolvedVersion pn -> CollectedWarnings [pn] mempty mempty mempty mempty
- UndeclaredDependency pn -> CollectedWarnings mempty [pn] mempty mempty mempty
- UnacceptableVersion t -> CollectedWarnings mempty mempty [t] mempty mempty
- DirtyWorkingTree_Warn -> CollectedWarnings mempty mempty mempty (Any True) mempty
- MissingPath pn -> CollectedWarnings mempty mempty mempty mempty [pn]
+ NoResolvedVersion pn ->
+ mempty { noResolvedVersions = [pn] }
+ UnacceptableVersion t ->
+ mempty { unacceptableVersions = [t] }
+ DirtyWorkingTree_Warn ->
+ mempty { dirtyWorkingTree = Any True }
+ LegacyResolutionsFormat path ->
+ mempty { legacyResolutionsFormat = Just (First path) }
renderWarnings :: [PackageWarning] -> Box
renderWarnings warns =
let CollectedWarnings{..} = collectWarnings warns
go toBox warns' = toBox <$> NonEmpty.nonEmpty warns'
- mboxes = [ go warnNoResolvedVersions noResolvedVersions
- , go warnUndeclaredDependencies undeclaredDependencies
- , go warnUnacceptableVersions unacceptableVersions
+ mboxes = [ go warnNoResolvedVersions noResolvedVersions
+ , go warnUnacceptableVersions unacceptableVersions
, if getAny dirtyWorkingTree
then Just warnDirtyWorkingTree
else Nothing
- , go warnMissingPaths missingPaths
+ , fmap (warnLegacyResolutions . getFirst) legacyResolutionsFormat
]
in case catMaybes mboxes of
[] -> nullBox
@@ -369,21 +361,6 @@ warnNoResolvedVersions pkgNames =
])
]
-warnUndeclaredDependencies :: NonEmpty PackageName -> Box
-warnUndeclaredDependencies pkgNames =
- let singular = NonEmpty.length pkgNames == 1
- pl a b = if singular then b else a
-
- packages = pl "packages" "package"
- are = pl "are" "is"
- dependencies = pl "dependencies" "a dependency"
- in vcat $
- para (concat
- [ "The following ", packages, " ", are, " installed, but not "
- , "declared as ", dependencies, " in your package manifest file:"
- ])
- : bulletedListT runPackageName (NonEmpty.toList pkgNames)
-
warnUnacceptableVersions :: NonEmpty (PackageName, Text) -> Box
warnUnacceptableVersions pkgs =
let singular = NonEmpty.length pkgs == 1
@@ -419,18 +396,20 @@ warnDirtyWorkingTree =
++ "were not a dry run)"
)
-warnMissingPaths :: NonEmpty PackageName -> Box
-warnMissingPaths pkgs =
- let singular = NonEmpty.length pkgs == 1
- pl a b = if singular then b else a
-
- packages = pl "packages" "package"
- in vcat $
- para (concat
- [ "The following installed ", packages, " were "
- , "missing path information in the resolutions file:"
- ])
- : bulletedListT runPackageName (NonEmpty.toList pkgs)
+warnLegacyResolutions :: FilePath -> Box
+warnLegacyResolutions path =
+ vcat $
+ [ para (concat
+ [ "Your resolutions file (" ++ path ++ ") is using the deprecated "
+ , "legacy format. Support for this format will be dropped in a future "
+ , "version."
+ ])
+ , spacer
+ , para (concat
+ [ "In most cases, all you need to do to use the new format and silence "
+ , "this warning is to upgrade Pulp."
+ ])
+ ]
printWarnings :: [PackageWarning] -> IO ()
printWarnings = printToStderr . renderWarnings
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 8348563..54370a4 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -205,7 +205,7 @@ renameInModule imports (Module modSS coms mn decls exps) =
fmap (bound,) $
DataDeclaration sa dtype name
<$> updateTypeArguments args
- <*> traverse (sndM (traverse updateTypesEverywhere)) dctors
+ <*> traverse (sndM (traverse (sndM updateTypesEverywhere))) dctors
updateDecl bound (TypeSynonymDeclaration sa name ps ty) =
fmap (bound,) $
TypeSynonymDeclaration sa name
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 9a2868f..20a2e04 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -315,7 +315,7 @@ updateTypes goType = (goDecl, goExpr, goBinder)
goDecl :: Declaration -> m Declaration
goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) =
- DataDeclaration sa ddt name args <$> traverse (sndM (traverse (goType' ss))) dctors
+ DataDeclaration sa ddt name args <$> traverse (sndM (traverse (sndM (goType' ss)))) dctors
goDecl (ExternDeclaration sa@(ss, _) name ty) =
ExternDeclaration sa name <$> goType' ss ty
goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 08e4af2..734a98a 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -14,7 +14,8 @@ import Control.Arrow (first, second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State
import Control.Monad.Supply.Class
-import Data.List (find, sortBy)
+import Data.Graph
+import Data.List (find, partition)
import qualified Data.Map as M
import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe)
import qualified Data.List.NonEmpty as NEL
@@ -72,14 +73,31 @@ desugarModule
=> Module
-> Desugar m Module
desugarModule (Module ss coms name decls (Just exps)) = do
- (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)
- return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
+ let (classDecls, restDecls) = partition isTypeClassDeclaration decls
+ classVerts = fmap (\d -> (d, classDeclName d, superClassesNames d)) classDecls
+ (classNewExpss, classDeclss) <- unzip <$> parU (stronglyConnComp classVerts) (desugarClassDecl name exps)
+ (restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl name exps)
+ return $ Module ss coms name (concat restDeclss ++ concat classDeclss) $ Just (exps ++ catMaybes restNewExpss ++ catMaybes classNewExpss)
where
- classesFirst :: Declaration -> Declaration -> Ordering
- classesFirst d1 d2
- | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT
- | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT
- | otherwise = EQ
+ desugarClassDecl :: (MonadSupply m, MonadError MultipleErrors m)
+ => ModuleName
+ -> [DeclarationRef]
+ -> SCC Declaration
+ -> Desugar m (Maybe DeclarationRef, [Declaration])
+ desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl name' exps' d
+ desugarClassDecl _ _ (CyclicSCC ds') = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeClassDeclaration (map classDeclName ds')
+
+ superClassesNames :: Declaration -> [ProperName 'ClassName]
+ superClassesNames (TypeClassDeclaration _ _ _ implies _ _) = fmap superClassName implies
+ superClassesNames _ = []
+
+ superClassName :: SourceConstraint -> ProperName 'ClassName
+ superClassName (Constraint _ (Qualified _ cName) _ _) = cName
+
+ classDeclName :: Declaration -> ProperName 'ClassName
+ classDeclName (TypeClassDeclaration _ pn _ _ _ _) = pn
+ classDeclName _ = internalError "Expected TypeClassDeclaration"
+
desugarModule _ = internalError "Exports should have been elaborated in name desugaring"
{- Desugar type class and type class instance declarations
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index 8851d9d..25c380f 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -205,7 +205,7 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do
tyCon <- findTypeDecl ss tyConNm ds
go tyCon
where
- go (DataDeclaration _ Newtype _ tyArgNames [(_, [wrapped])]) = do
+ go (DataDeclaration _ Newtype _ tyArgNames [(_, [(_, wrapped)])]) = do
-- The newtype might not be applied to all type arguments.
-- This is okay as long as the newtype wraps something which ends with
-- sufficiently many type applications to variables.
@@ -337,10 +337,10 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do
compN n f = f . compN (n - 1) f
makeInst
- :: (ProperName 'ConstructorName, [SourceType])
+ :: (ProperName 'ConstructorName, [(Ident, SourceType)])
-> m (SourceType, CaseAlternative, CaseAlternative)
makeInst (ctorName, args) = do
- args' <- mapM (replaceAllTypeSynonymsM syns) args
+ args' <- mapM (replaceAllTypeSynonymsM syns . snd) args
(ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args'
return ( srcTypeApp (srcTypeApp (srcTypeConstructor constructor)
(srcTypeLevelString $ mkString (runProperName ctorName)))
@@ -468,11 +468,11 @@ deriveEq ss mn syns ds tyConNm = do
where
catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (Literal ss (BooleanLiteral False)))
- mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative
+ mkCtorClause :: (ProperName 'ConstructorName, [(Ident, SourceType)]) -> m CaseAlternative
mkCtorClause (ctorName, tys) = do
identsL <- replicateM (length tys) (freshIdent "l")
identsR <- replicateM (length tys) (freshIdent "r")
- tys' <- mapM (replaceAllTypeSynonymsM syns) tys
+ tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys
let tests = zipWith3 toEqTest (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys'
return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (unguarded (conjAll tests))
where
@@ -547,11 +547,11 @@ deriveOrd ss mn syns ds tyConNm = do
ordCompare1 :: Expr -> Expr -> Expr
ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident C.compare1)))
- mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> m [CaseAlternative]
+ mkCtorClauses :: ((ProperName 'ConstructorName, [(Ident, SourceType)]), Bool) -> m [CaseAlternative]
mkCtorClauses ((ctorName, tys), isLast) = do
identsL <- replicateM (length tys) (freshIdent "l")
identsR <- replicateM (length tys) (freshIdent "r")
- tys' <- mapM (replaceAllTypeSynonymsM syns) tys
+ tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys
let tests = zipWith3 toOrdering (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys'
extras | not isLast = [ CaseAlternative [ ConstructorBinder ss (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
, NullBinder
@@ -622,7 +622,7 @@ deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do
checkNewtype name dctors
wrappedIdent <- freshIdent "n"
unwrappedIdent <- freshIdent "a"
- let (ctorName, [ty]) = head dctors
+ let (ctorName, [(_, ty)]) = head dctors
ty' <- replaceAllTypeSynonymsM syns ty
let inst =
[ ValueDecl (ss', []) (Ident "wrap") Public [] $ unguarded $
@@ -707,10 +707,10 @@ deriveFunctor ss mn syns ds tyConNm = do
lam ss' f . lamCase ss' m <$> mapM (mkCtorClause iTy f) ctors
mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration"
- mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative
+ mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [(Ident, SourceType)]) -> m CaseAlternative
mkCtorClause iTyName f (ctorName, ctorTys) = do
idents <- replicateM (length ctorTys) (freshIdent "v")
- ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys
+ ctorTys' <- mapM (replaceAllTypeSynonymsM syns . snd) ctorTys
args <- zipWithM transformArg idents ctorTys'
let ctor = Constructor ss (Qualified (Just mn) ctorName)
rebuilt = foldl' App ctor args
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 58a05a4..5bacf63 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -12,6 +12,7 @@ module Language.PureScript.TypeChecker
import Prelude.Compat
import Protolude (ordNub)
+import Control.Arrow (second)
import Control.Monad (when, unless, void, forM)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), modify, gets)
@@ -49,15 +50,15 @@ addDataType
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceKind)]
- -> [(ProperName 'ConstructorName, [SourceType])]
+ -> [(ProperName 'ConstructorName, [(Ident, SourceType)])]
-> SourceKind
-> m ()
addDataType moduleName dtype name args dctors ctorKind = do
env <- getEnv
- putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
- for_ dctors $ \(dctor, tys) ->
+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args (map (second (map snd)) dctors)) (types env) }
+ for_ dctors $ \(dctor, fields) ->
warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $
- addDataConstructor moduleName dtype name (map fst args) dctor tys
+ addDataConstructor moduleName dtype name (map fst args) dctor fields
addDataConstructor
:: (MonadState CheckState m, MonadError MultipleErrors m)
@@ -66,15 +67,15 @@ addDataConstructor
-> ProperName 'TypeName
-> [Text]
-> ProperName 'ConstructorName
- -> [SourceType]
+ -> [(Ident, SourceType)]
-> m ()
-addDataConstructor moduleName dtype name args dctor tys = do
+addDataConstructor moduleName dtype name args dctor dctorArgs = do
+ let (fields, tys) = unzip dctorArgs
env <- getEnv
traverse_ checkTypeSynonyms tys
let retTy = foldl srcTypeApp (srcTypeConstructor (Qualified (Just moduleName) name)) (map srcTypeVar args)
let dctorTy = foldr function retTy tys
let polyType = mkForAll (map (NullSourceAnn,) args) dctorTy
- let fields = [Ident ("value" <> T.pack (show n)) | n <- [0..(length tys - 1)]]
putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
addTypeSynonym
@@ -236,7 +237,7 @@ typeCheckAll moduleName _ = traverse go
warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do
when (dtype == Newtype) $ checkNewtype name dctors
checkDuplicateTypeArguments $ map fst args
- ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
+ ctorKind <- kindsOf True moduleName name args (concatMap (fmap snd . snd) dctors)
let args' = args `withKinds` ctorKind
addDataType moduleName dtype name args' dctors ctorKind
return $ DataDeclaration sa dtype name args dctors
@@ -247,7 +248,7 @@ typeCheckAll moduleName _ = traverse go
bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._3))
sss = fmap declSourceSpan tys
warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do
- (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap snd dctors)) dataDecls)
+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap (fmap snd . snd) dctors)) dataDecls)
for_ (zip dataDecls data_ks) $ \((_, dtype, name, args, dctors), ctorKind) -> do
when (dtype == Newtype) $ checkNewtype name dctors
checkDuplicateTypeArguments $ map fst args
@@ -494,7 +495,7 @@ checkNewtype
:: forall m
. MonadError MultipleErrors m
=> ProperName 'TypeName
- -> [(ProperName 'ConstructorName, [SourceType])]
+ -> [(ProperName 'ConstructorName, [(Ident, SourceType)])]
-> m ()
checkNewtype _ [(_, [_])] = return ()
checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
diff --git a/stack.yaml b/stack.yaml
index 332e29d..ac8c3aa 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-12.0
+resolver: lts-13.12
packages:
- '.'
extra-deps:
@@ -6,3 +6,7 @@ nix:
enable: false
packages:
- zlib
+ # Test dependencies
+ - nodejs
+ - nodePackages.npm
+ - nodePackages.bower
diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs
index c9a84cf..0a85fda 100644
--- a/tests/Language/PureScript/Ide/CompletionSpec.hs
+++ b/tests/Language/PureScript/Ide/CompletionSpec.hs
@@ -65,3 +65,10 @@ spec = describe "Applying completion options" $ do
, typ "withType"
]
result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n"
+
+ it "gets docs on module declaration" $ do
+ ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
+ Test.runIde [ load ["CompletionSpecDocs"]
+ , typ "CompletionSpecDocs"
+ ]
+ result `shouldSatisfy` \res -> complDocumentation res == Just "Module Documentation\n"
diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs
index ed0e376..84a0e50 100644
--- a/tests/Language/PureScript/Ide/FilterSpec.hs
+++ b/tests/Language/PureScript/Ide/FilterSpec.hs
@@ -3,7 +3,8 @@
module Language.PureScript.Ide.FilterSpec where
import Protolude
-import Data.List.NonEmpty
+import qualified Data.Map as Map
+import qualified Data.Set as Set
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Filter.Declaration as D
import Language.PureScript.Ide.Types
@@ -24,23 +25,23 @@ moduleG = (P.moduleNameFromString "Module.G", [T.ideTypeClass "MyClass" P.kindTy
moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing])
moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing])
-modules :: [Module]
-modules = [moduleA, moduleB]
+modules :: ModuleMap [IdeDeclarationAnn]
+modules = Map.fromList [moduleA, moduleB]
runEq :: Text -> [Module]
-runEq s = applyFilters [equalityFilter s] modules
+runEq s = Map.toList (applyFilters [exactFilter s] modules)
runPrefix :: Text -> [Module]
-runPrefix s = applyFilters [prefixFilter s] modules
+runPrefix s = Map.toList $ applyFilters [prefixFilter s] modules
runModule :: [P.ModuleName] -> [Module]
-runModule ms = applyFilters [moduleFilter ms] modules
+runModule ms = Map.toList $ applyFilters [moduleFilter (Set.fromList ms)] modules
-runNamespace :: NonEmpty IdeNamespace -> [Module] -> [Module]
-runNamespace namespaces = applyFilters [namespaceFilter namespaces]
+runNamespace :: Set IdeNamespace -> [Module] -> [Module]
+runNamespace namespaces = Map.toList . applyFilters [namespaceFilter namespaces] . Map.fromList
-runDeclaration :: [D.IdeDeclaration] -> [Module] -> [Module]
-runDeclaration decls = applyFilters [declarationTypeFilter decls]
+runDeclaration :: [D.DeclarationType] -> [Module] -> [Module]
+runDeclaration decls = Map.toList . applyFilters [declarationTypeFilter (Set.fromList decls)] . Map.fromList
spec :: Spec
spec = do
@@ -53,7 +54,7 @@ spec = do
runEq "data1" `shouldBe` [moduleB]
describe "prefixFilter" $ do
it "keeps everything on empty string" $
- runPrefix "" `shouldBe` modules
+ runPrefix "" `shouldBe` Map.toList modules
it "keeps functionname prefix matches" $
runPrefix "fun" `shouldBe` [moduleA]
it "keeps data decls prefix matches" $
@@ -67,102 +68,91 @@ spec = do
runModule (P.moduleNameFromString <$> ["Module.A", "Unknown"]) `shouldBe` [moduleA]
describe "namespaceFilter" $ do
it "extracts modules by filtering `value` namespaces" $
- runNamespace (fromList [IdeNSValue])
+ runNamespace (Set.fromList [IdeNSValue])
[moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB]
it "extracts no modules by filtering `value` namespaces" $
- runNamespace (fromList [IdeNSValue])
+ runNamespace (Set.fromList [IdeNSValue])
[moduleD] `shouldBe` []
it "extracts modules by filtering `type` namespaces" $
- runNamespace (fromList [IdeNSType])
+ runNamespace (Set.fromList [IdeNSType])
[moduleA, moduleB, moduleC] `shouldBe` [moduleC]
it "extracts no modules by filtering `type` namespaces" $
- runNamespace (fromList [IdeNSType])
+ runNamespace (Set.fromList [IdeNSType])
[moduleA, moduleB] `shouldBe` []
it "extracts modules by filtering `kind` namespaces" $
- runNamespace (fromList [IdeNSKind])
+ runNamespace (Set.fromList [IdeNSKind])
[moduleA, moduleB, moduleD] `shouldBe` [moduleD]
it "extracts no modules by filtering `kind` namespaces" $
- runNamespace (fromList [IdeNSKind])
+ runNamespace (Set.fromList [IdeNSKind])
[moduleA, moduleB] `shouldBe` []
it "extracts modules by filtering `value` and `type` namespaces" $
- runNamespace (fromList [ IdeNSValue, IdeNSType])
+ runNamespace (Set.fromList [ IdeNSValue, IdeNSType])
[moduleA, moduleB, moduleC, moduleD]
`shouldBe` [moduleA, moduleB, moduleC]
it "extracts modules by filtering `value` and `kind` namespaces" $
- runNamespace (fromList [ IdeNSValue, IdeNSKind])
+ runNamespace (Set.fromList [ IdeNSValue, IdeNSKind])
[moduleA, moduleB, moduleC, moduleD]
`shouldBe` [moduleA, moduleB, moduleD]
it "extracts modules by filtering `type` and `kind` namespaces" $
- runNamespace (fromList [ IdeNSType, IdeNSKind])
+ runNamespace (Set.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])
+ runNamespace (Set.fromList [ IdeNSValue, IdeNSType, IdeNSKind])
[moduleA, moduleB, moduleC, moduleD]
`shouldBe` [moduleA, moduleB, moduleC, moduleD]
describe "declarationTypeFilter" $ do
- let moduleADecl = D.IdeDeclaration D.Value
- moduleCDecl = D.IdeDeclaration D.Type
- moduleDDecl = D.IdeDeclaration D.Kind
- moduleEDecl = D.IdeDeclaration D.Synonym
- moduleFDecl = D.IdeDeclaration D.DataConstructor
- moduleGDecl = D.IdeDeclaration D.TypeClass
- moduleHDecl = D.IdeDeclaration D.ValueOperator
- moduleIDecl = D.IdeDeclaration D.TypeOperator
- it "keeps everything on empty list of declarations" $
- runDeclaration []
- [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB, moduleD]
it "extracts modules by filtering `value` declarations" $
- runDeclaration [moduleADecl]
+ runDeclaration [D.Value]
[moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB]
it "removes everything if no `value` declarations has been found" $
- runDeclaration [moduleADecl]
+ runDeclaration [D.Value]
[moduleD, moduleG, moduleE, moduleH] `shouldBe` []
it "extracts module by filtering `type` declarations" $
- runDeclaration [moduleCDecl]
+ runDeclaration [D.Type]
[moduleA, moduleB, moduleC, moduleD, moduleE] `shouldBe` [moduleC]
it "removes everything if a `type` declaration have not been found" $
- runDeclaration [moduleCDecl]
+ runDeclaration [D.Type]
[moduleA, moduleG, moduleE, moduleH] `shouldBe` []
it "extracts module by filtering `synonym` declarations" $
- runDeclaration [moduleEDecl]
+ runDeclaration [D.Synonym]
[moduleA, moduleB, moduleD, moduleE] `shouldBe` [moduleE]
it "removes everything if a `synonym` declaration have not been found" $
- runDeclaration [moduleEDecl]
+ runDeclaration [D.Synonym]
[moduleA, moduleB, moduleC, moduleH] `shouldBe` []
it "extracts module by filtering `constructor` declarations" $
- runDeclaration [moduleFDecl]
+ runDeclaration [D.DataConstructor]
[moduleA, moduleB, moduleC, moduleF] `shouldBe` [moduleF]
it "removes everything if a `constructor` declaration have not been found" $
- runDeclaration [moduleFDecl]
+ runDeclaration [D.DataConstructor]
[moduleA, moduleB, moduleC, moduleH] `shouldBe` []
it "extracts module by filtering `typeclass` declarations" $
- runDeclaration [moduleGDecl]
+ runDeclaration [D.TypeClass]
[moduleA, moduleC, moduleG] `shouldBe` [moduleG]
it "removes everything if a `typeclass` declaration have not been found" $
- runDeclaration [moduleGDecl]
+ runDeclaration [D.TypeClass]
[moduleA, moduleB, moduleC, moduleH] `shouldBe` []
it "extracts modules by filtering `valueoperator` declarations" $
- runDeclaration [moduleHDecl]
+ runDeclaration [D.ValueOperator]
[moduleA, moduleC, moduleG, moduleH, moduleF] `shouldBe` [moduleH]
it "removes everything if a `valueoperator` declaration have not been found" $
- runDeclaration [moduleHDecl]
+ runDeclaration [D.ValueOperator]
[moduleA, moduleB, moduleC, moduleD] `shouldBe` []
it "extracts modules by filtering `typeoperator` declarations" $
- runDeclaration [moduleIDecl]
+ runDeclaration [D.TypeOperator]
[moduleA, moduleC, moduleG, moduleI, moduleF] `shouldBe` [moduleI]
it "removes everything if a `typeoperator` declaration have not been found" $
- runDeclaration [moduleIDecl]
+ runDeclaration [D.TypeOperator]
[moduleA, moduleD] `shouldBe` []
it "extracts module by filtering `kind` declarations" $
- runDeclaration [moduleCDecl]
- [moduleA, moduleC, moduleG, moduleI, moduleF] `shouldBe` [moduleC]
+ runDeclaration [D.Kind]
+ [moduleA, moduleD, moduleG, moduleI, moduleF] `shouldBe` [moduleD]
it "removes everything if a `kind` declaration have not been found" $
- runDeclaration [moduleCDecl]
- [moduleA, moduleD] `shouldBe` []
+ runDeclaration [D.Kind]
+ [moduleA, moduleC] `shouldBe` []
it "extracts modules by filtering `value` and `synonym` declarations" $
- runDeclaration [moduleADecl, moduleEDecl]
+ runDeclaration [D.Value, D.Synonym]
[moduleA, moduleB, moduleD, moduleE] `shouldBe` [moduleA, moduleB, moduleE]
- it "extracts modules by filtering `kind`, `synonym` and `valueoperator` declarations" $
- runDeclaration [moduleADecl, moduleDDecl, moduleHDecl]
+ it "extracts modules by filtering `value`, `kind`, and `valueoperator` declarations" $
+ runDeclaration [D.Value, D.Kind, D.ValueOperator]
[moduleA, moduleB, moduleD, moduleG, moduleE, moduleH] `shouldBe` [moduleA, moduleB, moduleD, moduleH]
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index f84d088..5c29c86 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -3,9 +3,10 @@
module Language.PureScript.Ide.ImportsSpec where
import Protolude hiding (moduleName)
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust)
+import qualified Data.Set as Set
-import qualified Language.PureScript as P
+import qualified Language.PureScript as P
import Language.PureScript.Ide.Command as Command
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Imports
@@ -48,9 +49,9 @@ syntaxErrorFile =
]
testSliceImportSection :: [Text] -> (P.ModuleName, [Text], [Import], [Text])
-testSliceImportSection = fromRight . sliceImportSection
+testSliceImportSection = unsafeFromRight . sliceImportSection
where
- fromRight = fromJust . rightToMaybe
+ unsafeFromRight = fromJust . rightToMaybe
withImports :: [Text] -> [Text]
withImports is =
@@ -346,7 +347,7 @@ addExplicitImport i =
addExplicitImportFiltered :: Text -> [P.ModuleName] -> Command
addExplicitImportFiltered i ms =
- Command.Import ("src" </> "ImportsSpec.purs") Nothing [moduleFilter ms] (Command.AddImportForIdentifier i Nothing)
+ Command.Import ("src" </> "ImportsSpec.purs") Nothing [moduleFilter (Set.fromList ms)] (Command.AddImportForIdentifier i Nothing)
importShouldBe :: [Text] -> [Text] -> Expectation
importShouldBe res importSection =
diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs
index 2ef859e..20a6258 100644
--- a/tests/Language/PureScript/Ide/SourceFileSpec.hs
+++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs
@@ -93,6 +93,9 @@ spec = do
it "finds a type operator declaration" $ do
Just r <- getLocation "~>"
r `shouldBe` typeOpSS
+ it "finds a module declaration" $ do
+ Just r <- getLocation "SfModule"
+ r `shouldBe` moduleSS
getLocation :: Text -> IO (Maybe P.SourceSpan)
getLocation s = do
@@ -102,7 +105,8 @@ getLocation s = do
where
ideState = emptyIdeState `volatileState`
[ ("Test",
- [ ideValue "sfValue" Nothing `annLoc` valueSS
+ [ ideModule "SfModule" `annLoc` moduleSS
+ , ideValue "sfValue" Nothing `annLoc` valueSS
, ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS
, ideType "SFData" Nothing [] `annLoc` typeSS
, ideDtor "SFOne" "SFData" Nothing `annLoc` typeSS
diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs
index 5cf613f..6164e02 100644
--- a/tests/Language/PureScript/Ide/Test.hs
+++ b/tests/Language/PureScript/Ide/Test.hs
@@ -101,7 +101,11 @@ ideTypeOp opName ident precedence assoc k =
ideKind :: Text -> IdeDeclarationAnn
ideKind pn = ida (IdeDeclKind (P.ProperName pn))
-valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan
+ideModule :: Text -> IdeDeclarationAnn
+ideModule name = ida (IdeDeclModule (mn name))
+
+moduleSS, valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan
+moduleSS = ss 1 1
valueSS = ss 3 1
synonymSS = ss 5 1
typeSS = ss 7 1
diff --git a/tests/Main.hs b/tests/Main.hs
index 9214ff3..e7c29b4 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -18,6 +18,7 @@ import qualified TestPrimDocs
import qualified TestPsci
import qualified TestIde
import qualified TestPscPublish
+import qualified TestBundle
import qualified TestUtils
import System.IO (hSetEncoding, stdout, stderr, utf8)
@@ -29,14 +30,14 @@ main = do
heading "Updating support code"
TestUtils.updateSupportCode
- heading "Prim documentation test suite"
- TestPrimDocs.main
ideTests <- TestIde.main
compilerTests <- TestCompiler.main
psciTests <- TestPsci.main
+ pscBundleTests <- TestBundle.main
coreFnTests <- TestCoreFn.main
docsTests <- TestDocs.main
+ primDocsTests <- TestPrimDocs.main
publishTests <- TestPscPublish.main
hierarchyTests <- TestHierarchy.main
@@ -45,9 +46,11 @@ main = do
"Tests"
[ compilerTests
, psciTests
+ , pscBundleTests
, ideTests
, coreFnTests
, docsTests
+ , primDocsTests
, publishTests
, hierarchyTests
]
diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs
new file mode 100644
index 0000000..cbdcf68
--- /dev/null
+++ b/tests/TestBundle.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module TestBundle where
+
+import Prelude ()
+import Prelude.Compat
+
+import qualified Language.PureScript as P
+import Language.PureScript.Bundle
+
+import Data.Function (on)
+import Data.List (minimumBy)
+
+import qualified Data.Map as M
+
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except
+
+import System.Exit
+import System.Process
+import System.FilePath
+import System.IO
+import System.IO.UTF8
+import qualified System.FilePath.Glob as Glob
+
+import TestUtils
+import Test.Tasty
+import Test.Tasty.Hspec
+
+main :: IO TestTree
+main = testSpec "bundle" spec
+
+spec :: Spec
+spec = do
+ (supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules
+ bundleTestCases <- runIO $ getTestFiles "bundle"
+ outputFile <- runIO $ createOutputFile logfile
+
+ context "Bundle examples" $
+ forM_ bundleTestCases $ \testPurs -> do
+ it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile, bundle and run without error") $
+ assertBundles supportModules supportExterns supportForeigns testPurs outputFile
+ where
+
+ -- Takes the test entry point from a group of purs files - this is determined
+ -- by the file with the shortest path name, as everything but the main file
+ -- will be under a subdirectory.
+ getTestMain :: [FilePath] -> FilePath
+ getTestMain = minimumBy (compare `on` length)
+
+assertBundles
+ :: [P.Module]
+ -> [P.ExternsFile]
+ -> M.Map P.ModuleName FilePath
+ -> [FilePath]
+ -> Handle
+ -> Expectation
+assertBundles 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
+ process <- findNodeProcess
+ jsFiles <- Glob.globDir1 (Glob.compile "**/*.js") modulesDir
+ let entryPoint = modulesDir </> "index.js"
+ let entryModule = map (`ModuleIdentifier` Regular) ["Main"]
+ bundled <- runExceptT $ do
+ input <- forM jsFiles $ \filename -> do
+ js <- liftIO $ readUTF8File filename
+ mid <- guessModuleIdentifier filename
+ length js `seq` return (mid, Just filename, js)
+ bundleSM input entryModule (Just $ "Main") "PS" (Just entryPoint)
+ case bundled of
+ Right (_, js) -> do
+ writeUTF8File entryPoint js
+ result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
+ hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"
+ case result of
+ Just (ExitSuccess, out, err)
+ | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
+ | not (null out) && trim (last (lines out)) == "Done" -> do
+ hPutStr outputFile out
+ return Nothing
+ | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
+ Just (ExitFailure _, _, err) -> return $ Just err
+ Nothing -> return $ Just "Couldn't find node.js executable"
+ Left err -> return . Just $ "Coud not bundle: " ++ show err
+
+logfile :: FilePath
+logfile = "bundle-tests.out"
diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs
index ddd7eda..5c082da 100644
--- a/tests/TestCompiler.hs
+++ b/tests/TestCompiler.hs
@@ -26,29 +26,21 @@ import Prelude.Compat
import qualified Language.PureScript as P
-import Data.Char (isSpace)
+import Control.Arrow ((>>>))
import Data.Function (on)
-import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)
+import Data.List (sort, stripPrefix, intercalate, minimumBy)
import Data.Maybe (mapMaybe)
-import Data.Time.Clock (UTCTime())
import qualified Data.Text as T
-import Data.Tuple (swap)
import qualified Data.Map as M
import Control.Monad
-import Control.Arrow ((***), (>>>))
-
-import Control.Monad.Reader
-import Control.Monad.Trans.Except
import System.Exit
-import System.Process hiding (cwd)
+import System.Process
import System.FilePath
-import System.Directory
import System.IO
-import System.IO.UTF8
-import qualified System.FilePath.Glob as Glob
+import System.IO.UTF8 (readUTF8File)
import TestUtils
import Test.Tasty
@@ -59,29 +51,14 @@ main = testSpec "compiler" spec
spec :: Spec
spec = do
+ (supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules
+
+ (passingTestCases, warningTestCases, failingTestCases) <- runIO $
+ (,,) <$> getTestFiles "passing"
+ <*> getTestFiles "warning"
+ <*> getTestFiles "failing"
- (supportModules, supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do
- cwd <- getCurrentDirectory
- let passing = cwd </> "tests" </> "purs" </> "passing"
- let warning = cwd </> "tests" </> "purs" </> "warning"
- let failing = cwd </> "tests" </> "purs" </> "failing"
- passingFiles <- getTestFiles passing <$> testGlob passing
- warningFiles <- getTestFiles warning <$> testGlob warning
- failingFiles <- getTestFiles failing <$> testGlob failing
- ms <- getSupportModuleTuples
- let modules = map snd ms
- supportExterns <- runExceptT $ do
- 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 (modules, externs, foreigns, passingFiles, warningFiles, failingFiles)
-
- outputFile <- runIO $ do
- tmp <- getTemporaryDirectory
- createDirectoryIfMissing False (tmp </> logpath)
- openFile (tmp </> logpath </> logfile) WriteMode
+ outputFile <- runIO $ createOutputFile logfile
context "Passing examples" $
forM_ passingTestCases $ \testPurs ->
@@ -104,36 +81,12 @@ spec = do
where
- -- A glob for all purs and js files within a test directory
- testGlob :: FilePath -> IO [FilePath]
- testGlob = Glob.globDir1 (Glob.compile "**/*.purs")
-
- -- Groups the test files so that a top-level file can have dependencies in a
- -- subdirectory of the same name. The inner tuple contains a list of the
- -- .purs files and the .js files for the test case.
- getTestFiles :: FilePath -> [FilePath] -> [[FilePath]]
- getTestFiles baseDir
- = map (filter ((== ".purs") . takeExtensions) . map (baseDir </>))
- . groupBy ((==) `on` extractPrefix)
- . sortBy (compare `on` extractPrefix)
- . map (makeRelative baseDir)
-
-- Takes the test entry point from a group of purs files - this is determined
-- by the file with the shortest path name, as everything but the main file
-- will be under a subdirectory.
getTestMain :: [FilePath] -> FilePath
getTestMain = minimumBy (compare `on` length)
- -- Extracts the filename part of a .purs file, or if the file is in a
- -- subdirectory, the first part of that directory path.
- extractPrefix :: FilePath -> FilePath
- extractPrefix fp =
- let dir = takeDirectory fp
- ext = reverse ".purs"
- in if dir == "."
- then maybe fp reverse $ stripPrefix ext $ reverse fp
- else dir
-
-- Scans a file for @shouldFailWith directives in the comments, used to
-- determine expected failures
getShouldFailWith :: FilePath -> IO [String]
@@ -147,80 +100,8 @@ spec = do
extractPragma :: String -> FilePath -> IO [String]
extractPragma pragma = fmap go . readUTF8File
where
- go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim
-
-inferForeignModules
- :: MonadIO m
- => [(FilePath, P.Module)]
- -> m (M.Map P.ModuleName FilePath)
-inferForeignModules = P.inferForeignModules . fromList
- where
- fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
- fromList = M.fromList . map ((P.getModuleName *** Right) . swap)
-
-trim :: String -> String
-trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
-
-modulesDir :: FilePath
-modulesDir = ".test_modules" </> "node_modules"
-
-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
- , P.progress = const (pure ())
- }
- where
- getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
- getInputTimestamp mn
- | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
- | otherwise = return (Left P.RebuildAlways)
- where
- isSupportModule = flip elem (map (P.runModuleName . P.getModuleName) modules)
-
- getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
- getOutputTimestamp mn = do
- let filePath = modulesDir </> T.unpack (P.runModuleName mn)
- exists <- liftIO $ doesDirectoryExist filePath
- return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
+ go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim
-runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)
-runTest = P.runMake P.defaultOptions
-
-compile
- :: [P.Module]
- -> [P.ExternsFile]
- -> M.Map P.ModuleName FilePath
- -> [FilePath]
- -> ([P.Module] -> IO ())
- -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
-compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do
- fs <- liftIO $ readInput inputFiles
- ms <- P.parseModulesFromFiles id fs
- foreigns <- inferForeignModules ms
- liftIO (check (map snd ms))
- let actions = makeActions supportModules (foreigns `M.union` supportForeigns)
- case ms of
- [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule)
- _ -> P.make actions (supportModules ++ map snd ms)
-
-assert
- :: [P.Module]
- -> [P.ExternsFile]
- -> M.Map P.ModuleName FilePath
- -> [FilePath]
- -> ([P.Module] -> IO ())
- -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))
- -> Expectation
-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
-
-checkMain :: [P.Module] -> IO ()
-checkMain ms =
- unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)
- (fail "Main module missing")
checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String
checkShouldFailWith expected errs =
@@ -323,8 +204,5 @@ assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles sh
where
noPreCheck = const (return ())
-logpath :: FilePath
-logpath = "purescript-output"
-
logfile :: FilePath
logfile = "psc-tests.out"
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 7a2ba81..9c7bdfb 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -275,7 +275,7 @@ displayAssertionFailure = \case
"expected " <> decl <> " to be a " <> expected <> " declaration, but it" <>
" was a " <> actual <> " declaration"
DeclarationWrongType _ decl actual ->
- decl <> " had the wrong type; got " <> T.pack (P.prettyPrintType actual)
+ decl <> " had the wrong type; got " <> T.pack (P.prettyPrintType maxBound actual)
TypeSynonymMismatch _ decl expected actual ->
"expected the RHS of " <> decl <> " to be " <> expected <>
"; got " <> actual
@@ -294,8 +294,8 @@ displayAssertionFailure = \case
"in rendered code for " <> decl <> ", bad link location for " <> target <>
": expected " <> T.pack (show expected) <>
" got " <> T.pack (show actual)
- WrongOrder _ before after ->
- "expected to see " <> before <> " before " <> after
+ WrongOrder _ before after' ->
+ "expected to see " <> before <> " before " <> after'
displayTagsAssertionFailure :: TagsAssertionFailure -> Text
displayTagsAssertionFailure = \case
@@ -438,22 +438,22 @@ runAssertion assertion linksCtx Docs.Module{..} =
Nothing ->
Fail (LinkedDeclarationMissing mn decl destTitle)
- ShouldComeBefore mn before after ->
+ ShouldComeBefore mn before after' ->
let
decls = declarationsFor mn
indexOf :: Text -> Maybe Int
indexOf title = findIndex ((==) title . Docs.declTitle) decls
in
- case (indexOf before, indexOf after) of
+ case (indexOf before, indexOf after') of
(Just i, Just j) ->
if i < j
then Pass
- else Fail (WrongOrder mn before after)
+ else Fail (WrongOrder mn before after')
(Nothing, _) ->
Fail (NotDocumented mn before)
(_, Nothing) ->
- Fail (NotDocumented mn after)
+ Fail (NotDocumented mn after')
where
declarationsFor mn =
diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs
index ef545de..03d94d8 100644
--- a/tests/TestPrimDocs.hs
+++ b/tests/TestPrimDocs.hs
@@ -2,38 +2,40 @@ module TestPrimDocs where
import Prelude
-import Control.Monad
-import Data.List ((\\))
+import Data.List (sort)
+import Control.Exception (evaluate)
+import Control.DeepSeq (force)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Language.PureScript as P
import qualified Language.PureScript.Docs as D
-import qualified Language.PureScript.Docs.AsMarkdown as D
-main :: IO ()
-main = do
- putStrLn "Test that there are no bottoms hiding in primDocsModule"
- seq (D.runDocs (D.modulesAsMarkdown D.primModules)) (return ())
+import Test.Tasty
+import Test.Tasty.Hspec (Spec, testSpec, it)
+import Test.Hspec (shouldBe)
- putStrLn "Test that Prim is fully documented"
- let actualPrimNames =
- -- note that prim type classes are listed in P.primTypes
- (map (P.runProperName . P.disqualify . fst) $ Map.toList
- ( P.primTypes <>
- P.primBooleanTypes <>
- P.primOrderingTypes <>
- P.primRowTypes <>
- P.primRowListTypes <>
- P.primTypeErrorTypes <>
- P.primSymbolTypes )) ++
- (map (P.runProperName . P.disqualify) $ Set.toList P.allPrimKinds)
- let documentedPrimNames = map D.declTitle (concatMap D.modDeclarations D.primModules)
+main :: IO TestTree
+main = testSpec "prim docs" spec
- let undocumentedNames = actualPrimNames \\ documentedPrimNames
- let extraNames = documentedPrimNames \\ actualPrimNames
+spec :: Spec
+spec = do
+ it "there are no bottoms hiding in primModules" $ do
+ _ <- evaluate (force D.primModules)
+ return ()
- when (not (null undocumentedNames)) $
- error $ "Undocumented Prim names: " ++ show undocumentedNames
+ it "all Prim modules are fully documented" $ do
+ let actualPrimNames =
+ -- note that prim type classes are listed in P.primTypes
+ (map (P.runProperName . P.disqualify . fst) $ Map.toList
+ ( P.primTypes <>
+ P.primBooleanTypes <>
+ P.primOrderingTypes <>
+ P.primRowTypes <>
+ P.primRowListTypes <>
+ P.primTypeErrorTypes <>
+ P.primSymbolTypes )) ++
+ (map (P.runProperName . P.disqualify) $ Set.toList P.allPrimKinds)
+ let documentedPrimNames =
+ map D.declTitle (concatMap D.modDeclarations D.primModules)
- when (not (null extraNames)) $
- error $ "Extra Prim names: " ++ show extraNames
+ sort documentedPrimNames `shouldBe` sort actualPrimNames
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
index d32853e..64dda76 100644
--- a/tests/TestPscPublish.hs
+++ b/tests/TestPscPublish.hs
@@ -29,10 +29,21 @@ main = testSpec "publish" spec
spec :: Spec
spec = do
- it "roundtrips the json for purescript-prelude" $ do
- testPackage
- "tests/support/bower_components/purescript-prelude"
- "../../prelude-resolutions.json"
+ context "preparePackage with json roundtrips" $ do
+ it "purescript-prelude" $ do
+ testPackage
+ "tests/support/bower_components/purescript-prelude"
+ "../../prelude-resolutions.json"
+
+ it "basic example" $ do
+ testPackage
+ "tests/purs/publish/basic-example"
+ "resolutions.json"
+
+ it "basic example with legacy resolutions file" $ do
+ testPackage
+ "tests/purs/publish/basic-example"
+ "resolutions-legacy.json"
context "json compatibility" $ do
let compatDir = "tests" </> "json-compat"
@@ -61,10 +72,10 @@ roundTrip pkg =
in case A.eitherDecode before of
Left err -> ParseFailed err
Right parsed -> do
- let after = A.encode (parsed :: UploadedPackage)
- if before == after
+ let after' = A.encode (parsed :: UploadedPackage)
+ if before == after'
then Pass before
- else Mismatch before after
+ else Mismatch before after'
testRunOptions :: PublishOptions
testRunOptions = defaultPublishOptions
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index 6c70807..f2c477f 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
module TestUtils where
@@ -7,20 +9,29 @@ import Prelude.Compat
import qualified Language.PureScript as P
+import Control.Arrow ((***), (>>>))
import Control.Monad
+import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Exception
-import Data.List (sort)
+import Data.Char (isSpace)
+import Data.Function (on)
+import Data.List (sort, sortBy, stripPrefix, groupBy)
+import qualified Data.Map as M
import qualified Data.Text as T
-import System.Process
+import Data.Time.Clock (UTCTime())
+import Data.Tuple (swap)
+import System.Process hiding (cwd)
import System.Directory
import System.Info
import System.IO.UTF8 (readUTF8FileT)
import System.Exit (exitFailure)
-import System.FilePath ((</>))
+import System.FilePath
import qualified System.FilePath.Glob as Glob
-import System.IO (stderr, hPutStrLn)
+import System.IO
+import Test.Tasty.Hspec
+
findNodeProcess :: IO (Maybe String)
findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
@@ -86,3 +97,142 @@ pushd dir act = do
result <- try act :: IO (Either IOException a)
setCurrentDirectory original
either throwIO return result
+
+
+createOutputFile :: FilePath -> IO Handle
+createOutputFile logfileName = do
+ tmp <- getTemporaryDirectory
+ createDirectoryIfMissing False (tmp </> logpath)
+ openFile (tmp </> logpath </> logfileName) WriteMode
+
+setupSupportModules :: IO ([P.Module], [P.ExternsFile], M.Map P.ModuleName FilePath)
+setupSupportModules = do
+ ms <- getSupportModuleTuples
+ let modules = map snd ms
+ supportExterns <- runExceptT $ do
+ 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 (modules, externs, foreigns)
+
+getTestFiles :: FilePath -> IO [[FilePath]]
+getTestFiles testDir = do
+ cwd <- getCurrentDirectory
+ let dir = cwd </> "tests" </> "purs" </> testDir
+ testsInPath <- getFiles dir <$> testGlob dir
+ let rerunPath = dir </> "RerunCompilerTests.txt"
+ hasRerunFile <- doesFileExist rerunPath
+ rerunTests <-
+ if hasRerunFile
+ then let compilerTestDir = cwd </> "tests" </> "purs" </> "passing"
+ textToTestFiles
+ = mapM (\path -> ((path ++ ".purs") :) <$> testGlob path)
+ . map ((compilerTestDir </>) . T.unpack)
+ . filter (not . T.null)
+ . map (T.strip . fst . T.breakOn "--")
+ . T.lines
+ in readUTF8FileT rerunPath >>= textToTestFiles
+ else return []
+ return $ testsInPath ++ rerunTests
+ where
+ -- A glob for all purs and js files within a test directory
+ testGlob :: FilePath -> IO [FilePath]
+ testGlob = Glob.globDir1 (Glob.compile "**/*.purs")
+ -- Groups the test files so that a top-level file can have dependencies in a
+ -- subdirectory of the same name. The inner tuple contains a list of the
+ -- .purs files and the .js files for the test case.
+ getFiles :: FilePath -> [FilePath] -> [[FilePath]]
+ getFiles baseDir
+ = map (filter ((== ".purs") . takeExtensions) . map (baseDir </>))
+ . groupBy ((==) `on` extractPrefix)
+ . sortBy (compare `on` extractPrefix)
+ . map (makeRelative baseDir)
+ -- Extracts the filename part of a .purs file, or if the file is in a
+ -- subdirectory, the first part of that directory path.
+ extractPrefix :: FilePath -> FilePath
+ extractPrefix fp =
+ let dir = takeDirectory fp
+ ext = reverse ".purs"
+ in if dir == "."
+ then maybe fp reverse $ stripPrefix ext $ reverse fp
+ else dir
+
+compile
+ :: [P.Module]
+ -> [P.ExternsFile]
+ -> M.Map P.ModuleName FilePath
+ -> [FilePath]
+ -> ([P.Module] -> IO ())
+ -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
+compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do
+ fs <- liftIO $ readInput inputFiles
+ ms <- P.parseModulesFromFiles id fs
+ foreigns <- inferForeignModules ms
+ liftIO (check (map snd ms))
+ let actions = makeActions supportModules (foreigns `M.union` supportForeigns)
+ case ms of
+ [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule)
+ _ -> P.make actions (supportModules ++ map snd ms)
+
+assert
+ :: [P.Module]
+ -> [P.ExternsFile]
+ -> M.Map P.ModuleName FilePath
+ -> [FilePath]
+ -> ([P.Module] -> IO ())
+ -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))
+ -> Expectation
+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
+
+checkMain :: [P.Module] -> IO ()
+checkMain ms =
+ unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)
+ (fail "Main module missing")
+
+
+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
+ , P.progress = const (pure ())
+ }
+ where
+ getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
+ getInputTimestamp mn
+ | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
+ | otherwise = return (Left P.RebuildAlways)
+ where
+ isSupportModule = flip elem (map (P.runModuleName . P.getModuleName) modules)
+
+ getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
+ getOutputTimestamp mn = do
+ let filePath = modulesDir </> T.unpack (P.runModuleName mn)
+ exists <- liftIO $ doesDirectoryExist filePath
+ return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
+
+
+runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)
+runTest = P.runMake P.defaultOptions
+
+inferForeignModules
+ :: MonadIO m
+ => [(FilePath, P.Module)]
+ -> m (M.Map P.ModuleName FilePath)
+inferForeignModules = P.inferForeignModules . fromList
+ where
+ fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
+ fromList = M.fromList . map ((P.getModuleName *** Right) . swap)
+
+trim :: String -> String
+trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
+
+modulesDir :: FilePath
+modulesDir = ".test_modules" </> "node_modules"
+
+logpath :: FilePath
+logpath = "purescript-output"
diff --git a/tests/purs/bundle/PSasConstructor.purs b/tests/purs/bundle/PSasConstructor.purs
new file mode 100644
index 0000000..d30721a
--- /dev/null
+++ b/tests/purs/bundle/PSasConstructor.purs
@@ -0,0 +1,11 @@
+module Main where
+
+import Prelude
+import Effect (Effect)
+import Effect.Console (log)
+
+data P = PS
+
+main :: Effect Unit
+main = do
+ log "Done"
diff --git a/tests/purs/failing/Superclasses2.purs b/tests/purs/failing/Superclasses2.purs
index 0c50349..3c86b7f 100644
--- a/tests/purs/failing/Superclasses2.purs
+++ b/tests/purs/failing/Superclasses2.purs
@@ -1,5 +1,4 @@
--- @shouldFailWith CycleInTypeSynonym
--- TODO: Should this have its own error, perhaps CycleInTypeClassDeclaration?
+-- @shouldFailWith CycleInTypeClassDeclaration
module CycleInSuperclasses where
import Prelude
diff --git a/tests/purs/publish/basic-example/bower.json b/tests/purs/publish/basic-example/bower.json
new file mode 100644
index 0000000..23962c2
--- /dev/null
+++ b/tests/purs/publish/basic-example/bower.json
@@ -0,0 +1,13 @@
+{
+ "name": "basic-example",
+ "repository": {
+ "type": "git",
+ "url": "https://github.com/purescript/test.git"
+ },
+ "license": "MIT",
+ "dependencies": {
+ "purescript-console": "^1.0.0",
+ "purescript-prelude": "^1.0.0",
+ "purescript-effect": "^1.0.0"
+ }
+}
diff --git a/tests/purs/publish/basic-example/resolutions-legacy.json b/tests/purs/publish/basic-example/resolutions-legacy.json
new file mode 100644
index 0000000..c08e4d9
--- /dev/null
+++ b/tests/purs/publish/basic-example/resolutions-legacy.json
@@ -0,0 +1,640 @@
+{
+ "endpoint": {
+ "name": "basic-example",
+ "source": ".",
+ "target": "*"
+ },
+ "canonicalDir": ".",
+ "pkgMeta": {
+ "name": "basic-example",
+ "ignore": [
+ "**/.*",
+ "node_modules",
+ "bower_components",
+ "output"
+ ],
+ "dependencies": {
+ "purescript-prelude": "^4.1.0",
+ "purescript-console": "^4.2.0",
+ "purescript-effect": "^2.0.1",
+ "purescript-newtype": "#master"
+ },
+ "devDependencies": {
+ "purescript-psci-support": "^4.0.0"
+ }
+ },
+ "dependencies": {
+ "purescript-console": {
+ "endpoint": {
+ "name": "purescript-console",
+ "source": "purescript-console",
+ "target": "^4.2.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-console",
+ "pkgMeta": {
+ "name": "purescript-console",
+ "homepage": "https://github.com/purescript/purescript-console",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-console.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "dependencies": {
+ "purescript-effect": "^2.0.0",
+ "purescript-prelude": "^4.0.0"
+ },
+ "version": "4.2.0",
+ "_release": "4.2.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.2.0",
+ "commit": "add2bdb8a4af2213d993b728805f1f2a5e76deb8"
+ },
+ "_source": "https://github.com/purescript/purescript-console.git",
+ "_target": "^4.2.0",
+ "_originalSource": "purescript-console"
+ },
+ "dependencies": {
+ "purescript-effect": {
+ "endpoint": {
+ "name": "purescript-effect",
+ "source": "purescript-effect",
+ "target": "^2.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-effect",
+ "pkgMeta": {
+ "name": "purescript-effect",
+ "homepage": "https://github.com/purescript/purescript-effect",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-effect.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "dependencies": {
+ "purescript-prelude": "^4.0.0"
+ },
+ "version": "2.0.1",
+ "_release": "2.0.1",
+ "_resolution": {
+ "type": "version",
+ "tag": "v2.0.1",
+ "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf"
+ },
+ "_source": "https://github.com/purescript/purescript-effect.git",
+ "_target": "^2.0.1",
+ "_originalSource": "purescript-effect"
+ },
+ "dependencies": {
+ "purescript-prelude": {
+ "endpoint": {
+ "name": "purescript-prelude",
+ "source": "purescript-prelude",
+ "target": "^4.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-prelude",
+ "pkgMeta": {
+ "name": "purescript-prelude",
+ "homepage": "https://github.com/purescript/purescript-prelude",
+ "description": "The PureScript Prelude",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-prelude.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "version": "4.1.0",
+ "_release": "4.1.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.1.0",
+ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d"
+ },
+ "_source": "https://github.com/purescript/purescript-prelude.git",
+ "_target": "^4.1.0",
+ "_originalSource": "purescript-prelude"
+ },
+ "dependencies": {},
+ "nrDependants": 1
+ }
+ },
+ "nrDependants": 1
+ },
+ "purescript-prelude": {
+ "endpoint": {
+ "name": "purescript-prelude",
+ "source": "purescript-prelude",
+ "target": "^4.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-prelude",
+ "pkgMeta": {
+ "name": "purescript-prelude",
+ "homepage": "https://github.com/purescript/purescript-prelude",
+ "description": "The PureScript Prelude",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-prelude.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "version": "4.1.0",
+ "_release": "4.1.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.1.0",
+ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d"
+ },
+ "_source": "https://github.com/purescript/purescript-prelude.git",
+ "_target": "^4.1.0",
+ "_originalSource": "purescript-prelude"
+ },
+ "dependencies": {},
+ "nrDependants": 1
+ }
+ },
+ "nrDependants": 1
+ },
+ "purescript-effect": {
+ "endpoint": {
+ "name": "purescript-effect",
+ "source": "purescript-effect",
+ "target": "^2.0.1"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-effect",
+ "pkgMeta": {
+ "name": "purescript-effect",
+ "homepage": "https://github.com/purescript/purescript-effect",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-effect.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "dependencies": {
+ "purescript-prelude": "^4.0.0"
+ },
+ "version": "2.0.1",
+ "_release": "2.0.1",
+ "_resolution": {
+ "type": "version",
+ "tag": "v2.0.1",
+ "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf"
+ },
+ "_source": "https://github.com/purescript/purescript-effect.git",
+ "_target": "^2.0.1",
+ "_originalSource": "purescript-effect"
+ },
+ "dependencies": {},
+ "nrDependants": 1
+ },
+ "purescript-newtype": {
+ "endpoint": {
+ "name": "purescript-newtype",
+ "source": "purescript-newtype",
+ "target": "master"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-newtype",
+ "pkgMeta": {
+ "name": "purescript-newtype",
+ "homepage": "https://github.com/purescript/purescript-newtype",
+ "description": "Type class and functions for working with newtypes",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-newtype.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "dependencies": {
+ "purescript-prelude": "^4.0.0"
+ },
+ "_release": "7d85fa6a04",
+ "_resolution": {
+ "type": "branch",
+ "branch": "master",
+ "commit": "7d85fa6a040208c010b05f7c23af6a943ba08763"
+ },
+ "_source": "https://github.com/garyb/purescript-newtype.git",
+ "_target": "master",
+ "_originalSource": "purescript-newtype"
+ },
+ "dependencies": {
+ "purescript-prelude": {
+ "endpoint": {
+ "name": "purescript-prelude",
+ "source": "purescript-prelude",
+ "target": "^4.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-prelude",
+ "pkgMeta": {
+ "name": "purescript-prelude",
+ "homepage": "https://github.com/purescript/purescript-prelude",
+ "description": "The PureScript Prelude",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-prelude.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "version": "4.1.0",
+ "_release": "4.1.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.1.0",
+ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d"
+ },
+ "_source": "https://github.com/purescript/purescript-prelude.git",
+ "_target": "^4.1.0",
+ "_originalSource": "purescript-prelude"
+ },
+ "dependencies": {},
+ "nrDependants": 1
+ }
+ },
+ "nrDependants": 1
+ },
+ "purescript-prelude": {
+ "endpoint": {
+ "name": "purescript-prelude",
+ "source": "purescript-prelude",
+ "target": "^4.1.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-prelude",
+ "pkgMeta": {
+ "name": "purescript-prelude",
+ "homepage": "https://github.com/purescript/purescript-prelude",
+ "description": "The PureScript Prelude",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-prelude.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "version": "4.1.0",
+ "_release": "4.1.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.1.0",
+ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d"
+ },
+ "_source": "https://github.com/purescript/purescript-prelude.git",
+ "_target": "^4.1.0",
+ "_originalSource": "purescript-prelude"
+ },
+ "dependencies": {},
+ "nrDependants": 1
+ },
+ "purescript-psci-support": {
+ "endpoint": {
+ "name": "purescript-psci-support",
+ "source": "purescript-psci-support",
+ "target": "^4.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-psci-support",
+ "pkgMeta": {
+ "name": "purescript-psci-support",
+ "homepage": "https://github.com/purescript/purescript-psci-support",
+ "description": "Support module for the PSCI interactive mode",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-psci-support.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "bower.json",
+ "package.json"
+ ],
+ "dependencies": {
+ "purescript-console": "^4.0.0",
+ "purescript-effect": "^2.0.0",
+ "purescript-prelude": "^4.0.0"
+ },
+ "version": "4.0.0",
+ "_release": "4.0.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.0.0",
+ "commit": "a66a0fa8661eb8b5fe75cc862f4e2df2835c058d"
+ },
+ "_source": "https://github.com/purescript/purescript-psci-support.git",
+ "_target": "^4.0.0",
+ "_originalSource": "purescript-psci-support"
+ },
+ "dependencies": {
+ "purescript-console": {
+ "endpoint": {
+ "name": "purescript-console",
+ "source": "purescript-console",
+ "target": "^4.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-console",
+ "pkgMeta": {
+ "name": "purescript-console",
+ "homepage": "https://github.com/purescript/purescript-console",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-console.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "dependencies": {
+ "purescript-effect": "^2.0.0",
+ "purescript-prelude": "^4.0.0"
+ },
+ "version": "4.2.0",
+ "_release": "4.2.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.2.0",
+ "commit": "add2bdb8a4af2213d993b728805f1f2a5e76deb8"
+ },
+ "_source": "https://github.com/purescript/purescript-console.git",
+ "_target": "^4.2.0",
+ "_originalSource": "purescript-console"
+ },
+ "dependencies": {
+ "purescript-effect": {
+ "endpoint": {
+ "name": "purescript-effect",
+ "source": "purescript-effect",
+ "target": "^2.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-effect",
+ "pkgMeta": {
+ "name": "purescript-effect",
+ "homepage": "https://github.com/purescript/purescript-effect",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-effect.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "dependencies": {
+ "purescript-prelude": "^4.0.0"
+ },
+ "version": "2.0.1",
+ "_release": "2.0.1",
+ "_resolution": {
+ "type": "version",
+ "tag": "v2.0.1",
+ "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf"
+ },
+ "_source": "https://github.com/purescript/purescript-effect.git",
+ "_target": "^2.0.1",
+ "_originalSource": "purescript-effect"
+ },
+ "dependencies": {
+ "purescript-prelude": {
+ "endpoint": {
+ "name": "purescript-prelude",
+ "source": "purescript-prelude",
+ "target": "^4.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-prelude",
+ "pkgMeta": {
+ "name": "purescript-prelude",
+ "homepage": "https://github.com/purescript/purescript-prelude",
+ "description": "The PureScript Prelude",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-prelude.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "version": "4.1.0",
+ "_release": "4.1.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.1.0",
+ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d"
+ },
+ "_source": "https://github.com/purescript/purescript-prelude.git",
+ "_target": "^4.1.0",
+ "_originalSource": "purescript-prelude"
+ },
+ "dependencies": {},
+ "nrDependants": 1
+ }
+ },
+ "nrDependants": 1
+ },
+ "purescript-prelude": {
+ "endpoint": {
+ "name": "purescript-prelude",
+ "source": "purescript-prelude",
+ "target": "^4.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-prelude",
+ "pkgMeta": {
+ "name": "purescript-prelude",
+ "homepage": "https://github.com/purescript/purescript-prelude",
+ "description": "The PureScript Prelude",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-prelude.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "version": "4.1.0",
+ "_release": "4.1.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.1.0",
+ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d"
+ },
+ "_source": "https://github.com/purescript/purescript-prelude.git",
+ "_target": "^4.1.0",
+ "_originalSource": "purescript-prelude"
+ },
+ "dependencies": {},
+ "nrDependants": 1
+ }
+ },
+ "nrDependants": 1
+ },
+ "purescript-effect": {
+ "endpoint": {
+ "name": "purescript-effect",
+ "source": "purescript-effect",
+ "target": "^2.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-effect",
+ "pkgMeta": {
+ "name": "purescript-effect",
+ "homepage": "https://github.com/purescript/purescript-effect",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-effect.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "dependencies": {
+ "purescript-prelude": "^4.0.0"
+ },
+ "version": "2.0.1",
+ "_release": "2.0.1",
+ "_resolution": {
+ "type": "version",
+ "tag": "v2.0.1",
+ "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf"
+ },
+ "_source": "https://github.com/purescript/purescript-effect.git",
+ "_target": "^2.0.1",
+ "_originalSource": "purescript-effect"
+ },
+ "dependencies": {},
+ "nrDependants": 1
+ },
+ "purescript-prelude": {
+ "endpoint": {
+ "name": "purescript-prelude",
+ "source": "purescript-prelude",
+ "target": "^4.0.0"
+ },
+ "canonicalDir": "../../../support/bower_components/purescript-prelude",
+ "pkgMeta": {
+ "name": "purescript-prelude",
+ "homepage": "https://github.com/purescript/purescript-prelude",
+ "description": "The PureScript Prelude",
+ "license": "BSD-3-Clause",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-prelude.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "package.json"
+ ],
+ "version": "4.1.0",
+ "_release": "4.1.0",
+ "_resolution": {
+ "type": "version",
+ "tag": "v4.1.0",
+ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d"
+ },
+ "_source": "https://github.com/purescript/purescript-prelude.git",
+ "_target": "^4.1.0",
+ "_originalSource": "purescript-prelude"
+ },
+ "dependencies": {},
+ "nrDependants": 1
+ }
+ },
+ "nrDependants": 1
+ }
+ },
+ "nrDependants": 0
+}
diff --git a/tests/purs/publish/basic-example/resolutions.json b/tests/purs/publish/basic-example/resolutions.json
new file mode 100644
index 0000000..2e92161
--- /dev/null
+++ b/tests/purs/publish/basic-example/resolutions.json
@@ -0,0 +1,17 @@
+{
+ "purescript-console": {
+ "version": "1.0.0",
+ "path": "../../../support/bower_components/purescript-console"
+ },
+ "purescript-effect": {
+ "version": "1.0.0",
+ "path": "../../../support/bower_components/purescript-effect"
+ },
+ "purescript-prelude": {
+ "version": "1.0.0",
+ "path": "../../../support/bower_components/purescript-prelude"
+ },
+ "purescript-newtype": {
+ "path": "../../../support/bower_components/purescript-newtype"
+ }
+}
diff --git a/tests/purs/publish/basic-example/src/Main.purs b/tests/purs/publish/basic-example/src/Main.purs
new file mode 100644
index 0000000..085a2dd
--- /dev/null
+++ b/tests/purs/publish/basic-example/src/Main.purs
@@ -0,0 +1,16 @@
+module Main where
+
+import Prelude
+import Effect (Effect)
+import Effect.Console (log)
+import Data.Newtype (class Newtype, un)
+
+newtype Target = Target String
+
+derive instance newtypeTarget :: Newtype Target _
+
+greetingTarget :: Target
+greetingTarget = Target "world"
+
+main :: Effect Unit
+main = log ("hello, " <> un Target greetingTarget <> "!")
diff --git a/tests/support/package-lock.json b/tests/support/package-lock.json
index 1f41aea..c98e1d8 100644
--- a/tests/support/package-lock.json
+++ b/tests/support/package-lock.json
@@ -8,9 +8,9 @@
"integrity": "sha1-ibTRmasr7kneFk6gK4nORi1xt2c="
},
"bower": {
- "version": "1.8.4",
- "resolved": "http://registry.npmjs.org/bower/-/bower-1.8.4.tgz",
- "integrity": "sha1-54dqB23rgTf30GUl3F6MZtuC8oo="
+ "version": "1.8.8",
+ "resolved": "https://registry.npmjs.org/bower/-/bower-1.8.8.tgz",
+ "integrity": "sha512-1SrJnXnkP9soITHptSO+ahx3QKp3cVzn8poI6ujqc5SeOkg5iqM1pK9H+DSc2OQ8SnO0jC/NG4Ur/UIwy7574A=="
},
"brace-expansion": {
"version": "1.1.11",
@@ -75,15 +75,15 @@
},
"path-is-absolute": {
"version": "1.0.1",
- "resolved": "http://registry.npmjs.org/path-is-absolute/-/path-is-absolute-1.0.1.tgz",
+ "resolved": "https://registry.npmjs.org/path-is-absolute/-/path-is-absolute-1.0.1.tgz",
"integrity": "sha1-F0uSaHNVNP+8es5r9TpanhtcX18="
},
"rimraf": {
- "version": "2.6.2",
- "resolved": "https://registry.npmjs.org/rimraf/-/rimraf-2.6.2.tgz",
- "integrity": "sha512-lreewLK/BlghmxtfH36YYVg1i8IAce4TI7oao75I1g245+6BctqTVQiBP3YUJ9C6DQOXJmkYR9X9fCLtCOJc5w==",
+ "version": "2.6.3",
+ "resolved": "https://registry.npmjs.org/rimraf/-/rimraf-2.6.3.tgz",
+ "integrity": "sha512-mwqeW5XsA2qAejG46gYdENaxXjx9onRNCfn7L0duuP4hCuTIi/QO7PDK07KJfp1d+izWPrzEJDcSqBa0OZQriA==",
"requires": {
- "glob": "^7.0.5"
+ "glob": "^7.1.3"
},
"dependencies": {
"glob": {
diff --git a/tests/support/package.json b/tests/support/package.json
index 18aa9a7..0e54c5e 100644
--- a/tests/support/package.json
+++ b/tests/support/package.json
@@ -1,7 +1,7 @@
{
"private": true,
"dependencies": {
- "bower": "^1.4.1",
+ "bower": "^1.8.8",
"glob": "^5.0.14",
"rimraf": "^2.5.2"
}
diff --git a/tests/support/prelude-resolutions.json b/tests/support/prelude-resolutions.json
index a5704c4..0967ef4 100644
--- a/tests/support/prelude-resolutions.json
+++ b/tests/support/prelude-resolutions.json
@@ -1,7 +1 @@
-{
- "canonicalDir": "bower_components/purescript-prelude",
- "pkgMeta": {
- "dependencies": {}
- },
- "dependencies": {}
-}
+{}
diff --git a/tests/support/pscide/src/CompletionSpecDocs.purs b/tests/support/pscide/src/CompletionSpecDocs.purs
index 1c92a37..dae3fc4 100644
--- a/tests/support/pscide/src/CompletionSpecDocs.purs
+++ b/tests/support/pscide/src/CompletionSpecDocs.purs
@@ -1,3 +1,4 @@
+-- | Module Documentation
module CompletionSpecDocs where
-- | Doc x