summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2017-11-15 02:50:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-11-15 02:50:00 (GMT)
commitb725646839c21c8b8d698c862b6f3b7e88acaa8e (patch)
tree4c57d5ac61077ccf9170929092736fcf017c33b3
parentbc80a9937fd209e5553541b5abddf8010f1e3b31 (diff)
version 0.11.70.11.7
-rw-r--r--CONTRIBUTING.md4
-rw-r--r--CONTRIBUTORS.md10
-rw-r--r--INSTALL.md26
-rw-r--r--README.md2
-rw-r--r--app/Command/Docs/Html.hs13
-rw-r--r--app/Command/Docs/Tags.hs2
-rw-r--r--app/Command/Hierarchy.hs42
-rw-r--r--app/Command/Ide.hs17
-rw-r--r--app/static/pursuit.css10
-rw-r--r--app/static/pursuit.less875
-rw-r--r--examples/docs/src/DeclOrder.purs17
-rw-r--r--examples/docs/src/DeclOrderNoExportList.purs10
-rw-r--r--examples/docs/src/TypeOpAliases.purs26
-rw-r--r--examples/failing/2197-shouldFail.purs10
-rw-r--r--examples/failing/2197-shouldFail2.purs7
-rw-r--r--examples/failing/DuplicateInstance.purs6
-rw-r--r--examples/failing/DuplicateTypeClass.purs4
-rw-r--r--examples/failing/InfiniteKind2.purs5
-rw-r--r--examples/passing/2197-1.purs12
-rw-r--r--examples/passing/2197-2.purs11
-rw-r--r--examples/passing/2958.purs14
-rw-r--r--examples/passing/3125.purs16
-rw-r--r--examples/passing/ParensInType.purs20
-rw-r--r--examples/passing/UnsafeCoerce.purs16
-rw-r--r--purescript.cabal54
-rw-r--r--src/Language/PureScript/AST/Declarations.hs112
-rw-r--r--src/Language/PureScript/AST/Exported.hs34
-rw-r--r--src/Language/PureScript/AST/Traversals.hs26
-rw-r--r--src/Language/PureScript/Bundle.hs11
-rw-r--r--src/Language/PureScript/CodeGen/JS/Printer.hs11
-rw-r--r--src/Language/PureScript/Constants.hs6
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs2
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer.hs2
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/Inliner.hs8
-rw-r--r--src/Language/PureScript/Docs.hs1
-rw-r--r--src/Language/PureScript/Docs/AsHtml.hs48
-rw-r--r--src/Language/PureScript/Docs/Convert.hs4
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs11
-rw-r--r--src/Language/PureScript/Docs/Css.hs31
-rw-r--r--src/Language/PureScript/Docs/Prim.hs8
-rw-r--r--src/Language/PureScript/Docs/Types.hs2
-rw-r--r--src/Language/PureScript/Errors.hs52
-rw-r--r--src/Language/PureScript/Hierarchy.hs86
-rw-r--r--src/Language/PureScript/Ide.hs23
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs6
-rw-r--r--src/Language/PureScript/Ide/Command.hs14
-rw-r--r--src/Language/PureScript/Ide/Completion.hs4
-rw-r--r--src/Language/PureScript/Ide/Externs.hs18
-rw-r--r--src/Language/PureScript/Ide/Imports.hs35
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs27
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs7
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs13
-rw-r--r--src/Language/PureScript/Ide/State.hs118
-rw-r--r--src/Language/PureScript/Ide/Types.hs36
-rw-r--r--src/Language/PureScript/Interactive.hs15
-rw-r--r--src/Language/PureScript/Interactive/Completion.hs14
-rw-r--r--src/Language/PureScript/Interactive/Directive.hs41
-rw-r--r--src/Language/PureScript/Interactive/Module.hs15
-rw-r--r--src/Language/PureScript/Interactive/Parser.hs22
-rw-r--r--src/Language/PureScript/Interactive/Types.hs3
-rw-r--r--src/Language/PureScript/Linter.hs6
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs5
-rw-r--r--src/Language/PureScript/Linter/Imports.hs3
-rw-r--r--src/Language/PureScript/Names.hs4
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs4
-rw-r--r--src/Language/PureScript/Pretty/Common.hs6
-rw-r--r--src/Language/PureScript/Pretty/Values.hs8
-rw-r--r--src/Language/PureScript/Publish.hs21
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs10
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs50
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs20
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs2
-rw-r--r--src/Language/PureScript/Sugar/Names.hs33
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs6
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs2
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs59
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs30
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs24
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs12
-rw-r--r--src/Language/PureScript/TypeChecker.hs52
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs6
-rw-r--r--src/Language/PureScript/TypeChecker/TypeSearch.hs14
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs13
-rw-r--r--stack.yaml3
-rw-r--r--tests/Language/PureScript/Ide/CompletionSpec.hs34
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs151
-rw-r--r--tests/Language/PureScript/Ide/RebuildSpec.hs14
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs6
-rw-r--r--tests/Language/PureScript/Ide/Test.hs10
-rw-r--r--tests/Main.hs6
-rw-r--r--tests/TestDocs.hs270
-rw-r--r--tests/TestHierarchy.hs65
-rw-r--r--tests/TestPsci/CommandTest.hs6
-rw-r--r--tests/TestPsci/CompletionTest.hs10
-rw-r--r--tests/TestPsci/TestEnv.hs39
-rw-r--r--tests/support/bower.json32
-rw-r--r--tests/support/pscide/src/CompletionSpecDocs.purs13
97 files changed, 2569 insertions, 575 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index da40134..ef683c0 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -1,6 +1,4 @@
-An introductory overview of the compiler is available [here](https://www.youtube.com/watch?v=Y3P1dxqwFiE).
-
-Pull requests are encouraged.
+Pull requests are encouraged, but please open issues before starting to work on something that you intend to make into a PR, so that we can decide if it is a good fit or not.
## Finding Issues to Work On
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index e653c77..30ae2b4 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -15,6 +15,7 @@ If you would prefer to use different terms, please use the section below instead
| Username | Name | License |
| :------- | :--- | :------ |
| [@5outh](https://github.com/5outh) | Benjamin Kovach | MIT license |
+| [@actionshrimp](https://github.com/actionshrimp) | David Aitken | [MIT license](http://opensource.org/licenses/MIT) |
| [@alexbiehl](https://github.com/alexbiehl) | Alexander Biehl | [MIT license](http://opensource.org/licenses/MIT) |
| [@andreypopp](https://github.com/andreypopp) | Andrey Popp | MIT license |
| [@andyarvanitis](https://github.com/andyarvanitis) | Andy Arvanitis | [MIT license](http://opensource.org/licenses/MIT) |
@@ -33,6 +34,7 @@ If you would prefer to use different terms, please use the section below instead
| [@chrisdone](https://github.com/chrisdone) | Chris Done | MIT license |
| [@cmdv](https://github.com/cmdv) | Vincent Orr | MIT license |
| [@codedmart](https://github.com/codedmart) | Brandon Martin | [MIT license](http://opensource.org/licenses/MIT) |
+| [@coot](https://github.com/coot) | Marcin Szamotulski | [MIT license](http://opensource.org/licenses/MIT) |
| [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license](http://opensource.org/licenses/MIT) |
| [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) |
| [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license](http://opensource.org/licenses/MIT) |
@@ -49,9 +51,11 @@ If you would prefer to use different terms, please use the section below instead
| [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license](http://opensource.org/licenses/MIT) |
| [@ianbollinger](https://github.com/ianbollinger) | Ian D. Bollinger | [MIT license](http://opensource.org/licenses/MIT) |
| [@ilovezfs](https://github.com/ilovezfs) | ilovezfs | MIT license |
+| [@i-am-tom](https://github.com/i-am-tom) | i-am-tom | [MIT license](http://opensource.org/licenses/MIT) |
| [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license](http://opensource.org/licenses/MIT) |
| [@jacereda](https://github.com/jacereda) | Jorge Acereda | [MIT license](http://opensource.org/licenses/MIT) |
| [@japesinator](https://github.com/japesinator) | JP Smith | [MIT license](http://opensource.org/licenses/MIT) |
+| [@jkachmar](https://github.com/jkachmar) | Joe Kachmar | MIT license |
| [@joneshf](https://github.com/joneshf) | Hardy Jones | MIT license |
| [@kika](https://github.com/kika) | Kirill Pertsev | MIT license |
| [@kRITZCREEK](https://github.com/kRITZCREEK) | Christoph Hegemann | MIT license |
@@ -85,6 +89,7 @@ If you would prefer to use different terms, please use the section below instead
| [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) |
| [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) |
| [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) |
+| [@Rufflewind](https://github.com/Rufflewind) | Phil Ruffwind | [MIT license](https://opensource.org/licenses/MIT) |
| [@rvion](https://github.com/rvion) | Rémi Vion | [MIT license](http://opensource.org/licenses/MIT) |
| [@RyanGlScott](https://github.com/RyanGlScott) | Ryan Scott | [MIT license](http://opensource.org/licenses/MIT) |
| [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | MIT license |
@@ -105,6 +110,10 @@ If you would prefer to use different terms, please use the section below instead
| [@utkarshkukreti](https://github.com/utkarshkukreti) | Utkarsh Kukreti | [MIT license](http://opensource.org/licenses/MIT) |
| [@vkorablin](https://github.com/vkorablin) | Vladimir Korablin | MIT license |
| [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license](http://opensource.org/licenses/MIT) |
+| [@b123400](https://github.com/b123400) | b123400 | [MIT license](https://opensource.org/licenses/MIT) |
+| [@drets](https://github.com/drets) | Dmytro Rets | [MIT license](http://opensource.org/licenses/MIT) |
+| [@bjornmelgaaard](https://github.com/BjornMelgaard) | Sergey Homa | [MIT license](http://opensource.org/licenses/MIT) |
+| [@thimoteus](https://github.com/Thimoteus) | thimoteus | [MIT license](http://opensource.org/licenses/MIT) |
### Contributors using Modified Terms
@@ -122,3 +131,4 @@ If you would prefer to use different terms, please use the section below instead
| Username | Company | Terms |
| :------- | :--- | :------ |
| [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes |
+| [@qfpl](https://github.com/qfpl) | qfpl @ Data61 / CSIRO | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Data61 / CSIRO, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lightandlight](https://github.com/lightandlight) |
diff --git a/INSTALL.md b/INSTALL.md
index 4031f9e..27f170a 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -6,10 +6,10 @@ alternatively Stack Overflow.
## Using prebuilt binaries
-The prebuilt binaries are compiled with GHC 7.10.3, and therefore they should
-run on any operating system supported by GHC 7.10.3, such as:
+The prebuilt binaries are compiled with GHC 8.0.2 and therefore they should
+run on any operating system supported by GHC 8.0.2, such as:
-* Windows 2000 or later,
+* Windows Vista or later,
* OS X 10.7 or later,
* Linux ??? (we're not sure what the minimum version is).
@@ -17,20 +17,18 @@ This list is not exhaustive. If your OS is too old or not listed, or if the
binaries fail to run, you may be able to install the compiler by building it
from source; see below.
-It's probably safe to assume that other prebuilt distributions (eg, Homebrew,
-Chocolatey, AUR, npm) use the same binaries, and therefore have the same
-requirements.
+Other prebuilt distributions (eg, Homebrew, AUR, npm) will probably have the
+same requirements.
## Compiling from source
-GHC 7.10.1 or newer is required to compile from source. The easiest way is to
-use stack:
+The easiest way is to use stack:
```
$ stack update
$ stack unpack purescript
$ cd purescript-x.y.z # (replace x.y.z with whichever version you just downloaded)
-$ stack install
+$ stack install --flag purescript:RELEASE
```
This will then copy the compiler and utilities into `~/.local/bin`.
@@ -39,14 +37,14 @@ This will then copy the compiler and utilities into `~/.local/bin`.
If you don't have stack installed, there are install instructions
[here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md).
-If you don't have ghc installed, stack will prompt you to run `stack setup`
-which will install ghc for you.
+If you don't have GHC installed, stack will prompt you to run `stack setup`
+which will install the correct version of GHC for you.
## The "curses" library
-`psci` depends on the `curses` library (via the Haskell package `terminfo`). If
-you are having difficulty running the compiler, it may be because the `curses`
-library is missing.
+The PureScript REPL depends on the `curses` library (via the Haskell package
+`terminfo`). If you are having difficulty running the compiler, it may be
+because the `curses` library is missing.
On Linux, you will probably need to install `ncurses` manually. On Ubuntu, for
example, this can be done by running:
diff --git a/README.md b/README.md
index 504c5ca..3ac5df9 100644
--- a/README.md
+++ b/README.md
@@ -19,7 +19,7 @@ A small strongly typed programming language with expressive types that compiles
## Help!
-- [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript)
+- [#purescript @ FP Slack](https://functionalprogramming.slack.com/)
- [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript)
- [Google Group](https://groups.google.com/forum/#!forum/purescript)
- [Gitter Channel](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs
index 507917e..0352fce 100644
--- a/app/Command/Docs/Html.hs
+++ b/app/Command/Docs/Html.hs
@@ -15,7 +15,6 @@ import Data.List (sort)
import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import qualified Data.Text as T
-import Data.FileEmbed (embedStringFile)
import qualified Language.PureScript as P
import qualified Language.PureScript.Docs as D
import qualified Language.PureScript.Docs.AsHtml as D
@@ -36,7 +35,7 @@ writeHtmlModules outputDir modules = do
mapM_ (writeHtmlModule outputDir . (fst &&& layout moduleList)) modules
asHtml :: D.Module -> (P.ModuleName, D.HtmlOutputModule Html)
-asHtml m = D.moduleAsHtml (getHtmlRenderContext (D.modName m)) m
+asHtml m = D.moduleAsHtml (const $ Just $ getHtmlRenderContext (D.modName m)) m
writeHtmlModule :: FilePath -> (P.ModuleName, Html) -> IO ()
writeHtmlModule outputDir (mn, html) = do
@@ -133,9 +132,9 @@ basicLayout title inner =
H.link ! A.href "https://fonts.googleapis.com/css?family=Roboto+Mono|Roboto:300,400,400i,700,700i"
! A.type_ "text/css" ! A.rel "stylesheet"
H.style ! A.type_ "text/css" $
- toMarkup normalize_css
+ toMarkup D.normalizeCssT
H.style ! A.type_ "text/css" $
- toMarkup pursuit_css
+ toMarkup D.pursuitCssT
H.body $ do
H.div ! A.class_ "everything-except-footer" $ do
H.div ! A.class_ "top-banner clearfix" $ do
@@ -173,9 +172,3 @@ renderModuleList moduleList =
listItem mn = H.li $
H.a ! A.href (H.toValue (P.runModuleName mn <> ".html")) $
toMarkup (P.runModuleName mn)
-
-normalize_css :: Text
-normalize_css = $(embedStringFile "app/static/normalize.css")
-
-pursuit_css :: Text
-pursuit_css = $(embedStringFile "app/static/pursuit.css")
diff --git a/app/Command/Docs/Tags.hs b/app/Command/Docs/Tags.hs
index 6fd3275..ecdbdbc 100644
--- a/app/Command/Docs/Tags.hs
+++ b/app/Command/Docs/Tags.hs
@@ -10,7 +10,7 @@ tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations
dtags :: P.Declaration -> [(P.Text, Int)]
dtags (P.DataDeclaration (ss, _) _ name _ dcons) = (P.runProperName name, pos ss) : consNames
where consNames = map (\(cname, _) -> (P.runProperName cname, pos ss)) dcons
- dtags (P.TypeDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)]
+ dtags (P.TypeDeclaration (P.TypeDeclarationData (ss, _) ident _)) = [(P.showIdent ident, pos ss)]
dtags (P.ExternDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)]
dtags (P.TypeSynonymDeclaration (ss, _) name _ _) = [(P.runProperName name, pos ss)]
dtags (P.TypeClassDeclaration (ss, _) name _ _ _ _) = [(P.runProperName name, pos ss)]
diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs
index d06918e..1bb9346 100644
--- a/app/Command/Hierarchy.hs
+++ b/app/Command/Hierarchy.hs
@@ -18,14 +18,13 @@
module Command.Hierarchy (command) where
-import Protolude (ordNub)
+import Protolude (catMaybes)
import Control.Applicative (optional)
-import Control.Monad (unless)
-import Data.List (intercalate, sort)
import Data.Foldable (for_)
import Data.Monoid ((<>))
import qualified Data.Text as T
+import qualified Data.Text.IO as T
import Options.Applicative (Parser)
import qualified Options.Applicative as Opts
import System.Directory (createDirectoryIfMissing)
@@ -35,27 +34,13 @@ import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStr, stderr)
import System.IO.UTF8 (readUTF8FileT)
import qualified Language.PureScript as P
+import Language.PureScript.Hierarchy (Graph(..), _unDigraph, _unGraphName, typeClasses)
data HierarchyOptions = HierarchyOptions
{ _hierachyInput :: FilePath
, _hierarchyOutput :: Maybe FilePath
}
-newtype SuperMap = SuperMap { _unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) }
- deriving Eq
-
-instance Show SuperMap where
- show (SuperMap (Left sub)) = show sub
- show (SuperMap (Right (super, sub))) = show super ++ " -> " ++ show sub
-
-instance Ord SuperMap where
- compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s'
- where
- getCls = either id snd
-
-runModuleName :: P.ModuleName -> String
-runModuleName (P.ModuleName pns) = intercalate "_" ((T.unpack . P.runProperName) `map` pns)
-
readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module])
readInput paths = do
content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths
@@ -68,27 +53,14 @@ compile (HierarchyOptions inputGlob mOutput) = do
case modules of
Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
Right ms -> do
- for_ ms $ \(P.Module _ _ moduleName decls _) ->
- let name = runModuleName moduleName
- tcs = filter P.isTypeClassDeclaration decls
- supers = sort . ordNub . filter (not . null) $ fmap superClasses tcs
- prologue = "digraph " ++ name ++ " {\n"
- body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
- epilogue = "\n}"
- hier = prologue ++ body ++ epilogue
- in unless (null supers) $ case mOutput of
+ for_ (catMaybes $ typeClasses ms) $ \(Graph name graph) ->
+ case mOutput of
Just output -> do
createDirectoryIfMissing True output
- writeFile (output </> name) hier
- Nothing -> putStrLn hier
+ T.writeFile (output </> T.unpack (_unGraphName name)) (_unDigraph graph)
+ Nothing -> T.putStrLn (_unDigraph graph)
exitSuccess
-superClasses :: P.Declaration -> [SuperMap]
-superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) =
- fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers
-superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)]
-superClasses _ = []
-
inputFile :: Parser FilePath
inputFile = Opts.strArgument $
Opts.metavar "FILE"
diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs
index 76ad796..a33c33d 100644
--- a/app/Command/Ide.hs
+++ b/app/Command/Ide.hs
@@ -69,6 +69,7 @@ data ServerOptions = ServerOptions
, _serverNoWatch :: Bool
, _serverPolling :: Bool
, _serverLoglevel :: IdeLogLevel
+ , _serverEditorMode :: Bool
} deriving (Show)
data ClientOptions = ClientOptions
@@ -106,7 +107,7 @@ command = Opts.helper <*> subcommands where
Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer))
server :: ServerOptions -> IO ()
- server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel) = do
+ server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel editorMode) = do
when (logLevel == LogDebug || logLevel == LogAll)
(putText "Parsed Options:" *> print opts')
maybe (pure ()) setCurrentDirectory dir
@@ -118,10 +119,16 @@ command = Opts.helper <*> subcommands where
putText "Your output directory didn't exist. This usually means you didn't compile your project yet."
putText "psc-ide needs you to compile your project (for example by running pulp build)"
- unless noWatch $
+ unless (noWatch || editorMode) $
void (forkFinally (watcher polling logLevel ideState fullOutputPath) print)
- let conf = IdeConfiguration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs}
- env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}
+ let
+ conf = IdeConfiguration
+ { confLogLevel = logLevel
+ , confOutputPath = outputPath
+ , confGlobs = globs
+ , confEditorMode = editorMode
+ }
+ let env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}
startServer port env
serverOptions :: Opts.Parser ServerOptions
@@ -138,7 +145,9 @@ command = Opts.helper <*> subcommands where
(Opts.long "log-level"
`mappend` Opts.value ""
`mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""))
+ <*> Opts.switch (Opts.long "editor-mode")
+ parseLogLevel :: Text -> IdeLogLevel
parseLogLevel s = case s of
"debug" -> LogDebug
"perf" -> LogPerf
diff --git a/app/static/pursuit.css b/app/static/pursuit.css
index d250c36..dd46719 100644
--- a/app/static/pursuit.css
+++ b/app/static/pursuit.css
@@ -1,5 +1,5 @@
/** ************************************************************************* *
- ** Pursuit CSS
+ ** CSS for HTML docs (e.g. Pursuit)
**
** STRUCTURE
**
@@ -36,6 +36,14 @@
** To make use of this modular scale, use a ratio of the form
** (5/4)^n
** where n ∈ ℤ, -6 ≤ n ≤ 8.
+ **
+ ** LESS
+ **
+ ** This CSS is generated by less. To compile it:
+ **
+ ** npm install [-g] less
+ ** lessc app/static/pursuit.less > app/static/pursuit.css
+ **
** ************************************************************************* */
/* Section: Variables
* ========================================================================== */
diff --git a/app/static/pursuit.less b/app/static/pursuit.less
new file mode 100644
index 0000000..1b064b2
--- /dev/null
+++ b/app/static/pursuit.less
@@ -0,0 +1,875 @@
+/** ************************************************************************* *
+ ** CSS for HTML docs (e.g. Pursuit)
+ **
+ ** STRUCTURE
+ **
+ ** This CSS file is structured into several sections, from general to
+ ** specific, and (mostly) alphabetically within the sections.
+ **
+ ** Several global element styles are used. This is not encouraged and should
+ ** be kept to a minimum. If you want to add new styles you'll most likely
+ ** want to add a new CSS component. See the Components section for examples.
+ **
+ ** CSS components use three simple naming ideas from the BEM system:
+ ** - Block: `.my-component`
+ ** - Element: `.my-component__item`
+ ** - Modifier: `.my-component.my-component--highlighted`
+ **
+ ** Example:
+ ** <div .my-component>
+ ** <div .my-component__item>
+ ** <div .my-component__item>
+ ** ...
+ ** <div .my-component.my-component--highlighted>
+ ** <div .my-component__item>
+ ** <div .my-component__item>
+ **
+ ** Components can be nested.
+ **
+ **
+ ** TYPOGRAPHY
+ **
+ ** Typographic choices for sizes, line-heights and margins are based on a
+ ** musical major third scale (4:5). This gives us a way to find numbers
+ ** and relationships between them that are perceived as harmonic.
+ **
+ ** To make use of this modular scale, use a ratio of the form
+ ** (5/4)^n
+ ** where n ∈ ℤ, -6 ≤ n ≤ 8.
+ **
+ ** LESS
+ **
+ ** This CSS is generated by less. To compile it:
+ **
+ ** npm install [-g] less
+ ** lessc app/static/pursuit.less > app/static/pursuit.css
+ **
+ ** ************************************************************************* */
+
+/* Section: Variables
+ * ========================================================================== */
+@background: rgb(255, 255, 255);
+@banner_background: rgb(29, 34, 45);
+@package_banner_background: lighten(@banner_background, 30%);
+@dark_foreground: rgb(240, 240, 240);
+@link: rgb(196, 149, 58);
+@link_active: rgb(123, 89, 4);
+@error_background: rgb(255, 240, 240);
+@error_border: rgb(200, 80, 80);
+@not_available_background: rgb(240, 240, 150);
+@code_foreground: rgb(25, 74, 91);
+@code_background: rgb(241, 245, 249);
+@light_glyph: rgb(160, 160, 160);
+@light_type: rgb(102, 102, 102);
+
+/* Section: Document Styles
+ * ========================================================================== */
+
+html {
+ box-sizing: border-box;
+
+ /* This overflow rule prevents everything from shifting slightly to the side
+ when moving from a page which isn't large enough to generate a scrollbar
+ to one that is. */
+ overflow-y: scroll;
+}
+
+*, *::before, *::after {
+ box-sizing: inherit;
+}
+
+body {
+ background-color: @background;
+ color: #000;
+ font-family: "Roboto", sans-serif;
+ font-size: 87.5%;
+ line-height: 1.563;
+}
+
+@media (min-width: 38em) {
+ body {
+ font-size: 100%;
+ }
+}
+
+
+/* Section: Utility Classes
+ * ========================================================================== */
+
+.clear-floats {
+ clear: both;
+}
+
+.clearfix::before,
+.clearfix::after {
+ content: " ";
+ display: table;
+}
+
+.clearfix::after {
+ clear: both;
+}
+
+/* Content hidden like this will still be read by a screen reader */
+.hide-visually {
+ position: absolute;
+ left: -10000px;
+ top: auto;
+ width: 1px;
+ height: 1px;
+ overflow: hidden;
+}
+
+
+/* Section: Layout
+ * ========================================================================== */
+
+.container {
+ display: block;
+ max-width: 66em;
+ margin-left: auto;
+ margin-right: auto;
+ padding-left: 20px;
+ padding-right: 20px;
+}
+
+.col {
+ display: block;
+ position: relative;
+ width: 100%;
+}
+
+.col.col--main {
+ margin-bottom: 3.08em;
+}
+
+.col.col--aside {
+ margin-bottom: 2.44em;
+}
+
+@media (min-width: 52em) {
+ .container {
+ padding-left: 30px;
+ padding-right: 30px;
+ }
+
+ .col.col--main {
+ float: left;
+ width: 63.655%; /* 66.6…% - 30px */
+ }
+
+ .col.col--aside {
+ float: right;
+ font-size: 87.5%;
+ width: 33.333333%;
+ }
+}
+
+@media (min-width: 66em) {
+ .col.col--aside {
+ font-size: inherit;
+ }
+}
+
+
+/* Footer
+ * Based on http://www.lwis.net/journal/2008/02/08/pure-css-sticky-footer/
+ * Except we don't support IE6
+ * -------------------------------------------------------------------------- */
+
+html, body {
+ height: 100%;
+}
+
+.everything-except-footer {
+ min-height: 100%;
+ padding-bottom: 3em;
+}
+
+.footer {
+ position: relative;
+ height: 3em;
+ margin-top: -3em;
+ width: 100%;
+ text-align: center;
+ background-color: @banner_background;
+ color: @dark_foreground;
+}
+
+.footer * {
+ margin-bottom: 0;
+}
+
+
+/* Section: Element Styles
+ *
+ * Have as few of these as possible and keep them general, because they will
+ * influence every component hereafter.
+ * ========================================================================== */
+
+:target {
+ background-color: @code_background;
+}
+
+a, a:visited {
+ color: @link;
+ text-decoration: none;
+ font-weight: bold;
+}
+
+a:hover {
+ color: @link_active;
+ text-decoration: none;
+}
+
+code, pre {
+ background-color: @code_background;
+ border-radius: 3px;
+ color: @code_foreground;
+ font-family: "Roboto Mono", monospace;
+ font-size: 87.5%;
+}
+
+:target code,
+:target pre {
+ background-color: darken(@code_background, 5%);
+}
+
+code {
+ padding: 0.2em 0;
+ margin: 0;
+ white-space: pre-wrap;
+ word-wrap: break-word;
+}
+
+code::before,
+code::after {
+ letter-spacing: -0.2em;
+ content: "\00a0";
+}
+
+a > code {
+ font-weight: normal;
+}
+
+a > code::before {
+ content: "🡒";
+ letter-spacing: 0.33em;
+}
+
+a:hover > code {
+ color: @link;
+}
+
+pre {
+ margin-top: 0;
+ margin-bottom: 0;
+ padding: 1em 1.25rem; /* Using rem here to align with lists etc. */
+ overflow: auto;
+ white-space: pre;
+ word-wrap: normal;
+}
+
+pre code {
+ background-color: transparent;
+ border: 0;
+ font-size: 100%;
+ max-width: auto;
+ padding: 0;
+ margin: 0;
+ overflow: visible;
+ line-height: inherit;
+ white-space: pre;
+ word-break: normal;
+ word-wrap: normal;
+}
+
+pre code::before,
+pre code::after {
+ content: normal;
+}
+
+h1 {
+ font-size: 3.052em;
+ font-weight: 300;
+ letter-spacing: -0.5px;
+ line-height: 1.125;
+ margin-top: 1.563rem;
+ margin-bottom: 1.25rem;
+}
+
+@media (min-width: 52em) {
+ h1 {
+ font-size: 3.814em;
+ margin-top: 5.96rem;
+ }
+}
+
+h2 {
+ font-size: 1.953em;
+ font-weight: normal;
+ line-height: 1.250;
+ margin-top: 3.052rem;
+ margin-bottom: 1rem;
+}
+
+h3 {
+ font-size: 1.563em;
+ font-weight: normal;
+ line-height: 1.250;
+ margin-top: 2.441rem;
+ margin-bottom: 1rem;
+}
+
+h4 {
+ font-size: 1.25em;
+ font-weight: normal;
+ margin-top: 2.441rem;
+ margin-bottom: 1rem;
+}
+
+h1 + h2,
+h1 + h3,
+h1 + h4,
+h2 + h3,
+h2 + h4,
+h3 + h4 {
+ margin-top: 1rem;
+}
+
+hr {
+ border: none;
+ height: 1px;
+ background-color: darken(@background, 20%);
+}
+
+img {
+ border-style: none;
+ max-width: 100%;
+}
+
+p {
+ font-size: 1em;
+ margin-top: 1rem;
+ margin-bottom: 1rem;
+}
+
+table {
+ border-bottom: 1px solid darken(@background, 20%);
+ border-collapse: collapse;
+ border-spacing: 0;
+ margin-top: 1rem;
+ margin-bottom: 1rem;
+ width: 100%;
+}
+
+td, th {
+ text-align: left;
+ padding: 0.41em 0.51em;
+}
+
+td {
+ border-top: 1px solid darken(@background, 20%);
+}
+
+td:first-child, th:first-child {
+ padding-left: 0;
+}
+
+td:last-child, th:last-child {
+ padding-right: 0;
+}
+
+ul {
+ list-style-type: none;
+ margin-top: 1rem;
+ margin-bottom: 1rem;
+ padding-left: 0;
+}
+
+ul li {
+ position: relative;
+ padding-left: 1.250em;
+}
+
+ul li::before {
+ position: absolute;
+ color: @light_glyph;
+ content: "–";
+ display: inline-block;
+ margin-left: -1.250em;
+ width: 1.250em;
+}
+
+/* Tying this tightly to ul at the moment because it's a slight variation thereof */
+ul.ul--search li::before {
+ content: "⚲";
+ top: -0.2em;
+ transform: rotate(-45deg);
+}
+
+ol {
+ margin-top: 1rem;
+ margin-bottom: 1rem;
+ padding-left: 1.250em;
+}
+
+ol li {
+ position: relative;
+ padding-left: 0;
+}
+
+
+/* Section: Components
+ * ========================================================================== */
+
+/* Component: Badge
+ * -------------------------------------------------------------------------- */
+
+.badge {
+ position: relative;
+ top: -0.1em;
+ display: inline-block;
+ background-color: #000;
+ border-radius: 1.3em;
+ color: #fff;
+ font-size: 77%;
+ font-weight: bold;
+ line-height: 1.563;
+ text-align: center;
+ height: 1.5em;
+ width: 1.5em;
+}
+
+.badge.badge--package {
+ background-color: @link;
+ letter-spacing: -0.1em;
+}
+
+.badge.badge--module {
+ background-color: #75B134;
+}
+
+
+/* Component: Declarations
+ * -------------------------------------------------------------------------- */
+
+.decl {}
+
+.decl__title {
+ position: relative;
+ padding-bottom: 0.328em;
+ margin-bottom: 0.262em;
+}
+
+.decl__source {
+ display: block;
+ float: right;
+ font-size: 64%;
+ position: relative;
+ top: 0.57em;
+}
+
+.decl__anchor, .decl__anchor:visited {
+ position: absolute;
+ left: -0.8em;
+ color: lighten(@light_glyph, 10%);
+}
+
+.decl__anchor:hover {
+ color: @link;
+}
+
+.decl__signature {
+ background-color: transparent;
+ border-radius: 0;
+ border-top: 1px solid darken(@background, 20%);
+ border-bottom: 1px solid darken(@background, 20%);
+ padding: 0.328em 0;
+}
+
+.decl__signature code {
+ display: block;
+ padding-left: 2.441em;
+ text-indent: -2.441em;
+ white-space: normal;
+}
+
+:target .decl__signature,
+:target .decl__signature code {
+ /* We want the background to be transparent, even when the parent is a target */
+ background-color: transparent;
+}
+
+.decl__body .keyword,
+.decl__body .syntax {
+ color: #0B71B4;
+}
+
+.decl__child_comments {
+ margin-top: 1rem;
+ margin-bottom: 1rem;
+}
+
+/* Component: Dependency Link
+ * -------------------------------------------------------------------------- */
+
+.deplink { /* Currently no root styles, but keep the class as a namespace */ }
+
+.deplink__link {
+ display: inline-block;
+ margin-right: 0.41em;
+}
+
+.deplink__version {
+ color: @light_type;
+ display: inline-block;
+ font-size: 0.8em;
+ line-height: 1;
+}
+
+
+/* Component: Grouped List
+ * -------------------------------------------------------------------------- */
+
+.grouped-list {
+ border-top: 1px solid darken(@background, 20%);
+ margin: 0 0 2.44em 0;
+}
+
+.grouped-list__title {
+ color: @light_type;
+ font-size: 0.8em;
+ font-weight: 300;
+ letter-spacing: 1px;
+ margin: 0.8em 0 -0.1em 0;
+ text-transform: uppercase;
+}
+
+.grouped-list__item {
+ margin: 0;
+}
+
+
+/* Component: Message
+ * -------------------------------------------------------------------------- */
+
+.message {
+ border: 5px solid;
+ border-radius: 5px;
+ padding: 1em !important;
+}
+
+.message.message--error {
+ background-color: @error_background;
+ border-color: @error_border;
+}
+
+.message.message--not-available {
+ background-color: @not_available_background;
+ border-color: darken(@not_available_background, 20%);
+}
+
+
+/* Component: Multi Col
+ * Multiple columns side by side
+ * -------------------------------------------------------------------------- */
+
+.multi-col {
+ margin-bottom: 2.44em;
+}
+
+.multi-col__col {
+ display: block;
+ padding-right: 1em;
+ position: relative;
+ width: 100%;
+}
+
+@media (min-width: 38em) and (max-width: 51.999999em) {
+ .multi-col__col {
+ float: left;
+ width: 50%;
+ }
+
+ .multi-col__col:nth-child(2n+3) {
+ clear: both;
+ }
+}
+
+@media (min-width: 52em) {
+ .multi-col__col {
+ float: left;
+ width: 33.333333%;
+ }
+
+ .multi-col__col:nth-child(3n+4) {
+ clear: both;
+ }
+}
+
+
+/* Component: Page Title
+ * -------------------------------------------------------------------------- */
+
+.page-title {
+ margin: 4.77em 0 1.56em;
+ padding-bottom: 1.25em;
+ position: relative;
+}
+
+.page-title__title {
+ margin: 0 0 0 -0.05em; /* Visually align on left edge */
+}
+
+.page-title__label {
+ position: relative;
+ color: @light_type;
+ font-size: 0.8rem;
+ font-weight: 300;
+ letter-spacing: 1px;
+ margin-bottom: -0.8em;
+ text-transform: uppercase;
+ z-index: 1;
+}
+
+
+/* Component: Top Banner
+ * -------------------------------------------------------------------------- */
+
+.top-banner {
+ background-color: @banner_background;
+ color: @dark_foreground;
+ font-weight: normal;
+}
+
+.top-banner__logo,
+.top-banner__logo:visited {
+ float: left;
+ color: @dark_foreground;
+ font-size: 2.44em;
+ font-weight: 300;
+ line-height: 90px;
+ margin: 0;
+}
+
+.top-banner__logo:hover {
+ color: @link;
+ text-decoration: none;
+}
+
+.top-banner__form {
+ margin-bottom: 1.25em;
+}
+
+.top-banner__form input {
+ border: 1px solid @banner_background;
+ border-radius: 3px;
+ color: @banner_background;
+ font-weight: 300;
+ line-height: 2;
+ padding: 0.21em 0.512em;
+ width: 100%;
+}
+
+.top-banner__actions {
+ float: right;
+ text-align: right;
+}
+
+.top-banner__actions__item {
+ display: inline-block;
+ line-height: 90px;
+ margin: 0;
+ padding-left: 1.25em;
+}
+
+.top-banner__actions__item:first-child {
+ padding-left: 0;
+}
+
+.top-banner__actions__item a,
+.top-banner__actions__item a:visited {
+ color: @dark_foreground;
+}
+
+.top-banner__actions__item a:hover {
+ color: @link;
+}
+
+@media (min-width: 38em) {
+ .top-banner__logo {
+ float: left;
+ width: 25%;
+ }
+
+ .top-banner__form {
+ float: left;
+ line-height: 90px;
+ margin-bottom: 0;
+ width: 50%;
+ }
+
+ .top-banner__actions {
+ float: right;
+ width: 25%;
+ }
+}
+
+
+/* Component: Search Results
+ * -------------------------------------------------------------------------- */
+
+.result {}
+
+.result.result--empty {
+ font-size: 1.25em;
+}
+
+.result__title {
+ font-size: 1.25em;
+ margin-bottom: 0.2rem;
+}
+
+.result__badge {
+ margin-left: -0.1em;
+}
+
+.result__body > *:first-child {
+ margin-top: 0!important;
+}
+
+.result__body > *:last-child {
+ margin-bottom: 0!important;
+}
+
+.result__signature {
+ background-color: transparent;
+ border-radius: 0;
+ border-top: 1px solid darken(@background, 20%);
+ border-bottom: 1px solid darken(@background, 20%);
+ padding: 0.328em 0;
+}
+
+.result__signature code {
+ display: block;
+ padding-left: 2.441em;
+ text-indent: -2.441em;
+ white-space: normal;
+}
+
+.result__actions {
+ margin-top: 0.2rem;
+}
+
+.result__actions__item {
+ font-size: 80%;
+}
+
+.result__actions__item + .result__actions__item {
+ margin-left: 0.65em;
+}
+
+
+/* Component: Version Selector
+ * -------------------------------------------------------------------------- */
+
+.version-selector {
+ margin-bottom: 0.8em;
+}
+
+@media (min-width: 38em) {
+ .version-selector {
+ position: absolute;
+ top: 0.8em;
+ right: 0;
+ margin-bottom: 0;
+ }
+}
+
+
+/* Section: FIXME
+ * These styles should be cleaned up
+ * ========================================================================== */
+
+/* Help paragraphs */
+.help {
+ padding: 5px 0;
+}
+
+.help h3 { /* FIXME: target with class */
+ margin-top: 16px;
+}
+
+
+/* Section: Markdown
+ * Github rendered README
+ * ========================================================================== */
+
+.markdown-body {
+ /*
+ Useful for narrow screens, such as mobiles. Documentation often contains URLs
+ which would otherwise force the page to become wider, and force creation of
+ horizontal scrollbars. Yuck.
+ */
+ word-wrap: break-word;
+}
+
+.markdown-body>*:first-child {
+ margin-top: 0 !important;
+}
+
+.markdown-body>*:last-child {
+ margin-bottom: 0 !important;
+}
+
+.markdown-body a:not([href]) {
+ color: inherit;
+ text-decoration: none;
+}
+
+.markdown-body blockquote {
+ margin: 0;
+ padding: 0 1em;
+ color: #777;
+ border-left: 0.25em solid #ddd;
+}
+
+.markdown-body blockquote>:first-child {
+ margin-top: 0;
+}
+
+.markdown-body blockquote>:last-child {
+ margin-bottom: 0;
+}
+
+.markdown-body .anchor {
+ /* We hide the anchor because the link doesn't point to a valid location */
+ display: none;
+}
+
+.markdown-body .pl-k {
+ /* Keyword */
+ color: #a0a0a0;
+}
+
+.markdown-body .pl-c1,
+.markdown-body .pl-en {
+ /* Not really sure what this is */
+ color: #39d;
+}
+
+.markdown-body .pl-s {
+ /* String literals */
+ color: #1a1;
+}
+
+.markdown-body .pl-cce {
+ /* String literal escape sequences */
+ color: #921;
+}
+
+.markdown-body .pl-smi {
+ /* type variables? */
+ color: #62b;
+}
diff --git a/examples/docs/src/DeclOrder.purs b/examples/docs/src/DeclOrder.purs
new file mode 100644
index 0000000..9ec2d21
--- /dev/null
+++ b/examples/docs/src/DeclOrder.purs
@@ -0,0 +1,17 @@
+module DeclOrder
+ ( class A
+ , x1
+ , X2
+ , x3
+ , X4
+ , class B
+ ) where
+
+x1 = 0
+x3 = 0
+
+data X2
+data X4
+
+class A
+class B
diff --git a/examples/docs/src/DeclOrderNoExportList.purs b/examples/docs/src/DeclOrderNoExportList.purs
new file mode 100644
index 0000000..2cfed5d
--- /dev/null
+++ b/examples/docs/src/DeclOrderNoExportList.purs
@@ -0,0 +1,10 @@
+module DeclOrderNoExportList where
+
+x1 = 0
+x3 = 0
+
+data X2
+data X4
+
+class A
+class B
diff --git a/examples/docs/src/TypeOpAliases.purs b/examples/docs/src/TypeOpAliases.purs
index be11148..6d76c4e 100644
--- a/examples/docs/src/TypeOpAliases.purs
+++ b/examples/docs/src/TypeOpAliases.purs
@@ -14,5 +14,31 @@ data Tuple a b = Tuple a b
infixl 6 Tuple as ×
infixl 6 type Tuple as ×
+data Either a b = Left a | Right b
+
+infixl 5 type Either as ⊕
+
third ∷ ∀ a b c. a × b × c → c
third (a × b × c) = c
+
+class Show a where
+ show :: a -> String
+
+instance showTuple :: Show a => Show (a × b) where
+ show (a × _) = show a
+
+-- Test that precedence is taken into account while desugaring type operators
+
+class TestL a where
+ testL :: a
+
+class TestR a where
+ testR :: a
+
+-- Note: this type is Either Int (Tuple Int String)
+instance testLEither :: TestL (Int ⊕ Int × String) where
+ testL = Right (0 × "hi")
+
+-- Note: this type is Either (Tuple Int Int) String
+instance testREither :: TestR (Int × Int ⊕ String) where
+ testR = Left (0 × 1)
diff --git a/examples/failing/2197-shouldFail.purs b/examples/failing/2197-shouldFail.purs
new file mode 100644
index 0000000..a211f19
--- /dev/null
+++ b/examples/failing/2197-shouldFail.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith ScopeConflict
+module Main where
+
+import Prim as P
+import Prim (Number)
+
+type Number = P.Number
+
+z :: Number
+z = 0.0
diff --git a/examples/failing/2197-shouldFail2.purs b/examples/failing/2197-shouldFail2.purs
new file mode 100644
index 0000000..fb1b11b
--- /dev/null
+++ b/examples/failing/2197-shouldFail2.purs
@@ -0,0 +1,7 @@
+-- @shouldFailWith UnknownName
+module Main where
+
+import Prim (Boolean)
+
+z :: Number
+z = 0.0
diff --git a/examples/failing/DuplicateInstance.purs b/examples/failing/DuplicateInstance.purs
new file mode 100644
index 0000000..bb3c13e
--- /dev/null
+++ b/examples/failing/DuplicateInstance.purs
@@ -0,0 +1,6 @@
+-- @shouldFailWith DuplicateInstance
+module Main where
+class X
+class Y
+instance i :: X
+instance i :: Y
diff --git a/examples/failing/DuplicateTypeClass.purs b/examples/failing/DuplicateTypeClass.purs
new file mode 100644
index 0000000..969c3e3
--- /dev/null
+++ b/examples/failing/DuplicateTypeClass.purs
@@ -0,0 +1,4 @@
+-- @shouldFailWith DuplicateTypeClass
+module Main where
+class C
+class C
diff --git a/examples/failing/InfiniteKind2.purs b/examples/failing/InfiniteKind2.purs
new file mode 100644
index 0000000..63c9104
--- /dev/null
+++ b/examples/failing/InfiniteKind2.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith InfiniteKind
+
+module InfiniteKind2 where
+
+data Tree m a = Tree a (m (Tree a))
diff --git a/examples/passing/2197-1.purs b/examples/passing/2197-1.purs
new file mode 100644
index 0000000..a0c808f
--- /dev/null
+++ b/examples/passing/2197-1.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import Control.Monad.Eff.Console
+import Prim as P
+
+type Number = P.Number
+type Test = {}
+
+z :: Number
+z = 0.0
+
+main = log "Done"
diff --git a/examples/passing/2197-2.purs b/examples/passing/2197-2.purs
new file mode 100644
index 0000000..94354e9
--- /dev/null
+++ b/examples/passing/2197-2.purs
@@ -0,0 +1,11 @@
+module Main where
+
+import Control.Monad.Eff.Console
+import Prim (Int)
+
+type Number = Int
+
+z :: Number
+z = 0
+
+main = log "Done"
diff --git a/examples/passing/2958.purs b/examples/passing/2958.purs
new file mode 100644
index 0000000..462bcaa
--- /dev/null
+++ b/examples/passing/2958.purs
@@ -0,0 +1,14 @@
+module Main where
+
+import Control.Monad.Eff.Console
+
+data Nil
+data Snoc xs x
+
+infixl 1 type Snoc as :>
+
+type One = Nil :> Int
+type Two = Nil :> Int :> Int
+type Three = Nil :> Int :> Int :> Int
+
+main = log "Done"
diff --git a/examples/passing/3125.purs b/examples/passing/3125.purs
new file mode 100644
index 0000000..d427fd4
--- /dev/null
+++ b/examples/passing/3125.purs
@@ -0,0 +1,16 @@
+module Main where
+
+import Prelude
+import Data.Monoid (class Monoid, mempty)
+import Control.Monad.Eff.Console (log, logShow)
+
+data B a = B a a
+
+memptyB :: forall a b. Monoid b => B (a -> b)
+memptyB = B l r where
+ l _ = mempty
+ r _ = mempty
+
+main = do
+ logShow $ case (memptyB :: B (Int -> Array Unit)) of B l r -> l 0 == r 0
+ log "Done"
diff --git a/examples/passing/ParensInType.purs b/examples/passing/ParensInType.purs
new file mode 100644
index 0000000..75d0120
--- /dev/null
+++ b/examples/passing/ParensInType.purs
@@ -0,0 +1,20 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+
+class Foo a where
+ foo :: forall eff. (String -> a (( console :: CONSOLE | eff)) ((Unit)))
+
+instance fooLogEff :: Foo Eff where
+ foo = log
+
+main ::
+ forall eff.
+ Eff
+ ( console :: CONSOLE
+ | eff
+ )
+ Unit
+main = foo "Done"
diff --git a/examples/passing/UnsafeCoerce.purs b/examples/passing/UnsafeCoerce.purs
new file mode 100644
index 0000000..6b4dbb1
--- /dev/null
+++ b/examples/passing/UnsafeCoerce.purs
@@ -0,0 +1,16 @@
+module Main where
+
+import Prelude (Unit)
+import Unsafe.Coerce (unsafeCoerce)
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+
+x :: Number
+x = unsafeCoerce 1
+
+y :: Number
+y = case unsafeCoerce 1 of
+ z -> unsafeCoerce z
+
+main :: Eff (console :: CONSOLE) Unit
+main = log "Done"
diff --git a/purescript.cabal b/purescript.cabal
index 9754981..6fed6c9 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,9 +1,9 @@
--- This file has been generated from package.yaml by hpack version 0.15.0.
+-- This file has been generated from package.yaml by hpack version 0.17.1.
--
-- see: https://github.com/sol/hpack
name: purescript
-version: 0.11.6
+version: 0.11.7
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
@@ -24,6 +24,7 @@ extra-source-files:
app/static/index.js
app/static/normalize.css
app/static/pursuit.css
+ app/static/pursuit.less
CONTRIBUTING.md
CONTRIBUTORS.md
examples/docs/bower.json
@@ -36,6 +37,8 @@ extra-source-files:
examples/docs/src/Clash2.purs
examples/docs/src/Clash2a.purs
examples/docs/src/ConstrainedArgument.purs
+ examples/docs/src/DeclOrder.purs
+ examples/docs/src/DeclOrderNoExportList.purs
examples/docs/src/Desugar.purs
examples/docs/src/DocComments.purs
examples/docs/src/DuplicateNames.purs
@@ -76,6 +79,8 @@ extra-source-files:
examples/failing/1881.purs
examples/failing/2128-class.purs
examples/failing/2128-instance.purs
+ examples/failing/2197-shouldFail.purs
+ examples/failing/2197-shouldFail2.purs
examples/failing/2378.purs
examples/failing/2378/Lib.purs
examples/failing/2379.purs
@@ -140,9 +145,11 @@ extra-source-files:
examples/failing/DoNotSuggestComposition.purs
examples/failing/DoNotSuggestComposition2.purs
examples/failing/DuplicateDeclarationsInLet.purs
+ examples/failing/DuplicateInstance.purs
examples/failing/DuplicateModule.purs
examples/failing/DuplicateModule/M1.purs
examples/failing/DuplicateProperties.purs
+ examples/failing/DuplicateTypeClass.purs
examples/failing/DuplicateTypeVars.purs
examples/failing/Eff.purs
examples/failing/EmptyCase.purs
@@ -186,6 +193,7 @@ extra-source-files:
examples/failing/ImportModule.purs
examples/failing/ImportModule/M2.purs
examples/failing/InfiniteKind.purs
+ examples/failing/InfiniteKind2.purs
examples/failing/InfiniteType.purs
examples/failing/InstanceExport.purs
examples/failing/InstanceExport/InstanceExport.purs
@@ -303,6 +311,8 @@ extra-source-files:
examples/passing/2138/Lib.purs
examples/passing/2172.js
examples/passing/2172.purs
+ examples/passing/2197-1.purs
+ examples/passing/2197-2.purs
examples/passing/2252.purs
examples/passing/2288.purs
examples/passing/2378.purs
@@ -318,7 +328,9 @@ extra-source-files:
examples/passing/2787.purs
examples/passing/2795.purs
examples/passing/2806.purs
+ examples/passing/2958.purs
examples/passing/2972.purs
+ examples/passing/3125.purs
examples/passing/652.purs
examples/passing/810.purs
examples/passing/862.purs
@@ -489,6 +501,7 @@ extra-source-files:
examples/passing/OverlappingInstances.purs
examples/passing/OverlappingInstances2.purs
examples/passing/OverlappingInstances3.purs
+ examples/passing/ParensInType.purs
examples/passing/ParensInTypedBinder.purs
examples/passing/PartialFunction.purs
examples/passing/Patterns.purs
@@ -585,6 +598,7 @@ extra-source-files:
examples/passing/UnifyInTypeInstanceLookup.purs
examples/passing/Unit.purs
examples/passing/UnknownInTypeClassLookup.purs
+ examples/passing/UnsafeCoerce.purs
examples/passing/UntupledConstraints.purs
examples/passing/UsableTypeClassMethods.purs
examples/passing/UTF8Sourcefile.purs
@@ -639,6 +653,7 @@ extra-source-files:
tests/support/package.json
tests/support/prelude-resolutions.json
tests/support/psci/Sample.purs
+ tests/support/pscide/src/CompletionSpecDocs.purs
tests/support/pscide/src/ImportsSpec.purs
tests/support/pscide/src/ImportsSpec1.purs
tests/support/pscide/src/MatcherSpec.purs
@@ -668,12 +683,12 @@ library
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:
- aeson >=1.0 && <1.2
+ aeson >=1.0 && <1.3
, aeson-better-errors >=0.8
, ansi-terminal >=0.6.2 && <0.7
, base >=4.8 && <5
, base-compat >=0.6.0
- , blaze-html >=0.8.1 && <0.9
+ , blaze-html >=0.8.1 && <0.10
, bower-json >=1.0.0.1 && <1.1
, boxes >=0.1.4 && <0.2.0
, bytestring
@@ -685,9 +700,10 @@ library
, directory >=1.2.3
, dlist
, edit-distance
+ , file-embed
, filepath
, fsnotify >=0.2.1
- , Glob >=0.7 && <0.8
+ , Glob >=0.7 && <0.9
, haskeline >=0.7.0.0
, http-client >=0.4.30 && <0.6.0
, http-types
@@ -702,7 +718,7 @@ library
, pattern-arrows >=0.0.2 && <0.1
, pipes >=4.0.0 && <4.4.0
, pipes-http
- , process >=1.2.0 && <1.5
+ , process >=1.2.0 && <1.7
, protolude >=0.1.6
, regex-tdfa
, safe >=0.3.9 && <0.4
@@ -767,6 +783,7 @@ library
Language.PureScript.Docs.Convert
Language.PureScript.Docs.Convert.ReExports
Language.PureScript.Docs.Convert.Single
+ Language.PureScript.Docs.Css
Language.PureScript.Docs.ParseInPackage
Language.PureScript.Docs.Prim
Language.PureScript.Docs.Render
@@ -780,6 +797,7 @@ library
Language.PureScript.Errors
Language.PureScript.Errors.JSON
Language.PureScript.Externs
+ Language.PureScript.Hierarchy
Language.PureScript.Ide
Language.PureScript.Ide.CaseSplit
Language.PureScript.Ide.Command
@@ -879,12 +897,12 @@ executable purs
app
ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
build-depends:
- aeson >=1.0 && <1.2
+ aeson >=1.0 && <1.3
, aeson-better-errors >=0.8
, ansi-terminal >=0.6.2 && <0.7
, base >=4.8 && <5
, base-compat >=0.6.0
- , blaze-html >=0.8.1 && <0.9
+ , blaze-html >=0.8.1 && <0.10
, bower-json >=1.0.0.1 && <1.1
, boxes >=0.1.4 && <0.2.0
, bytestring
@@ -896,9 +914,10 @@ executable purs
, directory >=1.2.3
, dlist
, edit-distance
+ , file-embed
, filepath
, fsnotify >=0.2.1
- , Glob >=0.7 && <0.8
+ , Glob >=0.7 && <0.9
, haskeline >=0.7.0.0
, http-client >=0.4.30 && <0.6.0
, http-types
@@ -913,7 +932,7 @@ executable purs
, pattern-arrows >=0.0.2 && <0.1
, pipes >=4.0.0 && <4.4.0
, pipes-http
- , process >=1.2.0 && <1.5
+ , process >=1.2.0 && <1.7
, protolude >=0.1.6
, regex-tdfa
, safe >=0.3.9 && <0.4
@@ -941,12 +960,12 @@ executable purs
, wai ==3.*
, wai-websockets ==3.*
, warp ==3.*
- , websockets >=0.9 && <0.11
+ , websockets >=0.9 && <0.13
if flag(release)
cpp-options: -DRELEASE
else
build-depends:
- gitrev >=1.2.0 && <1.3
+ gitrev >=1.2.0 && <1.4
other-modules:
Command.Bundle
Command.Compile
@@ -959,6 +978,7 @@ executable purs
Command.Ide
Command.Publish
Command.REPL
+ Paths_purescript
Version
default-language: Haskell2010
@@ -969,12 +989,12 @@ test-suite tests
tests
ghc-options: -Wall
build-depends:
- aeson >=1.0 && <1.2
+ aeson >=1.0 && <1.3
, aeson-better-errors >=0.8
, ansi-terminal >=0.6.2 && <0.7
, base >=4.8 && <5
, base-compat >=0.6.0
- , blaze-html >=0.8.1 && <0.9
+ , blaze-html >=0.8.1 && <0.10
, bower-json >=1.0.0.1 && <1.1
, boxes >=0.1.4 && <0.2.0
, bytestring
@@ -986,9 +1006,10 @@ test-suite tests
, directory >=1.2.3
, dlist
, edit-distance
+ , file-embed
, filepath
, fsnotify >=0.2.1
- , Glob >=0.7 && <0.8
+ , Glob >=0.7 && <0.9
, haskeline >=0.7.0.0
, http-client >=0.4.30 && <0.6.0
, http-types
@@ -1003,7 +1024,7 @@ test-suite tests
, pattern-arrows >=0.0.2 && <0.1
, pipes >=4.0.0 && <4.4.0
, pipes-http
- , process >=1.2.0 && <1.5
+ , process >=1.2.0 && <1.7
, protolude >=0.1.6
, regex-tdfa
, safe >=0.3.9 && <0.4
@@ -1041,6 +1062,7 @@ test-suite tests
PscIdeSpec
TestCompiler
TestDocs
+ TestHierarchy
TestPrimDocs
TestPsci
TestPsci.CommandTest
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index d897ee0..77012c3 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -1,6 +1,8 @@
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveAnyClass #-}
-- |
-- Data types for modules and declarations
@@ -9,12 +11,15 @@ module Language.PureScript.AST.Declarations where
import Prelude.Compat
+import Control.DeepSeq (NFData)
import Control.Monad.Identity
import Data.Aeson.TH
import qualified Data.Map as M
+import Data.Set (Set)
import Data.Text (Text)
import qualified Data.List.NonEmpty as NEL
+import GHC.Generics (Generic)
import Language.PureScript.AST.Binders
import Language.PureScript.AST.Literals
@@ -89,6 +94,8 @@ data SimpleErrorMessage
| DeclConflict Name Name
| ExportConflict (Qualified Name) (Qualified Name)
| DuplicateModule ModuleName [SourceSpan]
+ | DuplicateTypeClass (ProperName 'ClassName) SourceSpan
+ | DuplicateInstance Ident SourceSpan
| DuplicateTypeArgument Text
| InvalidDoBind
| InvalidDoLet
@@ -126,7 +133,7 @@ data SimpleErrorMessage
| PropertyIsMissing Label
| AdditionalProperty Label
| TypeSynonymInstance
- | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
+ | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (Set ModuleName) [Type]
| InvalidNewtype (ProperName 'TypeName)
| InvalidInstanceHead Type
| TransitiveExportError DeclarationRef [DeclarationRef]
@@ -164,9 +171,8 @@ data SimpleErrorMessage
| ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int
-- | a user-defined warning raised by using the Warn type class
| UserDefinedWarning Type
- -- | a declaration couldn't be used because there wouldn't be enough information
- -- | to choose an instance
- | UnusableDeclaration Ident
+ -- | a declaration couldn't be used because it contained free variables
+ | UnusableDeclaration Ident [[Text]]
deriving (Show)
-- | Error message hints, providing more detailed information about failure.
@@ -229,12 +235,19 @@ getModuleSourceSpan (Module ss _ _ _ _) = ss
-- |
-- Add an import declaration for a module if it does not already explicitly import it.
--
+-- Will not import an unqualified module if that module has already been imported qualified.
+-- (See #2197)
+--
addDefaultImport :: Qualified ModuleName -> Module -> Module
addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) =
if isExistingImport `any` decls || mn == toImport then m
else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs : decls) exps
where
- isExistingImport (ImportDeclaration _ mn' _ as') | mn' == toImport && as' == toImportAs = True
+ isExistingImport (ImportDeclaration _ mn' _ as')
+ | mn' == toImport =
+ case toImportAs of
+ Nothing -> True
+ _ -> as' == toImportAs
isExistingImport _ = False
-- | Adds import declarations to a module for an implicit Prim import and Prim
@@ -244,8 +257,8 @@ importPrim =
let
primModName = ModuleName [ProperName C.prim]
in
- addDefaultImport (Qualified Nothing primModName)
- . addDefaultImport (Qualified (Just primModName) primModName)
+ addDefaultImport (Qualified (Just primModName) primModName)
+ . addDefaultImport (Qualified Nothing primModName)
-- |
-- An item in a list of explicit imports or exports
@@ -288,7 +301,7 @@ data DeclarationRef
-- elaboration in name desugaring.
--
| ReExportRef SourceSpan ModuleName DeclarationRef
- deriving (Show)
+ deriving (Show, Generic, NFData)
instance Eq DeclarationRef where
(TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors'
@@ -338,6 +351,17 @@ declRefSourceSpan (ModuleRef ss _) = ss
declRefSourceSpan (KindRef ss _) = ss
declRefSourceSpan (ReExportRef ss _ _) = ss
+declRefName :: DeclarationRef -> Name
+declRefName (TypeRef _ n _) = TyName n
+declRefName (TypeOpRef _ n) = TyOpName n
+declRefName (ValueRef _ n) = IdentName n
+declRefName (ValueOpRef _ n) = ValOpName n
+declRefName (TypeClassRef _ n) = TyClassName n
+declRefName (TypeInstanceRef _ n) = IdentName n
+declRefName (ModuleRef _ n) = ModName n
+declRefName (KindRef _ n) = KiName n
+declRefName (ReExportRef _ _ ref) = declRefName ref
+
getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
getTypeRef (TypeRef _ name dctors) = Just (name, dctors)
getTypeRef _ = Nothing
@@ -392,6 +416,53 @@ isExplicit :: ImportDeclarationType -> Bool
isExplicit (Explicit _) = True
isExplicit _ = False
+-- | A type declaration assigns a type to an identifier, eg:
+--
+-- @identity :: forall a. a -> a@
+--
+-- In this example @identity@ is the identifier and @forall a. a -> a@ the type.
+data TypeDeclarationData = TypeDeclarationData
+ { tydeclSourceAnn :: !SourceAnn
+ , tydeclIdent :: !Ident
+ , tydeclType :: !Type
+ } deriving (Show, Eq)
+
+overTypeDeclaration :: (TypeDeclarationData -> TypeDeclarationData) -> Declaration -> Declaration
+overTypeDeclaration f d = maybe d (TypeDeclaration . f) (getTypeDeclaration d)
+
+getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
+getTypeDeclaration (TypeDeclaration d) = Just d
+getTypeDeclaration _ = Nothing
+
+unwrapTypeDeclaration :: TypeDeclarationData -> (Ident, Type)
+unwrapTypeDeclaration td = (tydeclIdent td, tydeclType td)
+
+-- | A value declaration assigns a name and potential binders, to an expression (or multiple guarded expressions).
+--
+-- @double x = x + x@
+--
+-- In this example @double@ is the identifier, @x@ is a binder and @x + x@ is the expression.
+data ValueDeclarationData a = ValueDeclarationData
+ { valdeclSourceAnn :: !SourceAnn
+ , valdeclIdent :: !Ident
+ -- ^ The declared value's name
+ , valdeclName :: !NameKind
+ -- ^ Whether or not this value is exported/visible
+ , valdeclBinders :: ![Binder]
+ , valdeclExpression :: !a
+ } deriving (Show, Functor, Foldable, Traversable)
+
+overValueDeclaration :: (ValueDeclarationData [GuardedExpr] -> ValueDeclarationData [GuardedExpr]) -> Declaration -> Declaration
+overValueDeclaration f d = maybe d (ValueDeclaration . f) (getValueDeclaration d)
+
+getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
+getValueDeclaration (ValueDeclaration d) = Just d
+getValueDeclaration _ = Nothing
+
+pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
+pattern ValueDecl sann ident name binders expr
+ = ValueDeclaration (ValueDeclarationData sann ident name binders expr)
+
-- |
-- The data type of declarations
--
@@ -411,11 +482,11 @@ data Declaration
-- |
-- A type declaration for a value (name, ty)
--
- | TypeDeclaration SourceAnn Ident Type
+ | TypeDeclaration {-# UNPACK #-} !TypeDeclarationData
-- |
-- A value declaration (name, top-level binders, optional guard, value)
--
- | ValueDeclaration SourceAnn Ident NameKind [Binder] [GuardedExpr]
+ | ValueDeclaration {-# UNPACK #-} !(ValueDeclarationData [GuardedExpr])
-- |
-- A declaration paired with pattern matching in let-in expression (binder, optional guard, value)
| BoundValueDeclaration SourceAnn Binder Expr
@@ -491,8 +562,8 @@ declSourceAnn :: Declaration -> SourceAnn
declSourceAnn (DataDeclaration sa _ _ _ _) = sa
declSourceAnn (DataBindingGroupDeclaration ds) = declSourceAnn (NEL.head ds)
declSourceAnn (TypeSynonymDeclaration sa _ _ _) = sa
-declSourceAnn (TypeDeclaration sa _ _) = sa
-declSourceAnn (ValueDeclaration sa _ _ _ _) = sa
+declSourceAnn (TypeDeclaration td) = tydeclSourceAnn td
+declSourceAnn (ValueDeclaration vd) = valdeclSourceAnn vd
declSourceAnn (BoundValueDeclaration sa _ _) = sa
declSourceAnn (BindingGroupDeclaration ds) = let ((sa, _), _, _) = NEL.head ds in sa
declSourceAnn (ExternDeclaration sa _ _) = sa
@@ -506,6 +577,23 @@ declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _) = sa
declSourceSpan :: Declaration -> SourceSpan
declSourceSpan = fst . declSourceAnn
+declName :: Declaration -> Maybe Name
+declName (DataDeclaration _ _ n _ _) = Just (TyName n)
+declName (TypeSynonymDeclaration _ n _ _) = Just (TyName n)
+declName (ValueDeclaration vd) = Just (IdentName (valdeclIdent vd))
+declName (ExternDeclaration _ n _) = Just (IdentName n)
+declName (ExternDataDeclaration _ n _) = Just (TyName n)
+declName (ExternKindDeclaration _ n) = Just (KiName n)
+declName (FixityDeclaration _ (Left (ValueFixity _ _ n))) = Just (ValOpName n)
+declName (FixityDeclaration _ (Right (TypeFixity _ _ n))) = Just (TyOpName n)
+declName (TypeClassDeclaration _ n _ _ _ _) = Just (TyClassName n)
+declName (TypeInstanceDeclaration _ n _ _ _ _) = Just (IdentName n)
+declName ImportDeclaration{} = Nothing
+declName BindingGroupDeclaration{} = Nothing
+declName DataBindingGroupDeclaration{} = Nothing
+declName BoundValueDeclaration{} = Nothing
+declName TypeDeclaration{} = Nothing
+
-- |
-- Test if a declaration is a value declaration
--
diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
index 1e5b033..be6fa74 100644
--- a/src/Language/PureScript/AST/Exported.hs
+++ b/src/Language/PureScript/AST/Exported.hs
@@ -4,10 +4,12 @@ module Language.PureScript.AST.Exported
) where
import Prelude.Compat
+import Protolude (sortBy, on)
import Control.Category ((>>>))
import Data.Maybe (mapMaybe)
+import qualified Data.Map as M
import Language.PureScript.AST.Declarations
import Language.PureScript.Types
@@ -24,6 +26,10 @@ import Language.PureScript.Names
-- produce incorrect results if this is not the case - for example, type class
-- instances will be incorrectly removed in some cases.
--
+-- The returned declarations are in the same order as they appear in the export
+-- list, unless there is no export list, in which case they appear in the same
+-- order as they do in the source file.
+--
exportedDeclarations :: Module -> [Declaration]
exportedDeclarations (Module _ _ mn decls exps) = go decls
where
@@ -31,6 +37,7 @@ exportedDeclarations (Module _ _ mn decls exps) = go decls
>>> filter (isExported exps)
>>> map (filterDataConstructors exps)
>>> filterInstances mn exps
+ >>> maybe id reorder exps
-- |
-- Filter out all data constructors from a declaration which are not exported.
@@ -119,19 +126,9 @@ typeInstanceConstituents _ = []
isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
isExported Nothing _ = True
isExported _ TypeInstanceDeclaration{} = True
-isExported (Just exps) decl = any (matches decl) exps
+isExported (Just exps) decl = any matches exps
where
- matches (TypeDeclaration _ ident _) (ValueRef _ ident') = ident == ident'
- matches (ValueDeclaration _ ident _ _ _) (ValueRef _ ident') = ident == ident'
- matches (ExternDeclaration _ ident _) (ValueRef _ ident') = ident == ident'
- matches (DataDeclaration _ _ ident _ _) (TypeRef _ ident' _) = ident == ident'
- matches (ExternDataDeclaration _ ident _) (TypeRef _ ident' _) = ident == ident'
- matches (ExternKindDeclaration _ ident) (KindRef _ ident') = ident == ident'
- matches (TypeSynonymDeclaration _ ident _ _) (TypeRef _ ident' _) = ident == ident'
- matches (TypeClassDeclaration _ ident _ _ _ _) (TypeClassRef _ ident') = ident == ident'
- matches (ValueFixityDeclaration _ _ _ op) (ValueOpRef _ op') = op == op'
- matches (TypeFixityDeclaration _ _ _ op) (TypeOpRef _ op') = op == op'
- matches _ _ = False
+ matches declRef = declName decl == Just (declRefName declRef)
-- |
-- Test if a data constructor for a given type is exported, given a module's
@@ -144,3 +141,16 @@ isDctorExported ident (Just exps) ctor = test `any` exps
test (TypeRef _ ident' Nothing) = ident == ident'
test (TypeRef _ ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
test _ = False
+
+-- |
+-- Reorder declarations based on the order they appear in the given export
+-- list.
+--
+reorder :: [DeclarationRef] -> [Declaration] -> [Declaration]
+reorder refs =
+ sortBy (compare `on` refIndex)
+ where
+ refIndices =
+ M.fromList $ zip (map declRefName refs) [(0::Int)..]
+ refIndex decl =
+ declName decl >>= flip M.lookup refIndices
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 3fe55a8..4da91b1 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -53,7 +53,8 @@ everywhereOnValues f g h = (f', g', h')
where
f' :: Declaration -> Declaration
f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (fmap f' ds))
- f' (ValueDeclaration sa name nameKind bs val) = f (ValueDeclaration sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val))
+ f' (ValueDecl sa name nameKind bs val) =
+ f (ValueDecl sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val))
f' (BoundValueDeclaration sa b expr) = f (BoundValueDeclaration sa (h' b) (g' expr))
f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (fmap (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
f' (TypeClassDeclaration sa name args implies deps ds) = f (TypeClassDeclaration sa name args implies deps (fmap f' ds))
@@ -125,7 +126,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
f' :: Declaration -> m Declaration
f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
- f' (ValueDeclaration sa name nameKind bs val) = ValueDeclaration sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val
+ f' (ValueDecl sa name nameKind bs val) =
+ ValueDecl sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val
f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds
f' (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds
@@ -192,7 +194,8 @@ everywhereOnValuesM f g h = (f', g', h')
f' :: Declaration -> m Declaration
f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
- f' (ValueDeclaration sa name nameKind bs val) = (ValueDeclaration sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f
+ f' (ValueDecl sa name nameKind bs val) =
+ ValueDecl sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val >>= f
f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f
f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f
@@ -263,7 +266,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
f' :: Declaration -> r
f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (fmap f' ds)
- f' d@(ValueDeclaration _ _ _ bs val) = foldl (<>) (f d) (fmap h' bs ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) val)
+ f' d@(ValueDeclaration vd) = foldl (<>) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd))
f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (fmap (\(_, _, val) -> g' val) ds)
f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) (f d) (fmap f' ds)
f' d@(TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (fmap f' ds)
@@ -341,7 +344,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
f' :: s -> Declaration -> r
f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (fmap (f'' s) ds)
- f' s (ValueDeclaration _ _ _ bs val) = foldl (<>) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) val)
+ f' s (ValueDeclaration vd) = foldl (<>) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd))
f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (fmap (\(_, _, val) -> g'' s val) ds)
f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) r0 (fmap (f'' s) ds)
f' s (TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (fmap (f'' s) ds)
@@ -426,7 +429,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
f'' s = uncurry f' <=< f s
f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds
- f' s (ValueDeclaration sa name nameKind bs val) = ValueDeclaration sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val
+ f' s (ValueDecl sa name nameKind bs val) =
+ ValueDecl sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val
f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds
f' s (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f'' s) ds
f' s (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds
@@ -508,7 +512,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
f' s (DataBindingGroupDeclaration ds) =
let s' = S.union s (S.fromList (mapMaybe getDeclIdent (NEL.toList ds)))
in foldMap (f'' s') ds
- f' s (ValueDeclaration _ name _ bs val) =
+ f' s (ValueDecl _ name _ bs val) =
let s' = S.insert name s
s'' = S.union s' (S.fromList (concatMap binderNames bs))
in foldMap (h'' s') bs <> foldMap (l' s'') val
@@ -596,8 +600,8 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
in r <> l' s' (GuardedExpr gs e)
getDeclIdent :: Declaration -> Maybe Ident
- getDeclIdent (ValueDeclaration _ ident _ _ _) = Just ident
- getDeclIdent (TypeDeclaration _ ident _) = Just ident
+ getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
+ getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td)
getDeclIdent _ = Nothing
accumTypes
@@ -616,7 +620,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies)
forDecls (TypeInstanceDeclaration _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) `mappend` mconcat (fmap f tys)
forDecls (TypeSynonymDeclaration _ _ _ ty) = f ty
- forDecls (TypeDeclaration _ _ ty) = f ty
+ forDecls (TypeDeclaration td) = f (tydeclType td)
forDecls _ = mempty
forValues (TypeClassDictionary c _ _) = mconcat (fmap f (constraintArgs c))
@@ -647,7 +651,7 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con
forDecls (TypeSynonymDeclaration _ _ args ty) =
foldMap (foldMap f . snd) args `mappend`
forTypes ty
- forDecls (TypeDeclaration _ _ ty) = forTypes ty
+ forDecls (TypeDeclaration td) = forTypes (tydeclType td)
forDecls (ExternDeclaration _ _ ty) = forTypes ty
forDecls (ExternDataDeclaration _ _ kn) = f kn
forDecls _ = mempty
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index af226f6..1995905 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -52,7 +52,8 @@ data ErrorMessage
| MissingMainModule String
deriving (Show)
--- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
+-- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or
+-- foreign modules.
data ModuleType
= Regular
| Foreign
@@ -500,7 +501,7 @@ isModuleEmpty (Module _ _ els) = all isElementEmpty els
-- In particular, a module and its foreign imports share the same namespace inside PS.
-- This saves us from having to generate unique names for a module and its foreign imports,
-- and is safe since a module shares a namespace with its foreign imports in PureScript as well
--- (so there is no way to have overlaps in code generated by psc).
+-- (so there is no way to have overlaps in code generated by the compiler).
codeGen :: Maybe String -- ^ main module
-> String -- ^ namespace
-> [Module] -- ^ input modules
@@ -604,7 +605,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
keepCol (TokenPn _ _ c) = TokenPn 0 0 (if c >= 0 then c + 2 else 2)
prelude :: JSStatement
- prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by psc-bundle " ++ showVersion Paths.version
+ prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by purs bundle " ++ showVersion Paths.version
, WhiteSpace tokenPosnEmpty "\n" ])
(cList [
JSVarInitExpression (JSIdentifier sp optionsNamespace)
@@ -674,7 +675,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
-- This function performs dead code elimination, filters empty modules
-- and generates and prints the final JavaScript bundle.
bundleSM :: (MonadError ErrorMessage m)
- => [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
+ => [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from the compiler.
-> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
-> Maybe String -- ^ An optional main module.
-> String -- ^ The namespace (e.g. PS).
@@ -703,7 +704,7 @@ bundleSM inputStrs entryPoints mainModule namespace outFilename = do
-- This function performs dead code elimination, filters empty modules
-- and generates and prints the final JavaScript bundle.
bundle :: (MonadError ErrorMessage m)
- => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
+ => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from the compiler.
-> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
-> Maybe String -- ^ An optional main module.
-> String -- ^ The namespace (e.g. PS).
diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs
index 8c72e08..d8b59dc 100644
--- a/src/Language/PureScript/CodeGen/JS/Printer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Printer.hs
@@ -49,7 +49,7 @@ literals = mkPattern' match'
, withIndent $ do
jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value
indentString <- currentIndent
- return $ intercalate (emit ", \n") $ map (indentString <>) jss
+ return $ intercalate (emit ",\n") $ map (indentString <>) jss
, return $ emit "\n"
, currentIndent
, return $ emit "}"
@@ -116,20 +116,19 @@ literals = mkPattern' match'
, prettyPrintJS' value
]
match (Comment _ com js) = mconcat <$> sequence
- [ mconcat <$> forM com comment
+ [ return $ emit "\n"
+ , mconcat <$> forM com comment
, prettyPrintJS' js
]
match _ = mzero
comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
comment (LineComment com) = fmap mconcat $ sequence $
- [ return $ emit "\n"
- , currentIndent
+ [ currentIndent
, return $ emit "//" <> emit com <> emit "\n"
]
comment (BlockComment com) = fmap mconcat $ sequence $
- [ return $ emit "\n"
- , currentIndent
+ [ currentIndent
, return $ emit "/**\n"
] ++
map asLine (T.lines com) ++
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 73341f8..717aab7 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -479,3 +479,9 @@ partialUnsafe = "Partial_Unsafe"
unsafePartial :: forall a. (IsString a) => a
unsafePartial = "unsafePartial"
+
+unsafeCoerce :: forall a. (IsString a) => a
+unsafeCoerce = "Unsafe_Coerce"
+
+unsafeCoerceFn :: forall a. (IsString a) => a
+unsafeCoerceFn = "unsafeCoerce"
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index f0a681e..03873fb 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -63,7 +63,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
declToCoreFn (A.DataBindingGroupDeclaration ds) =
concatMap declToCoreFn ds
- declToCoreFn (A.ValueDeclaration (ss, com) name _ _ [A.MkUnguarded e]) =
+ declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) =
[NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
declToCoreFn (A.BindingGroupDeclaration ds) =
[Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds]
diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs
index cfdee15..e85e3ef 100644
--- a/src/Language/PureScript/CoreImp/Optimizer.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer.hs
@@ -33,7 +33,7 @@ import Language.PureScript.CoreImp.Optimizer.Unused
-- | Apply a series of optimizer passes to simplified JavaScript code
optimize :: MonadSupply m => AST -> m AST
optimize js = do
- js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll
+ js' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . applyAll
[ inlineCommonValues
, inlineCommonOperators
]) js
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
index 0c091e6..d7dc998 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
@@ -4,6 +4,7 @@ module Language.PureScript.CoreImp.Optimizer.Inliner
, inlineCommonValues
, inlineCommonOperators
, inlineFnComposition
+ , inlineUnsafeCoerce
, inlineUnsafePartial
, etaConvert
, unThunk
@@ -265,6 +266,13 @@ inlineFnComposition = everywhereTopDownM convert where
fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
+inlineUnsafeCoerce :: AST -> AST
+inlineUnsafeCoerce = everywhereTopDown convert where
+ convert (App _ (Indexer _ (StringLiteral _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
+ | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
+ = comp
+ convert other = other
+
inlineUnsafePartial :: AST -> AST
inlineUnsafePartial = everywhereTopDown convert where
convert (App ss (Indexer _ (StringLiteral _ unsafePartial) (Var _ partialUnsafe)) [ comp ])
diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs
index 7773952..f63544c 100644
--- a/src/Language/PureScript/Docs.hs
+++ b/src/Language/PureScript/Docs.hs
@@ -12,3 +12,4 @@ import Language.PureScript.Docs.ParseInPackage as Docs
import Language.PureScript.Docs.Render as Docs
import Language.PureScript.Docs.RenderedCode as Docs
import Language.PureScript.Docs.Types as Docs
+import Language.PureScript.Docs.Css as Docs
diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs
index c33109f..80856c9 100644
--- a/src/Language/PureScript/Docs/AsHtml.hs
+++ b/src/Language/PureScript/Docs/AsHtml.hs
@@ -15,10 +15,11 @@ module Language.PureScript.Docs.AsHtml (
) where
import Prelude
-import Control.Arrow (second)
import Control.Category ((>>>))
import Control.Monad (unless)
import Data.Char (isUpper)
+import Data.Either (isRight)
+import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Foldable (for_)
import Data.String (fromString)
@@ -29,6 +30,7 @@ import qualified Data.Text as T
import Text.Blaze.Html5 as H hiding (map)
import qualified Text.Blaze.Html5.Attributes as A
import qualified Cheapskate
+import Text.Parsec (eof)
import qualified Language.PureScript as P
@@ -68,22 +70,31 @@ nullRenderContext mn = HtmlRenderContext
, renderSourceLink = const Nothing
}
-packageAsHtml :: (P.ModuleName -> HtmlRenderContext) -> Package a -> HtmlOutput Html
+packageAsHtml
+ :: (InPackage P.ModuleName -> Maybe HtmlRenderContext)
+ -> Package a
+ -> HtmlOutput Html
packageAsHtml getHtmlCtx Package{..} =
HtmlOutput indexFile modules
where
indexFile = []
- modules = map (\m -> moduleAsHtml (getHtmlCtx (modName m)) m) pkgModules
+ modules = moduleAsHtml getHtmlCtx <$> pkgModules
-moduleAsHtml :: HtmlRenderContext -> Module -> (P.ModuleName, HtmlOutputModule Html)
-moduleAsHtml r Module{..} = (modName, HtmlOutputModule modHtml reexports)
+moduleAsHtml
+ :: (InPackage P.ModuleName -> Maybe HtmlRenderContext)
+ -> Module
+ -> (P.ModuleName, HtmlOutputModule Html)
+moduleAsHtml getR Module{..} = (modName, HtmlOutputModule modHtml reexports)
where
- renderDecl = declAsHtml r
modHtml = do
- for_ modComments renderMarkdown
- for_ modDeclarations renderDecl
+ let r = fromMaybe (nullRenderContext modName) $ getR (Local modName)
+ in do
+ for_ modComments renderMarkdown
+ for_ modDeclarations (declAsHtml r)
reexports =
- map (second (foldMap renderDecl)) modReExports
+ flip map modReExports $ \(pkg, decls) ->
+ let r = fromMaybe (nullRenderContext modName) $ getR pkg
+ in (pkg, foldMap (declAsHtml r) decls)
-- renderIndex :: LinksContext -> [(Maybe Char, Html)]
-- renderIndex LinksContext{..} = go ctxBookmarks
@@ -127,6 +138,8 @@ declAsHtml r d@Declaration{..} = do
h3 ! A.class_ "decl__title clearfix" $ do
a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#"
H.span $ text declTitle
+ text " " -- prevent browser from treating
+ -- declTitle + linkToSource as one word
for_ declSourceSpan (linkToSource r)
H.div ! A.class_ "decl__body" $ do
@@ -188,8 +201,14 @@ codeAsHtml r = outputWith elemAsHtml
case link_ of
Link mn ->
let
- class_ = if startsWithUpper name then "ctor" else "ident"
- target = if ns == TypeLevel then "type (" <> name <> ")" else name
+ class_ =
+ if startsWithUpper name then "ctor" else "ident"
+ target
+ | isOp name =
+ if ns == TypeLevel
+ then "type (" <> name <> ")"
+ else "(" <> name <> ")"
+ | otherwise = name
in
linkToDecl ns target mn (withClass class_ (text name))
NoLink ->
@@ -203,6 +222,13 @@ codeAsHtml r = outputWith elemAsHtml
then False
else isUpper (T.index str 0)
+ isOp = isRight . runParser P.symbol
+
+ runParser :: P.TokenParser a -> Text -> Either String a
+ runParser p' s = either (Left . show) Right $ do
+ ts <- P.lex "" s
+ P.runTokenParser "" (p' <* eof) ts
+
renderLink :: HtmlRenderContext -> DocLink -> Html -> Html
renderLink r link_@DocLink{..} =
a ! A.href (v (renderDocLink r link_ <> fragmentFor link_))
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index 2057a1e..17b72ae 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -208,5 +208,9 @@ partiallyDesugar = P.evalSupplyT 0 . desugar'
>>> traverse P.desugarCasesModule
>=> traverse P.desugarTypeDeclarationsModule
>=> ignoreWarnings . P.desugarImportsWithEnv []
+ >=> traverse (P.rebracketFiltered isInstanceDecl [])
ignoreWarnings = fmap fst . runWriterT
+
+ isInstanceDecl (P.TypeInstanceDeclaration {}) = True
+ isInstanceDecl _ = False
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index 5c1e6ef..6b16d57 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -1,8 +1,9 @@
module Language.PureScript.Docs.Convert.Single
( convertSingleModule
+ , convertComments
) where
-import Protolude
+import Protolude hiding (moduleName)
import Control.Category ((>>>))
@@ -82,7 +83,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =
d { declChildren = declChildren d ++ [child] }
getDeclarationTitle :: P.Declaration -> Maybe Text
-getDeclarationTitle (P.ValueDeclaration _ name _ _ _) = Just (P.showIdent name)
+getDeclarationTitle (P.ValueDeclaration vd) = Just (P.showIdent (P.valdeclIdent vd))
getDeclarationTitle (P.ExternDeclaration _ name _) = Just (P.showIdent name)
getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName name)
getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name)
@@ -108,9 +109,9 @@ basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe Intermediate
basicDeclaration sa title = Just . Right . mkDeclaration sa title
convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration
-convertDeclaration (P.ValueDeclaration sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title =
+convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title =
basicDeclaration sa title (ValueDeclaration ty)
-convertDeclaration (P.ValueDeclaration sa _ _ _ _) title =
+convertDeclaration (P.ValueDecl sa _ _ _ _) title =
-- If no explicit type declaration was provided, insert a wildcard, so that
-- the actual type will be added during type checking.
basicDeclaration sa title (ValueDeclaration P.TypeWildcard{})
@@ -134,7 +135,7 @@ convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title =
where
info = TypeClassDeclaration args implies (convertFundepsToStrings args fundeps)
children = map convertClassMember ds
- convertClassMember (P.TypeDeclaration (ss, com) ident' ty) =
+ convertClassMember (P.TypeDeclaration (P.TypeDeclarationData (ss, com) ident' ty)) =
ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember ty)
convertClassMember _ =
P.internalError "convertDeclaration: Invalid argument to convertClassMember."
diff --git a/src/Language/PureScript/Docs/Css.hs b/src/Language/PureScript/Docs/Css.hs
new file mode 100644
index 0000000..9567db9
--- /dev/null
+++ b/src/Language/PureScript/Docs/Css.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Language.PureScript.Docs.Css where
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Data.FileEmbed (embedFile)
+
+-- |
+-- An embedded copy of normalize.css as a UTF-8 encoded ByteString; this should
+-- be included before pursuit.css in any HTML page using pursuit.css.
+--
+normalizeCss :: ByteString
+normalizeCss = $(embedFile "app/static/normalize.css")
+
+-- |
+-- Like 'normalizeCss', but as a 'Text'.
+normalizeCssT :: Text
+normalizeCssT = decodeUtf8 normalizeCss
+
+-- |
+-- CSS for use with generated HTML docs, as a UTF-8 encoded ByteString.
+--
+pursuitCss :: ByteString
+pursuitCss = $(embedFile "app/static/pursuit.css")
+
+-- |
+-- Like 'pursuitCss', but as a 'Text'.
+--
+pursuitCssT :: Text
+pursuitCssT = decodeUtf8 pursuitCss
diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index 2a5e62c..66c4784 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -12,7 +12,7 @@ import qualified Language.PureScript as P
primDocsModule :: Module
primDocsModule = Module
{ modName = P.moduleNameFromString "Prim"
- , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types &mdash; for example, value literals, or syntax sugar."
+ , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types &mdash; for example, value literals, or syntax sugar. It is implicitly imported unqualified in every module except those that list it as a qualified import."
, modDeclarations =
[ function
, array
@@ -148,6 +148,12 @@ record = primType "Record" $ T.unlines
, "The syntactic sugar with curly braces `{ }` is generally preferred, though:"
, ""
, " type Person = { name :: String, age :: Number }"
+ , ""
+ , "The row associates a type to each label which appears in the record."
+ , ""
+ , "_Technical note_: PureScript allows duplicate labels in rows, and the"
+ , "meaning of `Record r` is based on the _first_ occurrence of each label in"
+ , "the row `r`."
]
number :: Declaration
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index f97a25d..b53f92b 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -488,7 +488,7 @@ asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a)
asPackage minimumVersion uploader = do
-- If the compilerVersion key is missing, we can be sure that it was produced
-- with 0.7.0.0, since that is the only released version that included the
- -- psc-publish tool before this key was added.
+ -- `psc-publish` tool (now `purs publish`) before this key was added.
compilerVersion <- keyOrDefault "compilerVersion" (Version [0,7,0,0] []) asVersion
when (compilerVersion < minimumVersion)
(throwCustomError $ CompilerTooOld minimumVersion compilerVersion)
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 474dc37..bd447fb 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -22,6 +22,7 @@ import Data.List (transpose, nubBy, sort, partition, dropWhileEnd)
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
import qualified Data.Map as M
+import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text (Text)
import Language.PureScript.AST
@@ -102,6 +103,8 @@ errorCode em = case unwrapErrorMessage em of
DeclConflict{} -> "DeclConflict"
ExportConflict{} -> "ExportConflict"
DuplicateModule{} -> "DuplicateModule"
+ DuplicateTypeClass{} -> "DuplicateTypeClass"
+ DuplicateInstance{} -> "DuplicateInstance"
DuplicateTypeArgument{} -> "DuplicateTypeArgument"
InvalidDoBind -> "InvalidDoBind"
InvalidDoLet -> "InvalidDoLet"
@@ -274,7 +277,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gSimple (InvalidDerivedInstance cl ts n) = InvalidDerivedInstance cl <$> traverse f ts <*> pure n
gSimple (ExpectedTypeConstructor cl ts ty) = ExpectedTypeConstructor cl <$> traverse f ts <*> f ty
gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
- gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
+ gSimple (OrphanInstance nm cl noms ts) = OrphanInstance nm cl noms <$> traverse f ts
gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> onTypeSearchTypesM f env
gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty
@@ -431,7 +434,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
renderSimpleErrorMessage (ModuleNotFound mn) =
paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found."
- , line "Make sure the source file exists, and that it has been provided as an input to psc."
+ , line "Make sure the source file exists, and that it has been provided as an input to the compiler."
]
renderSimpleErrorMessage (CannotGetFileInfo path) =
paras [ line "Unable to read file info: "
@@ -535,6 +538,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:")
, indent . paras $ map (line . displaySourceSpan relPath) ss
]
+ renderSimpleErrorMessage (DuplicateTypeClass pn ss) =
+ paras [ line ("Type class " <> markCode (runProperName pn) <> " has been defined multiple times:")
+ , indent $ line $ displaySourceSpan relPath ss
+ ]
+ renderSimpleErrorMessage (DuplicateInstance pn ss) =
+ paras [ line ("Instance " <> markCode (showIdent pn) <> " has been defined multiple times:")
+ , indent $ line $ displaySourceSpan relPath ss
+ ]
renderSimpleErrorMessage (CycleInDeclaration nm) =
line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed."
renderSimpleErrorMessage (CycleInModules mns) =
@@ -765,16 +776,24 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "."
renderSimpleErrorMessage TypeSynonymInstance =
line "Type class instances for type synonyms are disallowed."
- renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
- paras [ line $ "Type class instance " <> markCode (showIdent nm) <> " for "
+ renderSimpleErrorMessage (OrphanInstance nm cnm nonOrphanModules ts) =
+ 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)
]
- , line "is an orphan instance."
- , line "An orphan instance is one which is defined in a module that is unrelated to either the class or the collection of data types that the instance is defined for."
- , line "Consider moving the instance, if possible, or using a newtype wrapper."
- ]
+ , Box.vcat Box.left $ case modulesToList of
+ [] -> [ line "There is nowhere this instance can be placed without being an orphan."
+ , line "A newtype wrapper can be used to avoid this problem."
+ ]
+ _ -> [ Box.text $ "This problem can be resolved by declaring the instance in "
+ <> T.unpack formattedModules
+ <> ", or by defining the instance on a newtype wrapper."
+ ]
+ ]
+ where
+ modulesToList = S.toList $ S.delete (moduleNameFromString "Prim") nonOrphanModules
+ formattedModules = T.intercalate " or " ((markCode . runModuleName) <$> modulesToList)
renderSimpleErrorMessage (InvalidNewtype name) =
paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid."
, line "Newtypes must define a single constructor with a single argument."
@@ -950,9 +969,20 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
, indent msg
]
- renderSimpleErrorMessage (UnusableDeclaration ident) =
- paras [ line $ "The declaration " <> markCode (showIdent ident) <> " is unusable."
- , line $ "This happens when a constraint couldn't possibly have enough information to work out which instance is required."
+ renderSimpleErrorMessage (UnusableDeclaration ident unexplained) =
+ paras $
+ [ line $ "The declaration " <> markCode (showIdent ident) <> " contains arguments that couldn't be determined."
+ ] <>
+
+ case unexplained of
+ [required] ->
+ [ line $ "These arguments are: { " <> T.intercalate "," required <> "}"
+ ]
+
+ options ->
+ [ line "To fix this, one of the following sets of variables must be determined:"
+ , Box.moveRight 2 . Box.vsep 0 Box.top $
+ map (\set -> line $ "{ " <> T.intercalate ", " set <> " }") options
]
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs
new file mode 100644
index 0000000..837fd3a
--- /dev/null
+++ b/src/Language/PureScript/Hierarchy.hs
@@ -0,0 +1,86 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Hierarchy
+-- Copyright : (c) Hardy Jones 2014
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Generate Directed Graphs of PureScript TypeClasses
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Hierarchy where
+
+import Prelude.Compat
+import Protolude (ordNub)
+
+import Data.List (sort)
+import Data.Monoid ((<>))
+import qualified Data.Text as T
+import qualified Language.PureScript as P
+
+newtype SuperMap = SuperMap
+ { _unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName)
+ }
+ deriving Eq
+
+instance Ord SuperMap where
+ compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s'
+ where
+ getCls = either id snd
+
+data Graph = Graph
+ { graphName :: GraphName
+ , digraph :: Digraph
+ }
+ deriving (Eq, Show)
+
+newtype GraphName = GraphName
+ { _unGraphName :: T.Text
+ }
+ deriving (Eq, Show)
+
+newtype Digraph = Digraph
+ { _unDigraph :: T.Text
+ }
+ deriving (Eq, Show)
+
+prettyPrint :: SuperMap -> T.Text
+prettyPrint (SuperMap (Left sub)) = " " <> P.runProperName sub <> ";"
+prettyPrint (SuperMap (Right (super, sub))) =
+ " " <> P.runProperName super <> " -> " <> P.runProperName sub <> ";"
+
+runModuleName :: P.ModuleName -> GraphName
+runModuleName (P.ModuleName pns) =
+ GraphName $ T.intercalate "_" (P.runProperName <$> pns)
+
+typeClasses :: Functor f => f P.Module -> f (Maybe Graph)
+typeClasses =
+ fmap typeClassGraph
+
+typeClassGraph :: P.Module -> Maybe Graph
+typeClassGraph (P.Module _ _ moduleName decls _) =
+ if null supers then Nothing else Just (Graph name graph)
+ where
+ name = runModuleName moduleName
+ supers = sort . ordNub $ concatMap superClasses decls
+ graph = Digraph $ typeClassPrologue name <> typeClassBody supers <> typeClassEpilogue
+
+typeClassPrologue :: GraphName -> T.Text
+typeClassPrologue (GraphName name) = "digraph " <> name <> " {\n"
+
+typeClassBody :: [SuperMap] -> T.Text
+typeClassBody supers = T.intercalate "\n" (prettyPrint <$> supers)
+
+typeClassEpilogue :: T.Text
+typeClassEpilogue = "\n}"
+
+superClasses :: P.Declaration -> [SuperMap]
+superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) =
+ fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers
+superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)]
+superClasses _ = []
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index c566fa5..d6e339d 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -81,16 +81,16 @@ handleCommand c = case c of
Import fp outfp _ (AddQualifiedImport mn qual) -> do
rs <- addQualifiedImport fp mn qual
answerRequest outfp rs
- Import fp outfp filters (AddImportForIdentifier ident) -> do
- rs <- addImportForIdentifier fp ident filters
+ Import fp outfp filters (AddImportForIdentifier ident qual) -> do
+ rs <- addImportForIdentifier fp ident qual filters
case rs of
Right rs' -> answerRequest outfp rs'
Left question ->
pure (CompletionResult (map (completionFromMatch . simpleExport . map withEmptyAnn) question))
- Rebuild file ->
- rebuildFileAsync file
- RebuildSync file ->
- rebuildFileSync file
+ Rebuild file actualFile ->
+ rebuildFileAsync file actualFile
+ RebuildSync file actualFile ->
+ rebuildFileSync file actualFile
Cwd ->
TextResult . toS <$> liftIO getCurrentDirectory
Reset ->
@@ -187,14 +187,7 @@ loadModulesAsync
-> m Success
loadModulesAsync moduleNames = do
tr <- loadModules moduleNames
-
- -- Finally we kick off the worker with @async@ and return the number of
- -- successfully parsed modules.
- env <- ask
- let ll = confLogLevel (ideConfiguration env)
- -- populateVolatileState return Unit for now, so it's fine to discard this
- -- result. We might want to block on this in a benchmarking situation.
- _ <- liftIO (async (runLogger ll (runReaderT populateVolatileState env)))
+ _ <- populateVolatileState
pure tr
loadModulesSync
@@ -203,7 +196,7 @@ loadModulesSync
-> m Success
loadModulesSync moduleNames = do
tr <- loadModules moduleNames
- populateVolatileState
+ populateVolatileStateSync
pure tr
loadModules
diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs
index 033120b..7ee696b 100644
--- a/src/Language/PureScript/Ide/CaseSplit.hs
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -23,6 +23,7 @@ module Language.PureScript.Ide.CaseSplit
import Protolude hiding (Constructor)
+import qualified Data.Map as M
import qualified Data.Text as T
import qualified Language.PureScript as P
@@ -58,7 +59,8 @@ findTypeDeclaration :: (Ide m, MonadError IdeError m) =>
P.ProperName 'P.TypeName -> m ExternsDeclaration
findTypeDeclaration q = do
efs <- getExternFiles
- let m = getFirst $ foldMap (findTypeDeclaration' q) efs
+ efs' <- maybe efs (flip (uncurry M.insert) efs) <$> cachedRebuild
+ let m = getFirst $ foldMap (findTypeDeclaration' q) efs'
case m of
Just mn -> pure mn
Nothing -> throwError (GeneralError "Not Found")
@@ -129,7 +131,7 @@ parseTypeDeclaration' s =
P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts
in
case x of
- Right (P.TypeDeclaration _ i t) -> pure (i, t)
+ Right (P.TypeDeclaration td) -> pure (P.unwrapTypeDeclaration td)
Right _ -> throwError (GeneralError "Found a non-type-declaration")
Left err ->
throwError (GeneralError ("Parsing the type signature failed with: "
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index 5763fcb..46c6f3d 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -56,8 +56,8 @@ data Command
-- Import InputFile OutputFile
| Import FilePath (Maybe FilePath) [Filter] ImportCommand
| List { listType :: ListType }
- | Rebuild FilePath -- ^ Rebuild the specified file using the loaded externs
- | RebuildSync FilePath -- ^ Rebuild the specified file using the loaded externs
+ | Rebuild FilePath (Maybe FilePath)
+ | RebuildSync FilePath (Maybe FilePath)
| Cwd
| Reset
| Quit
@@ -82,7 +82,7 @@ commandName c = case c of
data ImportCommand
= AddImplicitImport P.ModuleName
| AddQualifiedImport P.ModuleName P.ModuleName
- | AddImportForIdentifier Text
+ | AddImportForIdentifier Text (Maybe P.ModuleName)
deriving (Show, Eq)
instance FromJSON ImportCommand where
@@ -96,7 +96,10 @@ instance FromJSON ImportCommand where
<$> (P.moduleNameFromString <$> o .: "module")
<*> (P.moduleNameFromString <$> o .: "qualifier")
"addImport" ->
- AddImportForIdentifier <$> o .: "identifier"
+ AddImportForIdentifier
+ <$> (o .: "identifier")
+ <*> (fmap P.moduleNameFromString <$> o .:? "qualifier")
+
_ -> mzero
data ListType = LoadedModules | Imports FilePath | AvailableModules
@@ -128,7 +131,7 @@ instance FromJSON Command where
params <- o .: "params"
Type
<$> params .: "search"
- <*> params .: "filters"
+ <*> params .:? "filters" .!= []
<*> (fmap P.moduleNameFromString <$> params .:? "currentModule")
"complete" -> do
params <- o .: "params"
@@ -166,6 +169,7 @@ instance FromJSON Command where
params <- o .: "params"
Rebuild
<$> params .: "file"
+ <*> params .:? "actualFile"
_ -> mzero
where
mkAnnotations True = explicitAnnotations
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
index 44a4ac6..eace77b 100644
--- a/src/Language/PureScript/Ide/Completion.hs
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -9,7 +9,7 @@ module Language.PureScript.Ide.Completion
, applyCompletionOptions
) where
-import Protolude
+import Protolude hiding ((<&>), moduleName)
import Control.Lens hiding ((&), op)
import Data.Aeson
@@ -130,7 +130,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) =
complLocation = _annLocation ann
- complDocumentation = Nothing
+ complDocumentation = _annDocumentation ann
showFixity p a r o =
let asso = case a of
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index 0e9e17f..ca7a53d 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -24,6 +24,7 @@ import Protolude hiding (to, from, (&))
import Control.Lens
import "monad-logger" Control.Monad.Logger
import Data.Aeson (decodeStrict)
+import Data.Aeson.Types (withObject, parseMaybe, (.:))
import qualified Data.ByteString as BS
import Data.Version (showVersion)
import Language.PureScript.Ide.Error (IdeError (..))
@@ -36,16 +37,19 @@ readExternFile
=> FilePath
-> m P.ExternsFile
readExternFile fp = do
- parseResult <- liftIO (decodeStrict <$> BS.readFile fp)
- case parseResult of
+ externsFile <- liftIO (BS.readFile fp)
+ case decodeStrict externsFile of
Nothing ->
- throwError (GeneralError
- ("Parsing the extern at: " <> toS fp <> " failed"))
- Just externs
- | P.efVersion externs /= version -> do
+ let parser = withObject "ExternsFileVersion" $ \o -> o .: "efVersion"
+ maybeEFVersion = parseMaybe parser =<< decodeStrict externsFile
+ in case maybeEFVersion of
+ Nothing ->
+ throwError (GeneralError
+ ("Parsing the extern at: " <> toS fp <> " failed"))
+ Just efVersion -> do
let errMsg = "Version mismatch for the externs at: " <> toS fp
<> " Expected: " <> version
- <> " Found: " <> P.efVersion externs
+ <> " Found: " <> efVersion
logErrorN errMsg
throwError (GeneralError errMsg)
Just externs -> pure externs
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index 1714b8e..82ec75c 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -30,7 +30,7 @@ module Language.PureScript.Ide.Imports
)
where
-import Protolude
+import Protolude hiding (moduleName)
import Control.Lens ((^.), (%~), ix)
import Data.List (findIndex, nubBy, partition)
@@ -165,27 +165,27 @@ addQualifiedImport' imports mn qualifier =
-- @import Prelude (bind)@ in the file File.purs returns @["import Prelude
-- (bind, unit)"]@
addExplicitImport :: (MonadIO m, MonadError IdeError m) =>
- FilePath -> IdeDeclaration -> P.ModuleName -> m [Text]
-addExplicitImport fp decl moduleName = do
+ FilePath -> IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> m [Text]
+addExplicitImport fp decl moduleName qualifier = do
(mn, pre, imports, post) <- parseImportsFromFile' fp
let newImportSection =
-- TODO: Open an issue when this PR is merged, we should optimise this
-- so that this case does not write to disc
if mn == moduleName
then imports
- else addExplicitImport' decl moduleName imports
+ else addExplicitImport' decl moduleName qualifier imports
pure (pre ++ prettyPrintImportSection newImportSection ++ post)
-addExplicitImport' :: IdeDeclaration -> P.ModuleName -> [Import] -> [Import]
-addExplicitImport' decl moduleName imports =
+addExplicitImport' :: IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> [Import] -> [Import]
+addExplicitImport' decl moduleName qualifier imports =
let
isImplicitlyImported =
not . null $ filter (\case
- (Import mn P.Implicit Nothing) -> mn == moduleName
+ (Import mn P.Implicit qualifier') -> mn == moduleName && qualifier == qualifier'
_ -> False) imports
- matches (Import mn (P.Explicit _) Nothing) = mn == moduleName
+ matches (Import mn (P.Explicit _) qualifier') = mn == moduleName && qualifier == qualifier'
matches _ = False
- freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) Nothing
+ freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) qualifier
in
if isImplicitlyImported
then imports
@@ -209,8 +209,8 @@ addExplicitImport' decl moduleName imports =
-- | Adds a declaration to an import:
-- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)
insertDeclIntoImport :: IdeDeclaration -> Import -> Import
- insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =
- Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) Nothing
+ insertDeclIntoImport decl' (Import mn (P.Explicit refs) qual) =
+ Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) qual
insertDeclIntoImport _ is = is
insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef]
@@ -220,6 +220,11 @@ addExplicitImport' decl moduleName imports =
(insertDtor (dtor ^. ideDtorName))
(refFromDeclaration d)
refs
+ insertDeclIntoRefs (IdeDeclType t) refs
+ | any matches refs = refs
+ where
+ matches (P.TypeRef _ typeName _) = _ideTypeName t == typeName
+ matches _ = False
insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)
insertDtor _ (P.TypeRef ss tn' _) = P.TypeRef ss tn' Nothing
@@ -251,10 +256,11 @@ updateAtFirstOrPrepend p t d l =
addImportForIdentifier :: (Ide m, MonadError IdeError m)
=> FilePath -- ^ The Sourcefile to read from
-> Text -- ^ The identifier to import
+ -> Maybe P.ModuleName -- ^ The optional qualifier under which to import
-> [Filter] -- ^ Filters to apply before searching for
-- the identifier
-> m (Either [Match IdeDeclaration] [Text])
-addImportForIdentifier fp ident filters = do
+addImportForIdentifier fp ident qual filters = do
modules <- getAllModules Nothing
case map (fmap discardAnn) (getExactMatches ident filters modules) of
[] ->
@@ -264,7 +270,7 @@ addImportForIdentifier fp ident filters = do
-- Only one match was found for the given identifier, so we can insert it
-- right away
[Match (m, decl)] ->
- Right <$> addExplicitImport fp decl m
+ Right <$> addExplicitImport fp decl m qual
-- This case comes up for newtypes and dataconstructors. Because values and
-- types don't share a namespace we can get multiple matches from the same
@@ -281,7 +287,7 @@ addImportForIdentifier fp ident filters = do
-- dataconstructor as that will give us an unnecessary import warning at
-- worst
Just decl ->
- Right <$> addExplicitImport fp decl m1
+ Right <$> addExplicitImport fp decl m1 qual
-- Here we need the user to specify whether he wanted a dataconstructor
-- or a type
@@ -319,6 +325,7 @@ prettyPrintImportSection imports =
isImplicitImport :: Import -> Bool
isImplicitImport i = case i of
Import _ P.Implicit Nothing -> True
+ Import _ (P.Hiding _) Nothing -> True
_ -> False
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index a7e765b..c4f4b20 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -40,14 +40,16 @@ rebuildFile
:: (Ide m, MonadLogger m, MonadError IdeError m)
=> FilePath
-- ^ The file to rebuild
+ -> Maybe FilePath
+ -- ^ The file to use as the location for parsing and errors
-> (ReaderT IdeEnvironment (LoggingT IO) () -> m ())
-- ^ A runner for the second build with open exports
-> m Success
-rebuildFile path runOpenBuild = do
+rebuildFile file actualFile runOpenBuild = do
- input <- ideReadFile path
+ input <- ideReadFile file
- m <- case snd <$> P.parseModuleFromFile identity (path, input) of
+ m <- case snd <$> P.parseModuleFromFile (maybe identity const actualFile) (file, input) of
Left parseError ->
throwError (RebuildError (P.MultipleErrors [P.toPositionedError parseError]))
Right m -> pure m
@@ -61,7 +63,7 @@ rebuildFile path runOpenBuild = do
-- For rebuilding, we want to 'RebuildAlways', but for inferring foreign
-- modules using their file paths, we need to specify the path in the 'Map'.
let filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)
- foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right path))
+ foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right file))
let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False
-- Rebuild the single module using the cached externs
@@ -72,14 +74,21 @@ rebuildFile path runOpenBuild = do
>>= shushProgress $ makeEnv) externs $ m
case result of
Left errors -> throwError (RebuildError errors)
- Right _ -> do
+ Right newExterns -> do
+ whenM isEditorMode $ do
+ insertModule (fromMaybe file actualFile, m)
+ insertExterns newExterns
+ void populateVolatileState
runOpenBuild (rebuildModuleOpen makeEnv externs m)
pure (RebuildSuccess warnings)
+isEditorMode :: Ide m => m Bool
+isEditorMode = asks (confEditorMode . ideConfiguration)
+
rebuildFileAsync
:: forall m. (Ide m, MonadLogger m, MonadError IdeError m)
- => FilePath -> m Success
-rebuildFileAsync fp = rebuildFile fp asyncRun
+ => FilePath -> Maybe FilePath -> m Success
+rebuildFileAsync fp fp' = rebuildFile fp fp' asyncRun
where
asyncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m ()
asyncRun action = do
@@ -89,8 +98,8 @@ rebuildFileAsync fp = rebuildFile fp asyncRun
rebuildFileSync
:: forall m. (Ide m, MonadLogger m, MonadError IdeError m)
- => FilePath -> m Success
-rebuildFileSync fp = rebuildFile fp syncRun
+ => FilePath -> Maybe FilePath -> m Success
+rebuildFileSync fp fp' = rebuildFile fp fp' syncRun
where
syncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m ()
syncRun action = do
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index 0a8b1de..82a639c 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Ide.Reexports
@@ -22,7 +23,7 @@ module Language.PureScript.Ide.Reexports
, resolveReexports'
) where
-import Protolude
+import Protolude hiding (moduleName)
import Control.Lens hiding ((&))
import qualified Data.Map as Map
@@ -35,7 +36,9 @@ data ReexportResult a
= ReexportResult
{ reResolved :: a
, reFailed :: [(P.ModuleName, P.DeclarationRef)]
- } deriving (Show, Eq, Functor)
+ } deriving (Show, Eq, Functor, Generic)
+
+instance NFData a => NFData (ReexportResult a)
-- | Uses the passed formatter to format the resolved module, and adds possible
-- failures
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index 8a03a5a..7b36e60 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -65,13 +65,8 @@ extractAstInformation (P.Module _ _ _ decls _) =
in (definitions, typeAnnotations)
-- | Extracts type annotations for functions from a given Module
-extractTypeAnnotations
- :: [P.Declaration]
- -> [(P.Ident, P.Type)]
-extractTypeAnnotations = mapMaybe extract
- where
- extract (P.TypeDeclaration _ ident ty) = Just (ident, ty)
- extract _ = Nothing
+extractTypeAnnotations :: [P.Declaration] -> [(P.Ident, P.Type)]
+extractTypeAnnotations = mapMaybe (map P.unwrapTypeDeclaration . P.getTypeDeclaration)
-- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts
-- definition sites inside that Declaration.
@@ -81,7 +76,7 @@ extractSpans
-> [(IdeNamespaced, P.SourceSpan)]
-- ^ Declarations and their source locations
extractSpans d = case d of
- P.ValueDeclaration (ss, _) i _ _ _ ->
+ P.ValueDecl (ss, _) i _ _ _ ->
[(IdeNamespaced IdeNSValue (P.runIdent i), ss)]
P.TypeSynonymDeclaration (ss, _) name _ _ ->
[(IdeNamespaced IdeNSType (P.runProperName name), ss)]
@@ -107,6 +102,6 @@ extractSpans d = case d of
-- declarations for non-typeclass members, which is why we can't handle them
-- in extractSpans.
extractSpans' dP = case dP of
- P.TypeDeclaration (ss', _) ident _ ->
+ P.TypeDeclaration (P.TypeDeclarationData (ss', _) ident _) ->
[(IdeNamespaced IdeNSValue (P.runIdent ident), ss')]
_ -> []
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 81c290c..28211f9 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -12,20 +12,23 @@
-- Functions to access psc-ide's state
-----------------------------------------------------------------------------
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE BangPatterns #-}
module Language.PureScript.Ide.State
( getLoadedModulenames
, getExternFiles
, resetIdeState
, cacheRebuild
+ , cachedRebuild
, insertExterns
, insertModule
, insertExternsSTM
, getAllModules
, populateVolatileState
+ , populateVolatileStateSync
, populateVolatileStateSTM
-- for tests
, resolveOperatorsForModule
@@ -33,7 +36,7 @@ module Language.PureScript.Ide.State
, resolveDataConstructorsForModule
) where
-import Protolude
+import Protolude hiding (moduleName)
import Control.Arrow
import Control.Concurrent.STM
@@ -41,6 +44,7 @@ import Control.Lens hiding (op, (&))
import "monad-logger" Control.Monad.Logger
import qualified Data.Map.Lazy as Map
import qualified Language.PureScript as P
+import Language.PureScript.Docs.Convert.Single (convertComments)
import Language.PureScript.Externs
import Language.PureScript.Ide.Externs
import Language.PureScript.Ide.Reexports
@@ -162,21 +166,33 @@ cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile))
cachedRebuild = vsCachedRebuild <$> getVolatileState
-- | Resolves reexports and populates VolatileState with data to be used in queries.
-populateVolatileState :: (Ide m, MonadLogger m) => m ()
-populateVolatileState = do
+populateVolatileStateSync :: (Ide m, MonadLogger m) => m ()
+populateVolatileStateSync = do
st <- ideStateVar <$> ask
- let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration
- results <- logPerf message (liftIO (atomically (populateVolatileStateSTM st)))
+ let message duration = "Finished populating volatile state in: " <> displayTimeSpec duration
+ results <- logPerf message $ do
+ !r <- liftIO (atomically (populateVolatileStateSTM st))
+ pure r
void $ Map.traverseWithKey
(\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))
(Map.filter reexportHasFailures results)
+populateVolatileState :: (Ide m, MonadLogger m) => m (Async ())
+populateVolatileState = do
+ env <- ask
+ let ll = confLogLevel (ideConfiguration env)
+ -- populateVolatileState return Unit for now, so it's fine to discard this
+ -- result. We might want to block on this in a benchmarking situation.
+ liftIO (async (runLogger ll (runReaderT populateVolatileStateSync env)))
+
-- | STM version of populateVolatileState
populateVolatileStateSTM
:: TVar IdeState
-> STM (ModuleMap (ReexportResult [IdeDeclarationAnn]))
populateVolatileStateSTM ref = do
IdeFileState{fsExterns = externs, fsModules = modules} <- getFileStateSTM ref
+ -- We're not using the cached rebuild for anything other than preserving it
+ -- through the repopulation
rebuildCache <- vsCachedRebuild <$> getVolatileStateSTM ref
let asts = map (extractAstInformation . fst) modules
let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs)
@@ -184,11 +200,12 @@ populateVolatileStateSTM ref = do
moduleDeclarations
& map resolveDataConstructorsForModule
& resolveLocations asts
+ & resolveDocumentation (map fst modules)
& resolveInstances externs
& resolveOperators
& resolveReexports reexportRefs
setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache)
- pure results
+ pure (force results)
resolveLocations
:: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)
@@ -206,23 +223,7 @@ resolveLocationsForModule (defs, types) decls =
map convertDeclaration decls
where
convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
- convertDeclaration (IdeDeclarationAnn ann d) = case d of
- IdeDeclValue v ->
- annotateFunction (v ^. ideValueIdent) (IdeDeclValue v)
- IdeDeclType t ->
- annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t)
- IdeDeclTypeSynonym s ->
- annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s)
- IdeDeclDataConstructor dtor ->
- annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)
- IdeDeclTypeClass tc ->
- annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc)
- IdeDeclValueOperator operator ->
- annotateValue (operator ^. ideValueOpName . opNameT) (IdeDeclValueOperator operator)
- IdeDeclTypeOperator operator ->
- annotateType (operator ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator operator)
- IdeDeclKind i ->
- annotateKind (i ^. properNameT) (IdeDeclKind i)
+ convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' annotateFunction annotateValue annotateType annotateKind d
where
annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs
, _annTypeAnnotation = Map.lookup x types
@@ -231,6 +232,71 @@ resolveLocationsForModule (defs, types) decls =
annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs})
annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs})
+convertDeclaration'
+ :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn)
+ -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+ -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+ -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+ -> IdeDeclaration
+ -> IdeDeclarationAnn
+convertDeclaration' annotateFunction annotateValue annotateType annotateKind d =
+ case d of
+ IdeDeclValue v ->
+ annotateFunction (v ^. ideValueIdent) d
+ IdeDeclType t ->
+ annotateType (t ^. ideTypeName . properNameT) d
+ IdeDeclTypeSynonym s ->
+ annotateType (s ^. ideSynonymName . properNameT) d
+ IdeDeclDataConstructor dtor ->
+ annotateValue (dtor ^. ideDtorName . properNameT) d
+ IdeDeclTypeClass tc ->
+ annotateType (tc ^. ideTCName . properNameT) d
+ IdeDeclValueOperator operator ->
+ annotateValue (operator ^. ideValueOpName . opNameT) d
+ IdeDeclTypeOperator operator ->
+ annotateType (operator ^. ideTypeOpName . opNameT) d
+ IdeDeclKind i ->
+ annotateKind (i ^. properNameT) d
+
+resolveDocumentation
+ :: ModuleMap P.Module
+ -> ModuleMap [IdeDeclarationAnn]
+ -> ModuleMap [IdeDeclarationAnn]
+resolveDocumentation modules =
+ Map.mapWithKey (\mn decls ->
+ maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules))
+
+resolveDocumentationForModule
+ :: P.Module
+ -> [IdeDeclarationAnn]
+ -> [IdeDeclarationAnn]
+resolveDocumentationForModule (P.Module _ _ _ sdecls _) decls = map convertDecl decls
+ where
+ comments :: Map P.Name [P.Comment]
+ comments = Map.fromListWith (flip (<>)) $ mapMaybe (\d ->
+ case name d of
+ Just name' -> Just (name', snd $ P.declSourceAnn d)
+ _ -> Nothing)
+ 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) =
+ convertDeclaration'
+ (annotateValue . P.IdentName)
+ (annotateValue . P.IdentName . P.Ident)
+ (annotateValue . P.TyName . P.ProperName)
+ (annotateValue . P.KiName . P.ProperName)
+ d
+ where
+ docs :: P.Name -> Text
+ docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments
+
+ annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident })
+
resolveInstances
:: ModuleMap P.ExternsFile
-> ModuleMap [IdeDeclarationAnn]
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index c951e49..f013ace 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -12,12 +12,14 @@
-- Type definitions for psc-ide
-----------------------------------------------------------------------------
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Ide.Types where
-import Protolude
+import Protolude hiding (moduleName)
import Control.Concurrent.STM
import Control.Lens.TH
@@ -38,43 +40,43 @@ data IdeDeclaration
| IdeDeclValueOperator IdeValueOperator
| IdeDeclTypeOperator IdeTypeOperator
| IdeDeclKind (P.ProperName 'P.KindName)
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic, NFData)
data IdeValue = IdeValue
{ _ideValueIdent :: P.Ident
, _ideValueType :: P.Type
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, NFData)
data IdeType = IdeType
{ _ideTypeName :: P.ProperName 'P.TypeName
, _ideTypeKind :: P.Kind
, _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.Type)]
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, NFData)
data IdeTypeSynonym = IdeTypeSynonym
{ _ideSynonymName :: P.ProperName 'P.TypeName
, _ideSynonymType :: P.Type
, _ideSynonymKind :: P.Kind
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, NFData)
data IdeDataConstructor = IdeDataConstructor
{ _ideDtorName :: P.ProperName 'P.ConstructorName
, _ideDtorTypeName :: P.ProperName 'P.TypeName
, _ideDtorType :: P.Type
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, NFData)
data IdeTypeClass = IdeTypeClass
{ _ideTCName :: P.ProperName 'P.ClassName
, _ideTCKind :: P.Kind
, _ideTCInstances :: [IdeInstance]
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, NFData)
data IdeInstance = IdeInstance
{ _ideInstanceModule :: P.ModuleName
, _ideInstanceName :: P.Ident
, _ideInstanceTypes :: [P.Type]
, _ideInstanceConstraints :: Maybe [P.Constraint]
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, NFData)
data IdeValueOperator = IdeValueOperator
{ _ideValueOpName :: P.OpName 'P.ValueOpName
@@ -82,7 +84,7 @@ data IdeValueOperator = IdeValueOperator
, _ideValueOpPrecedence :: P.Precedence
, _ideValueOpAssociativity :: P.Associativity
, _ideValueOpType :: Maybe P.Type
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, NFData)
data IdeTypeOperator = IdeTypeOperator
{ _ideTypeOpName :: P.OpName 'P.TypeOpName
@@ -90,7 +92,7 @@ data IdeTypeOperator = IdeTypeOperator
, _ideTypeOpPrecedence :: P.Precedence
, _ideTypeOpAssociativity :: P.Associativity
, _ideTypeOpKind :: Maybe P.Kind
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, NFData)
makePrisms ''IdeDeclaration
makeLenses ''IdeValue
@@ -105,27 +107,28 @@ makeLenses ''IdeTypeOperator
data IdeDeclarationAnn = IdeDeclarationAnn
{ _idaAnnotation :: Annotation
, _idaDeclaration :: IdeDeclaration
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, NFData)
data Annotation
= Annotation
{ _annLocation :: Maybe P.SourceSpan
, _annExportedFrom :: Maybe P.ModuleName
, _annTypeAnnotation :: Maybe P.Type
- } deriving (Show, Eq, Ord)
+ , _annDocumentation :: Maybe Text
+ } deriving (Show, Eq, Ord, Generic, NFData)
makeLenses ''Annotation
makeLenses ''IdeDeclarationAnn
emptyAnn :: Annotation
-emptyAnn = Annotation Nothing Nothing Nothing
+emptyAnn = Annotation Nothing Nothing Nothing Nothing
type DefinitionSites a = Map IdeNamespaced a
type TypeAnnotations = Map P.Ident P.Type
newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations))
-- ^ SourceSpans for the definition sites of values and types as well as type
-- annotations found in a module
- deriving (Show, Eq, Ord, Functor, Foldable)
+ deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable)
data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone
deriving (Show, Eq)
@@ -135,6 +138,7 @@ data IdeConfiguration =
{ confOutputPath :: FilePath
, confLogLevel :: IdeLogLevel
, confGlobs :: [FilePath]
+ , confEditorMode :: Bool
}
data IdeEnvironment =
@@ -316,7 +320,7 @@ instance ToJSON PursuitResponse where
-- | Denotes the different namespaces a name in PureScript can reside in.
data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic, NFData)
instance FromJSON IdeNamespace where
parseJSON (String s) = case s of
@@ -328,4 +332,4 @@ instance FromJSON IdeNamespace where
-- | A name tagged with a namespace
data IdeNamespaced = IdeNamespaced IdeNamespace Text
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic, NFData)
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index ac24735..ce051e9 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -24,7 +24,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Class
import Control.Monad.Reader.Class
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
-import Control.Monad.Trans.State.Strict (StateT, runStateT)
+import Control.Monad.Trans.State.Strict (StateT, runStateT, evalStateT)
import Control.Monad.Writer.Strict (Writer(), runWriter)
import qualified Language.PureScript as P
@@ -110,6 +110,7 @@ handleCommand _ _ p (KindOf typ) = handleKindOf p typ
handleCommand _ _ p (BrowseModule moduleName) = handleBrowse p moduleName
handleCommand _ _ p (ShowInfo QueryLoaded) = handleShowLoadedModules p
handleCommand _ _ p (ShowInfo QueryImport) = handleShowImportedModules p
+handleCommand _ _ p (CompleteStr prefix) = handleComplete p prefix
handleCommand _ _ _ _ = P.internalError "handleCommand: unexpected command"
-- | Reload the application state
@@ -307,3 +308,15 @@ handleBrowse print' moduleName = do
print' $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."
lookupUnQualifiedModName quaModName st =
(\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)
+
+-- | Return output as would be returned by tab completion, for tools integration etc.
+handleComplete
+ :: (MonadState PSCiState m, MonadIO m)
+ => (String -> m ())
+ -> String
+ -> m ()
+handleComplete print' prefix = do
+ st <- get
+ let act = liftCompletionM (completion' (reverse prefix, ""))
+ results <- evalStateT act st
+ print' $ unlines (formatCompletions results)
diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs
index dd94c74..90d05ee 100644
--- a/src/Language/PureScript/Interactive/Completion.hs
+++ b/src/Language/PureScript/Interactive/Completion.hs
@@ -3,6 +3,7 @@ module Language.PureScript.Interactive.Completion
, liftCompletionM
, completion
, completion'
+ , formatCompletions
) where
import Prelude.Compat
@@ -85,6 +86,14 @@ findCompletions prev word = do
go _ (':' : _) = GT
go xs ys = compare xs ys
+-- |
+-- Convert Haskeline completion result to results as they would be displayed
+formatCompletions :: (String, [Completion]) -> [String]
+formatCompletions (unusedR, completions) = actuals
+ where
+ unused = reverse unusedR
+ actuals = map ((unused ++) . replacement) completions
+
data CompletionContext
= CtxDirective String
| CtxFilePath String
@@ -128,6 +137,7 @@ directiveArg _ Paste = []
directiveArg _ Show = map CtxFixed replQueryStrings
directiveArg _ Type = [CtxIdentifier]
directiveArg _ Kind = [CtxType]
+directiveArg _ Complete = []
completeImport :: [String] -> String -> [CompletionContext]
completeImport ws w' =
@@ -205,8 +215,8 @@ identNames :: P.Module -> [(N.Ident, P.Declaration)]
identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations
where
getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)]
- getDeclNames d@(P.ValueDeclaration _ ident _ _ _) = [(ident, d)]
- getDeclNames d@(P.TypeDeclaration _ ident _ ) = [(ident, d)]
+ getDeclNames d@(P.ValueDecl _ ident _ _ _) = [(ident, d)]
+ getDeclNames d@(P.TypeDeclaration td) = [(P.tydeclIdent td, d)]
getDeclNames d@(P.ExternDeclaration _ ident _) = [(ident, d)]
getDeclNames d@(P.TypeClassDeclaration _ _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds
getDeclNames _ = []
diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs
index 7f2f010..c996488 100644
--- a/src/Language/PureScript/Interactive/Directive.hs
+++ b/src/Language/PureScript/Interactive/Directive.hs
@@ -23,15 +23,16 @@ directives = map fst directiveStrings
--
directiveStrings :: [(Directive, [String])]
directiveStrings =
- [ (Help , ["?", "help"])
- , (Quit , ["quit"])
- , (Reload , ["reload"])
- , (Clear , ["clear"])
- , (Browse , ["browse"])
- , (Type , ["type"])
- , (Kind , ["kind"])
- , (Show , ["show"])
- , (Paste , ["paste"])
+ [ (Help , ["?", "help"])
+ , (Quit , ["quit"])
+ , (Reload , ["reload"])
+ , (Clear , ["clear"])
+ , (Browse , ["browse"])
+ , (Type , ["type"])
+ , (Kind , ["kind"])
+ , (Show , ["show"])
+ , (Paste , ["paste"])
+ , (Complete , ["complete"])
]
-- |
@@ -93,14 +94,16 @@ hasArgument _ = True
--
help :: [(Directive, String, String)]
help =
- [ (Help, "", "Show this help menu")
- , (Quit, "", "Quit PSCi")
- , (Reload, "", "Reload all imported modules while discarding bindings")
- , (Clear, "", "Discard all imported modules and declared bindings")
- , (Browse, "<module>", "See all functions in <module>")
- , (Type, "<expr>", "Show the type of <expr>")
- , (Kind, "<type>", "Show the kind of <type>")
- , (Show, "import", "Show all imported modules")
- , (Show, "loaded", "Show all loaded modules")
- , (Paste, "paste", "Enter multiple lines, terminated by ^D")
+ [ (Help, "", "Show this help menu")
+ , (Quit, "", "Quit PSCi")
+ , (Reload, "", "Reload all imported modules while discarding bindings")
+ , (Clear, "", "Discard all imported modules and declared bindings")
+ , (Browse, "<module>", "See all functions in <module>")
+ , (Type, "<expr>", "Show the type of <expr>")
+ , (Kind, "<type>", "Show the kind of <type>")
+ , (Show, "import", "Show all imported modules")
+ , (Show, "loaded", "Show all loaded modules")
+ , (Paste, "paste", "Enter multiple lines, terminated by ^D")
+ , (Complete, "<prefix>", "Show completions for <prefix> as if pressing tab")
]
+
diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs
index 1837798..f68a373 100644
--- a/src/Language/PureScript/Interactive/Module.hs
+++ b/src/Language/PureScript/Interactive/Module.hs
@@ -51,15 +51,16 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"]))
eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval"))
mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it")))
- itDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val]
- typeDecl = P.TypeDeclaration (internalSpan, []) (P.Ident "$main")
- (P.TypeApp
+ itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val]
+ typeDecl = P.TypeDeclaration
+ (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main")
(P.TypeApp
- (P.TypeConstructor
- (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff")))
- (P.TypeWildcard internalSpan))
+ (P.TypeApp
+ (P.TypeConstructor
+ (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff")))
(P.TypeWildcard internalSpan))
- mainDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue]
+ (P.TypeWildcard internalSpan)))
+ mainDecl = P.ValueDecl (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue]
decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl]
in
P.Module internalSpan
diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs
index 6f0fc18..8c0ed26 100644
--- a/src/Language/PureScript/Interactive/Parser.hs
+++ b/src/Language/PureScript/Interactive/Parser.hs
@@ -58,19 +58,19 @@ parseDirective cmd =
ds -> Left ("Ambiguous directive. Possible matches: " ++
intercalate ", " (map snd ds) ++ ". Type :? for help.")
where
- (dstr, arg) = break isSpace cmd
+ (dstr, arg) = trim <$> break isSpace cmd
commandFor d = case d of
- Help -> return ShowHelp
- Quit -> return QuitPSCi
- Reload -> return ReloadState
- Clear -> return ClearState
- Paste -> return PasteLines
- Browse -> BrowseModule <$> parseRest P.moduleName arg
- Show -> ShowInfo <$> parseReplQuery' (trim arg)
- Type -> TypeOf <$> parseRest P.parseValue arg
- Kind -> KindOf <$> parseRest P.parseType arg
-
+ Help -> return ShowHelp
+ Quit -> return QuitPSCi
+ Reload -> return ReloadState
+ Clear -> return ClearState
+ Paste -> return PasteLines
+ Browse -> BrowseModule <$> parseRest P.moduleName arg
+ Show -> ShowInfo <$> parseReplQuery' arg
+ Type -> TypeOf <$> parseRest P.parseValue arg
+ Kind -> KindOf <$> parseRest P.parseType arg
+ Complete -> return (CompleteStr arg)
-- |
-- Parses expressions entered at the PSCI repl.
--
diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs
index 3ab26a6..003b90b 100644
--- a/src/Language/PureScript/Interactive/Types.hs
+++ b/src/Language/PureScript/Interactive/Types.hs
@@ -96,6 +96,8 @@ data Command
| ShowInfo ReplQuery
-- | Paste multiple lines
| PasteLines
+ -- | Return auto-completion output as if pressing <tab>
+ | CompleteStr String
deriving Show
data ReplQuery
@@ -129,4 +131,5 @@ data Directive
| Kind
| Show
| Paste
+ | Complete
deriving (Eq, Show)
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
index a1f99a7..7c7a275 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -32,7 +32,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
moduleNames = S.fromList (ordNub (mapMaybe getDeclIdent ds))
getDeclIdent :: Declaration -> Maybe Ident
- getDeclIdent (ValueDeclaration _ ident _ _ _) = Just ident
+ getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
getDeclIdent (ExternDeclaration _ ident _) = Just ident
getDeclIdent (TypeInstanceDeclaration _ ident _ _ _ _) = Just ident
getDeclIdent BindingGroupDeclaration{} = internalError "lint: binding groups should not be desugared yet."
@@ -48,8 +48,8 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
f dec = f' S.empty dec
f' :: S.Set Text -> Declaration -> MultipleErrors
- f' s dec@(ValueDeclaration _ name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec)
- f' s (TypeDeclaration _ name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty)
+ f' s dec@(ValueDeclaration vd) = addHint (ErrorInValueDeclaration (valdeclIdent vd)) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec)
+ f' s (TypeDeclaration td) = addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars s (tydeclType td))
f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec
stepE :: S.Set Ident -> Expr -> MultipleErrors
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index a8a21f8..30ad256 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -295,7 +295,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl'
where
partial :: Text -> Text -> Declaration
partial var tyVar =
- ValueDeclaration (ss, []) (Ident C.__unused) Private [] $
+ ValueDecl (ss, []) (Ident C.__unused) Private [] $
[MkUnguarded
(TypedValue
True
@@ -331,7 +331,8 @@ checkExhaustiveExpr initSS env mn = onExpr initSS
where
onDecl :: Declaration -> m Declaration
onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> onExpr ss expr) bs
- onDecl (ValueDeclaration sa@(ss, _) name x y [MkUnguarded e]) = ValueDeclaration sa name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr ss e)
+ onDecl (ValueDecl sa@(ss, _) name x y [MkUnguarded e]) =
+ ValueDecl sa name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr ss e)
onDecl decl = return decl
onExpr :: SourceSpan -> Expr -> m Expr
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index bba9e26..3a57797 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -301,13 +301,14 @@ findUsedRefs ss env mni qn names =
valueOpRefs = ValueOpRef ss <$> mapMaybe (getValOpName <=< disqualifyFor qn) names
typeOpRefs = TypeOpRef ss <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names
types = mapMaybe (getTypeName <=< disqualifyFor qn) names
+ kindRefs = KindRef ss <$> mapMaybe (getKindName <=< disqualifyFor qn) names
dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names
typesWithDctors = reconstructTypeRefs dctors
typesWithoutDctors = filter (`M.notMember` typesWithDctors) types
typesRefs
= map (flip (TypeRef ss) (Just [])) typesWithoutDctors
++ map (\(ty, ds) -> TypeRef ss ty (Just ds)) (M.toList typesWithDctors)
- in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs
+ in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ kindRefs ++ valueRefs ++ valueOpRefs
where
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index c804b20..ea84f15 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -44,6 +44,10 @@ getTypeName :: Name -> Maybe (ProperName 'TypeName)
getTypeName (TyName name) = Just name
getTypeName _ = Nothing
+getKindName :: Name -> Maybe (ProperName 'KindName)
+getKindName (KiName name) = Just name
+getKindName _ = Nothing
+
getTypeOpName :: Name -> Maybe (OpName 'TypeOpName)
getTypeOpName (TyOpName name) = Just name
getTypeOpName _ = Nothing
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 1dbb9d5..242312b 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -59,7 +59,7 @@ parseTypeDeclaration :: TokenParser Declaration
parseTypeDeclaration = withSourceAnnF $ do
name <- P.try (parseIdent <* indented <* doubleColon)
ty <- parsePolyType
- return $ \sa -> TypeDeclaration sa name ty
+ return $ \sa -> TypeDeclaration (TypeDeclarationData sa name ty)
parseTypeSynonymDeclaration :: TokenParser Declaration
parseTypeSynonymDeclaration = withSourceAnnF $ do
@@ -87,7 +87,7 @@ parseValueWithIdentAndBinders ident bs = do
<*> (indented *> equals
*> withSourceSpan PositionedValue parseValueWithWhereClause))
)
- return $ \sa -> ValueDeclaration sa ident Public bs value
+ return $ \sa -> ValueDecl sa ident Public bs value
parseValueDeclaration :: TokenParser Declaration
parseValueDeclaration = withSourceAnnF $ do
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 32b5ea2..b728023 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -13,6 +13,7 @@ import Data.List (elemIndices, intersperse)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Char (isUpper)
import Language.PureScript.AST (SourcePos(..), SourceSpan(..))
import Language.PureScript.Parser.Lexer (isUnquotedKey, reservedPsNames)
@@ -148,7 +149,10 @@ prettyPrintMany f xs = do
objectKeyRequiresQuoting :: Text -> Bool
objectKeyRequiresQuoting s =
- s `elem` reservedPsNames || not (isUnquotedKey s)
+ s `elem` reservedPsNames || not (isUnquotedKey s) || startsUppercase s where
+ startsUppercase label = case T.uncons label of
+ Just (c, _) -> isUpper c
+ _ -> False
-- | Place a box before another, vertically when the first box takes up multiple lines.
before :: Box -> Box -> Box
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 2c28bcc..659e98c 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -122,14 +122,14 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon
prettyPrintDeclaration :: Int -> Declaration -> Box
prettyPrintDeclaration d _ | d < 0 = ellipsis
-prettyPrintDeclaration _ (TypeDeclaration _ ident ty) =
- text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty
-prettyPrintDeclaration d (ValueDeclaration _ ident _ [] [GuardedExpr [] val]) =
+prettyPrintDeclaration _ (TypeDeclaration td) =
+ text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox (tydeclType td)
+prettyPrintDeclaration d (ValueDecl _ ident _ [] [GuardedExpr [] val]) =
text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val
prettyPrintDeclaration d (BindingGroupDeclaration ds) =
vsep 1 left (NEL.toList (fmap (prettyPrintDeclaration (d - 1) . toDecl) ds))
where
- toDecl ((sa, nm), t, e) = ValueDeclaration sa nm t [] [GuardedExpr [] e]
+ toDecl ((sa, nm), t, e) = ValueDecl sa nm t [] [GuardedExpr [] e]
prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration"
prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index a1ec686..e41620e 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -202,15 +202,20 @@ getTagTime tag = do
_ -> internalError (CouldntParseGitTagDate tag)
getManifestRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
-getManifestRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
+getManifestRepositoryInfo pkgMeta =
+ case bowerRepository pkgMeta of
+ Nothing -> do
+ giturl <- catchError (Just . T.strip . T.pack <$> readProcess' "git" ["config", "remote.origin.url"] "")
+ (const (return Nothing))
+ userError (BadRepositoryField (RepositoryFieldMissing (giturl >>= extractGithub >>= return . format)))
+ Just Repository{..} -> do
+ unless (repositoryType == "git")
+ (userError (BadRepositoryField (BadRepositoryType repositoryType)))
+ maybe (userError (BadRepositoryField NotOnGithub)) return (extractGithub repositoryUrl)
+
where
- tryExtract pkgMeta =
- case bowerRepository pkgMeta of
- Nothing -> Left RepositoryFieldMissing
- Just Repository{..} -> do
- unless (repositoryType == "git")
- (Left (BadRepositoryType repositoryType))
- maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
+ format :: (D.GithubUser, D.GithubRepo) -> Text
+ format (user, repo) = "https://github.com/" <> D.runGithubUser user <> "/" <> D.runGithubRepo repo <> ".git"
checkLicense :: PackageMeta -> PrepareM ()
checkLicense pkgMeta =
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index e62b0a2..8067395 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -66,7 +66,7 @@ data UserError
deriving (Show)
data RepositoryFieldError
- = RepositoryFieldMissing
+ = RepositoryFieldMissing (Maybe Text)
| BadRepositoryType Text
| NotOnGithub
deriving (Show)
@@ -140,7 +140,7 @@ displayUserError e = case e of
TagMustBeCheckedOut ->
vcat
[ para (concat
- [ "psc-publish requires a tagged version to be checked out in "
+ [ "purs publish requires a tagged version to be checked out in "
, "order to build documentation, and no suitable tag was found. "
, "Please check out a previously tagged version, or tag a new "
, "version."
@@ -152,7 +152,7 @@ displayUserError e = case e of
, para (concat
[ "If the version you are publishing is not yet tagged, you might "
, "want to use the --dry-run flag instead, which removes this "
- , "requirement. Run psc-publish --help for more details."
+ , "requirement. Run `purs publish --help` for more details."
])
]
AmbiguousVersions vs ->
@@ -234,7 +234,7 @@ spdxExamples =
displayRepositoryError :: RepositoryFieldError -> Box
displayRepositoryError err = case err of
- RepositoryFieldMissing ->
+ RepositoryFieldMissing giturl ->
vcat
[ para (concat
[ "The 'repository' field is not present in your package manifest file. "
@@ -246,7 +246,7 @@ displayRepositoryError err = case err of
, indented (vcat
[ para "\"repository\": {"
, indented (para "\"type\": \"git\",")
- , indented (para "\"url\": \"git://github.com/purescript/purescript-prelude.git\"")
+ , indented (para ("\"url\": \"" ++ T.unpack (fromMaybe "https://github.com/USER/REPO.git" giturl) ++ "\""))
, para "}"
]
)
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 0cb2a8b..f31ad3c 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -17,7 +17,7 @@ import Control.Monad.Error.Class (MonadError(..))
import Data.Graph
import Data.List (intersect)
-import Data.Maybe (isJust)
+import Data.Maybe (isJust, mapMaybe)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Set as S
@@ -66,13 +66,13 @@ createBindingGroups moduleName = mapM f <=< handleDecls
--
handleDecls :: [Declaration] -> m [Declaration]
handleDecls ds = do
- let values = filter isValueDecl ds
+ let values = mapMaybe (fmap (fmap extractGuardedExpr) . getValueDeclaration) ds
dataDecls = filter isDataDecl ds
allProperNames = fmap declTypeName dataDecls
dataVerts = fmap (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls
dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
- let allIdents = fmap declIdent values
- valueVerts = fmap (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values
+ let allIdents = fmap valdeclIdent values
+ valueVerts = fmap (\d -> (d, valdeclIdent d, usedIdents moduleName d `intersect` allIdents)) values
bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
return $ filter isImportDecl ds ++
filter isExternKindDecl ds ++
@@ -83,6 +83,9 @@ createBindingGroups moduleName = mapM f <=< handleDecls
filter isFixityDecl ds ++
filter isExternDecl ds ++
bindingGroupDecls
+ where
+ extractGuardedExpr [MkUnguarded expr] = expr
+ extractGuardedExpr _ = internalError "Expected Guards to have been desugared in handleDecls."
-- |
-- Collapse all binding groups to individual declarations
@@ -95,22 +98,18 @@ collapseBindingGroups =
go (DataBindingGroupDeclaration ds) = NEL.toList ds
go (BindingGroupDeclaration ds) =
NEL.toList $ fmap (\((sa, ident), nameKind, val) ->
- ValueDeclaration sa ident nameKind [] [MkUnguarded val]) ds
+ ValueDecl sa ident nameKind [] [MkUnguarded val]) ds
go other = [other]
collapseBindingGroupsForValue :: Expr -> Expr
collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
collapseBindingGroupsForValue other = other
-usedIdents :: ModuleName -> Declaration -> [Ident]
-usedIdents moduleName = ordNub . usedIdents' S.empty . getValue
+usedIdents :: ModuleName -> ValueDeclarationData Expr -> [Ident]
+usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression
where
def _ _ = []
- getValue (ValueDeclaration _ _ _ [] [MkUnguarded val]) = val
- getValue ValueDeclaration{} = internalError "Binders should have been desugared"
- getValue _ = internalError "Expected ValueDeclaration"
-
(_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def
usedNamesE :: S.Set Ident -> Expr -> [Ident]
@@ -149,10 +148,6 @@ usedTypeNames moduleName =
| moduleName == moduleName' = [name]
usedNames _ = []
-declIdent :: Declaration -> Ident
-declIdent (ValueDeclaration _ ident _ _ _) = ident
-declIdent _ = internalError "Expected ValueDeclaration"
-
declTypeName :: Declaration -> ProperName 'TypeName
declTypeName (DataDeclaration _ _ pn _ _) = pn
declTypeName (TypeSynonymDeclaration _ pn _ _) = pn
@@ -166,9 +161,9 @@ toBindingGroup
:: forall m
. (MonadError MultipleErrors m)
=> ModuleName
- -> SCC Declaration
+ -> SCC (ValueDeclarationData Expr)
-> m Declaration
-toBindingGroup _ (AcyclicSCC d) = return d
+toBindingGroup _ (AcyclicSCC d) = return (mkDeclaration d)
toBindingGroup moduleName (CyclicSCC ds') = do
-- Once we have a mutually-recursive group of declarations, we need to sort
-- them further by their immediate dependencies (those outside function
@@ -184,16 +179,15 @@ toBindingGroup moduleName (CyclicSCC ds') = do
idents :: [Ident]
idents = fmap (\(_, i, _) -> i) valueVerts
- valueVerts :: [(Declaration, Ident, [Ident])]
- valueVerts = fmap (\d -> (d, declIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
+ valueVerts :: [(ValueDeclarationData Expr, Ident, [Ident])]
+ valueVerts = fmap (\d -> (d, valdeclIdent d, usedImmediateIdents moduleName (mkDeclaration d) `intersect` idents)) ds'
- toBinding :: SCC Declaration -> m ((SourceAnn, Ident), NameKind, Expr)
+ toBinding :: SCC (ValueDeclarationData Expr) -> m ((SourceAnn, Ident), NameKind, Expr)
toBinding (AcyclicSCC d) = return $ fromValueDecl d
toBinding (CyclicSCC ds) = throwError $ foldMap cycleError ds
- cycleError :: Declaration -> MultipleErrors
- cycleError (ValueDeclaration (ss, _) n _ _ [MkUnguarded _]) = errorMessage' ss $ CycleInDeclaration n
- cycleError _ = internalError "cycleError: Expected ValueDeclaration"
+ cycleError :: ValueDeclarationData Expr -> MultipleErrors
+ cycleError (ValueDeclarationData (ss, _) n _ _ _) = errorMessage' ss $ CycleInDeclaration n
toDataBindingGroup
:: MonadError MultipleErrors m
@@ -211,7 +205,9 @@ isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName)
isTypeSynonym (TypeSynonymDeclaration _ pn _ _) = Just pn
isTypeSynonym _ = Nothing
-fromValueDecl :: Declaration -> ((SourceAnn, Ident), NameKind, Expr)
-fromValueDecl (ValueDeclaration sa ident nameKind [] [MkUnguarded val]) = ((sa, ident), nameKind, val)
-fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared"
-fromValueDecl _ = internalError "Expected ValueDeclaration"
+mkDeclaration :: ValueDeclarationData Expr -> Declaration
+mkDeclaration = ValueDeclaration . fmap (pure . MkUnguarded)
+
+fromValueDecl :: ValueDeclarationData Expr -> ((SourceAnn, Ident), NameKind, Expr)
+fromValueDecl (ValueDeclarationData sa ident nameKind [] val) = ((sa, ident), nameKind, val)
+fromValueDecl ValueDeclarationData{} = internalError "Binders should have been desugared"
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 66cf9c9..a8f15a1 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -65,7 +65,7 @@ desugarGuardedExprs ss (Case scrut alternatives)
(scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do
scrut_id <- freshIdent'
pure ( Var (Qualified Nothing scrut_id)
- , ValueDeclaration (ss, []) scrut_id Private [] [MkUnguarded e]
+ , ValueDecl (ss, []) scrut_id Private [] [MkUnguarded e]
)
)
Let scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives)
@@ -231,7 +231,7 @@ desugarGuardedExprs ss (Case scrut alternatives) =
alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]]
pure $ Let [
- ValueDeclaration (ss, []) rem_case_id Private []
+ ValueDecl (ss, []) rem_case_id Private []
[MkUnguarded (Abs (VarBinder unused_binder) desugared)]
] (mk_body alt_fail)
@@ -328,10 +328,10 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro
desugarRest :: [Declaration] -> m [Declaration]
desugarRest (TypeInstanceDeclaration sa name constraints className tys ds : rest) =
(:) <$> (TypeInstanceDeclaration sa name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest
- desugarRest (ValueDeclaration sa name nameKind bs result : rest) =
+ desugarRest (ValueDecl sa name nameKind bs result : rest) =
let (_, f, _) = everywhereOnValuesTopDownM return go return
f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e)
- in (:) <$> (ValueDeclaration sa name nameKind bs <$> f' result) <*> desugarRest rest
+ in (:) <$> (ValueDecl sa name nameKind bs <$> f' result) <*> desugarRest rest
where
go (Let ds val') = Let <$> desugarCases ds <*> pure val'
go other = return other
@@ -339,15 +339,15 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro
desugarRest [] = pure []
inSameGroup :: Declaration -> Declaration -> Bool
-inSameGroup (ValueDeclaration _ ident1 _ _ _) (ValueDeclaration _ ident2 _ _ _) = ident1 == ident2
+inSameGroup (ValueDeclaration vd1) (ValueDeclaration vd2) = valdeclIdent vd1 == valdeclIdent vd2
inSameGroup _ _ = False
toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
-toDecls [ValueDeclaration sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do
+toDecls [ValueDecl sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do
args <- mapM fromVarBinder bs
let body = foldr (Abs . VarBinder) val args
guardWith (errorMessage' ss (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args
- return [ValueDeclaration sa ident nameKind [] [MkUnguarded body]]
+ return [ValueDecl sa ident nameKind [] [MkUnguarded body]]
where
fromVarBinder :: Binder -> m Ident
fromVarBinder NullBinder = freshIdent'
@@ -355,7 +355,7 @@ toDecls [ValueDeclaration sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all
fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b
fromVarBinder (TypedBinder _ b) = fromVarBinder b
fromVarBinder _ = internalError "fromVarBinder: Invalid argument"
-toDecls ds@(ValueDeclaration (ss, _) ident _ bs (result : _) : _) = do
+toDecls ds@(ValueDecl (ss, _) ident _ bs (result : _) : _) = do
let tuples = map toTuple ds
isGuarded (MkUnguarded _) = False
@@ -370,7 +370,7 @@ toDecls ds@(ValueDeclaration (ss, _) ident _ bs (result : _) : _) = do
toDecls ds = return ds
toTuple :: Declaration -> ([Binder], [GuardedExpr])
-toTuple (ValueDeclaration _ _ _ bs result) = (bs, result)
+toTuple (ValueDecl _ _ _ bs result) = (bs, result)
toTuple _ = internalError "Not a value declaration"
makeCaseDeclaration :: forall m. (MonadSupply m) => SourceSpan -> Ident -> [([Binder], [GuardedExpr])] -> m Declaration
@@ -384,7 +384,7 @@ makeCaseDeclaration ss ident alternatives = do
binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
let value = foldr (Abs . VarBinder) (Case vars binders) args
- return $ ValueDeclaration (ss, []) ident Public [] [MkUnguarded value]
+ return $ ValueDecl (ss, []) ident Public [] [MkUnguarded value]
where
-- We will construct a table of potential names.
-- VarBinders will become Just _ which is a potential name.
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 282602a..4edb6b6 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -61,7 +61,7 @@ desugarDo d =
go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
go (DoNotationLet ds : rest) = do
let checkBind :: Declaration -> m ()
- checkBind (ValueDeclaration (ss, _) i@(Ident name) _ _ _)
+ checkBind (ValueDecl (ss, _) i@(Ident name) _ _ _)
| name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i
checkBind _ = pure ()
mapM_ checkBind ds
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 24bbe47..4f341cf 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -9,7 +9,7 @@ module Language.PureScript.Sugar.Names
) where
import Prelude.Compat
-import Protolude (ordNub)
+import Protolude (ordNub, sortBy, on)
import Control.Arrow (first)
import Control.Monad
@@ -118,13 +118,17 @@ desugarImportsWithEnv externs modules = do
return m''
-- |
--- Make all exports for a module explicit. This may still effect modules that
+-- Make all exports for a module explicit. This may still affect modules that
-- have an exports list, as it will also make all data constructor exports
-- explicit.
--
+-- The exports will appear in the same order as they do in the existing exports
+-- list, or if there is no export list, declarations are order based on their
+-- order of appearance in the module.
+--
elaborateExports :: Exports -> Module -> Module
elaborateExports exps (Module ss coms mn decls refs) =
- Module ss coms mn decls $ Just
+ Module ss coms mn decls $ Just $ reorderExports decls refs
$ elaboratedTypeRefs
++ go (TypeOpRef ss) exportedTypeOps
++ go (TypeClassRef ss) exportedTypeClasses
@@ -146,6 +150,22 @@ elaborateExports exps (Module ss coms mn decls refs) =
if mn == mn' then toRef export else ReExportRef ss mn' (toRef export)
-- |
+-- Given a list of declarations, an original exports list, and an elaborated
+-- exports list, reorder the elaborated list so that it matches the original
+-- order. If there is no original exports list, reorder declarations based on
+-- their order in the source file.
+reorderExports :: [Declaration] -> Maybe [DeclarationRef] -> [DeclarationRef] -> [DeclarationRef]
+reorderExports decls originalRefs =
+ sortBy (compare `on` originalIndex)
+ where
+ names =
+ maybe (mapMaybe declName decls) (map declRefName) originalRefs
+ namesMap =
+ M.fromList $ zip names [(0::Int)..]
+ originalIndex ref =
+ M.lookup (declRefName ref) namesMap
+
+-- |
-- Replaces all local names with qualified names within a module and checks that all existing
-- qualified names are valid.
--
@@ -196,9 +216,9 @@ renameInModule imports (Module modSS coms mn decls exps) =
<*> updateClassName cn ss
<*> traverse (updateTypesEverywhere ss) ts
<*> pure ds
- updateDecl bound (TypeDeclaration sa@(ss, _) name ty) =
+ updateDecl bound (TypeDeclaration (TypeDeclarationData sa@(ss, _) name ty)) =
fmap (bound,) $
- TypeDeclaration sa name
+ TypeDeclaration . TypeDeclarationData sa name
<$> updateTypesEverywhere ss ty
updateDecl bound (ExternDeclaration sa@(ss, _) name ty) =
fmap (name : bound,) $
@@ -283,8 +303,7 @@ renameInModule imports (Module modSS coms mn decls exps) =
updatePatGuard _ = []
letBoundVariable :: Declaration -> Maybe Ident
- letBoundVariable (ValueDeclaration _ ident _ _ _) = Just ident
- letBoundVariable _ = Nothing
+ letBoundVariable = fmap valdeclIdent . getValueDeclaration
updateKindsEverywhere :: SourceSpan -> Kind -> m Kind
updateKindsEverywhere pos = everywhereOnKindsM updateKind
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
index 660efc1..14156c7 100644
--- a/src/Language/PureScript/Sugar/Names/Exports.hs
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -37,7 +37,7 @@ findExportable (Module _ _ mn ds _) =
exps' <- rethrowWithPosition ss $ exportTypeClass Internal exps tcn mn
foldM go exps' ds'
where
- go exps'' (TypeDeclaration (ss', _) name _) = rethrowWithPosition ss' $ exportValue exps'' name mn
+ go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = rethrowWithPosition ss' $ exportValue exps'' name mn
go _ _ = internalError "Invalid declaration in TypeClassDeclaration"
updateExports exps (DataDeclaration _ _ tn _ dcs) =
exportType Internal exps tn (map fst dcs) mn
@@ -45,8 +45,8 @@ findExportable (Module _ _ mn ds _) =
exportType Internal exps tn [] mn
updateExports exps (ExternDataDeclaration _ tn _) =
exportType Internal exps tn [] mn
- updateExports exps (ValueDeclaration _ name _ _ _) =
- exportValue exps name mn
+ updateExports exps (ValueDeclaration vd) =
+ exportValue exps (valdeclIdent vd) mn
updateExports exps (ValueFixityDeclaration _ _ _ op) =
exportValueOp exps op mn
updateExports exps (TypeFixityDeclaration _ _ _ op) =
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index fafa345..7556f94 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -69,7 +69,7 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d
then Abs (VarBinder val) <$> wrapLambda (buildUpdates valExpr) ps
else wrapLambda (buildLet val . buildUpdates valExpr) ps
where
- buildLet val = Let [ValueDeclaration (declSourceSpan d, []) val Public [] [MkUnguarded obj]]
+ buildLet val = Let [ValueDecl (declSourceSpan d, []) val Public [] [MkUnguarded obj]]
-- recursively build up the nested `ObjectUpdate` expressions
buildUpdates :: Expr -> PathTree Expr -> Expr
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index a55071a..f8033be 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -8,6 +8,7 @@
module Language.PureScript.Sugar.Operators
( desugarSignedLiterals
, rebracket
+ , rebracketFiltered
, checkFixityExports
) where
@@ -68,7 +69,24 @@ rebracket
=> [ExternsFile]
-> [Module]
-> m [Module]
-rebracket externs modules = do
+rebracket =
+ rebracketFiltered (const True)
+
+-- |
+-- A version of `rebracket` which allows you to choose which declarations
+-- should be affected. This is used in docs generation, where we want to
+-- desugar type operators in instance declarations to ensure that instances are
+-- paired up with their types correctly, but we don't want to desugar type
+-- operators in value declarations.
+--
+rebracketFiltered
+ :: forall m
+ . MonadError MultipleErrors m
+ => (Declaration -> Bool)
+ -> [ExternsFile]
+ -> [Module]
+ -> m [Module]
+rebracketFiltered pred_ externs modules = do
let (valueFixities, typeFixities) =
partitionEithers
$ concatMap externsFixities externs
@@ -84,7 +102,7 @@ rebracket externs modules = do
for modules
$ renameAliasedOperators valueAliased typeAliased
- <=< rebracketModule valueOpTable typeOpTable
+ <=< rebracketModule pred_ valueOpTable typeOpTable
where
@@ -110,7 +128,7 @@ rebracket externs modules = do
-> Module
-> m Module
renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) =
- Module ss coms mn <$> mapM f' ds <*> pure exts
+ Module ss coms mn <$> mapM (usingPredicate pred_ f') ds <*> pure exts
where
(goDecl', goExpr', goBinder') = updateTypes goType
(f', _, _, _, _) =
@@ -153,7 +171,7 @@ rebracket externs modules = do
goBinder pos other = return (pos, other)
goType :: Maybe SourceSpan -> Type -> m Type
- goType pos = maybe id rethrowWithPosition pos . everywhereOnTypesM go
+ goType pos = maybe id rethrowWithPosition pos . go
where
go :: Type -> m Type
go (BinaryNoParensType (TypeOp op) lhs rhs) =
@@ -167,13 +185,19 @@ rebracket externs modules = do
rebracketModule
:: forall m
. (MonadError MultipleErrors m)
- => [[(Qualified (OpName 'ValueOpName), Associativity)]]
+ => (Declaration -> Bool)
+ -> [[(Qualified (OpName 'ValueOpName), Associativity)]]
-> [[(Qualified (OpName 'TypeOpName), Associativity)]]
-> Module
-> m Module
-rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) =
- Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
+rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) =
+ Module ss coms mn <$> f' ds <*> pure exts
where
+ f' :: [Declaration] -> m [Declaration]
+ f' =
+ fmap (map (\d -> if pred_ d then removeParens d else d)) .
+ flip parU (usingPredicate pred_ f)
+
(f, _, _) =
everywhereOnValuesTopDownM
goDecl
@@ -206,15 +230,15 @@ removeParens = f
(goDecl, goExpr', goBinder') = updateTypes (\_ -> return . goType)
goExpr :: Expr -> Expr
- goExpr (Parens val) = val
+ goExpr (Parens val) = goExpr val
goExpr val = val
goBinder :: Binder -> Binder
- goBinder (ParensInBinder b) = b
+ goBinder (ParensInBinder b) = goBinder b
goBinder b = b
goType :: Type -> Type
- goType (ParensInType t) = t
+ goType (ParensInType t) = goType t
goType t = t
decontextify
@@ -297,7 +321,7 @@ updateTypes goType = (goDecl, goExpr, goBinder)
where
goType' :: Maybe SourceSpan -> Type -> m Type
- goType' = everywhereOnTypesM . goType
+ goType' = everywhereOnTypesTopDownM . goType
goType'' :: SourceSpan -> Type -> m Type
goType'' = goType' . Just
@@ -316,8 +340,8 @@ updateTypes goType = (goDecl, goExpr, goBinder)
return $ TypeInstanceDeclaration sa name cs' className tys' impls
goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) =
TypeSynonymDeclaration sa name args <$> goType'' ss ty
- goDecl (TypeDeclaration sa@(ss, _) expr ty) =
- TypeDeclaration sa expr <$> goType'' ss ty
+ goDecl (TypeDeclaration (TypeDeclarationData sa@(ss, _) expr ty)) =
+ TypeDeclaration . TypeDeclarationData sa expr <$> goType'' ss ty
goDecl other =
return other
@@ -405,3 +429,12 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) =
:: ((ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool)
-> Bool
anyTypeRef f = any (maybe False f . getTypeRef) exps
+
+usingPredicate
+ :: forall f a
+ . Applicative f
+ => (a -> Bool)
+ -> (a -> f a)
+ -> (a -> f a)
+usingPredicate p f x =
+ if p x then f x else pure x
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 5819bb8..84ce5d9 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -16,7 +16,7 @@ import Control.Monad.State
import Control.Monad.Supply.Class
import Data.List ((\\), find, sortBy)
import qualified Data.Map as M
-import Data.Maybe (catMaybes, mapMaybe, isJust)
+import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe)
import Data.Text (Text)
import qualified Language.PureScript.Constants as C
import Language.PureScript.Crash
@@ -187,7 +187,7 @@ desugarDecl mn exps = go
go d@(TypeInstanceDeclaration sa name deps className tys (NewtypeInstanceWithDictionary dict)) = do
let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
constrainedTy = quantify (foldr ConstrainedType dictTy deps)
- return (expRef name className tys, [d, ValueDeclaration sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]])
+ return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]])
go other = return (Nothing, [other])
expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef
@@ -222,7 +222,7 @@ desugarDecl mn exps = go
genSpan = internalModuleSourceSpan "<generated>"
memberToNameAndType :: Declaration -> (Ident, Type)
-memberToNameAndType (TypeDeclaration _ ident ty) = (ident, ty)
+memberToNameAndType (TypeDeclaration td) = unwrapTypeDeclaration td
memberToNameAndType _ = internalError "Invalid declaration in type class definition"
typeClassDictionaryDeclaration
@@ -247,9 +247,9 @@ typeClassMemberToDictionaryAccessor
-> [(Text, Maybe Kind)]
-> Declaration
-> Declaration
-typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration sa ident ty) =
+typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) =
let className = Qualified (Just mn) name
- in ValueDeclaration sa ident Private [] $
+ in ValueDecl sa ident Private [] $
[MkUnguarded (
TypedValue False (TypeClassDictionaryAccessor className ident) $
moveQuantifiersToFront (quantify (ConstrainedType (Constraint className (map (TypeVar . fst) args) Nothing) ty))
@@ -279,7 +279,7 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls =
maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $
M.lookup (qualify mn className) m
- case map fst typeClassMembers \\ mapMaybe declName decls of
+ case map fst typeClassMembers \\ mapMaybe declIdent decls of
member : _ -> throwError . errorMessage $ MissingClassMember member
[] -> do
-- Replace the type arguments with the appropriate types in the member types
@@ -301,26 +301,24 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls =
dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
constrainedTy = quantify (foldr ConstrainedType dictTy deps)
dict = TypeClassDictionaryConstructorApp className props
- result = ValueDeclaration sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]
+ result = ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]
return result
where
- declName :: Declaration -> Maybe Ident
- declName (ValueDeclaration _ ident _ _ _) = Just ident
- declName (TypeDeclaration _ ident _) = Just ident
- declName _ = Nothing
-
memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr
- memberToValue tys' (ValueDeclaration _ ident _ [] [MkUnguarded val]) = do
+ memberToValue tys' (ValueDecl _ ident _ [] [MkUnguarded val]) = do
_ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'
return val
memberToValue _ _ = internalError "Invalid declaration in type instance definition"
+declIdent :: Declaration -> Maybe Ident
+declIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
+declIdent (TypeDeclaration td) = Just (tydeclIdent td)
+declIdent _ = Nothing
+
typeClassMemberName :: Declaration -> Text
-typeClassMemberName (TypeDeclaration _ ident _) = runIdent ident
-typeClassMemberName (ValueDeclaration _ ident _ _ _) = runIdent ident
-typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition"
+typeClassMemberName = fromMaybe (internalError "typeClassMemberName: Invalid declaration in type class definition") . fmap runIdent . declIdent
superClassDictionaryNames :: [Constraint] -> [Text]
superClassDictionaryNames supers =
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index 503487c..6914f4b 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -289,9 +289,9 @@ deriveGeneric ss mn syns ds tyConNm dargs = do
toSpine <- mkSpineFunction tyCon
fromSpine <- mkFromSpineFunction tyCon
toSignature <- mkSignatureFunction tyCon dargs
- return [ ValueDeclaration (ss, []) (Ident C.toSpine) Public [] (unguarded toSpine)
- , ValueDeclaration (ss, []) (Ident C.fromSpine) Public [] (unguarded fromSpine)
- , ValueDeclaration (ss, []) (Ident C.toSignature) Public [] (unguarded toSignature)
+ return [ ValueDecl (ss, []) (Ident C.toSpine) Public [] (unguarded toSpine)
+ , ValueDecl (ss, []) (Ident C.fromSpine) Public [] (unguarded fromSpine)
+ , ValueDecl (ss, []) (Ident C.toSignature) Public [] (unguarded toSignature)
]
where
mkSpineFunction :: Declaration -> m Expr
@@ -467,19 +467,19 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
let rep = toRepTy reps
inst | null reps =
-- If there are no cases, spin
- [ ValueDeclaration (ss, []) (Ident "to") Public [] $ unguarded $
+ [ ValueDecl (ss, []) (Ident "to") Public [] $ unguarded $
lamCase x [ CaseAlternative [NullBinder]
(unguarded (App toName (Var (Qualified Nothing x))))
]
- , ValueDeclaration (ss, []) (Ident "from") Public [] $ unguarded $
+ , ValueDecl (ss, []) (Ident "from") Public [] $ unguarded $
lamCase x [ CaseAlternative [NullBinder]
(unguarded (App fromName (Var (Qualified Nothing x))))
]
]
| otherwise =
- [ ValueDeclaration (ss, []) (Ident "to") Public [] $ unguarded $
+ [ ValueDecl (ss, []) (Ident "to") Public [] $ unguarded $
lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to)
- , ValueDeclaration (ss, []) (Ident "from") Public [] $ unguarded $
+ , ValueDecl (ss, []) (Ident "from") Public [] $ unguarded $
lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from)
]
@@ -649,7 +649,7 @@ deriveEq
deriveEq ss mn syns ds tyConNm = do
tyCon <- findTypeDecl tyConNm ds
eqFun <- mkEqFunction tyCon
- return [ ValueDeclaration (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ]
+ return [ ValueDecl (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ]
where
mkEqFunction :: Declaration -> m Expr
mkEqFunction (DataDeclaration _ _ _ _ args) = do
@@ -705,7 +705,7 @@ deriveOrd
deriveOrd ss mn syns ds tyConNm = do
tyCon <- findTypeDecl tyConNm ds
compareFun <- mkCompareFunction tyCon
- return [ ValueDeclaration (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ]
+ return [ ValueDecl (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ]
where
mkCompareFunction :: Declaration -> m Expr
mkCompareFunction (DataDeclaration _ _ _ _ args) = do
@@ -806,9 +806,9 @@ deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do
let (ctorName, [ty]) = head dctors
ty' <- replaceAllTypeSynonymsM syns ty
let inst =
- [ ValueDeclaration (ss, []) (Ident "wrap") Public [] $ unguarded $
+ [ ValueDecl (ss, []) (Ident "wrap") Public [] $ unguarded $
Constructor (Qualified (Just mn) ctorName)
- , ValueDeclaration (ss, []) (Ident "unwrap") Public [] $ unguarded $
+ , ValueDecl (ss, []) (Ident "unwrap") Public [] $ unguarded $
lamCase wrappedIdent
[ CaseAlternative
[ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]]
@@ -886,7 +886,7 @@ deriveFunctor
deriveFunctor ss mn syns ds tyConNm = do
tyCon <- findTypeDecl tyConNm ds
mapFun <- mkMapFunction tyCon
- return [ ValueDeclaration (ss, []) (Ident C.map) Public [] (unguarded mapFun) ]
+ return [ ValueDecl (ss, []) (Ident C.map) Public [] (unguarded mapFun) ]
where
mkMapFunction :: Declaration -> m Expr
mkMapFunction (DataDeclaration (ss', _) _ _ tys ctors) = case reverse tys of
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 8013f70..1003a10 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -29,21 +29,21 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) =
where
desugarTypeDeclarations :: [Declaration] -> m [Declaration]
- desugarTypeDeclarations (TypeDeclaration sa name' ty : d : rest) = do
+ desugarTypeDeclarations (TypeDeclaration (TypeDeclarationData sa name' ty) : d : rest) = do
(_, nameKind, val) <- fromValueDeclaration d
- desugarTypeDeclarations (ValueDeclaration sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest)
+ desugarTypeDeclarations (ValueDecl sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest)
where
fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)
- fromValueDeclaration (ValueDeclaration _ name'' nameKind [] [MkUnguarded val])
+ fromValueDeclaration (ValueDecl _ name'' nameKind [] [MkUnguarded val])
| name' == name'' = return (name'', nameKind, val)
fromValueDeclaration d' =
throwError . errorMessage' (declSourceSpan d') $ OrphanTypeDeclaration name'
- desugarTypeDeclarations [TypeDeclaration (ss, _) name' _] =
+ desugarTypeDeclarations [TypeDeclaration (TypeDeclarationData (ss, _) name' _)] =
throwError . errorMessage' ss $ OrphanTypeDeclaration name'
- desugarTypeDeclarations (ValueDeclaration sa name' nameKind bs val : rest) = do
+ desugarTypeDeclarations (ValueDecl sa name' nameKind bs val : rest) = do
let (_, f, _) = everywhereOnValuesTopDownM return go return
f' = mapM (\(GuardedExpr g e) -> GuardedExpr g <$> f e)
- (:) <$> (ValueDeclaration sa name' nameKind bs <$> f' val)
+ (:) <$> (ValueDecl sa name' nameKind bs <$> f' val)
<*> desugarTypeDeclarations rest
where
go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val'
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 819328f..63875ad 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -20,7 +20,7 @@ import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Lens ((^..), _1, _2)
import Data.Foldable (for_, traverse_, toList)
-import Data.List (nubBy, (\\), sort, group)
+import Data.List (nub, nubBy, (\\), sort, group)
import Data.Maybe
import Data.Monoid ((<>))
import Data.Text (Text)
@@ -116,17 +116,16 @@ addValue moduleName name ty nameKind = do
addTypeClass
:: forall m
. (MonadState CheckState m, MonadError MultipleErrors m)
- => ModuleName
- -> ProperName 'ClassName
+ => Qualified (ProperName 'ClassName)
-> [(Text, Maybe Kind)]
-> [Constraint]
-> [FunctionalDependency]
-> [Declaration]
-> m ()
-addTypeClass moduleName pn args implies dependencies ds = do
+addTypeClass qualifiedClassName args implies dependencies ds = do
env <- getEnv
traverse_ (checkMemberIsUsable (typeSynonyms env)) classMembers
- modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } }
+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert qualifiedClassName newClass (typeClasses . checkEnv $ st) } }
where
classMembers :: [(Ident, Type)]
classMembers = map toPair ds
@@ -140,7 +139,7 @@ addTypeClass moduleName pn args implies dependencies ds = do
argToIndex :: Text -> Maybe Int
argToIndex = flip M.lookup $ M.fromList (zipWith ((,) . fst) args [0..])
- toPair (TypeDeclaration _ ident ty) = (ident, ty)
+ toPair (TypeDeclaration (TypeDeclarationData _ ident ty)) = (ident, ty)
toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
-- Currently we are only checking usability based on the type class currently
@@ -150,8 +149,13 @@ addTypeClass moduleName pn args implies dependencies ds = do
checkMemberIsUsable syns (ident, memberTy) = do
memberTy' <- T.replaceAllTypeSynonymsM syns memberTy
let mentionedArgIndexes = S.fromList (mapMaybe argToIndex (freeTypeVariables memberTy'))
- unless (any (`S.isSubsetOf` mentionedArgIndexes) coveringSets) $
- throwError . errorMessage $ UnusableDeclaration ident
+ let leftovers = map (`S.difference` mentionedArgIndexes) coveringSets
+
+ unless (any null leftovers) . throwError . errorMessage $
+ let
+ solutions = map (map (fst . (args !!)) . S.toList) leftovers
+ in
+ UnusableDeclaration ident (nub solutions)
addTypeClassDictionaries
:: (MonadState CheckState m)
@@ -267,14 +271,14 @@ typeCheckAll moduleName _ = traverse go
return $ TypeSynonymDeclaration sa name args ty
go TypeDeclaration{} =
internalError "Type declarations should have been removed before typeCheckAlld"
- go (ValueDeclaration sa@(ss, _) name nameKind [] [MkUnguarded val]) = do
+ go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do
env <- getEnv
warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (PositionedError ss)) $ do
val' <- checkExhaustiveExpr ss env moduleName val
valueIsNotDefined moduleName name
[(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')]
addValue moduleName name ty nameKind
- return $ ValueDeclaration sa name nameKind [] [MkUnguarded val'']
+ return $ ValueDecl sa name nameKind [] [MkUnguarded val'']
go ValueDeclaration{} = internalError "Binders were not desugared"
go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared"
go (BindingGroupDeclaration vals) = do
@@ -310,12 +314,21 @@ typeCheckAll moduleName _ = traverse go
return d
go d@FixityDeclaration{} = return d
go d@ImportDeclaration{} = return d
- go d@(TypeClassDeclaration _ pn args implies deps tys) = do
- addTypeClass moduleName pn args implies deps tys
- return d
+ go d@(TypeClassDeclaration (ss, _) pn args implies deps tys) = do
+ warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (PositionedError ss)) $ do
+ env <- getEnv
+ let qualifiedClassName = Qualified (Just moduleName) pn
+ guardWith (errorMessage (DuplicateTypeClass pn ss)) $
+ not (M.member qualifiedClassName (typeClasses env))
+ addTypeClass qualifiedClassName args implies deps tys
+ return d
go (d@(TypeInstanceDeclaration (ss, _) dictName deps className tys body)) =
rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do
env <- getEnv
+ let qualifiedDictName = Qualified (Just moduleName) dictName
+ flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries ->
+ guardWith (errorMessage (DuplicateInstance dictName ss)) $
+ not (M.member qualifiedDictName dictionaries)
case M.lookup className (typeClasses env) of
Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"
Just typeClass -> do
@@ -324,7 +337,7 @@ typeCheckAll moduleName _ = traverse go
checkOrphanInstance dictName className typeClass tys
_ <- traverseTypeInstanceBody checkInstanceMembers body
deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps
- let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps')
+ let dict = TypeClassDictionaryInScope qualifiedDictName [] className tys (Just deps')
addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict
return d
@@ -343,7 +356,7 @@ typeCheckAll moduleName _ = traverse go
return instDecls
where
memberName :: Declaration -> Ident
- memberName (ValueDeclaration _ ident _ _ _) = ident
+ memberName (ValueDeclaration vd) = valdeclIdent vd
memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition"
firstDuplicate :: (Eq a) => [a] -> Maybe a
@@ -354,9 +367,12 @@ typeCheckAll moduleName _ = traverse go
checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m ()
checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys'
- | moduleName == mn' || moduleName `S.member` nonOrphanModules = return ()
- | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
+ | moduleName `S.member` nonOrphanModules' = return ()
+ | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules' tys'
where
+ nonOrphanModules' :: S.Set ModuleName
+ nonOrphanModules' = S.insert mn' nonOrphanModules
+
typeModule :: Type -> Maybe ModuleName
typeModule (TypeVar _) = Nothing
typeModule (TypeLevelString _) = Nothing
@@ -493,6 +509,6 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
findClassMembers (TypeClassDeclaration _ name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds
findClassMembers _ = Nothing
extractMemberName :: Declaration -> Ident
- extractMemberName (TypeDeclaration _ memberName _) = memberName
+ extractMemberName (TypeDeclaration td) = tydeclIdent td
extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
checkClassMembersAreExported _ = return ()
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 4ca1248..58ec2f0 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -86,10 +86,10 @@ unifyKinds k1 k2 = do
go (KUnknown u) k = solveKind u k
go k (KUnknown u) = solveKind u k
go (NamedKind k1') (NamedKind k2') | k1' == k2' = return ()
- go (Row k1') (Row k2') = go k1' k2'
+ go (Row k1') (Row k2') = unifyKinds k1' k2'
go (FunKind k1' k2') (FunKind k3 k4) = do
- go k1' k3
- go k2' k4
+ unifyKinds k1' k3
+ unifyKinds k2' k4
go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2'
-- | Infer the kind of a single type
diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs
index bfb53d0..ae55033 100644
--- a/src/Language/PureScript/TypeChecker/TypeSearch.hs
+++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs
@@ -116,8 +116,14 @@ typeSearch
-> ([(P.Qualified Text, P.Type)], Maybe [(Label, P.Type)])
typeSearch unsolved env st type' =
let
- resultMap = Map.mapMaybe (\(x, _, _) -> checkSubsume unsolved env st type' x $> x) (P.names env)
- (allLabels, solvedLabels) = accessorSearch unsolved env st type'
- solvedLabels' = first (P.Qualified Nothing . ("_." <>) . P.prettyPrintLabel) <$> solvedLabels
+ runTypeSearch :: Map k P.Type -> Map k P.Type
+ runTypeSearch = Map.mapMaybe (\ty -> checkSubsume unsolved env st type' ty $> ty)
+
+ matchingNames = runTypeSearch (Map.map (\(ty, _, _) -> ty) (P.names env))
+ matchingConstructors = runTypeSearch (Map.map (\(_, _, ty, _) -> ty) (P.dataConstructors env))
+ (allLabels, matchingLabels) = accessorSearch unsolved env st type'
in
- (solvedLabels' <> (first (map P.runIdent) <$> Map.toList resultMap), if null allLabels then Nothing else Just allLabels)
+ ( (first (P.Qualified Nothing . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels)
+ <> (first (map P.runIdent) <$> Map.toList matchingNames)
+ <> (first (map P.runProperName) <$> Map.toList matchingConstructors)
+ , if null allLabels then Nothing else Just allLabels)
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index c3d95f8..f96771a 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -357,7 +357,8 @@ infer' (Abs binder ret)
ty <- freshType
withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do
body@(TypedValue _ _ bodyTy) <- infer' ret
- return $ TypedValue True (Abs (VarBinder arg) body) $ function ty bodyTy
+ (body', bodyTy') <- instantiatePolyTypeWithUnknowns body bodyTy
+ return $ TypedValue True (Abs (VarBinder arg) body') (function ty bodyTy')
| otherwise = internalError "Binder was not desugared"
infer' (App f arg) = do
f'@(TypedValue _ _ ft) <- infer f
@@ -426,7 +427,7 @@ inferLetBinding
-> (Expr -> m Expr)
-> m ([Declaration], Expr)
inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)
-inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j =
+inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j =
warnAndRethrowWithPositionTC ss $ do
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- kindOfWithScopedVars ty
@@ -434,14 +435,16 @@ inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded
let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined)
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv
- bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j
-inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j =
+ bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined))
+ $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j
+inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j =
warnAndRethrowWithPositionTC ss $ do
valTy <- freshType
let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined)
TypedValue _ val' valTy' <- bindNames dict $ infer val
unifyTypes valTy valTy'
- bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration sa ident nameKind [] [MkUnguarded val']]) rest ret j
+ bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined))
+ $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j
inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds
diff --git a/stack.yaml b/stack.yaml
index c04a09e..df22368 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,5 +1,6 @@
-resolver: lts-8.5
+resolver: nightly-2017-09-10
packages:
- '.'
extra-deps:
- pipes-http-1.0.5
+- Win32-notify-0.3.0.3
diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs
index 255d697..4df331a 100644
--- a/tests/Language/PureScript/Ide/CompletionSpec.hs
+++ b/tests/Language/PureScript/Ide/CompletionSpec.hs
@@ -5,10 +5,12 @@ module Language.PureScript.Ide.CompletionSpec where
import Protolude
import Language.PureScript as P
+import Language.PureScript.Ide.Test as Test
+import Language.PureScript.Ide.Command as Command
import Language.PureScript.Ide.Completion
-import Language.PureScript.Ide.Test
import Language.PureScript.Ide.Types
import Test.Hspec
+import System.FilePath
reexportMatches :: [Match IdeDeclarationAnn]
reexportMatches =
@@ -21,6 +23,15 @@ reexportMatches =
matches :: [(Match IdeDeclarationAnn, [P.ModuleName])]
matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing [] ]
+typ :: Text -> Command
+typ txt = Type txt [] Nothing
+
+load :: [Text] -> Command
+load = LoadSync . map Test.mn
+
+rebuildSync :: FilePath -> Command
+rebuildSync fp = RebuildSync ("src" </> fp) Nothing
+
spec :: Spec
spec = describe "Applying completion options" $ do
it "keeps all matches if maxResults is not specified" $ do
@@ -32,3 +43,24 @@ spec = describe "Applying completion options" $ do
it "groups reexports for a single identifier" $ do
applyCompletionOptions (defaultCompletionOptions { coGroupReexports = True })
reexportMatches `shouldBe` [(Match (mn "A", ideKind "Kind"), [mn "A", mn "B"])]
+
+ it "gets simple docs on definition itself" $ do
+ ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
+ Test.runIde [ load ["CompletionSpecDocs"]
+ , typ "something"
+ ]
+ result `shouldSatisfy` \res -> complDocumentation res == Just "Doc x\n"
+
+ it "gets multiline docs" $ do
+ ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
+ Test.runIde [ load ["CompletionSpecDocs"]
+ , typ "multiline"
+ ]
+ result `shouldSatisfy` \res -> complDocumentation res == Just "This is\na multi-line\ncomment\n"
+
+ it "gets simple docs on type annotation" $ do
+ ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
+ Test.runIde [ load ["CompletionSpecDocs"]
+ , typ "withType"
+ ]
+ result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n" \ No newline at end of file
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index e95309f..b7c8196 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.PureScript.Ide.ImportsSpec where
-import Protolude
+import Protolude hiding (moduleName)
import Data.Maybe (fromJust)
import qualified Language.PureScript as P
@@ -29,6 +29,15 @@ simpleFile =
, "myFunc x y = x + y"
]
+hidingFile :: [Text]
+hidingFile =
+ [ "module Main where"
+ , "import Prelude"
+ , "import Data.Maybe hiding (maybe)"
+ , ""
+ , "myFunc x y = x + y"
+ ]
+
syntaxErrorFile :: [Text]
syntaxErrorFile =
[ "module Main where"
@@ -37,8 +46,8 @@ syntaxErrorFile =
, "myFunc ="
]
-splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text])
-splitSimpleFile = fromRight (sliceImportSection simpleFile)
+testSliceImportSection :: [Text] -> (P.ModuleName, [Text], [Import], [Text])
+testSliceImportSection = fromRight . sliceImportSection
where
fromRight = fromJust . rightToMaybe
@@ -99,17 +108,19 @@ spec = do
shouldBe (prettyPrintImport' maybeImport) "import Data.Maybe (Maybe(Just))"
describe "import commands" $ do
- let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i
- addValueImport i mn is =
- prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValue i Nothing)) mn is)
- addOpImport op mn is =
- prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValueOp op (P.Qualified Nothing (Left "")) 2 Nothing Nothing)) mn is)
- addDtorImport i t mn is =
- prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn is)
- addTypeImport i mn is =
- prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing [])) mn is)
- addKindImport i mn is =
- prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideKind i)) mn is)
+ let simpleFileImports = let (_, _, i, _) = testSliceImportSection simpleFile in i
+ hidingFileImports = let (_, _, i, _) = testSliceImportSection hidingFile in i
+ addValueImport i mn q is =
+ prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValue i Nothing)) mn q is)
+ addOpImport op mn q is =
+ prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValueOp op (P.Qualified q (Left "")) 2 Nothing Nothing)) mn q is)
+ addDtorImport i t mn q is =
+ prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn q is)
+ addTypeImport i mn q is =
+ prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing [])) mn q is)
+ addKindImport i mn q is =
+ prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideKind i)) mn q is)
+ qualify s = Just (Test.mn s)
it "adds an implicit unqualified import to a file without any imports" $
shouldBe
(addImplicitImport' [] (P.moduleNameFromString "Data.Map"))
@@ -127,86 +138,172 @@ spec = do
, ""
, "import Data.Map as Map"
]
+ it "adds a qualified import and maintains proper grouping for implicit hiding imports" $
+ shouldBe
+ (addQualifiedImport' hidingFileImports (Test.mn "Data.Map") (Test.mn "Map"))
+ [ "import Data.Maybe hiding (maybe)"
+ , "import Prelude"
+ , ""
+ , "import Data.Map as Map"
+ ]
it "adds an explicit unqualified import to a file without any imports" $
shouldBe
- (addValueImport "head" (P.moduleNameFromString "Data.Array") [])
+ (addValueImport "head" (P.moduleNameFromString "Data.Array") Nothing [])
["import Data.Array (head)"]
+ it "adds an explicit qualified import to a file without any imports" $
+ shouldBe
+ (addValueImport "head" (P.moduleNameFromString "Data.Array") (qualify "Array") [])
+ ["import Data.Array (head) as Array"]
it "adds an explicit unqualified import" $
shouldBe
- (addValueImport "head" (P.moduleNameFromString "Data.Array") simpleFileImports)
+ (addValueImport "head" (P.moduleNameFromString "Data.Array") Nothing simpleFileImports)
[ "import Prelude"
, ""
, "import Data.Array (head)"
]
+ it "adds an explicit qualified import" $
+ shouldBe
+ (addValueImport "head" (P.moduleNameFromString "Data.Array") (qualify "Array") simpleFileImports)
+ [ "import Prelude"
+ , ""
+ , "import Data.Array (head) as Array"
+ ]
it "doesn't add an import if the containing module is imported implicitly" $
shouldBe
- (addValueImport "const" (P.moduleNameFromString "Prelude") simpleFileImports)
+ (addValueImport "const" (P.moduleNameFromString "Prelude") Nothing simpleFileImports)
["import Prelude"]
+ let Right (_, _, qualifiedImports, _) = sliceImportSection (withImports ["import Data.Array as Array"])
+ it "doesn't add a qualified explicit import if the containing module is imported qualified" $
+ shouldBe
+ (addValueImport "length" (P.moduleNameFromString "Data.Array") (qualify "Array") qualifiedImports)
+ ["import Prelude"
+ , ""
+ , "import Data.Array as Array"]
let Right (_, _, explicitImports, _) = sliceImportSection (withImports ["import Data.Array (tail)"])
it "adds an identifier to an explicit import list" $
shouldBe
- (addValueImport "head" (P.moduleNameFromString "Data.Array") explicitImports)
+ (addValueImport "head" (P.moduleNameFromString "Data.Array") Nothing explicitImports)
[ "import Prelude"
, ""
, "import Data.Array (head, tail)"
]
+ let Right (_, _, explicitQualImports, _) = sliceImportSection (withImports ["import Data.Array (tail) as Array"])
+ it "adds an identifier to an explicit qualified import list" $
+ shouldBe
+ (addValueImport "head" (P.moduleNameFromString "Data.Array") (qualify "Array") explicitQualImports)
+ [ "import Prelude"
+ , ""
+ , "import Data.Array (head, tail) as Array"
+ ]
it "adds a kind to an explicit import list" $
shouldBe
- (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") simpleFileImports)
+ (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") Nothing simpleFileImports)
[ "import Prelude"
, ""
, "import Control.Monad.Eff (kind Effect)"
]
+ it "adds a kind to an explicit qualified import list" $
+ shouldBe
+ (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") (qualify "Eff") simpleFileImports)
+ [ "import Prelude"
+ , ""
+ , "import Control.Monad.Eff (kind Effect) as Eff"
+ ]
it "adds an operator to an explicit import list" $
shouldBe
- (addOpImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports)
+ (addOpImport "<~>" (P.moduleNameFromString "Data.Array") Nothing explicitImports)
[ "import Prelude"
, ""
, "import Data.Array (tail, (<~>))"
]
+ it "adds an operator to an explicit qualified import list" $
+ shouldBe
+ (addOpImport "<~>" (P.moduleNameFromString "Data.Array") (qualify "Array") explicitQualImports)
+ [ "import Prelude"
+ , ""
+ , "import Data.Array (tail, (<~>)) as Array"
+ ]
it "adds a type with constructors without automatically adding an open import of said constructors " $
shouldBe
- (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports)
+ (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing simpleFileImports)
[ "import Prelude"
, ""
, "import Data.Maybe (Maybe)"
]
it "adds the type for a given DataConstructor" $
shouldBe
- (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports)
+ (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing simpleFileImports)
[ "import Prelude"
, ""
, "import Data.Maybe (Maybe(..))"
]
+ it "adds the type for a given DataConstructor qualified" $
+ shouldBe
+ (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") (qualify "M") simpleFileImports)
+ [ "import Prelude"
+ , ""
+ , "import Data.Maybe (Maybe(..)) as M"
+ ]
it "adds a dataconstructor to an existing type import" $ do
let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"])
shouldBe
- (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports)
+ (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports)
+ [ "import Prelude"
+ , ""
+ , "import Data.Maybe (Maybe(..))"
+ ]
+ it "adding a type to an existing import of that type is noop" $ do
+ let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"])
+ shouldBe
+ (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports)
+ [ "import Prelude"
+ , ""
+ , "import Data.Maybe (Maybe)"
+ ]
+ it "adding a type to an existing import of that type with its constructors is noop" $ do
+ let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe (..))"])
+ shouldBe
+ (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports)
[ "import Prelude"
, ""
, "import Data.Maybe (Maybe(..))"
]
+ it "adds a dataconstructor to an existing qualified type import" $ do
+ let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe) as M"])
+ shouldBe
+ (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") (qualify "M") typeImports)
+ [ "import Prelude"
+ , ""
+ , "import Data.Maybe (Maybe(..)) as M"
+ ]
it "doesn't add a dataconstructor to an existing type import with open dtors" $ do
let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"])
shouldBe
- (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports)
+ (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports)
[ "import Prelude"
, ""
, "import Data.Maybe (Maybe(..))"
]
it "doesn't add an identifier to an explicit import list if it's already imported" $
shouldBe
- (addValueImport "tail" (P.moduleNameFromString "Data.Array") explicitImports)
+ (addValueImport "tail" (P.moduleNameFromString "Data.Array") Nothing explicitImports)
[ "import Prelude"
, ""
, "import Data.Array (tail)"
]
+ it "doesn't add an identifier to an explicit qualified import list if it's already imported qualified" $
+ shouldBe
+ (addValueImport "tail" (P.moduleNameFromString "Data.Array") (qualify "Array") explicitQualImports)
+ [ "import Prelude"
+ , ""
+ , "import Data.Array (tail) as Array"
+ ]
describe "explicit import sorting" $ do
-- given some basic import skeleton
let Right (_, _, baseImports, _) = sliceImportSection $ withImports ["import Control.Monad (ap)"]
moduleName = (P.moduleNameFromString "Control.Monad")
- addImport imports import' = addExplicitImport' import' moduleName imports
+ addImport imports import' = addExplicitImport' import' moduleName Nothing imports
valueImport ident = _idaDeclaration (Test.ideValue ident Nothing)
typeImport name = _idaDeclaration (Test.ideType name Nothing [])
classImport name = _idaDeclaration (Test.ideTypeClass name P.kindType [])
@@ -244,7 +341,7 @@ implImport mn =
addExplicitImport :: Text -> Command
addExplicitImport i =
- Command.Import ("src" </> "ImportsSpec.purs") Nothing [] (Command.AddImportForIdentifier i)
+ Command.Import ("src" </> "ImportsSpec.purs") Nothing [] (Command.AddImportForIdentifier i Nothing)
importShouldBe :: [Text] -> [Text] -> Expectation
importShouldBe res importSection =
diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs
index 9c00312..03ea688 100644
--- a/tests/Language/PureScript/Ide/RebuildSpec.hs
+++ b/tests/Language/PureScript/Ide/RebuildSpec.hs
@@ -4,6 +4,7 @@ module Language.PureScript.Ide.RebuildSpec where
import Protolude
+import Language.PureScript.AST.SourcePos (spanName)
import Language.PureScript.Ide.Command
import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Matcher
@@ -16,10 +17,10 @@ load :: [Text] -> Command
load = LoadSync . map Test.mn
rebuild :: FilePath -> Command
-rebuild fp = Rebuild ("src" </> fp)
+rebuild fp = Rebuild ("src" </> fp) Nothing
rebuildSync :: FilePath -> Command
-rebuildSync fp = RebuildSync ("src" </> fp)
+rebuildSync fp = RebuildSync ("src" </> fp) Nothing
spec :: Spec
spec = describe "Rebuilding single modules" $ do
@@ -60,3 +61,12 @@ spec = describe "Rebuilding single modules" $ do
Test.runIde [ rebuildSync "RebuildSpecWithHiddenIdent.purs"
, Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions]
complIdentifier result `shouldBe` "hidden"
+ it "uses the specified `actualFile` for location information (in editor mode)" $ do
+ let editorConfig = Test.defConfig { confEditorMode = True }
+ ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
+ Test.runIde'
+ editorConfig
+ emptyIdeState
+ [ RebuildSync ("src" </> "RebuildSpecWithHiddenIdent.purs") (Just "actualFile")
+ , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions]
+ map spanName (complLocation result) `shouldBe` Just "actualFile"
diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs
index 1bf01f4..dbcfed9 100644
--- a/tests/Language/PureScript/Ide/SourceFileSpec.hs
+++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs
@@ -22,8 +22,8 @@ ann1 = (span1, [])
ann2 = (span2, [])
typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration
-typeAnnotation1 = P.TypeDeclaration ann1 (P.Ident "value1") P.REmpty
-value1 = P.ValueDeclaration ann1 (P.Ident "value1") P.Public [] []
+typeAnnotation1 = P.TypeDeclaration (P.TypeDeclarationData ann1 (P.Ident "value1") P.REmpty)
+value1 = P.ValueDecl ann1 (P.Ident "value1") P.Public [] []
synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.REmpty
class1 = P.TypeClassDeclaration ann1 (P.ProperName "Class1") [] [] [] []
class2 = P.TypeClassDeclaration ann1 (P.ProperName "Class2") [] [] [] [member1]
@@ -44,7 +44,7 @@ typeFixity =
foreign1 = P.ExternDeclaration ann1 (P.Ident "foreign1") P.REmpty
foreign2 = P.ExternDataDeclaration ann1 (P.ProperName "Foreign2") P.kindType
foreign3 = P.ExternKindDeclaration ann1 (P.ProperName "Foreign3")
-member1 = P.TypeDeclaration ann2 (P.Ident "member1") P.REmpty
+member1 = P.TypeDeclaration (P.TypeDeclarationData ann2 (P.Ident "member1") P.REmpty)
spec :: Spec
spec = do
diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs
index dd48b8f..d9d50ae 100644
--- a/tests/Language/PureScript/Ide/Test.hs
+++ b/tests/Language/PureScript/Ide/Test.hs
@@ -20,10 +20,12 @@ import qualified Language.PureScript as P
defConfig :: IdeConfiguration
defConfig =
- IdeConfiguration { confLogLevel = LogNone
- , confOutputPath = "output/"
- , confGlobs = ["src/*.purs"]
- }
+ IdeConfiguration
+ { confLogLevel = LogNone
+ , confOutputPath = "output/"
+ , confGlobs = ["src/*.purs"]
+ , confEditorMode = False
+ }
runIde' :: IdeConfiguration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState)
runIde' conf s cs = do
diff --git a/tests/Main.hs b/tests/Main.hs
index acfce36..1622bd4 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -10,10 +10,11 @@ import Prelude.Compat
import qualified TestCompiler
import qualified TestDocs
+import qualified TestHierarchy
+import qualified TestPrimDocs
import qualified TestPsci
import qualified TestPscIde
import qualified TestPscPublish
-import qualified TestPrimDocs
import qualified TestUtils
import System.IO (hSetEncoding, stdout, stderr, utf8)
@@ -29,6 +30,9 @@ main = do
TestCompiler.main
heading "Documentation test suite"
TestDocs.main
+ heading "Hierarchy test suite"
+ TestHierarchy.main
+ heading "Prim documentation test suite"
TestPrimDocs.main
heading "psc-publish test suite"
TestPscPublish.main
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index d3dbbdb..e486988 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -12,8 +12,10 @@ import Prelude.Compat
import Control.Arrow (first)
import Control.Monad.IO.Class (liftIO)
+import Data.List (findIndex)
import Data.Foldable
-import Data.Maybe (fromMaybe)
+import Safe (headMay)
+import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
@@ -27,9 +29,10 @@ import Language.PureScript.Docs.AsMarkdown (codeToString)
import qualified Language.PureScript.Publish as Publish
import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
-import Web.Bower.PackageMeta (parsePackageName)
+import Web.Bower.PackageMeta (parsePackageName, runPackageName)
import TestUtils
+import Test.Hspec (Spec, it, context, expectationFailure, runIO, hspec)
publishOpts :: Publish.PublishOptions
publishOpts = Publish.defaultPublishOptions
@@ -39,23 +42,54 @@ publishOpts = Publish.defaultPublishOptions
}
where testVersion = ("v999.0.0", Version [999,0,0] [])
+getPackage :: IO (Either Publish.PackageError (Docs.Package Docs.NotYetKnown))
+getPackage =
+ pushd "examples/docs" $
+ Publish.preparePackage "bower.json" "resolutions.json" publishOpts
+
main :: IO ()
-main = pushd "examples/docs" $ do
- res <- Publish.preparePackage "bower.json" "resolutions.json" publishOpts
- case res of
- Left e -> Publish.printErrorToStdout e >> exitFailure
- Right pkg@Docs.Package{..} ->
- forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
- let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))
- (find ((==) mn . Docs.modName) pkgModules)
- linksCtx = Docs.getLinksContext pkg
- in forM_ pragmas (\a -> runAssertionIO a linksCtx mdl)
+main = hspec spec
+
+spec :: Spec
+spec = do
+ pkg@Docs.Package{..} <- runIO $ do
+ res <- getPackage
+ case res of
+ Left e ->
+ Publish.printErrorToStdout e >> exitFailure
+ Right p ->
+ pure p
+
+ let linksCtx = Docs.getLinksContext pkg
+
+ context "Language.PureScript.Docs" $
+ forM_ testCases $ \(mnString, assertions) -> do
+ let mn = P.moduleNameFromString mnString
+ mdl = find ((==) mn . Docs.modName) pkgModules
+
+ context ("in module " ++ T.unpack mnString) $ do
+ case mdl of
+ Nothing ->
+ it "exists in docs output" $
+ expectationFailure ("module not found in docs: " ++ T.unpack mnString)
+ Just mdl' ->
+ toHspec linksCtx mdl' assertions
+ where
+ toHspec :: Docs.LinksContext -> Docs.Module -> [DocsAssertion] -> Spec
+ toHspec linksCtx mdl assertions =
+ forM_ assertions $ \a ->
+ it (T.unpack (displayAssertion a)) $ do
+ case runAssertion a linksCtx mdl of
+ Pass ->
+ pure ()
+ Fail reason ->
+ expectationFailure (T.unpack (displayAssertionFailure reason))
takeJust :: String -> Maybe a -> a
takeJust msg = fromMaybe (error msg)
-data Assertion
+data DocsAssertion
-- | Assert that a particular declaration is documented with the given
-- children
= ShouldBeDocumented P.ModuleName Text [Text]
@@ -72,7 +106,10 @@ data Assertion
| ShouldHaveFunDeps P.ModuleName Text [([Text],[Text])]
-- | Assert that a particular value declaration exists, and its type
-- satisfies the given predicate.
- | ValueShouldHaveTypeSignature P.ModuleName Text (ShowFn (P.Type -> Bool))
+ | ValueShouldHaveTypeSignature P.ModuleName Text (P.Type -> Bool)
+ -- | Assert that a particular instance declaration exists under some class or
+ -- type declaration, and that its type satisfies the given predicate.
+ | InstanceShouldHaveTypeSignature P.ModuleName Text Text (P.Type -> Bool)
-- | Assert that a particular type alias exists, and its corresponding
-- type, when rendered, matches a given string exactly
-- fields: module, type synonym name, expected type
@@ -88,14 +125,47 @@ data Assertion
-- declaration title, title of linked declaration, namespace of linked
-- declaration, destination of link.
| ShouldHaveLink P.ModuleName Text Text Docs.Namespace Docs.LinkLocation
- deriving (Show)
-
-newtype ShowFn a = ShowFn a
-
-instance Show (ShowFn a) where
- show _ = "<function>"
-
-data AssertionFailure
+ -- | Assert that a given declaration comes before another in the output
+ | ShouldComeBefore P.ModuleName Text Text
+
+displayAssertion :: DocsAssertion -> Text
+displayAssertion = \case
+ ShouldBeDocumented mn decl children ->
+ showQual mn decl <> " should be documented" <>
+ (if not (null children)
+ then " with children: " <> T.pack (show children)
+ else "")
+ ShouldNotBeDocumented mn decl ->
+ showQual mn decl <> " should not be documented"
+ ChildShouldNotBeDocumented mn decl child ->
+ showQual mn decl <> " should not have " <> child <> " as a child declaration"
+ ShouldBeConstrained mn decl constraint ->
+ showQual mn decl <> " should have a " <> constraint <> " constraint"
+ ShouldHaveFunDeps mn decl fundeps ->
+ showQual mn decl <> " should have fundeps: " <> T.pack (show fundeps)
+ ValueShouldHaveTypeSignature mn decl _ ->
+ "the type signature for " <> showQual mn decl <>
+ " should satisfy the given predicate"
+ InstanceShouldHaveTypeSignature _ parent instName _ ->
+ "the instance " <> instName <> " (under " <> parent <> ") should have" <>
+ " a type signature satisfying the given predicate"
+ TypeSynonymShouldRenderAs mn synName code ->
+ "the RHS of the type synonym " <> showQual mn synName <>
+ " should be rendered as " <> code
+ ShouldHaveDocComment mn decl excerpt ->
+ "the string " <> T.pack (show excerpt) <> " should appear in the" <>
+ " doc-comments for " <> showQual mn decl
+ ShouldHaveReExport inPkg ->
+ "there should be some re-exports from " <>
+ showInPkg P.runModuleName inPkg
+ ShouldHaveLink mn decl targetTitle targetNs _ ->
+ "the rendered code for " <> showQual mn decl <> " should contain a link" <>
+ " to " <> targetTitle <> " (" <> T.pack (show targetNs) <> ")"
+ ShouldComeBefore mn declA declB ->
+ showQual mn declA <> " should come before " <> showQual mn declB <>
+ " in the docs"
+
+data DocsAssertionFailure
-- | A declaration was not documented, but should have been
= NotDocumented P.ModuleName Text
-- | The expected list of child declarations did not match the actual list
@@ -111,16 +181,16 @@ data AssertionFailure
-- | A declaration had the wrong "type" (ie, value, type, type class)
-- Fields: declaration title, expected "type", actual "type".
| WrongDeclarationType P.ModuleName Text Text Text
- -- | A value declaration had the wrong type (in the sense of "type
- -- checking"), eg, because the inferred type was used when the explicit type
- -- should have been.
+ -- | A declaration had the wrong type (in the sense of "type checking"), eg,
+ -- because the inferred type was used when the explicit type should have
+ -- been.
-- Fields: module name, declaration name, actual type.
- | ValueDeclarationWrongType P.ModuleName Text P.Type
+ | DeclarationWrongType P.ModuleName Text P.Type
-- | A Type synonym has been rendered in an unexpected format
-- Fields: module name, declaration name, expected rendering, actual rendering
| TypeSynonymMismatch P.ModuleName Text Text Text
-- | A doc comment was not found or did not match what was expected
- -- Fields: module name, expected substring, actual comments
+ -- Fields: module name, declaration, actual comments
| DocCommentMissing P.ModuleName Text (Maybe Text)
-- | A module was missing re-exports from a particular module.
-- Fields: module name, expected re-export, actual re-exports.
@@ -136,14 +206,54 @@ data AssertionFailure
-- declaration, title of the linked declaration, expected location, actual
-- location.
| BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation
- deriving (Show)
-
-data AssertionResult
+ -- | Declarations were in the wrong order
+ | WrongOrder P.ModuleName Text Text
+
+displayAssertionFailure :: DocsAssertionFailure -> Text
+displayAssertionFailure = \case
+ NotDocumented _ decl ->
+ decl <> " was not documented, but should have been"
+ ChildrenNotDocumented _ decl children ->
+ decl <> " had the wrong children; got " <> T.pack (show children)
+ Documented _ decl ->
+ decl <> " was documented, but should not have been"
+ ChildDocumented _ decl child ->
+ decl <> " had " <> child <> " as a child"
+ ConstraintMissing _ decl constraint ->
+ decl <> " did not have a " <> constraint <> " constraint"
+ FunDepMissing _ decl fundeps ->
+ decl <> " had the wrong fundeps; got " <> T.pack (show fundeps)
+ WrongDeclarationType _ decl expected actual ->
+ "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)
+ TypeSynonymMismatch _ decl expected actual ->
+ "expected the RHS of " <> decl <> " to be " <> expected <>
+ "; got " <> actual
+ DocCommentMissing _ decl actual ->
+ "the doc-comment for " <> decl <> " did not contain the expected substring;" <>
+ " got " <> T.pack (show actual)
+ ReExportMissing _ expected actuals ->
+ "expected to see some re-exports from " <>
+ showInPkg P.runModuleName expected <>
+ "; instead only saw re-exports from " <>
+ T.pack (show (map (showInPkg P.runModuleName) actuals))
+ LinkedDeclarationMissing _ decl target ->
+ "expected to find a link to " <> target <> " within the rendered code" <>
+ " for " <> decl <> ", but no such link was found"
+ BadLinkLocation _ decl target expected actual ->
+ "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
+
+data DocsAssertionResult
= Pass
- | Fail AssertionFailure
- deriving (Show)
+ | Fail DocsAssertionFailure
-runAssertion :: Assertion -> Docs.LinksContext -> Docs.Module -> AssertionResult
+runAssertion :: DocsAssertion -> Docs.LinksContext -> Docs.Module -> DocsAssertionResult
runAssertion assertion linksCtx Docs.Module{..} =
case assertion of
ShouldBeDocumented mn decl children ->
@@ -193,18 +303,39 @@ runAssertion assertion linksCtx Docs.Module{..} =
Fail (WrongDeclarationType mn decl "value"
(Docs.declInfoToString declInfo))
- ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
+ ValueShouldHaveTypeSignature mn decl tyPredicate ->
findDecl mn decl $ \Docs.Declaration{..} ->
case declInfo of
Docs.ValueDeclaration ty ->
if tyPredicate ty
then Pass
- else Fail
- (ValueDeclarationWrongType mn decl ty)
+ else Fail (DeclarationWrongType mn decl ty)
_ ->
Fail (WrongDeclarationType mn decl "value"
(Docs.declInfoToString declInfo))
+ InstanceShouldHaveTypeSignature mn parent decl tyPredicate ->
+ case find ((==) parent . Docs.declTitle) (declarationsFor mn) >>= findTarget of
+ Just ty ->
+ if tyPredicate ty
+ then Pass
+ else Fail (DeclarationWrongType mn decl ty)
+ Nothing ->
+ Fail (NotDocumented mn decl)
+
+ where
+ findTarget =
+ headMay .
+ mapMaybe (extractInstanceType . Docs.cdeclInfo) .
+ filter (\cdecl -> Docs.cdeclTitle cdecl == decl) .
+ Docs.declChildren
+
+ extractInstanceType = \case
+ (Docs.ChildInstance _ ty) ->
+ Just ty
+ _ ->
+ Nothing
+
TypeSynonymShouldRenderAs mn decl expected ->
findDecl mn decl $ \Docs.Declaration{..} ->
case declInfo of
@@ -244,6 +375,23 @@ runAssertion assertion linksCtx Docs.Module{..} =
Nothing ->
Fail (LinkedDeclarationMissing mn decl destTitle)
+ 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
+ (Just i, Just j) ->
+ if i < j
+ then Pass
+ else Fail (WrongOrder mn before after)
+ (Nothing, _) ->
+ Fail (NotDocumented mn before)
+ (_, Nothing) ->
+ Fail (NotDocumented mn after)
+
where
declarationsFor mn =
if mn == modName
@@ -287,16 +435,7 @@ checkConstrained ty tyClass =
matches className =
(==) className . P.runProperName . P.disqualify . P.constraintClass
-runAssertionIO :: Assertion -> Docs.LinksContext -> Docs.Module -> IO ()
-runAssertionIO assertion linksCtx mdl = do
- putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)
- case runAssertion assertion linksCtx mdl of
- Pass -> pure ()
- Fail reason -> do
- putStrLn ("Failed: " <> show reason)
- exitFailure
-
-testCases :: [(Text, [Assertion])]
+testCases :: [(Text, [DocsAssertion])]
testCases =
[ ("Example",
[ -- From dependencies
@@ -374,9 +513,9 @@ testCases =
])
, ("ExplicitTypeSignatures",
- [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
- , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
- , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
+ [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (hasTypeVar "something")
+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (P.tyInt ==)
+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (P.tyNumber ==)
])
, ("ConstrainedArgument",
@@ -392,6 +531,13 @@ testCases =
, ValueShouldHaveTypeSignature (n "TypeOpAliases") "test3" (renderedType "forall a b c d. a ~> (b ~> c) ~> d")
, ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d")
, ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c")
+
+ , ShouldBeDocumented (n "TypeOpAliases") "Tuple" ["Tuple","showTuple", "testLEither", "testREither"]
+ , ShouldBeDocumented (n "TypeOpAliases") "Either" ["Left", "Right","testLEither", "testREither"]
+ , ShouldBeDocumented (n "TypeOpAliases") "Show" ["show","showTuple"]
+
+ , InstanceShouldHaveTypeSignature (n "TypeOpAliases") "Either" "testLEither" (renderedType "TestL (Either Int (Tuple Int String))")
+ , InstanceShouldHaveTypeSignature (n "TypeOpAliases") "Either" "testREither" (renderedType "TestR (Either (Tuple Int Int) String)")
])
, ("DocComments",
@@ -410,6 +556,14 @@ testCases =
[ ShouldBeDocumented (n "ChildDeclOrder") "Two" ["First", "Second", "showTwo", "fooTwo"]
, ShouldBeDocumented (n "ChildDeclOrder") "Foo" ["foo1", "foo2", "fooTwo", "fooInt"]
])
+
+ , ("DeclOrder",
+ shouldBeOrdered (n "DeclOrder")
+ ["A", "x1", "X2", "x3", "X4", "B"])
+
+ , ("DeclOrderNoExportList",
+ shouldBeOrdered (n "DeclOrderNoExportList")
+ [ "x1", "x3", "X2", "X4", "A", "B" ])
]
where
@@ -422,5 +576,19 @@ testCases =
isVar varName (P.TypeVar name) | varName == T.unpack name = True
isVar _ _ = False
- renderedType expected =
- ShowFn $ \ty -> codeToString (Docs.renderType ty) == expected
+ renderedType expected ty =
+ codeToString (Docs.renderType ty) == expected
+
+ shouldBeOrdered mn declNames =
+ zipWith (ShouldComeBefore mn) declNames (tail declNames)
+
+showQual :: P.ModuleName -> Text -> Text
+showQual mn decl =
+ P.runModuleName mn <> "." <> decl
+
+showInPkg :: (a -> Text) -> Docs.InPackage a -> Text
+showInPkg f = \case
+ Docs.Local x ->
+ f x <> " (local)"
+ Docs.FromDep pkgName x ->
+ f x <> " (from dep: " <> runPackageName pkgName <> ")"
diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs
new file mode 100644
index 0000000..98bea9a
--- /dev/null
+++ b/tests/TestHierarchy.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+module TestHierarchy where
+
+import Language.PureScript.Hierarchy
+import qualified Language.PureScript as P
+import Test.Hspec (describe, hspec, it, shouldBe)
+
+main :: IO ()
+main = hspec $ do
+ describe "Language.PureScript.Hierarchy" $ do
+ describe "prettyPrint" $ do
+ it "creates just the node when there is no relation" $ do
+ let superMap = SuperMap (Left $ P.ProperName "A")
+
+ let prettyPrinted = prettyPrint superMap
+
+ prettyPrinted `shouldBe` " A;"
+
+ it "creates a relation when there is one" $ do
+ let superMap = SuperMap (Right $ (P.ProperName "A", P.ProperName "B"))
+
+ let prettyPrinted = prettyPrint superMap
+
+ prettyPrinted `shouldBe` " A -> B;"
+
+ describe "typeClassGraph" $ do
+ it "doesn't generate a graph if there are no type classes" $ do
+ let mainModule = P.Module
+ (P.internalModuleSourceSpan "<hierarchy>")
+ []
+ (P.ModuleName [P.ProperName "Main"])
+ []
+ Nothing
+
+ let graph = typeClassGraph mainModule
+
+ graph `shouldBe` Nothing
+
+ it "generates usable graphviz graphs" $ do
+ let declarations =
+ [ P.TypeClassDeclaration
+ (P.internalModuleSourceSpan "<A>", [])
+ (P.ProperName "A")
+ []
+ []
+ []
+ []
+ , P.TypeClassDeclaration
+ (P.internalModuleSourceSpan "<B>", [])
+ (P.ProperName "B")
+ []
+ [P.Constraint (P.Qualified Nothing $ P.ProperName "A") [] Nothing]
+ []
+ []
+ ]
+ let mainModule = P.Module
+ (P.internalModuleSourceSpan "<hierarchy>")
+ []
+ (P.ModuleName [P.ProperName "Main"])
+ declarations
+ Nothing
+
+ let graph = typeClassGraph mainModule
+
+ graph `shouldBe` Just (Graph (GraphName "Main") (Digraph "digraph Main {\n A;\n A -> B;\n}"))
diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs
index f1e36b2..57e7742 100644
--- a/tests/TestPsci/CommandTest.hs
+++ b/tests/TestPsci/CommandTest.hs
@@ -32,3 +32,9 @@ commandTests = context "commandTests" $ do
run ":reload"
ms' <- psciImportedModules <$> get
length ms' `equalsTo` 3
+
+ specPSCi ":complete" $ do
+ ":complete ma" `prints` []
+ ":complete Data.Functor.ma" `prints` (unlines (map ("Data.Functor." ++ ) ["map", "mapFlipped"]))
+ run "import Data.Functor"
+ ":complete ma" `prints` (unlines ["map", "mapFlipped"])
diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs
index fef5f7b..1040561 100644
--- a/tests/TestPsci/CompletionTest.hs
+++ b/tests/TestPsci/CompletionTest.hs
@@ -12,7 +12,6 @@ import Data.List (sort)
import qualified Data.Text as T
import qualified Language.PureScript as P
import Language.PureScript.Interactive
-import System.Console.Haskeline
import TestPsci.TestEnv (initTestPSCiEnv)
import TestUtils (getSupportModuleNames)
@@ -29,7 +28,7 @@ completionTestData supportModuleNames =
-- basic directives
[ (":h", [":help"])
, (":r", [":reload"])
- , (":c", [":clear"])
+ , (":c", [":clear", ":complete"])
, (":q", [":quit"])
, (":b", [":browse"])
@@ -88,10 +87,9 @@ completionTestData supportModuleNames =
assertCompletedOk :: (String, [String]) -> Spec
assertCompletedOk (line, expecteds) = specify line $ do
- (unusedR, completions) <- runCM (completion' (reverse line, ""))
- let unused = reverse unusedR
- let actuals = map ((unused ++) . replacement) completions
- sort expecteds `shouldBe` sort actuals
+ results <- runCM (completion' (reverse line, ""))
+ let actuals = formatCompletions results
+ sort actuals `shouldBe` sort expecteds
runCM :: CompletionM a -> IO a
runCM act = do
diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs
index 8f71d9a..fdf0ca9 100644
--- a/tests/TestPsci/TestEnv.hs
+++ b/tests/TestPsci/TestEnv.hs
@@ -56,26 +56,41 @@ jsEval = liftIO $ do
Just (ExitFailure _, _, err) -> putStrLn err >> exitFailure
Nothing -> putStrLn "Couldn't find node.js" >> exitFailure
--- | Run a PSCi command and evaluate the output with 'eval'.
-runAndEval :: String -> TestPSCi () -> TestPSCi ()
-runAndEval comm eval =
+-- | Run a PSCi command and evaluate its outputs:
+-- * jsOutputEval is used to evaluate compiled JS output by PSCi
+-- * printedOutputEval is used to evaluate text printed directly by PSCi itself
+runAndEval :: String -> TestPSCi () -> (String -> TestPSCi ()) -> TestPSCi ()
+runAndEval comm jsOutputEval textOutputEval =
case parseCommand comm of
Left errStr -> liftIO $ putStrLn errStr >> exitFailure
Right command ->
- -- the JS result can be ignored, as it's already written in a source file
- -- for the detail, please refer to Interactive.hs
- handleCommand (\_ -> eval) (return ()) (\_ -> return ()) command
+ -- The JS result is ignored, as it's already written in a JS source file.
+ -- For the detail, please refer to Interactive.hs
+ handleCommand (\_ -> jsOutputEval) (return ()) textOutputEval command
--- | Run a PSCi command and ignore the output
+-- | Run a PSCi command, evaluate compiled JS, and ignore evaluation output and printed output
run :: String -> TestPSCi ()
-run comm = runAndEval comm $ jsEval *> return ()
+run comm = runAndEval comm evalJsAndIgnore ignorePrinted
+ where
+ evalJsAndIgnore = jsEval *> return ()
+ ignorePrinted _ = return ()
-- | A lifted evaluation of Hspec 'shouldBe' for the TestPSCi
equalsTo :: (Eq a, Show a) => a -> a -> TestPSCi ()
equalsTo x y = liftIO $ x `shouldBe` y
--- | An assertion to check if a command evaluates to a string
+-- | An assertion to check command evaluated javascript output against a given string
evaluatesTo :: String -> String -> TestPSCi ()
-evaluatesTo command expected = runAndEval command $ do
- actual <- jsEval
- actual `equalsTo` (expected ++ "\n")
+evaluatesTo command expected = runAndEval command evalJsAndCompare ignorePrinted
+ where
+ evalJsAndCompare = do
+ actual <- jsEval
+ actual `equalsTo` (expected ++ "\n")
+ ignorePrinted _ = return ()
+
+-- | An assertion to check command PSCi printed output against a given string
+prints :: String -> String -> TestPSCi ()
+prints command expected = runAndEval command evalJsAndIgnore evalPrinted
+ where
+ evalJsAndIgnore = jsEval *> return ()
+ evalPrinted s = s `equalsTo` expected
diff --git a/tests/support/bower.json b/tests/support/bower.json
index 932650f..0973f7a 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -1,22 +1,42 @@
{
"name": "purescript-test-suite-support",
"dependencies": {
- "purescript-arrays": "4.0.0",
+ "purescript-arrays": "4.1.2",
"purescript-assert": "3.0.0",
+ "purescript-bifunctors": "3.0.0",
"purescript-console": "3.0.0",
+ "purescript-control": "3.3.0",
+ "purescript-distributive": "3.0.0",
"purescript-eff": "3.1.0",
+ "purescript-either": "3.1.0",
+ "purescript-foldable-traversable": "3.4.0",
"purescript-functions": "3.0.0",
+ "purescript-gen": "1.1.0",
"purescript-generics": "4.0.0",
- "purescript-generics-rep": "5.0.0",
- "purescript-lists": "4.6.0",
+ "purescript-generics-rep": "5.1.0",
+ "purescript-globals": "3.0.0",
+ "purescript-identity": "3.1.0",
+ "purescript-integers": "3.1.0",
+ "purescript-invariant": "3.0.0",
+ "purescript-lazy": "3.0.0",
+ "purescript-lists": "4.9.0",
+ "purescript-math": "2.1.0",
+ "purescript-maybe": "3.0.0",
+ "purescript-monoid": "3.1.0",
"purescript-newtype": "2.0.0",
- "purescript-partial": "1.2.0",
- "purescript-prelude": "3.0.0",
+ "purescript-nonempty": "4.0.0",
+ "purescript-partial": "1.2.1",
+ "purescript-prelude": "3.1.0",
+ "purescript-proxy": "2.1.0",
"purescript-psci-support": "3.0.0",
"purescript-st": "3.0.0",
+ "purescript-strings": "3.3.0",
"purescript-symbols": "3.0.0",
"purescript-tailrec": "3.3.0",
- "purescript-typelevel-prelude": "2.0.0",
+ "purescript-tuples": "4.1.0",
+ "purescript-type-equality": "2.1.0",
+ "purescript-typelevel-prelude": "2.3.0",
+ "purescript-unfoldable": "3.0.0",
"purescript-unsafe-coerce": "3.0.0"
}
}
diff --git a/tests/support/pscide/src/CompletionSpecDocs.purs b/tests/support/pscide/src/CompletionSpecDocs.purs
new file mode 100644
index 0000000..1c92a37
--- /dev/null
+++ b/tests/support/pscide/src/CompletionSpecDocs.purs
@@ -0,0 +1,13 @@
+module CompletionSpecDocs where
+
+-- | Doc x
+something = "something"
+
+-- | Doc *123*
+withType :: Int
+withType = 42
+
+-- | This is
+-- | a multi-line
+-- | comment
+multiline = "multiline" \ No newline at end of file