summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-04-06 19:56:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-04-06 19:56:00 (GMT)
commiteedee6382a33ad7ca6c1fe36c7c02798f20e2086 (patch)
tree2075e8f57d7fc299005f5b28ec550679f934608e
parent6bc83edfdc50ee74921ae3e0e751a764c8a618fa (diff)
version 0.8.4.00.8.4.0
-rw-r--r--CONTRIBUTORS.md2
-rw-r--r--examples/docs/src/ConstrainedArgument.purs9
-rw-r--r--examples/failing/Generalization1.purs11
-rw-r--r--examples/failing/Generalization2.purs8
-rw-r--r--examples/passing/1991.purs20
-rw-r--r--examples/passing/Generalization1.purs10
-rw-r--r--psc-bundle/Main.hs21
-rw-r--r--psc-docs/Main.hs20
-rw-r--r--psc-ide-server/Main.hs17
-rw-r--r--psc-publish/Main.hs7
-rw-r--r--psc/Main.hs21
-rw-r--r--purescript.cabal26
-rw-r--r--src/Language/PureScript/AST/Traversals.hs2
-rw-r--r--src/Language/PureScript/Bundle.hs440
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs1
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Render.hs36
-rw-r--r--src/Language/PureScript/Errors.hs37
-rw-r--r--src/Language/PureScript/Ide.hs84
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs85
-rw-r--r--src/Language/PureScript/Ide/CodecJSON.hs13
-rw-r--r--src/Language/PureScript/Ide/Command.hs92
-rw-r--r--src/Language/PureScript/Ide/Completion.hs17
-rw-r--r--src/Language/PureScript/Ide/Error.hs21
-rw-r--r--src/Language/PureScript/Ide/Externs.hs104
-rw-r--r--src/Language/PureScript/Ide/Filter.hs39
-rw-r--r--src/Language/PureScript/Ide/Imports.hs355
-rw-r--r--src/Language/PureScript/Ide/Matcher.hs71
-rw-r--r--src/Language/PureScript/Ide/Pursuit.hs14
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs16
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs17
-rw-r--r--src/Language/PureScript/Ide/State.hs27
-rw-r--r--src/Language/PureScript/Ide/Types.hs94
-rw-r--r--src/Language/PureScript/Ide/Util.hs65
-rw-r--r--src/Language/PureScript/Ide/Watcher.hs15
-rw-r--r--src/Language/PureScript/Make.hs61
-rw-r--r--src/Language/PureScript/Parser/JS.hs2
-rw-r--r--src/Language/PureScript/TypeChecker.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs36
-rw-r--r--stack-lts-5.yaml1
-rw-r--r--stack-nightly.yaml3
-rw-r--r--stack.yaml1
-rw-r--r--tests/Language/PureScript/Ide/FilterSpec.hs63
-rw-r--r--tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs101
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs125
-rw-r--r--tests/Language/PureScript/Ide/Integration.hs238
-rw-r--r--tests/Language/PureScript/Ide/MatcherSpec.hs56
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs78
-rw-r--r--tests/Language/PureScript/IdeSpec.hs35
-rw-r--r--tests/TestDocs.hs30
-rw-r--r--tests/support/pscide/src/ImportsSpec.purs5
-rw-r--r--tests/support/pscide/src/ImportsSpec1.purs32
-rw-r--r--tests/support/pscide/src/Main.purs7
52 files changed, 2165 insertions, 530 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 700c3c8..0120af5 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -68,6 +68,8 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, 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).
- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, 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).
+- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
### Companies
diff --git a/examples/docs/src/ConstrainedArgument.purs b/examples/docs/src/ConstrainedArgument.purs
new file mode 100644
index 0000000..65156a5
--- /dev/null
+++ b/examples/docs/src/ConstrainedArgument.purs
@@ -0,0 +1,9 @@
+module ConstrainedArgument where
+
+class Foo t
+
+type WithoutArgs = forall a. (Partial => a) -> a
+type WithArgs = forall a. (Foo a => a) -> a
+type MultiWithoutArgs = forall a. ((Partial, Partial) => a) -> a
+type MultiWithArgs = forall a b. ((Foo a, Foo b) => a) -> a
+
diff --git a/examples/failing/Generalization1.purs b/examples/failing/Generalization1.purs
new file mode 100644
index 0000000..a4a7b9b
--- /dev/null
+++ b/examples/failing/Generalization1.purs
@@ -0,0 +1,11 @@
+-- @shouldFailWith CannotGeneralizeRecursiveFunction
+module Main where
+
+import Prelude
+
+foo 0 x _ = x
+foo n x y = x <> bar (n - 1) x y
+
+bar 0 x _ = x
+bar n x y = y <> foo (n - 1) x y
+
diff --git a/examples/failing/Generalization2.purs b/examples/failing/Generalization2.purs
new file mode 100644
index 0000000..9fa8e1c
--- /dev/null
+++ b/examples/failing/Generalization2.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith CannotGeneralizeRecursiveFunction
+module Main where
+
+import Prelude
+
+test n m | n <= 1 = m
+ | otherwise = test (n - 1) (m <> m)
+
diff --git a/examples/passing/1991.purs b/examples/passing/1991.purs
new file mode 100644
index 0000000..96738fa
--- /dev/null
+++ b/examples/passing/1991.purs
@@ -0,0 +1,20 @@
+module Main where
+
+import Prelude
+
+singleton :: forall a. a -> Array a
+singleton x = [x]
+
+empty :: forall a. Array a
+empty = []
+
+foldMap :: forall a m. (Semigroup m) => (a -> m) -> Array a -> m
+foldMap f [a, b, c, d, e] = f a <> f b <> f c <> f d <> f e
+
+regression :: Array Int
+regression =
+ let as = [1,2,3,4,5]
+ as' = foldMap (\x -> if 1 < x && x < 4 then singleton x else empty) as
+ in as'
+
+main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/Generalization1.purs b/examples/passing/Generalization1.purs
new file mode 100644
index 0000000..a956ab6
--- /dev/null
+++ b/examples/passing/Generalization1.purs
@@ -0,0 +1,10 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (print)
+
+main = do
+ print (sum 1.0 2.0)
+ print (sum 1 2)
+
+sum x y = x + y
diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs
index f97e36f..a5eee56 100644
--- a/psc-bundle/Main.hs
+++ b/psc-bundle/Main.hs
@@ -1,25 +1,12 @@
------------------------------------------------------------------------------
---
--- Module : psc-bundle
--- Copyright : (c) Phil Freeman 2015
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- | Bundles compiled PureScript modules for the browser.
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
+-- | Bundles compiled PureScript modules for the browser.
module Main (main) where
-import Data.Maybe
+import Data.Maybe
import Data.Traversable (for)
import Data.Version (showVersion)
@@ -32,7 +19,7 @@ import Control.Monad.IO.Class
import System.FilePath (takeFileName, takeDirectory)
import System.FilePath.Glob (glob)
import System.Exit (exitFailure)
-import System.IO (stderr, hPutStrLn)
+import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8)
import System.Directory (createDirectoryIfMissing)
import Language.PureScript.Bundle
@@ -125,6 +112,8 @@ options = Options <$> some inputFile
-- | Make it go.
main :: IO ()
main = do
+ hSetEncoding stdout utf8
+ hSetEncoding stderr utf8
opts <- execParser (info (version <*> helper <*> options) infoModList)
when (isJust (optionsRequirePath opts)) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9."
output <- runExceptT (app opts)
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index 70650c8..9d4ff6d 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -1,17 +1,4 @@
{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
---
--- Module : Main
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
module Main where
@@ -32,7 +19,7 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import System.Exit (exitFailure)
-import System.IO (hPutStrLn, hPrint, stderr)
+import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.FilePath.Glob (glob)
@@ -228,7 +215,10 @@ buildOptions (fmt, input, mapping) =
exitFailure
main :: IO ()
-main = execParser opts >>= buildOptions >>= docgen
+main = do
+ hSetEncoding stdout utf8
+ hSetEncoding stderr utf8
+ execParser opts >>= buildOptions >>= docgen
where
opts = info (version <*> helper <*> pscDocsOptions) infoModList
infoModList = fullDesc <> headerInfo <> footerInfo
diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs
index 77f2243..896b135 100644
--- a/psc-ide-server/Main.hs
+++ b/psc-ide-server/Main.hs
@@ -1,9 +1,24 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Main
+-- Description : The server accepting commands for psc-ide
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- The server accepting commands for psc-ide
+-----------------------------------------------------------------------------
+
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TemplateHaskell #-}
+
module Main where
import Prelude ()
@@ -21,7 +36,7 @@ import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Version (showVersion)
import Language.PureScript.Ide
-import Language.PureScript.Ide.CodecJSON
+import Language.PureScript.Ide.Util
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Watcher
diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs
index d7d397c..7242235 100644
--- a/psc-publish/Main.hs
+++ b/psc-publish/Main.hs
@@ -7,6 +7,8 @@ import qualified Data.ByteString.Lazy.Char8 as BL
import Options.Applicative hiding (str)
+import System.IO (hSetEncoding, stderr, stdout, utf8)
+
import qualified Paths_purescript as Paths
import Language.PureScript.Publish
import Language.PureScript.Publish.ErrorsWarnings
@@ -24,7 +26,10 @@ dryRunOptions = defaultPublishOptions
where dummyVersion = ("0.0.0", Version [0,0,0] [])
main :: IO ()
-main = execParser opts >>= publish
+main = do
+ hSetEncoding stdout utf8
+ hSetEncoding stderr utf8
+ execParser opts >>= publish
where
opts = info (version <*> helper <*> dryRun) infoModList
infoModList = fullDesc <> headerInfo <> footerInfo
diff --git a/psc/Main.hs b/psc/Main.hs
index fc90127..72e364b 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -1,17 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Main
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
@@ -34,7 +20,7 @@ import qualified Data.ByteString.UTF8 as BU8
import Options.Applicative as Opts
import System.Exit (exitSuccess, exitFailure)
-import System.IO (hPutStrLn, stderr)
+import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)
import System.IO.UTF8
import System.FilePath.Glob (glob)
@@ -202,7 +188,10 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile
<*> jsonErrors
main :: IO ()
-main = execParser opts >>= compile
+main = do
+ hSetEncoding stdout utf8
+ hSetEncoding stderr utf8
+ execParser opts >>= compile
where
opts = info (version <*> helper <*> pscMakeOptions) infoModList
infoModList = fullDesc <> headerInfo <> footerInfo
diff --git a/purescript.cabal b/purescript.cabal
index 9c0040d..7244621 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.8.3.0
+version: 0.8.4.0
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -36,6 +36,7 @@ extra-source-files: examples/passing/*.purs
, tests/support/flattened/*.purs
, tests/support/flattened/*.js
, tests/support/psci/*.purs
+ , tests/support/pscide/src/*.purs
, stack.yaml
, stack-lts-5.yaml
, stack-nightly.yaml
@@ -74,7 +75,7 @@ library
bytestring -any,
text -any,
split -any,
- language-javascript == 0.5.*,
+ language-javascript == 0.6.*,
syb -any,
Glob >= 0.7 && < 0.8,
process >= 1.2.0 && < 1.5,
@@ -201,7 +202,6 @@ library
Language.PureScript.Ide.Command
Language.PureScript.Ide.Externs
Language.PureScript.Ide.Error
- Language.PureScript.Ide.CodecJSON
Language.PureScript.Ide.Pursuit
Language.PureScript.Ide.Completion
Language.PureScript.Ide.Matcher
@@ -212,6 +212,8 @@ library
Language.PureScript.Ide.SourceFile
Language.PureScript.Ide.Watcher
Language.PureScript.Ide.Reexports
+ Language.PureScript.Ide.Imports
+ Language.PureScript.Ide.Util
Control.Monad.Logger
Control.Monad.Supply
@@ -313,7 +315,7 @@ executable psc-bundle
executable psc-ide-server
main-is: Main.hs
- other-modules:
+ other-modules: Paths_purescript
other-extensions:
build-depends: base >=4 && <5
, purescript -any
@@ -333,7 +335,7 @@ executable psc-ide-server
executable psc-ide-client
main-is: Main.hs
- other-modules:
+ other-modules: Paths_purescript
other-extensions:
build-depends: base >=4 && <5
, mtl -any
@@ -350,7 +352,8 @@ test-suite tests
transformers -any, process -any, transformers-compat -any, time -any,
Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,
base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any,
- boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any
+ boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any,
+ vector -any, utf8-string -any
ghc-options: -Wall
type: exitcode-stdio-1.0
main-is: Main.hs
@@ -361,5 +364,16 @@ test-suite tests
TestPsci
TestPscIde
PscIdeSpec
+ Language.PureScript.Ide.FilterSpec
+ Language.PureScript.Ide.ImportsSpec
+ Language.PureScript.Ide.Imports.IntegrationSpec
+ Language.PureScript.Ide.Integration
+ Language.PureScript.Ide.MatcherSpec
+ Language.PureScript.Ide.ReexportsSpec
+ Language.PureScript.IdeSpec
+ PSCi.Completion
+ PSCi.Directive
+ PSCi.Module
+ PSCi.Types
buildable: True
hs-source-dirs: tests psci
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 4ea8c5b..4a75f9a 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -508,7 +508,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
g' :: S.Set Ident -> Expr -> r
g' s (Literal l) = lit g'' s l
g' s (UnaryMinus v1) = g'' s v1
- g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2
+ g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
g' s (Parens v1) = g'' s v1
g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 38caa2d..13f6605 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -27,6 +27,7 @@ module Language.PureScript.Bundle (
, ModuleType(..)
, ErrorMessage(..)
, printErrorMessage
+ , getExportedIdentifiers
) where
import Prelude ()
@@ -43,6 +44,7 @@ import qualified Data.Set as S
import Control.Monad
import Control.Monad.Error.Class
import Language.JavaScript.Parser
+import Language.JavaScript.Parser.AST
import qualified Paths_purescript as Paths
@@ -83,7 +85,7 @@ type Key = (ModuleIdentifier, String)
data ExportType
= RegularExport String
| ForeignReexport
- deriving (Show, Read, Eq, Ord)
+ deriving (Show, Eq, Ord)
-- | There are four types of module element we are interested in:
--
@@ -95,14 +97,14 @@ data ExportType
-- Each is labelled with the original AST node which generated it, so that we can dump it back
-- into the output during codegen.
data ModuleElement
- = Require JSNode String (Either String ModuleIdentifier)
- | Member JSNode Bool String [JSNode] [Key]
- | ExportsList [(ExportType, String, JSNode, [Key])]
- | Other JSNode
- deriving (Show, Read)
+ = Require JSStatement String (Either String ModuleIdentifier)
+ | Member JSStatement Bool String JSExpression [Key]
+ | ExportsList [(ExportType, String, JSExpression, [Key])]
+ | Other JSStatement
+ deriving (Show)
-- | A module is just a list of elements of the types listed above.
-data Module = Module ModuleIdentifier [ModuleElement] deriving (Show, Read)
+data Module = Module ModuleIdentifier [ModuleElement] deriving (Show)
-- | Prepare an error message for consumption by humans.
printErrorMessage :: ErrorMessage -> [String]
@@ -131,11 +133,6 @@ printErrorMessage (ErrorInModule mid e) =
displayIdentifier (ModuleIdentifier name ty) =
name ++ " (" ++ showModuleType ty ++ ")"
--- | Unpack the node inside a JSNode. This is useful when pattern matching.
-node :: JSNode -> Node
-node (NN n) = n
-node (NT n _ _) = n
-
-- | Calculate the ModuleIdentifier which a require(...) statement imports.
checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
checkImportPath _ "./foreign" m _ =
@@ -179,116 +176,184 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
-- | Calculate dependencies and add them to the current element.
expandDeps :: ModuleElement -> ModuleElement
- expandDeps (Member n f nm decl _) = Member n f nm decl (nub (concatMap (dependencies modulePath) decl))
+ expandDeps (Member n f nm decl _) = Member n f nm decl (nub $ dependencies modulePath decl)
expandDeps (ExportsList exps) = ExportsList (map expand exps)
where
expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
expandDeps other = other
- dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)]
+ dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)]
dependencies m = everything (++) (mkQ [] toReference)
where
- toReference :: Node -> [(ModuleIdentifier, String)]
- toReference (JSMemberDot [ mn ] _ nm)
- | JSIdentifier mn' <- node mn
- , JSIdentifier nm' <- node nm
+ toReference :: JSExpression -> [(ModuleIdentifier, String)]
+ toReference (JSMemberDot mn _ nm)
+ | JSIdentifier _ mn' <- mn
+ , JSIdentifier _ nm' <- nm
, Just mid <- lookup mn' imports
= [(mid, nm')]
- toReference (JSMemberSquare [ mn ] _ nm _)
- | JSIdentifier mn' <- node mn
- , JSExpression [ s ] <- node nm
- , JSStringLiteral _ nm' <- node s
+ toReference (JSMemberSquare mn _ nm _)
+ | JSIdentifier _ mn' <- mn
+ , Just nm' <- fromStringLiteral nm
, Just mid <- lookup mn' imports
= [(mid, nm')]
- toReference (JSIdentifier nm)
+ toReference (JSIdentifier _ nm)
| nm `elem` boundNames
= [(m, nm)]
toReference _ = []
+-- String literals include the quote chars
+fromStringLiteral :: JSExpression -> Maybe String
+fromStringLiteral (JSStringLiteral _ str) = Just $ trimStringQuotes str
+fromStringLiteral _ = Nothing
+
+trimStringQuotes :: String -> String
+trimStringQuotes str = reverse $ drop 1 $ reverse $ drop 1 $ str
+
+commaList :: JSCommaList a -> [a]
+commaList JSLNil = []
+commaList (JSLOne x) = [x]
+commaList (JSLCons l _ x) = commaList l ++ [x]
+
+trailingCommaList :: JSCommaTrailingList a -> [a]
+trailingCommaList (JSCTLComma l _) = commaList l
+trailingCommaList (JSCTLNone l) = commaList l
+
-- | Attempt to create a Module from a Javascript AST.
--
-- Each type of module element is matched using pattern guards, and everything else is bundled into the
-- Other constructor.
-toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module
+toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSAST -> m Module
toModule requirePath mids mid top
- | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns
+ | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts
| otherwise = err InvalidTopLevel
where
err = throwError . ErrorInModule mid
- toModuleElement :: JSNode -> m ModuleElement
- toModuleElement n
- | JSVariables var [ varIntro ] _ <- node n
- , JSLiteral "var" <- node var
- , JSVarDecl impN [ eq, req, impP ] <- node varIntro
- , JSIdentifier importName <- node impN
- , JSLiteral "=" <- node eq
- , JSIdentifier "require" <- node req
- , JSArguments _ [ impS ] _ <- node impP
- , JSStringLiteral _ importPath <- node impS
- , importPath' <- checkImportPath requirePath importPath mid mids
- = pure (Require n importName importPath')
- toModuleElement n
- | JSVariables var [ varIntro ] _ <- node n
- , JSLiteral "var" <- node var
- , JSVarDecl declN (eq : decl) <- node varIntro
- , JSIdentifier name <- node declN
- , JSLiteral "=" <- node eq
- = pure (Member n False name decl [])
- toModuleElement n
- | JSExpression (e : op : decl) <- node n
- , Just name <- accessor (node e)
- , JSOperator eq <- node op
- , JSLiteral "=" <- node eq
- = pure (Member n True name decl [])
- where
- accessor :: Node -> Maybe String
- accessor (JSMemberDot [ exports ] _ nm)
- | JSIdentifier "exports" <- node exports
- , JSIdentifier name <- node nm
- = Just name
- accessor (JSMemberSquare [ exports ] _ nm _)
- | JSIdentifier "exports" <- node exports
- , JSExpression [e] <- node nm
- , JSStringLiteral _ name <- node e
- = Just name
- accessor _ = Nothing
- toModuleElement n
- | JSExpression (mnExp : op : obj: _) <- node n
- , JSMemberDot [ mn ] _ e <- node mnExp
- , JSIdentifier "module" <- node mn
- , JSIdentifier "exports" <- node e
- , JSOperator eq <- node op
- , JSLiteral "=" <- node eq
- , JSObjectLiteral _ props _ <- node obj
- = ExportsList <$> traverse toExport (filter (not . isSeparator) (map node props))
+ toModuleElement :: JSStatement -> m ModuleElement
+ toModuleElement stmt
+ | Just (importName, importPath) <- matchRequire requirePath mids mid stmt
+ = pure (Require stmt importName importPath)
+ toModuleElement stmt
+ | Just (exported, name, decl) <- matchMember stmt
+ = pure (Member stmt exported name decl [])
+ toModuleElement stmt
+ | Just props <- matchExportsAssignment stmt
+ = (ExportsList <$> traverse toExport (trailingCommaList props))
where
- toExport :: Node -> m (ExportType, String, JSNode, [Key])
- toExport (JSPropertyNameandValue name _ [val] ) =
- (,,val,[]) <$> exportType (node val)
- <*> extractLabel (node name)
- toExport _ = err UnsupportedExport
-
- exportType :: Node -> m ExportType
- exportType (JSMemberDot [f] _ _)
- | JSIdentifier "$foreign" <- node f
- = pure ForeignReexport
- exportType (JSMemberSquare [f] _ _ _)
- | JSIdentifier "$foreign" <- node f
- = pure ForeignReexport
- exportType (JSIdentifier s) = pure (RegularExport s)
- exportType _ = err UnsupportedExport
-
- extractLabel :: Node -> m String
- extractLabel (JSStringLiteral _ nm) = pure nm
- extractLabel (JSIdentifier nm) = pure nm
- extractLabel _ = err UnsupportedExport
-
- isSeparator :: Node -> Bool
- isSeparator (JSLiteral ",") = True
- isSeparator _ = False
+ toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])
+ toExport (JSPropertyNameandValue name _ [val]) =
+ (,,val,[]) <$> exportType val
+ <*> extractLabel' name
+ toExport _ = err UnsupportedExport
+
+ exportType :: JSExpression -> m ExportType
+ exportType (JSMemberDot f _ _)
+ | JSIdentifier _ "$foreign" <- f
+ = pure ForeignReexport
+ exportType (JSMemberSquare f _ _ _)
+ | JSIdentifier _ "$foreign" <- f
+ = pure ForeignReexport
+ exportType (JSIdentifier _ s) = pure (RegularExport s)
+ exportType _ = err UnsupportedExport
+
+ extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
+
toModuleElement other = pure (Other other)
+-- Get a list of all the exported identifiers from a foreign module.
+--
+-- TODO: what if we assign to exports.foo and then later assign to
+-- module.exports (presumably overwriting exports.foo)?
+getExportedIdentifiers :: (MonadError ErrorMessage m)
+ => String
+ -> JSAST
+ -> m [String]
+getExportedIdentifiers mname top
+ | JSAstProgram stmts _ <- top = concat <$> traverse go stmts
+ | otherwise = err InvalidTopLevel
+ where
+ err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
+
+ go stmt
+ | Just props <- matchExportsAssignment stmt
+ = traverse toIdent (trailingCommaList props)
+ | Just (True, name, _) <- matchMember stmt
+ = pure [name]
+ | otherwise
+ = pure []
+
+ toIdent (JSPropertyNameandValue name _ [_]) =
+ extractLabel' name
+ toIdent _ =
+ err UnsupportedExport
+
+ extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
+
+-- Matches JS statements like this:
+-- var ModuleName = require("file");
+matchRequire :: Maybe FilePath
+ -> S.Set String
+ -> ModuleIdentifier
+ -> JSStatement
+ -> Maybe (String, Either String ModuleIdentifier)
+matchRequire requirePath mids mid stmt
+ | JSVariable _ jsInit _ <- stmt
+ , [JSVarInitExpression var varInit] <- commaList jsInit
+ , JSIdentifier _ importName <- var
+ , JSVarInit _ jsInitEx <- varInit
+ , JSMemberExpression req _ argsE _ <- jsInitEx
+ , JSIdentifier _ "require" <- req
+ , [ Just importPath ] <- map fromStringLiteral (commaList argsE)
+ , importPath' <- checkImportPath requirePath importPath mid mids
+ = Just (importName, importPath')
+ | otherwise
+ = Nothing
+
+-- Matches JS member declarations.
+matchMember :: JSStatement -> Maybe (Bool, String, JSExpression)
+matchMember stmt
+ -- var foo = expr;
+ | JSVariable _ jsInit _ <- stmt
+ , [JSVarInitExpression var varInit] <- commaList jsInit
+ , JSIdentifier _ name <- var
+ , JSVarInit _ decl <- varInit
+ = Just (False, name, decl)
+ -- exports.foo = expr; exports["foo"] = expr;
+ | JSAssignStatement e (JSAssign _) decl _ <- stmt
+ , Just name <- accessor e
+ = Just (True, name, decl)
+ | otherwise
+ = Nothing
+ where
+ accessor :: JSExpression -> Maybe String
+ accessor (JSMemberDot exports _ nm)
+ | JSIdentifier _ "exports" <- exports
+ , JSIdentifier _ name <- nm
+ = Just name
+ accessor (JSMemberSquare exports _ nm _)
+ | JSIdentifier _ "exports" <- exports
+ , Just name <- fromStringLiteral nm
+ = Just name
+ accessor _ = Nothing
+
+-- Matches assignments to module.exports, like this:
+-- module.exports = { ... }
+matchExportsAssignment :: JSStatement -> Maybe JSObjectPropertyList
+matchExportsAssignment stmt
+ | JSAssignStatement e (JSAssign _) decl _ <- stmt
+ , JSMemberDot module' _ exports <- e
+ , JSIdentifier _ "module" <- module'
+ , JSIdentifier _ "exports" <- exports
+ , JSObjectLiteral _ props _ <- decl
+ = Just props
+ | otherwise
+ = Nothing
+
+extractLabel :: JSPropertyName -> Maybe String
+extractLabel (JSPropertyString _ nm) = Just (trimStringQuotes nm)
+extractLabel (JSPropertyIdent _ nm) = Just nm
+extractLabel _ = Nothing
+
-- | Eliminate unused code based on the specified entry point set.
compile :: [Module] -> [ModuleIdentifier] -> [Module]
compile modules [] = modules
@@ -339,10 +404,6 @@ compile modules entryPoints = filteredModules
where
go :: [ModuleElement] -> [ModuleElement]
go [] = []
- go (d : Other semi : rest)
- | JSLiteral ";" <- node semi
- , not (isDeclUsed d)
- = go rest
go (d : rest)
| not (isDeclUsed d) = go rest
| otherwise = d : go rest
@@ -405,130 +466,121 @@ codeGen :: Maybe String -- ^ main module
-> String -- ^ namespace
-> [Module] -- ^ input modules
-> String
-codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElementsTop (prelude ++ concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule)))
+codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (prelude : concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule) JSNoAnnot)
where
- moduleToJS :: Module -> [JSNode]
+ moduleToJS :: Module -> [JSStatement]
moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
where
- declToJS :: ModuleElement -> [JSNode]
+ declToJS :: ModuleElement -> [JSStatement]
declToJS (Member n _ _ _ _) = [n]
declToJS (Other n) = [n]
declToJS (Require _ nm req) =
- [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])
- [ NN (JSVarDecl (sp (JSIdentifier nm))
- (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req))
- ]
- (nt (JSLiteral ";"))) ]
+ [
+ JSVariable lfsp
+ (cList [
+ JSVarInitExpression (JSIdentifier sp nm)
+ (JSVarInit sp $ either require (moduleReference sp . moduleName) req )
+ ]) (JSSemi JSNoAnnot)
+ ]
declToJS (ExportsList exps) = map toExport exps
where
- toExport :: (ExportType, String, JSNode, [Key]) -> JSNode
+ toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement
toExport (_, nm, val, _) =
- NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]
- (nt (JSLiteral "["))
- (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))
- (nt (JSLiteral "]")))
- , NN (JSOperator (sp (JSLiteral "=")))
- , reindent val
- , nt (JSLiteral ";")
- ])
-
- reindent :: JSNode -> JSNode
- reindent (NT n _ _) = sp n
- reindent nn = nn
-
- indent :: [JSNode] -> [JSNode]
+ JSAssignStatement
+ (JSMemberSquare (JSIdentifier lfsp "exports") JSNoAnnot
+ (str nm) JSNoAnnot)
+ (JSAssign sp)
+ val
+ (JSSemi JSNoAnnot)
+
+ -- comma lists are reverse-consed
+ cList :: [a] -> JSCommaList a
+ cList [] = JSLNil
+ cList [x] = JSLOne x
+ cList l = go $ reverse l
+ where
+ go [x] = JSLOne x
+ go (h:t)= JSLCons (go t) JSNoAnnot h
+ go [] = error "Invalid case in comma-list"
+
+ indent :: [JSStatement] -> [JSStatement]
indent = everywhere (mkT squash)
where
- squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)
- squash nn = nn
+ squash JSNoAnnot = (JSAnnot (TokenPn 0 0 2) [])
+ squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)
splat (CommentA pos s) = CommentA (keepCol pos) s
splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
splat ann = ann
- keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)
-
- prelude :: [JSNode]
- prelude =
- [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)
- , WhiteSpace tokenPosnEmpty "\n"
- ])
- [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))
- [ sp (JSLiteral "=")
- , NN (JSObjectLiteral (sp (JSLiteral "{"))
- []
- (sp (JSLiteral "}")))
- ])
- ]
- (nt (JSLiteral ";")))
- , lf
- ]
+ 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
+ , WhiteSpace tokenPosnEmpty "\n" ])
+ (cList [
+ JSVarInitExpression (JSIdentifier sp optionsNamespace)
+ (JSVarInit sp (emptyObj sp))
+ ]) (JSSemi JSNoAnnot)
- require :: String -> [JSNode]
- require mn = [ sp (JSIdentifier "require")
- , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")")))
- ]
+ require :: String -> JSExpression
+ require mn =
+ JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot (cList [ str mn ]) JSNoAnnot
- moduleReference :: (Node -> JSNode) -> String -> JSNode
- moduleReference f mn =
- NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]
- (nt (JSLiteral "["))
- (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
- (nt (JSLiteral "]")))
+ moduleReference :: JSAnnot -> String -> JSExpression
+ moduleReference a mn =
+ JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot
+ (str mn) JSNoAnnot
- wrap :: String -> [JSNode] -> [JSNode]
+ str :: String -> JSExpression
+ str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\""
+
+
+ emptyObj :: JSAnnot -> JSExpression
+ emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot
+
+ wrap :: String -> [JSStatement] -> [JSStatement]
wrap mn ds =
- [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))
- (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))
- []
- (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))
- (NN (JSBlock [sp (JSLiteral "{")]
- (lf : ds)
- [nl (JSLiteral "}")])))]))
- (nt (JSLiteral ")")))
- , NN (JSArguments (nt (JSLiteral "("))
- [ NN (JSExpression [ moduleReference nt mn
- , NN (JSOperator (sp (JSLiteral "=")))
- , NN (JSExpressionBinary "||"
- [ moduleReference sp mn ]
- (sp (JSLiteral "||"))
- [ emptyObj ])
- ])
- ]
- (nt (JSLiteral ")")))
- ])
- , nt (JSLiteral ";")
- , lf
+ [
+ JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot
+ (JSLOne (JSIdentName JSNoAnnot "exports")) JSNoAnnot
+ (JSBlock sp (lfHead ds) lf)) -- \n not quite in right place
+ JSNoAnnot)
+ JSNoAnnot
+ (JSLOne (JSAssignExpression (moduleReference JSNoAnnot mn) (JSAssign sp)
+ (JSExpressionBinary (moduleReference sp mn) (JSBinOpOr sp) (emptyObj sp))))
+ JSNoAnnot
+ (JSSemi JSNoAnnot)
]
where
- emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))
+ lfHead (h:t) = (addAnn (WhiteSpace tokenPosnEmpty "\n ") h) : t
+ lfHead x = x
- runMain :: String -> [JSNode]
+ addAnn :: CommentAnnotation -> JSStatement -> JSStatement
+ addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) =
+ (JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot))
+ addAnn _ x = x
+
+ appendAnn a JSNoAnnot = (JSAnnot tokenPosnEmpty [a])
+ appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])
+
+ runMain :: String -> [JSStatement]
runMain mn =
- [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]
- (nt (JSLiteral "["))
- (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
- (nt (JSLiteral "]")))
- ]
- (nt (JSLiteral "."))
- (nt (JSIdentifier "main")))
- , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")")))
- ])
- , nt (JSLiteral ";")
- ]
+ [JSMethodCall
+ (JSMemberDot (moduleReference lf mn) JSNoAnnot
+ (JSIdentifier JSNoAnnot "main"))
+ JSNoAnnot (cList []) JSNoAnnot (JSSemi JSNoAnnot)]
- nt :: Node -> JSNode
- nt n = NT n tokenPosnEmpty []
+ lf :: JSAnnot
+ lf = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
- lf :: JSNode
- lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
- sp :: Node -> JSNode
- sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
+ lfsp :: JSAnnot
+ lfsp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ]
- nl :: Node -> JSNode
- nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
+ sp :: JSAnnot
+ sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
-- | The bundling function.
-- This function performs dead code elimination, filters empty modules
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index b2de1d6..9843931 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -6,6 +6,7 @@ module Language.PureScript.Docs.AsMarkdown
, Docs
, runDocs
, modulesAsMarkdown
+ , codeToString
) where
import Prelude ()
diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs
index 5b04b13..6f9bbd0 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Render.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs
@@ -44,18 +44,6 @@ typeLiterals = mkPattern match
]
match (TypeConstructor (Qualified mn name)) =
Just (ctor (runProperName name) (maybeToContainingModule mn))
- match (ConstrainedType deps ty) =
- Just $ mintersperse sp
- [ syntax "(" <> constraints <> syntax ")"
- , syntax "=>"
- , renderType ty
- ]
- where
- constraints = mintersperse (syntax "," <> sp) (map renderDep deps)
- renderDep :: Constraint -> RenderedCode
- renderDep (pn, tys) =
- let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys
- in renderType instApp
match REmpty =
Just (syntax "()")
match row@RCons{} =
@@ -63,6 +51,23 @@ typeLiterals = mkPattern match
match _ =
Nothing
+renderConstraint :: Constraint -> RenderedCode
+renderConstraint (pn, tys) =
+ let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys
+ in renderType instApp
+
+renderConstraints :: [Constraint] -> RenderedCode -> RenderedCode
+renderConstraints deps ty =
+ mintersperse sp
+ [ if length deps == 1
+ then constraints
+ else syntax "(" <> constraints <> syntax ")"
+ , syntax "=>"
+ , ty
+ ]
+ where
+ constraints = mintersperse (syntax "," <> sp) (map renderConstraint deps)
+
-- |
-- Render code representing a Row
--
@@ -104,6 +109,12 @@ kinded = mkPattern match
match (KindedType t k) = Just (k, t)
match _ = Nothing
+constrained :: Pattern () Type ([Constraint], Type)
+constrained = mkPattern match
+ where
+ match (ConstrainedType deps ty) = Just (deps, ty)
+ match _ = Nothing
+
matchTypeAtom :: Pattern () Type RenderedCode
matchTypeAtom = typeLiterals <+> fmap parens matchType
where
@@ -116,6 +127,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom
operators =
OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]
, [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]
+ , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ]
, [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ]
, [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]
]
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index c6bdb14..3b97919 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -12,6 +12,7 @@ import Data.Char (isSpace)
import Data.Either (lefts, rights)
import Data.List (intercalate, transpose, nub, nubBy, sortBy)
import Data.Foldable (fold)
+import Data.Maybe (maybeToList)
import qualified Data.Map as M
@@ -28,6 +29,7 @@ import Language.PureScript.Pretty.Common (before)
import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Kinds
+import qualified Language.PureScript.Bundle as Bundle
import qualified Text.PrettyPrint.Boxes as Box
@@ -37,11 +39,13 @@ import Text.Parsec.Error (Message(..))
-- | A type of error messages
data SimpleErrorMessage
- = ErrorParsingFFIModule FilePath
+ = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
| ErrorParsingModule P.ParseError
| MissingFFIModule ModuleName
| MultipleFFIModules ModuleName [FilePath]
| UnnecessaryFFIModule ModuleName FilePath
+ | MissingFFIImplementations ModuleName [Ident]
+ | UnusedFFIImplementations ModuleName [Ident]
| CannotGetFileInfo FilePath
| CannotReadFile FilePath
| CannotWriteFile FilePath
@@ -149,6 +153,7 @@ data SimpleErrorMessage
| IncorrectAnonymousArgument
| InvalidOperatorInBinder Ident Ident
| DeprecatedRequirePath
+ | CannotGeneralizeRecursiveFunction Ident Type
deriving (Show)
-- | Error message hints, providing more detailed information about failure.
@@ -223,6 +228,8 @@ errorCode em = case unwrapErrorMessage em of
MissingFFIModule{} -> "MissingFFIModule"
MultipleFFIModules{} -> "MultipleFFIModules"
UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"
+ MissingFFIImplementations{} -> "MissingFFIImplementations"
+ UnusedFFIImplementations{} -> "UnusedFFIImplementations"
CannotGetFileInfo{} -> "CannotGetFileInfo"
CannotReadFile{} -> "CannotReadFile"
CannotWriteFile{} -> "CannotWriteFile"
@@ -330,6 +337,7 @@ errorCode em = case unwrapErrorMessage em of
IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"
InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
DeprecatedRequirePath{} -> "DeprecatedRequirePath"
+ CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"
-- |
-- A stack trace for an error
@@ -420,6 +428,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty
gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty
+ gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty
gSimple other = pure other
@@ -522,10 +531,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
paras [ line "Unable to write file: "
, indent . line $ path
]
- renderSimpleErrorMessage (ErrorParsingFFIModule path) =
- paras [ line "Unable to parse foreign module:"
- , indent . line $ path
- ]
+ renderSimpleErrorMessage (ErrorParsingFFIModule path extra) =
+ paras $ [ line "Unable to parse foreign module:"
+ , indent . line $ path
+ ] ++
+ (map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra)))
renderSimpleErrorMessage (ErrorParsingModule err) =
paras [ line "Unable to parse module: "
, prettyPrintParseError err
@@ -537,6 +547,14 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
, indent . line $ path
, line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary."
]
+ renderSimpleErrorMessage (MissingFFIImplementations mn idents) =
+ paras [ line $ "The following values are not defined in the foreign module for module " ++ runModuleName mn ++ ": "
+ , indent . paras $ map (line . runIdent) idents
+ ]
+ renderSimpleErrorMessage (UnusedFFIImplementations mn idents) =
+ paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: "
+ , indent . paras $ map (line . runIdent) idents
+ ]
renderSimpleErrorMessage (MultipleFFIModules mn paths) =
paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "
, indent . paras $ map line paths
@@ -981,6 +999,13 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
renderSimpleErrorMessage DeprecatedRequirePath =
line "The require-path option is deprecated and will be removed in PureScript 0.9."
+ renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =
+ paras [ line $ "Unable to generalize the type of the recursive function " ++ showIdent ident ++ "."
+ , line $ "The inferred type of " ++ showIdent ident ++ " was:"
+ , indent $ typeAsBox ty
+ , line "Try adding a type signature."
+ ]
+
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
renderHint (ErrorUnifyingTypes t1 t2) detail =
paras [ detail
@@ -1202,7 +1227,7 @@ prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning
-- | Pretty print errors as a Box
prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]
-prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error"
+prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error"
prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box]
prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index a77734e..21840a2 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -1,3 +1,17 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide
+-- Description : Interface for the psc-ide-server
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Interface for the psc-ide-server
+-----------------------------------------------------------------------------
+
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -6,7 +20,11 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
-module Language.PureScript.Ide where
+module Language.PureScript.Ide
+ ( handleCommand
+ -- for tests
+ , printModules
+ ) where
import Prelude ()
import Prelude.Compat
@@ -27,12 +45,14 @@ import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Externs
import Language.PureScript.Ide.Filter
+import Language.PureScript.Ide.Imports hiding (Import)
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Pursuit
import Language.PureScript.Ide.Reexports
import Language.PureScript.Ide.SourceFile
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Util
import System.Directory
import System.FilePath
import System.Exit
@@ -40,39 +60,48 @@ import System.Exit
handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
Command -> m Success
+handleCommand (Load [] []) = loadAllModules
handleCommand (Load modules deps) =
- loadModulesAndDeps modules deps
+ loadModulesAndDeps modules deps
handleCommand (Type search filters) =
- findType search filters
+ findType search filters
handleCommand (Complete filters matcher) =
- findCompletions filters matcher
+ findCompletions filters matcher
handleCommand (Pursuit query Package) =
- findPursuitPackages query
+ findPursuitPackages query
handleCommand (Pursuit query Identifier) =
- findPursuitCompletions query
+ findPursuitCompletions query
handleCommand (List LoadedModules) =
- printModules
+ printModules
handleCommand (List AvailableModules) =
- listAvailableModules
+ listAvailableModules
handleCommand (List (Imports fp)) =
- importsForFile fp
+ importsForFile fp
handleCommand (CaseSplit l b e wca t) =
- caseSplit l b e wca t
+ caseSplit l b e wca t
handleCommand (AddClause l wca) =
- pure $ addClause l wca
+ pure $ addClause l wca
+handleCommand (Import fp outfp _ (AddImplicitImport mn)) = do
+ rs <- addImplicitImport fp mn
+ answerRequest outfp rs
+handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do
+ rs <- addImportForIdentifier fp ident filters
+ case rs of
+ Right rs' -> answerRequest outfp rs'
+ Left question -> pure $ CompletionResult (mapMaybe completionFromMatch question)
handleCommand Cwd =
- TextResult . T.pack <$> liftIO getCurrentDirectory
+ TextResult . T.pack <$> liftIO getCurrentDirectory
handleCommand Quit = liftIO exitSuccess
findCompletions :: (PscIde m, MonadLogger m) =>
[Filter] -> Matcher -> m Success
findCompletions filters matcher =
- CompletionResult . getCompletions filters matcher <$> getAllModulesWithReexports
+ CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher <$> getAllModulesWithReexports
findType :: (PscIde m, MonadLogger m) =>
DeclIdent -> [Filter] -> m Success
findType search filters =
- CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports
+ CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters <$> getAllModulesWithReexports
findPursuitCompletions :: (MonadIO m, MonadLogger m) =>
PursuitQuery -> m Success
@@ -179,6 +208,26 @@ loadModule mn = do
$(logDebug) ("Loaded extern file at: " <> T.pack path)
pure ("Loaded extern file at: " <> T.pack path)
+loadAllModules :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => m Success
+loadAllModules = do
+ outputPath <- confOutputPath . envConfiguration <$> ask
+ cwd <- liftIO getCurrentDirectory
+ let outputDirectory = cwd </> outputPath
+ liftIO (getDirectoryContents outputDirectory)
+ >>= liftIO . traverse (getExternsPath outputDirectory)
+ >>= traverse_ loadExtern . catMaybes
+ pure (TextResult "All modules loaded.")
+ where
+ getExternsPath :: FilePath -> FilePath -> IO (Maybe FilePath)
+ getExternsPath outputDirectory d
+ | d `elem` [".", ".."] = pure Nothing
+ | otherwise = do
+ let file = outputDirectory </> d </> "externs.json"
+ ex <- doesFileExist file
+ if ex
+ then pure (Just file)
+ else pure Nothing
+
filePathFromModule :: (PscIde m, MonadError PscIdeError m) =>
ModuleIdent -> m FilePath
filePathFromModule moduleName = do
@@ -190,10 +239,3 @@ filePathFromModule moduleName = do
then pure path
else throwError (ModuleFileNotFound moduleName)
--- | Taken from Data.Either.Utils
-maybeToEither :: MonadError e m =>
- e -- ^ (Left e) will be returned if the Maybe value is Nothing
- -> Maybe a -- ^ (Right a) will be returned if this is (Just a)
- -> m a
-maybeToEither errorval Nothing = throwError errorval
-maybeToEither _ (Just normalval) = return normalval
diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs
index 0e4d089..450ba5f 100644
--- a/src/Language/PureScript/Ide/CaseSplit.hs
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -1,3 +1,17 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.CaseSplit
+-- Description : Casesplitting and adding function clauses
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Casesplitting and adding function clauses
+-----------------------------------------------------------------------------
+
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -26,23 +40,18 @@ import Data.List (find)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
-import Language.PureScript.AST
-import Language.PureScript.Environment
+import qualified Language.PureScript as P
+
import Language.PureScript.Externs
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Externs (unwrapPositioned)
import Language.PureScript.Ide.State
-import Language.PureScript.Ide.Types hiding (Type)
-import Language.PureScript.Names
-import Language.PureScript.Parser.Common (runTokenParser)
-import Language.PureScript.Parser.Declarations
-import Language.PureScript.Parser.Lexer (lex)
-import Language.PureScript.Parser.Types
-import Language.PureScript.Pretty
-import Language.PureScript.Types
-import Text.Parsec as P
-
-type Constructor = (ProperName 'ConstructorName, [Type])
+import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Util
+
+import Text.Parsec as Parsec
+
+type Constructor = (P.ProperName 'P.ConstructorName, [P.Type])
newtype WildcardAnnotations = WildcardAnnotations Bool
@@ -57,13 +66,13 @@ caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
caseSplit q = do
type' <- parseType' (T.unpack q)
(tc, args) <- splitTypeConstructor type'
- (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc
- let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args))
+ (EDType _ _ (P.DataType typeVars ctors)) <- findTypeDeclaration tc
+ let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args))
let appliedCtors = map (second (map applyTypeVars)) ctors
pure appliedCtors
findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
- ProperName 'TypeName -> m ExternsDeclaration
+ P.ProperName 'P.TypeName -> m ExternsDeclaration
findTypeDeclaration q = do
efs <- getExternFiles
let m = getFirst $ foldMap (findTypeDeclaration' q) efs
@@ -72,7 +81,7 @@ findTypeDeclaration q = do
Nothing -> throwError (GeneralError "Not Found")
findTypeDeclaration' ::
- ProperName 'TypeName
+ P.ProperName 'P.TypeName
-> ExternsFile
-> First ExternsDeclaration
findTypeDeclaration' t ExternsFile{..} =
@@ -81,25 +90,25 @@ findTypeDeclaration' t ExternsFile{..} =
_ -> False) efDeclarations
splitTypeConstructor :: (MonadError PscIdeError m) =>
- Type -> m (ProperName 'TypeName, [Type])
+ P.Type -> m (P.ProperName 'P.TypeName, [P.Type])
splitTypeConstructor = go []
where
- go acc (TypeApp ty arg) = go (arg : acc) ty
- go acc (TypeConstructor tc) = pure (disqualify tc, acc)
+ go acc (P.TypeApp ty arg) = go (arg : acc) ty
+ go acc (P.TypeConstructor tc) = pure (P.disqualify tc, acc)
go _ _ = throwError (GeneralError "Failed to read TypeConstructor")
prettyCtor :: WildcardAnnotations -> Constructor -> Text
-prettyCtor _ (ctorName, []) = T.pack (runProperName ctorName)
+prettyCtor _ (ctorName, []) = runProperNameT ctorName
prettyCtor wsa (ctorName, ctorArgs) =
- "("<> T.pack (runProperName ctorName) <> " "
+ "("<> runProperNameT ctorName <> " "
<> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"
-prettyPrintWildcard :: WildcardAnnotations -> Type -> Text
+prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text
prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard
prettyPrintWildcard (WildcardAnnotations False) = const "_"
-prettyWildcard :: Type -> Text
-prettyWildcard t = "( _ :: " <> T.strip (T.pack (prettyPrintTypeAtom t)) <> ")"
+prettyWildcard :: P.Type -> Text
+prettyWildcard t = "( _ :: " <> T.strip (T.pack (P.prettyPrintTypeAtom t)) <> ")"
-- | Constructs Patterns to insert into a sourcefile
makePattern :: Text -- ^ Current line
@@ -116,38 +125,38 @@ addClause :: Text -> WildcardAnnotations -> [Text]
addClause s wca =
let (fName, fType) = parseTypeDeclaration' (T.unpack s)
(args, _) = splitFunctionType fType
- template = T.pack (runIdent fName) <> " " <>
+ template = runIdentT fName <> " " <>
T.unwords (map (prettyPrintWildcard wca) args) <>
- " = ?" <> (T.strip . T.pack . runIdent $ fName)
+ " = ?" <> (T.strip . runIdentT $ fName)
in [s, template]
parseType' :: (MonadError PscIdeError m) =>
- String -> m Type
+ String -> m P.Type
parseType' s =
- case lex "<psc-ide>" s >>= runTokenParser "<psc-ide>" (parseType <* P.eof) of
+ case P.lex "<psc-ide>" s >>= P.runTokenParser "<psc-ide>" (P.parseType <* Parsec.eof) of
Right type' -> pure type'
Left err ->
throwError (GeneralError ("Parsing the splittype failed with:"
++ show err))
-parseTypeDeclaration' :: String -> (Ident, Type)
+parseTypeDeclaration' :: String -> (P.Ident, P.Type)
parseTypeDeclaration' s =
let x = do
- ts <- lex "" s
- runTokenParser "" (parseDeclaration <* P.eof) ts
+ ts <- P.lex "" s
+ P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts
in
case unwrapPositioned <$> x of
- Right (TypeDeclaration i t) -> (i, t)
+ Right (P.TypeDeclaration i t) -> (i, t)
y -> error (show y)
-splitFunctionType :: Type -> ([Type], Type)
+splitFunctionType :: P.Type -> ([P.Type], P.Type)
splitFunctionType t = (arguments, returns)
where
returns = last splitted
arguments = init splitted
splitted = splitType' t
- splitType' (ForAll _ t' _) = splitType' t'
- splitType' (ConstrainedType _ t') = splitType' t'
- splitType' (TypeApp (TypeApp t' lhs) rhs)
- | t' == tyFunction = lhs : splitType' rhs
+ splitType' (P.ForAll _ t' _) = splitType' t'
+ splitType' (P.ConstrainedType _ t') = splitType' t'
+ splitType' (P.TypeApp (P.TypeApp t' lhs) rhs)
+ | t' == P.tyFunction = lhs : splitType' rhs
splitType' t' = [t']
diff --git a/src/Language/PureScript/Ide/CodecJSON.hs b/src/Language/PureScript/Ide/CodecJSON.hs
deleted file mode 100644
index 8a264c0..0000000
--- a/src/Language/PureScript/Ide/CodecJSON.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Language.PureScript.Ide.CodecJSON where
-
-import Data.Aeson
-import Data.Text (Text())
-import Data.Text.Lazy (toStrict, fromStrict)
-import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
-
-encodeT :: (ToJSON a) => a -> Text
-encodeT = toStrict . decodeUtf8 . encode
-
-decodeT :: (FromJSON a) => Text -> Maybe a
-decodeT = decode . encodeUtf8 . fromStrict
-
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index d7387d4..dbec3f1 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -1,3 +1,17 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Command
+-- Description : Datatypes for the commands psc-ide accepts
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Datatypes for the commands psc-ide accepts
+-----------------------------------------------------------------------------
+
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -11,33 +25,64 @@ import Control.Monad
import Data.Aeson
import Data.Maybe
import Data.Text (Text)
+import Language.PureScript (ModuleName,
+ moduleNameFromString)
import Language.PureScript.Ide.CaseSplit
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
data Command
- = Load { loadModules :: [ModuleIdent]
- , loadDependencies :: [ModuleIdent]}
- | Type { typeSearch :: DeclIdent
- , typeFilters :: [Filter]}
- | Complete { completeFilters :: [Filter]
- , completeMatcher :: Matcher}
- | Pursuit { pursuitQuery :: PursuitQuery
- , pursuitSearchType :: PursuitSearchType}
- | List {listType :: ListType}
- | CaseSplit {
- caseSplitLine :: Text
+ = Load
+ { loadModules :: [ModuleIdent]
+ , loadDependencies :: [ModuleIdent]
+ }
+ | Type
+ { typeSearch :: DeclIdent
+ , typeFilters :: [Filter]
+ }
+ | Complete
+ { completeFilters :: [Filter]
+ , completeMatcher :: Matcher
+ }
+ | Pursuit
+ { pursuitQuery :: PursuitQuery
+ , pursuitSearchType :: PursuitSearchType
+ }
+ | CaseSplit
+ { caseSplitLine :: Text
, caseSplitBegin :: Int
, caseSplitEnd :: Int
, caseSplitAnnotations :: WildcardAnnotations
- , caseSplitType :: Type}
- | AddClause {
- addClauseLine :: Text
- , addClauseAnnotations :: WildcardAnnotations}
+ , caseSplitType :: Text
+ }
+ | AddClause
+ { addClauseLine :: Text
+ , addClauseAnnotations :: WildcardAnnotations
+ }
+ -- Import InputFile OutputFile
+ | Import FilePath (Maybe FilePath) [Filter] ImportCommand
+ | List { listType :: ListType }
| Cwd
| Quit
+data ImportCommand
+ = AddImplicitImport ModuleName
+ | AddImportForIdentifier DeclIdent
+ deriving (Show, Eq)
+
+instance FromJSON ImportCommand where
+ parseJSON = withObject "ImportCommand" $ \o -> do
+ (command :: String) <- o .: "importCommand"
+ case command of
+ "addImplicitImport" -> do
+ mn <- o .: "module"
+ pure (AddImplicitImport (moduleNameFromString mn))
+ "addImport" -> do
+ ident <- o .: "identifier"
+ pure (AddImportForIdentifier ident)
+ _ -> mzero
+
data ListType = LoadedModules | Imports FilePath | AvailableModules
instance FromJSON ListType where
@@ -60,11 +105,11 @@ instance FromJSON Command where
return $ List (fromMaybe LoadedModules listType')
"cwd" -> return Cwd
"quit" -> return Quit
- "load" -> do
- params <- o .: "params"
- mods <- params .:? "modules"
- deps <- params .:? "dependencies"
- return $ Load (fromMaybe [] mods) (fromMaybe [] deps)
+ "load" ->
+ maybe (pure (Load [] [])) (\params -> do
+ mods <- params .:? "modules"
+ deps <- params .:? "dependencies"
+ pure $ Load (fromMaybe [] mods) (fromMaybe [] deps)) =<< o .:? "params"
"type" -> do
params <- o .: "params"
search <- params .: "search"
@@ -97,5 +142,12 @@ instance FromJSON Command where
return $ AddClause line (if annotations
then explicitAnnotations
else noAnnotations)
+ "import" -> do
+ params <- o .: "params"
+ fp <- params .: "file"
+ out <- params .:? "outfile"
+ filters <- params .:? "filters"
+ importCommand <- params .: "importCommand"
+ pure $ Import fp out (fromMaybe [] filters) importCommand
_ -> mzero
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
index c813066..f120c6f 100644
--- a/src/Language/PureScript/Ide/Completion.hs
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -13,23 +13,20 @@ import Language.PureScript.Ide.Types
-- | Applies the CompletionFilters and the Matcher to the given Modules
-- and sorts the found Completions according to the Matching Score
-getCompletions :: [Filter] -> Matcher -> [Module] -> [Completion]
+getCompletions :: [Filter] -> Matcher -> [Module] -> [Match]
getCompletions filters matcher modules =
runMatcher matcher $ completionsFromModules (applyFilters filters modules)
-getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Completion]
+getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Match]
getExactMatches search filters modules =
completionsFromModules $
applyFilters (equalityFilter search : filters) modules
-completionsFromModules :: [Module] -> [Completion]
+completionsFromModules :: [Module] -> [Match]
completionsFromModules = foldMap completionFromModule
where
- completionFromModule :: Module -> [Completion]
- completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls
+ completionFromModule :: Module -> [Match]
+ completionFromModule (moduleIdent, decls) = mapMaybe (matchFromDecl moduleIdent) decls
-completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion
-completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type'))
-completionFromDecl mi (DataDecl name kind) = Just (Completion (mi, name, kind))
-completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module"))
-completionFromDecl _ _ = Nothing
+matchFromDecl :: ModuleIdent -> ExternDecl -> Maybe Match
+matchFromDecl mi = Just . Match mi
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 0281211..37cccb3 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -1,6 +1,20 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Error
+-- Description : Error types for psc-ide
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Error types for psc-ide
+-----------------------------------------------------------------------------
+
{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.Ide.Error
- (ErrorMsg, PscIdeError(..), textError, first)
+ (ErrorMsg, PscIdeError(..), textError)
where
import Data.Aeson
@@ -35,8 +49,3 @@ textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parse
-- escape newlines and other special chars so we can send the error over the socket as a single line
escape :: P.ParseError -> String
escape = show
-
--- | Specialized version of `first` from `Data.Bifunctors`
-first :: (a -> b) -> Either a r -> Either b r
-first f (Left x) = Left (f x)
-first _ (Right r2) = Right r2
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index 0ce7a8e..de64116 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -1,3 +1,17 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Externs
+-- Description : Handles externs files for psc-ide
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Handles externs files for psc-ide
+-----------------------------------------------------------------------------
+
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -5,34 +19,32 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Language.PureScript.Ide.Externs
- (
- ExternDecl(..),
+ ( ExternDecl(..),
ModuleIdent,
DeclIdent,
- Type,
- Fixity(..),
readExternFile,
convertExterns,
unwrapPositioned,
unwrapPositionedRef
) where
-import Prelude ()
+import Prelude ()
import Prelude.Compat
import Control.Monad.Error.Class
import Control.Monad.IO.Class
-import Data.Maybe (mapMaybe)
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import qualified Language.PureScript.AST.Declarations as D
-import qualified Language.PureScript.Externs as PE
-import Language.PureScript.Ide.CodecJSON
-import Language.PureScript.Ide.Error (PscIdeError (..))
+import Data.List (nub)
+import Data.Maybe (mapMaybe)
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Language.PureScript.Ide.Error (PscIdeError (..))
import Language.PureScript.Ide.Types
-import qualified Language.PureScript.Names as N
-import qualified Language.PureScript.Pretty as PP
+import Language.PureScript.Ide.Util
+
+import qualified Language.PureScript as P
+import qualified Language.PureScript.Externs as PE
readExternFile :: (MonadIO m, MonadError PscIdeError m) =>
FilePath -> m PE.ExternsFile
@@ -42,17 +54,14 @@ readExternFile fp = do
Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed"
Just externs -> pure externs
-moduleNameToText :: N.ModuleName -> Text
-moduleNameToText = T.pack . N.runModuleName
+moduleNameToText :: P.ModuleName -> Text
+moduleNameToText = T.pack . P.runModuleName
-properNameToText :: N.ProperName a -> Text
-properNameToText = T.pack . N.runProperName
-
-identToText :: N.Ident -> Text
-identToText = T.pack . N.runIdent
+identToText :: P.Ident -> Text
+identToText = T.pack . P.runIdent
convertExterns :: PE.ExternsFile -> Module
-convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls)
+convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls)
where
moduleName = moduleNameToText (PE.efModuleName ef)
importDecls = convertImport <$> PE.efImports ef
@@ -61,42 +70,45 @@ convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls)
-- operatorDecls = convertOperator <$> PE.efFixities ef
otherDecls = mapMaybe convertDecl (PE.efDeclarations ef)
+ typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls)
+ decls = nub $ appEndo typeClassFilter otherDecls
+
+removeTypeDeclarationsForClass :: ExternDecl -> Endo [ExternDecl]
+removeTypeDeclarationsForClass (TypeClassDeclaration n) = Endo (filter notDuplicate)
+ where notDuplicate (TypeDeclaration n' _) = runProperNameT n /= runProperNameT n'
+ notDuplicate (TypeSynonymDeclaration n' _) = runProperNameT n /= runProperNameT n'
+ notDuplicate _ = True
+removeTypeDeclarationsForClass _ = mempty
+
+isTypeClassDeclaration :: ExternDecl -> Bool
+isTypeClassDeclaration TypeClassDeclaration{} = True
+isTypeClassDeclaration _ = False
+
convertImport :: PE.ExternsImport -> ExternDecl
convertImport ei = Dependency
(moduleNameToText (PE.eiModule ei))
[]
(moduleNameToText <$> PE.eiImportedAs ei)
-convertExport :: D.DeclarationRef -> Maybe ExternDecl
-convertExport (D.ModuleRef mn) = Just (Export (moduleNameToText mn))
+convertExport :: P.DeclarationRef -> Maybe ExternDecl
+convertExport (P.ModuleRef mn) = Just (Export (moduleNameToText mn))
convertExport _ = Nothing
convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl
-convertDecl PE.EDType{..} = Just $
- DataDecl
- (properNameToText edTypeName)
- (packAndStrip (PP.prettyPrintKind edTypeKind))
+convertDecl PE.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind
convertDecl PE.EDTypeSynonym{..} = Just $
- DataDecl
- (properNameToText edTypeSynonymName)
- (packAndStrip (PP.prettyPrintType edTypeSynonymType))
+ TypeSynonymDeclaration edTypeSynonymName edTypeSynonymType
convertDecl PE.EDDataConstructor{..} = Just $
- DataDecl
- (properNameToText edDataCtorName)
- (packAndStrip (PP.prettyPrintType edDataCtorType))
+ DataConstructor (runProperNameT edDataCtorName) edDataCtorTypeCtor edDataCtorType
convertDecl PE.EDValue{..} = Just $
- FunctionDecl
- (identToText edValueName)
- (packAndStrip (PP.prettyPrintType edValueType))
-convertDecl _ = Nothing
-
-packAndStrip :: String -> Text
-packAndStrip = T.unwords . fmap T.strip . T.lines . T.pack
+ ValueDeclaration (identToText edValueName) edValueType
+convertDecl PE.EDClass{..} = Just $ TypeClassDeclaration edClassName
+convertDecl PE.EDInstance{} = Nothing
-unwrapPositioned :: D.Declaration -> D.Declaration
-unwrapPositioned (D.PositionedDeclaration _ _ x) = x
+unwrapPositioned :: P.Declaration -> P.Declaration
+unwrapPositioned (P.PositionedDeclaration _ _ x) = x
unwrapPositioned x = x
-unwrapPositionedRef :: D.DeclarationRef -> D.DeclarationRef
-unwrapPositionedRef (D.PositionedDeclarationRef _ _ x) = x
+unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
+unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x
unwrapPositionedRef x = x
diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs
index 47deed9..8055e36 100644
--- a/src/Language/PureScript/Ide/Filter.hs
+++ b/src/Language/PureScript/Ide/Filter.hs
@@ -1,10 +1,30 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Filter
+-- Description : Filters for psc-ide commands
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Filters for psc-ide commands
+-----------------------------------------------------------------------------
+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
+
module Language.PureScript.Ide.Filter
- (Filter, moduleFilter, prefixFilter, equalityFilter, dependencyFilter,
- runFilter, applyFilters)
- where
+ ( Filter
+ , moduleFilter
+ , prefixFilter
+ , equalityFilter
+ , dependencyFilter
+ , runFilter
+ , applyFilters
+ ) where
import Prelude ()
import Prelude.Compat
@@ -16,6 +36,7 @@ import Data.Maybe (listToMaybe, mapMaybe)
import Data.Monoid
import Data.Text (Text, isPrefixOf)
import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Util
newtype Filter = Filter (Endo [Module]) deriving(Monoid)
@@ -57,10 +78,9 @@ prefixFilter "" = mkFilter id
prefixFilter t = mkFilter $ identFilter prefix t
where
prefix :: ExternDecl -> Text -> Bool
- prefix (FunctionDecl name _) search = search `isPrefixOf` name
- prefix (DataDecl name _) search = search `isPrefixOf` name
- prefix (ModuleDecl name _) search = search `isPrefixOf` name
- prefix _ _ = False
+ prefix Export{} _ = False
+ prefix Dependency{} _ = False
+ prefix ed search = search `isPrefixOf` identifierFromExternDecl ed
-- | Only keeps Identifiers that are equal to the search string
@@ -68,10 +88,7 @@ equalityFilter :: Text -> Filter
equalityFilter = mkFilter . identFilter equality
where
equality :: ExternDecl -> Text -> Bool
- equality (FunctionDecl name _) prefix = prefix == name
- equality (DataDecl name _) prefix = prefix == name
- equality _ _ = False
-
+ equality ed search = identifierFromExternDecl ed == search
identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module]
identFilter predicate search =
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
new file mode 100644
index 0000000..8fe4dcf
--- /dev/null
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -0,0 +1,355 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Imports
+-- Description : Provides functionality to manage imports
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Provides functionality to manage imports
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+
+module Language.PureScript.Ide.Imports
+ ( addImplicitImport
+ , addImportForIdentifier
+ , answerRequest
+ -- for tests
+ , parseImport
+ , prettyPrintImportSection
+ , addImplicitImport'
+ , addExplicitImport'
+ , sliceImportSection
+ , prettyPrintImport'
+ , Import(Import)
+ )
+ where
+
+import Control.Applicative ((<|>))
+import Control.Monad.Error.Class
+import Control.Monad.IO.Class
+import "monad-logger" Control.Monad.Logger
+import Data.Bifunctor (first, second)
+import Data.Function (on)
+import qualified Data.List as List
+import Data.Maybe (isNothing)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import qualified Language.PureScript as P
+import Language.PureScript.Ide.Completion
+import Language.PureScript.Ide.Error
+import Language.PureScript.Ide.Externs (unwrapPositioned,
+ unwrapPositionedRef)
+import Language.PureScript.Ide.Filter
+import Language.PureScript.Ide.State
+import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Util
+
+data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
+ deriving (Eq, Show)
+
+instance Ord Import where
+ compare = compImport
+
+compImportType :: P.ImportDeclarationType -> P.ImportDeclarationType -> Ordering
+compImportType P.Implicit P.Implicit = EQ
+compImportType P.Implicit _ = LT
+compImportType (P.Explicit _) (P.Hiding _) = LT
+compImportType (P.Explicit _) (P.Explicit _) = EQ
+compImportType (P.Explicit _) P.Implicit = GT
+compImportType (P.Hiding _) (P.Hiding _) = EQ
+compImportType (P.Hiding _) _ = GT
+
+compImport :: Import -> Import -> Ordering
+compImport (Import n i q) (Import n' i' q')
+ | compImportType i i' /= EQ = compImportType i i'
+ -- This means that for a stable sort, the first implicit import will stay
+ -- the first implicit import
+ | P.isImplicit i && isNothing q = LT
+ | P.isImplicit i && isNothing q' = GT
+ | otherwise = compare n n'
+
+-- | Reads a file and returns the (lines before the imports, the imports, the
+-- lines after the imports)
+parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>
+ FilePath -> m (P.ModuleName, [Text], [Import], [Text])
+parseImportsFromFile fp = do
+ file <- liftIO (TIO.readFile fp)
+ case sliceImportSection (T.lines file) of
+ Right res -> pure res
+ Left err -> throwError (GeneralError err)
+
+parseImportsWithModuleName :: [Text] -> Either String (P.ModuleName, [Import])
+parseImportsWithModuleName ls = do
+ (P.Module _ _ mn decls _) <- moduleParse ls
+ pure (mn, concatMap mkImport (unwrapPositioned <$> decls))
+ where
+ mkImport (P.ImportDeclaration mn (P.Explicit refs) qual _) =
+ [Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual]
+ mkImport (P.ImportDeclaration mn it qual _) = [Import mn it qual]
+ mkImport _ = []
+
+sliceImportSection :: [Text] -> Either String (P.ModuleName, [Text], [Import], [Text])
+sliceImportSection ts =
+ case foldl step (ModuleHeader 0) (zip [0..] ts) of
+ Res start end ->
+ let
+ (moduleHeader, (importSection, remainingFile)) =
+ List.splitAt (succ (end - start)) `second` List.splitAt start ts
+ in
+ (\(mn, is) -> (mn, moduleHeader, is, remainingFile)) <$>
+ parseImportsWithModuleName (moduleHeader <> importSection)
+
+ -- If we don't find any imports, we insert a newline after the module
+ -- declaration and begin a new importsection
+ ModuleHeader ix ->
+ let (moduleHeader, remainingFile) = List.splitAt (succ ix) ts
+ in
+ (\(mn, is) -> (mn, moduleHeader ++ [""], is, remainingFile)) <$>
+ parseImportsWithModuleName moduleHeader
+ _ -> Left "Failed to detect the import section"
+
+data ImportStateMachine = ModuleHeader Int | ImportSection Int Int | Res Int Int
+
+-- | We start in the
+--
+-- * ModuleHeader state.
+--
+-- We skip every line we encounter, that doesn't start with "import". If we find
+-- a line that starts with module we store that linenumber. Once we find a line
+-- with "import" we store its linenumber as the start of the import section and
+-- change into the
+--
+-- * ImportSection state
+--
+-- For any line that starts with import or whitespace(is thus indented) we
+-- expand the end of the import section to that line and continue. If we
+-- encounter a commented or empty line, we continue moving forward in the
+-- ImportSection state but don't expand the import section end yet. This allows
+-- us to exclude newlines or comments that directly follow the import section.
+-- Once we encounter a line that is not a comment, newline, indentation or
+-- import we switch into the
+--
+-- * Res state
+--
+-- , which just shortcuts to the end of the file and carries the detected import
+-- section boundaries
+step :: ImportStateMachine -> (Int, Text) -> ImportStateMachine
+step (ModuleHeader mi) (ix, l)
+ | T.isPrefixOf "module " l = ModuleHeader ix
+ | T.isPrefixOf "import " l = ImportSection ix ix
+ | otherwise = ModuleHeader mi
+step (ImportSection start lastImportLine) (ix, l)
+ | any (`T.isPrefixOf` l) ["import", " "] = ImportSection start ix
+ | T.isPrefixOf "--" l || l == "" = ImportSection start lastImportLine
+ | otherwise = Res start lastImportLine
+step (Res start end) _ = Res start end
+
+moduleParse :: [Text] -> Either String P.Module
+moduleParse t = first show $ do
+ tokens <- (P.lex "" . T.unpack . T.unlines) t
+ P.runTokenParser "<psc-ide>" P.parseModule tokens
+
+-- | Adds an implicit import like @import Prelude@ to a Sourcefile.
+addImplicitImport :: (MonadIO m, MonadError PscIdeError m)
+ => FilePath -- ^ The Sourcefile read from
+ -> P.ModuleName -- ^ The module to import
+ -> m [Text]
+addImplicitImport fp mn = do
+ (_, pre, imports, post) <- parseImportsFromFile fp
+ let newImportSection = addImplicitImport' imports mn
+ pure $ pre ++ newImportSection ++ post
+
+addImplicitImport' :: [Import] -> P.ModuleName -> [Text]
+addImplicitImport' imports mn =
+ -- We need to append the new import, because there could already be implicit
+ -- imports and we need to preserve the order on these, as the first implicit
+ -- import is the one that doesn't generate warnings.
+ prettyPrintImportSection ( imports ++ [Import mn P.Implicit Nothing])
+
+-- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an
+-- explicit import already exists for the given module, it adds the identifier
+-- to that imports list.
+--
+-- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing
+-- @import Prelude (bind)@ in the file File.purs returns @["import Prelude
+-- (bind, unit)"]@
+addExplicitImport :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>
+ FilePath -> ExternDecl -> P.ModuleName -> m [Text]
+addExplicitImport fp decl moduleName = 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
+ pure (pre ++ prettyPrintImportSection newImportSection ++ post)
+
+addExplicitImport' :: ExternDecl -> P.ModuleName -> [Import] -> [Import]
+addExplicitImport' decl moduleName imports =
+ let
+ isImplicitlyImported =
+ not . null $ filter (\case
+ (Import mn P.Implicit Nothing) -> mn == moduleName
+ _ -> False) imports
+ matches (Import mn (P.Explicit _) Nothing) = mn == moduleName
+ matches _ = False
+ freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) Nothing
+ in
+ if isImplicitlyImported
+ then imports
+ else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports
+ where
+ refFromDeclaration (TypeClassDeclaration n) = P.TypeClassRef n
+ refFromDeclaration (DataConstructor n tn _) =
+ P.TypeRef tn (Just [P.ProperName (T.unpack n)])
+ refFromDeclaration (TypeDeclaration n _) = P.TypeRef n (Just [])
+ refFromDeclaration d =
+ let
+ ident = T.unpack (identifierFromExternDecl d)
+ in
+ P.ValueRef ((if all P.isSymbolChar ident then P.Op else P.Ident) ident)
+
+ -- | Adds a declaration to an import:
+ -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)
+ insertDeclIntoImport :: ExternDecl -> Import -> Import
+ insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =
+ Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing
+ insertDeclIntoImport _ is = is
+
+ insertDeclIntoRefs :: ExternDecl -> [P.DeclarationRef] -> [P.DeclarationRef]
+ insertDeclIntoRefs (DataConstructor dtor tn _) refs =
+ let
+ dtor' = P.ProperName (T.unpack dtor)
+ -- TODO: Get rid of this once typeclasses can't be imported like types
+ refs' = properRefToTypeRef <$> refs
+ in
+ updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs'
+ insertDeclIntoRefs dr refs = List.nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)
+
+ insertDtor dtor (P.TypeRef tn' dtors) =
+ case dtors of
+ Just dtors' -> P.TypeRef tn' (Just (List.nub (dtor : dtors')))
+ -- This means the import was opened. We don't add anything in this case
+ -- import Data.Maybe (Maybe(..)) -> import Data.Maybe (Maybe(Just))
+ Nothing -> P.TypeRef tn' Nothing
+ insertDtor _ refs = refs
+
+
+ -- TODO: Get rid of this once typeclasses can't be imported like types
+ properRefToTypeRef (P.ProperRef n) = P.TypeRef (P.ProperName n) (Just [])
+ properRefToTypeRef r = r
+
+ matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool
+ matchType tn (P.TypeRef n _) = tn == n
+ matchType _ _ = False
+
+updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a]
+updateAtFirstOrPrepend p t d l =
+ case List.findIndex p l of
+ Nothing -> d : l
+ Just ix ->
+ let (x, a : y) = List.splitAt ix l
+ in x ++ [t a] ++ y
+
+-- | Looks up the given identifier in the currently loaded modules.
+--
+-- * Throws an error if the identifier cannot be found.
+--
+-- * If exactly one match is found, adds an explicit import to the importsection
+--
+-- * If more than one possible imports are found, reports the possibilities as a
+-- list of completions.
+addImportForIdentifier :: (PscIde m, MonadError PscIdeError m, MonadLogger m)
+ => FilePath -- ^ The Sourcefile to read from
+ -> Text -- ^ The identifier to import
+ -> [Filter] -- ^ Filters to apply before searching for
+ -- the identifier
+ -> m (Either [Match] [Text])
+addImportForIdentifier fp ident filters = do
+ modules <- getAllModulesWithReexports
+ case getExactMatches ident filters modules of
+ [] ->
+ throwError (NotFound "Couldn't find the given identifier. \
+ \Have you loaded the corresponding module?")
+
+ -- Only one match was found for the given identifier, so we can insert it
+ -- right away
+ [Match m decl] ->
+ Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m))
+
+ -- This case comes up for newtypes and dataconstructors. Because values and
+ -- types don't share a namespace we can get multiple matches from the same
+ -- module. This also happens for parameterized types, as these generate both
+ -- a type aswell as a type synonym.
+
+ ms@[Match m1 d1, Match m2 d2] ->
+ if m1 /= m2
+ -- If the modules don't line up we just ask the user to specify the
+ -- module
+ then pure $ Left ms
+ else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of
+ -- If dataconstructor and type line up we just import the
+ -- dataconstructor as that will give us an unnecessary import warning at
+ -- worst
+ Just decl ->
+ Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m1))
+ -- Here we need the user to specify whether he wanted a dataconstructor
+ -- or a type
+ Nothing ->
+ throwError (GeneralError "Undecidable between type and dataconstructor")
+
+ -- Multiple matches were found so we need to ask the user to clarify which
+ -- module he meant
+ xs ->
+ pure $ Left xs
+ where
+ decideRedundantCase dtor@(DataConstructor _ t _) (TypeDeclaration t' _) =
+ if t == t' then Just dtor else Nothing
+ decideRedundantCase TypeDeclaration{} ts@TypeSynonymDeclaration{} =
+ Just ts
+ decideRedundantCase _ _ = Nothing
+
+prettyPrintImport' :: Import -> Text
+-- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs
+prettyPrintImport' (Import mn (P.Explicit refs) qual) =
+ T.pack $ "import " ++ P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual
+prettyPrintImport' (Import mn idt qual) =
+ T.pack $ "import " ++ P.prettyPrintImport mn idt qual
+
+prettyPrintImportSection :: [Import] -> [Text]
+prettyPrintImportSection imports = map prettyPrintImport' (List.sort imports)
+
+-- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@,
+-- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the
+-- first argument.
+answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success
+answerRequest outfp rs =
+ case outfp of
+ Nothing -> pure $ MultilineTextResult rs
+ Just outfp' -> do
+ liftIO $ TIO.writeFile outfp' (T.unlines rs)
+ pure $ TextResult $ "Written to " <> T.pack outfp'
+
+-- | Test and ghci helper
+parseImport :: Text -> Maybe Import
+parseImport t =
+ case P.lex "<psc-ide>" (T.unpack t)
+ >>= P.runTokenParser "<psc-ide>" P.parseImportDeclaration' of
+ Right (mn, P.Explicit refs, mmn, _) ->
+ Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn)
+ Right (mn, idt, mmn, _) -> Just (Import mn idt mmn)
+ Left _ -> Nothing
+
diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs
index 65244a6..d99a36e 100644
--- a/src/Language/PureScript/Ide/Matcher.hs
+++ b/src/Language/PureScript/Ide/Matcher.hs
@@ -1,7 +1,26 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Matcher
+-- Description : Matchers for psc-ide commands
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Matchers for psc-ide commands
+-----------------------------------------------------------------------------
+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Language.PureScript.Ide.Matcher (Matcher, flexMatcher, runMatcher) where
+
+module Language.PureScript.Ide.Matcher
+ ( Matcher
+ , flexMatcher
+ , runMatcher
+ ) where
import Prelude ()
import Prelude.Compat
@@ -16,13 +35,14 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Util
import Text.EditDistance
import Text.Regex.TDFA ((=~))
-type ScoredCompletion = (Completion, Double)
+type ScoredMatch = (Match, Double)
-newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid)
+newtype Matcher = Matcher (Endo [Match]) deriving(Monoid)
instance FromJSON Matcher where
parseJSON = withObject "matcher" $ \o -> do
@@ -41,42 +61,43 @@ instance FromJSON Matcher where
Nothing -> return mempty
-- | Matches any occurence of the search string with intersections
--- |
--- | The scoring measures how far the matches span the string where
--- | closer is better.
--- | Examples:
--- | flMa matches flexMatcher. Score: 14.28
--- | sons matches sortCompletions. Score: 6.25
+--
+-- The scoring measures how far the matches span the string where
+-- closer is better.
+-- Examples:
+-- flMa matches flexMatcher. Score: 14.28
+-- sons matches sortCompletions. Score: 6.25
flexMatcher :: Text -> Matcher
-flexMatcher pattern = mkMatcher (flexMatch pattern)
+flexMatcher p = mkMatcher (flexMatch p)
distanceMatcher :: Text -> Int -> Matcher
distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist)
-distanceMatcher' :: Text -> Int -> [Completion] -> [ScoredCompletion]
+distanceMatcher' :: Text -> Int -> [Match] -> [ScoredMatch]
distanceMatcher' q maxDist = mapMaybe go
where
- go c@(Completion (_, y, _)) = let d = dist (T.unpack y)
- in if d <= maxDist
- then Just (c, 1 / fromIntegral d)
- else Nothing
+ go m = let d = dist (T.unpack y)
+ y = identifierFromMatch m
+ in if d <= maxDist
+ then Just (m, 1 / fromIntegral d)
+ else Nothing
dist = levenshteinDistance defaultEditCosts (T.unpack q)
-mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher
+mkMatcher :: ([Match] -> [ScoredMatch]) -> Matcher
mkMatcher matcher = Matcher . Endo $ fmap fst . sortCompletions . matcher
-runMatcher :: Matcher -> [Completion] -> [Completion]
+runMatcher :: Matcher -> [Match] -> [Match]
runMatcher (Matcher m)= appEndo m
-sortCompletions :: [ScoredCompletion] -> [ScoredCompletion]
+sortCompletions :: [ScoredMatch] -> [ScoredMatch]
sortCompletions = sortBy (flip compare `on` snd)
-flexMatch :: Text -> [Completion] -> [ScoredCompletion]
-flexMatch pattern = mapMaybe (flexRate pattern)
+flexMatch :: Text -> [Match] -> [ScoredMatch]
+flexMatch = mapMaybe . flexRate
-flexRate :: Text -> Completion -> Maybe ScoredCompletion
-flexRate pattern c@(Completion (_,ident,_)) = do
- score <- flexScore pattern ident
+flexRate :: Text -> Match -> Maybe ScoredMatch
+flexRate p c = do
+ score <- flexScore p (identifierFromMatch c)
return (c, score)
-- FlexMatching ala Sublime.
@@ -89,13 +110,13 @@ flexScore :: Text -> DeclIdent -> Maybe Double
flexScore pat str =
case T.uncons pat of
Nothing -> Nothing
- Just (first, pattern) ->
+ Just (first, p) ->
case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of
(-1,0) -> Nothing
(start,len) -> Just $ calcScore start (start + len)
where
escapedPattern :: [Text]
- escapedPattern = map escape (T.unpack pattern)
+ escapedPattern = map escape (T.unpack p)
-- escape prepends a backslash to "regexy" characters to prevent the
-- matcher from crashing when trying to build the regex
diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs
index ed401f4..7a9eb9d 100644
--- a/src/Language/PureScript/Ide/Pursuit.hs
+++ b/src/Language/PureScript/Ide/Pursuit.hs
@@ -1,3 +1,17 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Pursuit
+-- Description : Pursuit client for psc-ide
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Pursuit client for psc-ide
+-----------------------------------------------------------------------------
+
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index fa00f56..2ab8a85 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -1,6 +1,22 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Reexports
+-- Description : Resolves reexports for psc-ide
+-- Copyright : Christoph Hegemann 2016
+-- Brian Sermons 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Resolves reexports for psc-ide
+-----------------------------------------------------------------------------
+
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TupleSections #-}
+
module Language.PureScript.Ide.Reexports where
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index 846a8fa..24ce7de 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -1,6 +1,21 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.SourceFile
+-- Description : Getting declarations from PureScript sourcefiles
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Getting declarations from PureScript sourcefiles
+-----------------------------------------------------------------------------
+
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
+
module Language.PureScript.Ide.SourceFile where
import Prelude
@@ -69,7 +84,7 @@ getPositionedImports :: D.Module -> [D.Declaration]
getPositionedImports (D.Module _ _ _ declarations _) =
mapMaybe isImport declarations
where
- isImport i@(D.PositionedDeclaration _ _ (D.ImportDeclaration{})) = Just i
+ isImport i@(D.PositionedDeclaration _ _ D.ImportDeclaration{}) = Just i
isImport _ = Nothing
getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 80791c2..b649fe8 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -1,3 +1,17 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.State
+-- Description : Functions to access psc-ide's state
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Functions to access psc-ide's state
+-----------------------------------------------------------------------------
+
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -68,12 +82,13 @@ insertModule ::(PscIde m, MonadLogger m) =>
insertModule externsFile = do
env <- ask
let moduleName = efModuleName externsFile
- $(logDebug) $ "Inserting Module: " <> (T.pack (runModuleName moduleName))
+ $(logDebug) $ "Inserting Module: " <> T.pack (runModuleName moduleName)
liftIO . atomically $ insertModule' (envStateVar env) externsFile
insertModule' :: TVar PscIdeState -> ExternsFile -> STM ()
-insertModule' st ef = modifyTVar st $ \x ->
- x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)
- , pscStateModules = let (mn, decls) = convertExterns ef
- in M.insert mn decls (pscStateModules x)
- }
+insertModule' st ef =
+ modifyTVar st $ \x ->
+ x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)
+ , pscStateModules = let (mn, decls) = convertExterns ef
+ in M.insert mn decls (pscStateModules x)
+ }
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 8692e69..d1349e1 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -1,3 +1,17 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Types
+-- Description : Type definitions for psc-ide
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Type definitions for psc-ide
+-----------------------------------------------------------------------------
+
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -19,51 +33,40 @@ import Data.Maybe (maybeToList)
import Data.Text (Text (), pack, unpack)
import qualified Language.PureScript.AST.Declarations as D
import Language.PureScript.Externs
-import Language.PureScript.Names
import qualified Language.PureScript.Names as N
+import qualified Language.PureScript as P
import Text.Parsec
import Text.Parsec.Text
+type Ident = Text
+type DeclIdent = Text
type ModuleIdent = Text
-type DeclIdent = Text
-type Type = Text
-
-data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)
data ExternDecl
-- | A function/value declaration
- = FunctionDecl
- DeclIdent -- The functions name
- Type -- The functions type
- | FixityDeclaration Fixity Int DeclIdent
+ = ValueDeclaration Ident P.Type
+ | TypeDeclaration (P.ProperName 'P.TypeName) P.Kind
+ | TypeSynonymDeclaration (P.ProperName 'P.TypeName) P.Type
-- | A Dependency onto another Module
| Dependency
ModuleIdent -- name of the dependency
[Text] -- explicit imports
(Maybe Text) -- An eventual qualifier
-
-- | A module declaration
| ModuleDecl
ModuleIdent -- The modules name
[DeclIdent] -- The exported identifiers
-- | A data/newtype declaration
- | DataDecl DeclIdent -- The type name
- Text -- The "type"
+ | DataConstructor
+ DeclIdent -- ^ The type name
+ (P.ProperName 'P.TypeName)
+ P.Type -- ^ The "type"
-- | An exported module
+ | TypeClassDeclaration (P.ProperName 'P.ClassName)
| Export ModuleIdent -- The exported Modules name
deriving (Show,Eq,Ord)
-instance ToJSON ExternDecl where
- toJSON (FunctionDecl n t) = object ["name" .= n, "type" .= t]
- toJSON (ModuleDecl n t) = object ["name" .= n, "type" .= t]
- toJSON (DataDecl n t) = object ["name" .= n, "type" .= t]
- toJSON (Dependency n names _) = object ["module" .= n, "names" .= names]
- toJSON (FixityDeclaration f p n) = object ["name" .= n
- , "fixity" .= show f
- , "precedence" .= p]
- toJSON (Export _) = object []
-
type Module = (ModuleIdent, [ExternDecl])
data Configuration =
@@ -83,15 +86,22 @@ type PscIde m = (MonadIO m, MonadReader PscIdeEnvironment m)
data PscIdeState =
PscIdeState
{ pscStateModules :: M.Map Text [ExternDecl]
- , externsFiles :: M.Map ModuleName ExternsFile
+ , externsFiles :: M.Map P.ModuleName ExternsFile
} deriving Show
emptyPscIdeState :: PscIdeState
emptyPscIdeState = PscIdeState M.empty M.empty
+data Match = Match ModuleIdent ExternDecl
+ deriving (Show, Eq)
+
newtype Completion =
- Completion (ModuleIdent, DeclIdent, Type)
- deriving (Show,Eq)
+ Completion (ModuleIdent, DeclIdent, Text)
+ deriving (Show,Eq)
+
+instance ToJSON Completion where
+ toJSON (Completion (m,d,t)) =
+ object ["module" .= m, "identifier" .= d, "type" .= t]
data ModuleImport =
ModuleImport
@@ -127,18 +137,6 @@ identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident
identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name
identifierFromDeclarationRef _ = ""
-instance FromJSON Completion where
- parseJSON (Object o) = do
- m <- o .: "module"
- d <- o .: "identifier"
- t <- o .: "type"
- pure (Completion (m, d, t))
- parseJSON _ = mzero
-
-instance ToJSON Completion where
- toJSON (Completion (m,d,t)) =
- object ["module" .= m, "identifier" .= d, "type" .= t]
-
data Success =
CompletionResult [Completion]
| TextResult Text
@@ -174,7 +172,7 @@ instance FromJSON PursuitSearchType where
parseJSON _ = mzero
instance FromJSON PursuitQuery where
- parseJSON o = PursuitQuery <$> (parseJSON o)
+ parseJSON o = PursuitQuery <$> parseJSON o
data PursuitResponse =
-- | A Pursuit Response for a module. Consists of the modules name and the
@@ -182,7 +180,7 @@ data PursuitResponse =
ModuleResponse ModuleIdent Text
-- | A Pursuit Response for a declaration. Consist of the declarations type,
-- module, name and package
- | DeclarationResponse Type ModuleIdent DeclIdent Text
+ | DeclarationResponse Text ModuleIdent DeclIdent Text
deriving (Show,Eq)
instance FromJSON PursuitResponse where
@@ -215,15 +213,15 @@ typeParse t = case parse parseType "" t of
type' <- many1 anyChar
pure (unpack name, type')
-identifier :: Parser Text
-identifier = do
- spaces
- ident <-
- -- necessary for being able to parse the following ((++), concat)
- between (char '(') (char ')') (many1 (noneOf ", )")) <|>
- many1 (noneOf ", )")
- spaces
- pure (pack ident)
+ identifier :: Parser Text
+ identifier = do
+ spaces
+ ident <-
+ -- necessary for being able to parse the following ((++), concat)
+ between (char '(') (char ')') (many1 (noneOf ", )")) <|>
+ many1 (noneOf ", )")
+ spaces
+ pure (pack ident)
instance ToJSON PursuitResponse where
toJSON (ModuleResponse name package) =
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
new file mode 100644
index 0000000..d963282
--- /dev/null
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -0,0 +1,65 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Util
+-- Description : Generally useful functions and conversions
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- Generally useful functions and conversions
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.PureScript.Ide.Util where
+
+import Data.Aeson
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Lazy (fromStrict, toStrict)
+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
+import qualified Language.PureScript as P
+import Language.PureScript.Ide.Types
+
+runProperNameT :: P.ProperName a -> Text
+runProperNameT = T.pack . P.runProperName
+
+runIdentT :: P.Ident -> Text
+runIdentT = T.pack . P.runIdent
+
+prettyTypeT :: P.Type -> Text
+prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType
+
+identifierFromExternDecl :: ExternDecl -> Text
+identifierFromExternDecl (ValueDeclaration name _) = name
+identifierFromExternDecl (TypeDeclaration name _) = runProperNameT name
+identifierFromExternDecl (TypeSynonymDeclaration name _) = runProperNameT name
+identifierFromExternDecl (DataConstructor name _ _) = name
+identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name
+identifierFromExternDecl (ModuleDecl name _) = name
+identifierFromExternDecl Dependency{} = "~Dependency~"
+identifierFromExternDecl Export{} = "~Export~"
+
+identifierFromMatch :: Match -> Text
+identifierFromMatch (Match _ ed) = identifierFromExternDecl ed
+
+completionFromMatch :: Match -> Maybe Completion
+completionFromMatch (Match _ Dependency{}) = Nothing
+completionFromMatch (Match _ Export{}) = Nothing
+completionFromMatch (Match m d) = Just $ case d of
+ ValueDeclaration name type' -> Completion (m, name, prettyTypeT type')
+ TypeDeclaration name kind -> Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind)
+ TypeSynonymDeclaration name kind -> Completion (m, runProperNameT name, prettyTypeT kind)
+ DataConstructor name _ type' -> Completion (m, name, prettyTypeT type')
+ TypeClassDeclaration name -> Completion (m, runProperNameT name, "class")
+ ModuleDecl name _ -> Completion ("module", name, "module")
+ _ -> error "the impossible happened in completionFromMatch"
+
+encodeT :: (ToJSON a) => a -> Text
+encodeT = toStrict . decodeUtf8 . encode
+
+decodeT :: (FromJSON a) => Text -> Maybe a
+decodeT = decode . encodeUtf8 . fromStrict
diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs
index 9a6c1ff..184df16 100644
--- a/src/Language/PureScript/Ide/Watcher.hs
+++ b/src/Language/PureScript/Ide/Watcher.hs
@@ -1,4 +1,19 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Watcher
+-- Description : File watcher for externs files
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- File watcher for externs files
+-----------------------------------------------------------------------------
+
{-# LANGUAGE RecordWildCards #-}
+
module Language.PureScript.Ide.Watcher where
import Prelude ()
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index ddc0d10..024bd67 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -25,6 +25,7 @@ module Language.PureScript.Make
import Prelude ()
import Prelude.Compat
+import Control.Applicative ((<|>))
import Control.Monad hiding (sequence)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
@@ -52,6 +53,8 @@ import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Set as S
import qualified Data.Map as M
+import qualified Text.Parsec as Parsec
+
import SourceMap.Types
import SourceMap
@@ -61,6 +64,8 @@ import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise
import System.IO.Error (tryIOError)
import System.IO.UTF8 (readUTF8File, writeUTF8File)
+import qualified Language.JavaScript.Parser as JS
+
import Language.PureScript.Crash
import Language.PureScript.AST
import Language.PureScript.Externs
@@ -76,6 +81,8 @@ import Language.PureScript.Renamer
import Language.PureScript.Sugar
import Language.PureScript.TypeChecker
import qualified Language.PureScript.Constants as C
+import qualified Language.PureScript.Bundle as Bundle
+import qualified Language.PureScript.Parser as PSParser
import qualified Language.PureScript.CodeGen.JS as J
import qualified Language.PureScript.CoreFn as CF
@@ -331,7 +338,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
| not $ requiresForeign m -> do
tell $ errorMessage $ UnnecessaryFFIModule mn path
return Nothing
- | otherwise -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
+ | otherwise -> do
+ checkForeignDecls m path
+ return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
| otherwise -> return Nothing
rawJs <- J.moduleToJs m foreignInclude
@@ -384,9 +393,6 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
exists <- doesFileExist path
traverse (const $ getModificationTime path) $ guard exists
- readTextFile :: FilePath -> Make String
- readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
-
writeTextFile :: FilePath -> String -> Make ()
writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
mkdirp path
@@ -397,3 +403,50 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
progress :: ProgressMessage -> Make ()
progress = liftIO . putStrLn . renderProgressMessage
+
+readTextFile :: FilePath -> Make String
+readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
+
+-- |
+-- Check that the declarations in a given PureScript module match with those
+-- in its corresponding foreign module.
+--
+checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()
+checkForeignDecls m path = do
+ jsStr <- lift $ readTextFile path
+ js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path
+
+ foreignIdentsStrs <- either errorParsingModule pure $ getExps js
+ let foreignIdents =
+ either
+ (internalError . ("checkForeignDecls: unexpected idents: " ++) . show)
+ S.fromList
+ (traverse parseIdent foreignIdentsStrs)
+ let importedIdents = S.fromList $ map fst (CF.moduleForeign m)
+
+ let unusedFFI = foreignIdents S.\\ importedIdents
+ unless (null unusedFFI) $
+ tell . errorMessage . UnusedFFIImplementations mname $
+ S.toList unusedFFI
+
+ let missingFFI = importedIdents S.\\ foreignIdents
+ unless (null missingFFI) $
+ throwError . errorMessage . MissingFFIImplementations mname $
+ S.toList missingFFI
+
+ where
+ mname = CF.moduleName m
+
+ errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a
+ errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just
+
+ getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]
+ getExps = Bundle.getExportedIdentifiers (runModuleName mname)
+
+ -- TODO: Handling for parenthesised operators should be removed after 0.9.
+ parseIdent :: String -> Either String Ident
+ parseIdent str = try str <|> try ("(" ++ str ++ ")")
+ where
+ try s = either (Left . show) Right $ do
+ ts <- PSParser.lex "" s
+ PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts
diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs
index 9defab4..7043991 100644
--- a/src/Language/PureScript/Parser/JS.hs
+++ b/src/Language/PureScript/Parser/JS.hs
@@ -43,7 +43,7 @@ parseForeignModulesFromFiles files = do
foreigns <- parU files $ \(path, file) ->
case findModuleName (lines file) of
Just name -> return (name, path)
- Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path)
+ Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path Nothing)
let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns
forM_ grouped $ \grp ->
when (length grp > 1) $ do
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index d020b44..15b13aa 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -234,7 +234,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
go (ValueDeclaration name nameKind [] (Right val)) =
warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
valueIsNotDefined moduleName name
- [(_, (val', ty))] <- typesOf moduleName [(name, val)]
+ [(_, (val', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val)]
addValue moduleName name ty nameKind
return $ ValueDeclaration name nameKind [] $ Right val'
go ValueDeclaration{} = internalError "Binders were not desugared"
@@ -242,7 +242,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
for_ (map (\(ident, _, _) -> ident) vals) $ \name ->
valueIsNotDefined moduleName name
- tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
+ tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
vals' <- forM [ (name, val, nameKind, ty)
| (name, nameKind, _) <- vals
, (name', (val, ty)) <- tys
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index bd8f600..bc90c67 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -7,9 +7,10 @@
-- |
-- This module implements the type checker
--
-module Language.PureScript.TypeChecker.Types (
- typesOf
-) where
+module Language.PureScript.TypeChecker.Types
+ ( BindingGroupType(..)
+ , typesOf
+ ) where
{-
The following functions represent the corresponding type checking judgements:
@@ -59,14 +60,20 @@ import Language.PureScript.TypeChecker.Unify
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
+data BindingGroupType
+ = RecursiveBindingGroup
+ | NonRecursiveBindingGroup
+ deriving (Show, Eq, Ord)
+
-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
-- type class dictionaries and type annotations.
typesOf ::
(MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ BindingGroupType ->
ModuleName ->
[(Ident, Expr)] ->
m [(Ident, (Expr, Type))]
-typesOf moduleName vals = do
+typesOf bindingGroupType moduleName vals = do
tys <- fmap tidyUp . liftUnifyWarnings replace $ do
(untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
@@ -79,14 +86,23 @@ typesOf moduleName vals = do
let unsolvedTypeVars = nub $ unknownsInType ty
-- Generalize and constrain the type
let generalized = generalize unsolved ty
- -- Make sure any unsolved type constraints only use type variables which appear
- -- unknown in the inferred type.
+
when shouldGeneralize $ do
+ -- Show the inferred type in a warning
tell . errorMessage $ MissingTypeDeclaration ident generalized
+ -- For non-recursive binding groups, can generalize over constraints.
+ -- For recursive binding groups, we throw an error here for now.
+ when (bindingGroupType == RecursiveBindingGroup && not (null unsolved))
+ . throwError
+ . errorMessage
+ $ CannotGeneralizeRecursiveFunction ident generalized
+ -- Make sure any unsolved type constraints only use type variables which appear
+ -- unknown in the inferred type.
forM_ unsolved $ \(_, (className, classTys)) -> do
let constraintTypeVars = nub $ foldMap unknownsInType classTys
when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $
throwError . errorMessage $ NoInstanceFound className classTys
+
-- Check skolem variables did not escape their scope
skolemEscapeCheck val'
-- Check rows do not contain duplicate labels
@@ -179,7 +195,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco
g other = other
-
+
-- | Check the kind of a type, failing if it is not of kind *.
checkTypeKind ::
(MonadState CheckState m, MonadError MultipleErrors m) =>
@@ -283,8 +299,10 @@ infer' (IfThenElse cond th el) = do
cond' <- check cond tyBoolean
th'@(TypedValue _ _ thTy) <- infer th
el'@(TypedValue _ _ elTy) <- infer el
- unifyTypes thTy elTy
- return $ TypedValue True (IfThenElse cond' th' el') thTy
+ (th'', thTy') <- instantiatePolyTypeWithUnknowns th' thTy
+ (el'', elTy') <- instantiatePolyTypeWithUnknowns el' elTy
+ unifyTypes thTy' elTy'
+ return $ TypedValue True (IfThenElse cond' th'' el'') thTy'
infer' (Let ds val) = do
(ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
return $ TypedValue True (Let ds' val') valTy
diff --git a/stack-lts-5.yaml b/stack-lts-5.yaml
index 2671991..9f87d0e 100644
--- a/stack-lts-5.yaml
+++ b/stack-lts-5.yaml
@@ -3,4 +3,5 @@ packages:
- '.'
extra-deps:
- bower-json-0.8.0
+- language-javascript-0.6.0.4
flags: {}
diff --git a/stack-nightly.yaml b/stack-nightly.yaml
index c389d15..22c2f0d 100644
--- a/stack-nightly.yaml
+++ b/stack-nightly.yaml
@@ -1,5 +1,6 @@
flags: {}
packages:
- '.'
-extra-deps: []
+extra-deps:
+- language-javascript-0.6.0.4
resolver: nightly-2016-03-17
diff --git a/stack.yaml b/stack.yaml
index 2671991..9f87d0e 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -3,4 +3,5 @@ packages:
- '.'
extra-deps:
- bower-json-0.8.0
+- language-javascript-0.6.0.4
flags: {}
diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs
new file mode 100644
index 0000000..700e30e
--- /dev/null
+++ b/tests/Language/PureScript/Ide/FilterSpec.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.PureScript.Ide.FilterSpec where
+
+import Data.Text (Text)
+import Language.PureScript.Ide.Filter
+import Language.PureScript.Ide.Types
+import qualified Language.PureScript as P
+import Test.Hspec
+
+value :: Text -> ExternDecl
+value s = ValueDeclaration s P.TypeWildcard
+
+modules :: [Module]
+modules =
+ [
+ ("Module.A", [value "function1"]),
+ ("Module.B", [value "data1"]),
+ ("Module.C", [ModuleDecl "Module.C" []]),
+ ("Module.D", [Dependency "Module.C" [] Nothing, value "asd"])
+ ]
+
+runEq :: Text -> [Module]
+runEq s = runFilter (equalityFilter s) modules
+runPrefix :: Text -> [Module]
+runPrefix s = runFilter (prefixFilter s) modules
+runModule :: [ModuleIdent] -> [Module]
+runModule ms = runFilter (moduleFilter ms) modules
+runDependency :: [ModuleIdent] -> [Module]
+runDependency ms = runFilter (dependencyFilter ms) modules
+
+spec :: Spec
+spec = do
+ describe "equality Filter" $ do
+ it "removes empty modules" $
+ runEq "test" `shouldBe` []
+ it "keeps function declarations that are equal" $
+ runEq "function1" `shouldBe` [head modules]
+ -- TODO: It would be more sensible to match Constructors
+ it "keeps data declarations that are equal" $
+ runEq "data1" `shouldBe` [modules !! 1]
+ describe "prefixFilter" $ do
+ it "keeps everything on empty string" $
+ runPrefix "" `shouldBe` modules
+ it "keeps functionname prefix matches" $
+ runPrefix "fun" `shouldBe` [head modules]
+ it "keeps data decls prefix matches" $
+ runPrefix "dat" `shouldBe` [modules !! 1]
+ it "keeps module decl prefix matches" $
+ runPrefix "Mod" `shouldBe` [modules !! 2]
+ describe "moduleFilter" $ do
+ it "removes everything on empty input" $
+ runModule [] `shouldBe` []
+ it "only keeps the specified modules" $
+ runModule ["Module.A", "Module.C"] `shouldBe` [head modules, modules !! 2]
+ it "ignores modules that are not in scope" $
+ runModule ["Module.A", "Module.C", "Unknown"] `shouldBe` [head modules, modules !! 2]
+ describe "dependencyFilter" $ do
+ it "removes everything on empty input" $
+ runDependency [] `shouldBe` []
+ it "only keeps the specified modules if they have no imports" $
+ runDependency ["Module.A", "Module.B"] `shouldBe` [head modules, modules !! 1]
+ it "keeps the specified modules and their imports" $
+ runDependency ["Module.A", "Module.D"] `shouldBe` [head modules, modules !! 2, modules !! 3]
diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
new file mode 100644
index 0000000..9992819
--- /dev/null
+++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.PureScript.Ide.Imports.IntegrationSpec where
+
+import Control.Monad
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import qualified Language.PureScript.Ide.Integration as Integration
+import Test.Hspec
+
+import System.Directory
+import System.FilePath
+
+setup :: IO ()
+setup = do
+ Integration.deleteOutputFolder
+ s <- Integration.compileTestProject
+ unless s $ fail "Failed to compile .purs sources"
+ Integration.quitServer -- kill a eventually running psc-ide-server instance
+ _ <- Integration.startServer
+ mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"]
+
+teardown :: IO ()
+teardown = Integration.quitServer
+
+withSupportFiles :: (FilePath -> FilePath -> IO a) -> IO ()
+withSupportFiles test = do
+ pdir <- Integration.projectDirectory
+ let sourceFp = pdir </> "src" </> "ImportsSpec.purs"
+ outFp = pdir </> "src" </> "ImportsSpecOut.tmp"
+ Integration.deleteFileIfExists outFp
+ void $ test sourceFp outFp
+
+outputFileShouldBe :: [Text] -> IO ()
+outputFileShouldBe expectation = do
+ outFp <- (</> "src" </> "ImportsSpecOut.tmp") <$> Integration.projectDirectory
+ outRes <- TIO.readFile outFp
+ shouldBe (T.lines outRes) expectation
+
+spec :: Spec
+spec = beforeAll_ setup $ afterAll_ teardown $ describe "Adding imports" $ do
+ let
+ sourceFileSkeleton :: [Text] -> [Text]
+ sourceFileSkeleton importSection =
+ [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId = id"]
+ it "adds an implicit import" $ do
+ withSupportFiles (Integration.addImplicitImport "Prelude")
+ outputFileShouldBe (sourceFileSkeleton
+ [ "import Prelude"
+ , "import Main (id)"
+ ])
+ it "adds an explicit unqualified import" $ do
+ withSupportFiles (Integration.addImport "exportedFunction")
+ outputFileShouldBe (sourceFileSkeleton
+ [ "import ImportsSpec1 (exportedFunction)"
+ , "import Main (id)"
+ ])
+ it "adds an explicit unqualified import (type)" $ do
+ withSupportFiles (Integration.addImport "MyType")
+ outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyType)"
+ , "import Main (id)"
+ ])
+ it "adds an explicit unqualified import (parameterized type)" $ do
+ withSupportFiles (Integration.addImport "MyParamType")
+ outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyParamType)"
+ , "import Main (id)"
+ ])
+ it "adds an explicit unqualified import (typeclass)" $ do
+ withSupportFiles (Integration.addImport "ATypeClass")
+ outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (class ATypeClass)"
+ , "import Main (id)"])
+ it "adds an explicit unqualified import (dataconstructor)" $ do
+ withSupportFiles (Integration.addImport "MyJust")
+ outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyMaybe(MyJust))"
+ , "import Main (id)"])
+ it "adds an explicit unqualified import (newtype)" $ do
+ withSupportFiles (Integration.addImport "MyNewtype")
+ outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyNewtype(MyNewtype))"
+ , "import Main (id)"])
+ it "adds an explicit unqualified import (typeclass member function)" $ do
+ withSupportFiles (Integration.addImport "typeClassFun")
+ outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (typeClassFun)"
+ , "import Main (id)"])
+ it "doesn't add a newtypes constructor if only the type is exported" $ do
+ withSupportFiles (Integration.addImport "OnlyTypeExported")
+ outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (OnlyTypeExported)"
+ , "import Main (id)"])
+ it "doesn't add an import if the identifier is defined in the module itself" $ do
+ withSupportFiles (Integration.addImport "myId")
+ outputFileShouldBe (sourceFileSkeleton [ "import Main (id)"])
+ it "responds with an error if it's undecidable whether we want a type or constructor" $
+ withSupportFiles (\sourceFp outFp -> do
+ r <- Integration.addImport "SpecialCase" sourceFp outFp
+ shouldBe False (Integration.resultIsSuccess r)
+ shouldBe False =<< doesFileExist outFp)
+ it "responds with an error if the identifier cannot be found and doesn't \
+ \write to the output file" $
+ withSupportFiles (\sourceFp outFp -> do
+ r <- Integration.addImport "doesntExist" sourceFp outFp
+ shouldBe False (Integration.resultIsSuccess r)
+ shouldBe False =<< doesFileExist outFp)
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
new file mode 100644
index 0000000..36cbe25
--- /dev/null
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.PureScript.Ide.ImportsSpec where
+
+import Data.Maybe (fromJust)
+import Data.Text (Text)
+import qualified Language.PureScript as P
+import Language.PureScript.Ide.Imports
+import Language.PureScript.Ide.Types
+import Test.Hspec
+
+simpleFile :: [Text]
+simpleFile =
+ [ "module Main where"
+ , "import Prelude"
+ , ""
+ , "myFunc x y = x + y"
+ ]
+
+splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text])
+splitSimpleFile = fromRight $ sliceImportSection simpleFile
+ where
+ fromRight (Right r) = r
+ fromRight (Left _) = error "fromRight"
+
+withImports :: [Text] -> [Text]
+withImports is =
+ take 2 simpleFile ++ is ++ drop 2 simpleFile
+
+testParseImport :: Text -> Import
+testParseImport = fromJust . parseImport
+
+preludeImport, arrayImport, listImport, consoleImport, maybeImport :: Import
+preludeImport = testParseImport "import Prelude"
+arrayImport = testParseImport "import Data.Array (head, cons)"
+listImport = testParseImport "import Data.List as List"
+consoleImport = testParseImport "import Control.Monad.Eff.Console (log) as Console"
+maybeImport = testParseImport "import Data.Maybe (Maybe(Just))"
+
+spec :: Spec
+spec = do
+ describe "determining the importsection" $ do
+ let moduleSkeleton imports =
+ Right (P.moduleNameFromString "Main", take 1 simpleFile, imports, drop 2 simpleFile)
+ it "finds a simple import" $
+ shouldBe (sliceImportSection simpleFile) (moduleSkeleton [preludeImport])
+
+ it "allows multiline import statements" $
+ shouldBe
+ (sliceImportSection (withImports [ "import Data.Array (head,"
+ , " cons)"
+ ]))
+ (moduleSkeleton [preludeImport, arrayImport])
+ describe "pretty printing imports" $ do
+ it "pretty prints a simple import" $
+ shouldBe (prettyPrintImport' preludeImport) "import Prelude"
+ it "pretty prints an explicit import" $
+ shouldBe (prettyPrintImport' arrayImport) "import Data.Array (head, cons)"
+ it "pretty prints a qualified import" $
+ shouldBe (prettyPrintImport' listImport) "import Data.List as List"
+ it "pretty prints a qualified explicit import" $
+ shouldBe (prettyPrintImport' consoleImport) "import Control.Monad.Eff.Console (log) as Console"
+ it "pretty prints an import with a datatype (and PositionedRef's for the dtors)" $
+ 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' (ValueDeclaration i P.TypeWildcard) mn is)
+ addDtorImport i t mn is =
+ prettyPrintImportSection (addExplicitImport' (DataConstructor i t P.TypeWildcard) mn is)
+ it "adds an implicit unqualified import" $
+ shouldBe
+ (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))
+ [ "import Prelude"
+ , "import Data.Map"
+ ]
+ it "adds an explicit unqualified import" $
+ shouldBe
+ (addValueImport "head" (P.moduleNameFromString "Data.Array") simpleFileImports)
+ [ "import Prelude"
+ , "import Data.Array (head)"
+ ]
+ it "doesn't add an import if the containing module is imported implicitly" $
+ shouldBe
+ (addValueImport "const" (P.moduleNameFromString "Prelude") simpleFileImports)
+ ["import Prelude"]
+ 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)
+ [ "import Prelude"
+ , "import Data.Array (head, tail)"
+ ]
+ it "adds an operator to an explicit import list" $
+ shouldBe
+ (addValueImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports)
+ [ "import Prelude"
+ , "import Data.Array ((<~>), tail)"
+ ]
+ it "adds the type for a given DataConstructor" $
+ shouldBe
+ (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports)
+ [ "import Prelude"
+ , "import Data.Maybe (Maybe(Just))"
+ ]
+ it "adds a dataconstructor to an existing type import" $ do
+ let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"])
+ shouldBe
+ (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports)
+ [ "import Prelude"
+ , "import Data.Maybe (Maybe(Just))"
+ ]
+ 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" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports)
+ [ "import Prelude"
+ , "import Data.Maybe (Maybe(..))"
+ ]
+ it "doesn't add an identifier to an explicit import list if it's already imported" $
+ shouldBe
+ (addValueImport "tail" (P.moduleNameFromString "Data.Array") explicitImports)
+ [ "import Prelude"
+ , "import Data.Array (tail)"
+ ]
diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs
new file mode 100644
index 0000000..7a57662
--- /dev/null
+++ b/tests/Language/PureScript/Ide/Integration.hs
@@ -0,0 +1,238 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Ide.Integration
+-- Description : A psc-ide client for use in integration tests
+-- Copyright : Christoph Hegemann 2016
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability : experimental
+--
+-- |
+-- A psc-ide client for use in integration tests
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Language.PureScript.Ide.Integration
+ (
+ -- managing the server process
+ startServer
+ , withServer
+ , stopServer
+ , quitServer
+ -- util
+ , compileTestProject
+ , deleteOutputFolder
+ , projectDirectory
+ , deleteFileIfExists
+ -- sending commands
+ , loadModuleWithDeps
+ , getFlexCompletions
+ , getType
+ , addImport
+ , addImplicitImport
+ -- checking results
+ , resultIsSuccess
+ , parseCompletions
+ , parseTextResult
+ ) where
+
+import Control.Concurrent (threadDelay)
+import Control.Exception
+import Control.Monad (join, when)
+import Data.Aeson
+import Data.Aeson.Types
+import qualified Data.ByteString.Lazy.UTF8 as BSL
+import Data.Either (isRight)
+import Data.Maybe (fromJust)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import Language.PureScript.Ide.Util
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.Process
+
+projectDirectory :: IO FilePath
+projectDirectory = do
+ cd <- getCurrentDirectory
+ return $ cd </> "tests" </> "support" </> "pscide"
+
+startServer :: IO ProcessHandle
+startServer = do
+ pdir <- projectDirectory
+ (_, _, _, procHandle) <- createProcess $ (shell "psc-ide-server") {cwd=Just pdir}
+ threadDelay 500000 -- give the server 500ms to start up
+ return procHandle
+
+stopServer :: ProcessHandle -> IO ()
+stopServer = terminateProcess
+
+withServer :: IO a -> IO a
+withServer s = do
+ _ <- startServer
+ r <- s
+ quitServer
+ return r
+
+-- project management utils
+
+compileTestProject :: IO Bool
+compileTestProject = do
+ pdir <- projectDirectory
+ (_, _, _, procHandle) <- createProcess $
+ (shell $ "psc " ++ fileGlob) {cwd=Just pdir
+ ,std_out=CreatePipe
+ ,std_err=CreatePipe
+ }
+ isSuccess <$> waitForProcess procHandle
+
+deleteOutputFolder :: IO ()
+deleteOutputFolder = do
+ odir <- fmap (</> "output") projectDirectory
+ whenM (doesDirectoryExist odir) (removeDirectoryRecursive odir)
+
+deleteFileIfExists :: FilePath -> IO ()
+deleteFileIfExists fp = whenM (doesFileExist fp) (removeFile fp)
+
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM p f = do
+ x <- p
+ when x f
+
+isSuccess :: ExitCode -> Bool
+isSuccess ExitSuccess = True
+isSuccess (ExitFailure _) = False
+
+fileGlob :: String
+fileGlob = unwords
+ [ "\"src/**/*.purs\""
+ , "\"src/**/*.js\""
+ , "\"bower_components/purescript-*/**/*.purs\""
+ , "\"bower_components/purescript-*/**/*.js\""
+ ]
+
+-- Integration Testing API
+
+sendCommand :: Value -> IO String
+sendCommand v = readCreateProcess
+ ((shell "psc-ide-client") { std_out=CreatePipe
+ , std_err=CreatePipe
+ })
+ (T.unpack (encodeT v))
+
+quitServer :: IO ()
+quitServer = do
+ let quitCommand = object ["command" .= ("quit" :: String)]
+ _ <- try $ sendCommand quitCommand :: IO (Either SomeException String)
+ return ()
+
+loadModuleWithDeps :: String -> IO String
+loadModuleWithDeps m = sendCommand $ load [] [m]
+
+getFlexCompletions :: String -> IO [(String, String, String)]
+getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)))
+
+getType :: String -> IO [(String, String, String)]
+getType q = parseCompletions <$> sendCommand (typeC q [])
+
+addImport :: String -> FilePath -> FilePath -> IO String
+addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp)
+
+addImplicitImport :: String -> FilePath -> FilePath -> IO String
+addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp)
+
+-- Command Encoding
+
+commandWrapper :: String -> Value -> Value
+commandWrapper c p = object ["command" .= c, "params" .= p]
+
+load :: [String] -> [String] -> Value
+load ms ds = commandWrapper "load" (object ["modules" .= ms, "dependencies" .= ds])
+
+typeC :: String -> [Value] -> Value
+typeC q filters = commandWrapper "type" (object ["search" .= q, "filters" .= filters])
+
+addImportC :: String -> FilePath -> FilePath -> Value
+addImportC identifier = addImportW $
+ object [ "importCommand" .= ("addImport" :: String)
+ , "identifier" .= identifier
+ ]
+
+addImplicitImportC :: String -> FilePath -> FilePath -> Value
+addImplicitImportC mn = addImportW $
+ object [ "importCommand" .= ("addImplicitImport" :: String)
+ , "module" .= mn
+ ]
+
+addImportW :: Value -> FilePath -> FilePath -> Value
+addImportW importCommand fp outfp =
+ commandWrapper "import" (object [ "file" .= fp
+ , "outfile" .= outfp
+ , "importCommand" .= importCommand
+ ])
+
+
+completion :: [Value] -> Maybe Value -> Value
+completion filters matcher =
+ let
+ matcher' = case matcher of
+ Nothing -> []
+ Just m -> ["matcher" .= m]
+ in
+ commandWrapper "complete" (object $ "filters" .= filters : matcher')
+
+flexMatcher :: String -> Value
+flexMatcher q = object [ "matcher" .= ("flex" :: String)
+ , "params" .= object ["search" .= q]
+ ]
+
+-- Result parsing
+
+unwrapResult :: Value -> Parser (Either String Value)
+unwrapResult = withObject "result" $ \o -> do
+ (rt :: String) <- o .: "resultType"
+ case rt of
+ "error" -> do
+ res <- o .: "result"
+ pure (Left res)
+ "success" -> do
+ res <- o .: "result"
+ pure (Right res)
+ _ -> fail "lol"
+
+withResult :: (Value -> Parser a) -> Value -> Parser (Either String a)
+withResult p v = do
+ r <- unwrapResult v
+ case r of
+ Left err -> pure (Left err)
+ Right res -> Right <$> p res
+
+completionParser :: Value -> Parser [(String, String, String)]
+completionParser = withArray "res" $ \cs ->
+ mapM (withObject "completion" $ \o -> do
+ ident <- o .: "identifier"
+ module' <- o .: "module"
+ ty <- o .: "type"
+ pure (module', ident, ty)) (V.toList cs)
+
+valueFromString :: String -> Value
+valueFromString = fromJust . decode . BSL.fromString
+
+resultIsSuccess :: String -> Bool
+resultIsSuccess = isRight . join . parseEither unwrapResult . valueFromString
+
+parseCompletions :: String -> [(String, String, String)]
+parseCompletions s = fromJust $ do
+ cs <- parseMaybe (withResult completionParser) (valueFromString s)
+ case cs of
+ Left _ -> error "Failed to parse completions"
+ Right cs' -> pure cs'
+
+parseTextResult :: String -> String
+parseTextResult s = fromJust $ do
+ r <- parseMaybe (withResult (withText "tr" pure)) (valueFromString s)
+ case r of
+ Left _ -> error "Failed to parse textResult"
+ Right r' -> pure (T.unpack r')
diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs
new file mode 100644
index 0000000..13cef33
--- /dev/null
+++ b/tests/Language/PureScript/Ide/MatcherSpec.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.PureScript.Ide.MatcherSpec where
+
+import Data.Text (Text)
+import Language.PureScript.Ide.Integration
+import Language.PureScript.Ide.Matcher
+import Language.PureScript.Ide.Types
+import qualified Language.PureScript as P
+import Test.Hspec
+
+value :: Text -> ExternDecl
+value s = ValueDeclaration s P.TypeWildcard
+
+completions :: [Match]
+completions = [
+ Match "" $ value "firstResult",
+ Match "" $ value "secondResult",
+ Match "" $ value "fiult"
+ ]
+
+mkResult :: [Int] -> [Match]
+mkResult = map (completions !!)
+
+runFlex :: Text -> [Match]
+runFlex s = runMatcher (flexMatcher s) completions
+
+setup :: IO ()
+setup = do
+ deleteOutputFolder
+ _ <- compileTestProject
+ _ <- startServer
+ _ <- loadModuleWithDeps "Main"
+ return ()
+
+teardown :: IO ()
+teardown = quitServer
+
+spec :: Spec
+spec = do
+ describe "Flex Matcher" $ do
+ it "doesn't match on an empty string" $
+ runFlex "" `shouldBe` []
+ it "matches on equality" $
+ runFlex "firstResult" `shouldBe` mkResult [0]
+ it "scores short matches higher and sorts accordingly" $
+ runFlex "filt" `shouldBe` mkResult [2, 0]
+
+ beforeAll_ setup $ afterAll_ teardown $
+ describe "Integration Tests: Flex Matcher" $ do
+ it "doesn't match on an empty string" $ do
+ cs <- getFlexCompletions ""
+ cs `shouldBe` []
+ it "matches on equality" $ do
+ cs <- getFlexCompletions "const"
+ cs `shouldBe` [("Main", "const", "forall a b. a -> b -> a")]
diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs
new file mode 100644
index 0000000..42d28f0
--- /dev/null
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.PureScript.Ide.ReexportsSpec where
+
+import Control.Exception (evaluate)
+import Data.List (sort)
+import qualified Data.Map as Map
+import Language.PureScript.Ide.Reexports
+import Language.PureScript.Ide.Types
+import qualified Language.PureScript as P
+import Test.Hspec
+
+decl1 :: ExternDecl
+decl1 = ValueDeclaration "filter" P.TypeWildcard
+decl2 :: ExternDecl
+decl2 = ValueDeclaration "map" P.TypeWildcard
+decl3 :: ExternDecl
+decl3 = ValueDeclaration "catMaybe" P.TypeWildcard
+dep1 :: ExternDecl
+dep1 = Dependency "Test.Foo" [] (Just "T")
+dep2 :: ExternDecl
+dep2 = Dependency "Test.Bar" [] (Just "T")
+
+circularModule :: Module
+circularModule = ("Circular", [Export "Circular"])
+
+module1 :: Module
+module1 = ("Module1", [Export "Module2", Export "Module3", decl1])
+
+module2 :: Module
+module2 = ("Module2", [decl2])
+
+module3 :: Module
+module3 = ("Module3", [decl3])
+
+module4 :: Module
+module4 = ("Module4", [Export "T", decl1, dep1, dep2])
+
+result :: Module
+result = ("Module1", [decl1, decl2, Export "Module3"])
+
+db :: Map.Map ModuleIdent [ExternDecl]
+db = Map.fromList [module1, module2, module3]
+
+shouldBeEqualSorted :: Module -> Module -> Expectation
+shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2)
+
+spec :: Spec
+spec =
+ describe "Reexports" $ do
+ it "finds all reexports" $
+ getReexports module1 `shouldBe` [Export "Module2", Export "Module3"]
+
+ it "replaces a reexport with another module" $
+ replaceReexport (Export "Module2") module1 module2 `shouldBeEqualSorted` result
+
+ it "adds another module even if there is no export statement" $
+ replaceReexport (Export "Module2") ("Module1", [decl1, Export "Module3"]) module2
+ `shouldBeEqualSorted` result
+
+ it "only adds a declaration once" $
+ let replaced = replaceReexport (Export "Module2") module1 module2
+ in replaceReexport (Export "Module2") replaced module2 `shouldBeEqualSorted` result
+
+ it "should error when given a non-Export to replace" $
+ evaluate (replaceReexport decl1 module1 module2)
+ `shouldThrow` errorCall "Should only get Exports here."
+ it "replaces all Exports with their corresponding declarations" $
+ replaceReexports module1 db `shouldBe` ("Module1", [decl1, decl2, decl3])
+
+ it "does not list itself as a reexport" $
+ getReexports circularModule `shouldBe` []
+
+ it "does not include circular references when replacing reexports" $
+ replaceReexports circularModule (uncurry Map.singleton circularModule )
+ `shouldBe` ("Circular", [])
+
+ it "replaces exported aliases with imported module" $
+ getReexports module4 `shouldBe` [Export "Test.Foo", Export "Test.Bar"]
diff --git a/tests/Language/PureScript/IdeSpec.hs b/tests/Language/PureScript/IdeSpec.hs
new file mode 100644
index 0000000..83533f1
--- /dev/null
+++ b/tests/Language/PureScript/IdeSpec.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.PureScript.IdeSpec where
+
+import Control.Concurrent.STM
+import Control.Monad.Reader
+import Data.List
+import qualified Data.Map as Map
+import Language.PureScript.Ide
+import Language.PureScript.Ide.Types
+import Test.Hspec
+
+testState :: PscIdeState
+testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) Map.empty
+
+defaultConfig :: Configuration
+defaultConfig =
+ Configuration
+ {
+ confOutputPath = "output/"
+ , confDebug = False
+ }
+
+spec :: SpecWith ()
+spec =
+ describe "list" $
+ describe "loadedModules" $ do
+ it "returns an empty list when no modules are loaded" $ do
+ st <- newTVarIO emptyPscIdeState
+ result <- runReaderT printModules (PscIdeEnvironment st defaultConfig)
+ result `shouldBe` ModuleList []
+ it "returns the list of loaded modules" $ do
+ st <- newTVarIO testState
+ ModuleList result <- runReaderT printModules (PscIdeEnvironment st defaultConfig)
+ sort result `shouldBe` sort ["Data.Array", "Control.Monad.Eff"]
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 91bdf52..1af8bd4 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -17,6 +17,7 @@ import System.Exit
import qualified Language.PureScript as P
import qualified Language.PureScript.Docs as Docs
+import Language.PureScript.Docs.AsMarkdown (codeToString)
import qualified Language.PureScript.Publish as Publish
import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
@@ -59,6 +60,10 @@ data Assertion
-- | Assert that a particular value declaration exists, and its type
-- satisfies the given predicate.
| ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (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
+ | TypeSynonymShouldRenderAs P.ModuleName String String
deriving (Show)
newtype ShowFn a = ShowFn a
@@ -85,6 +90,9 @@ data AssertionFailure
-- should have been.
-- Fields: module name, declaration name, actual type.
| ValueDeclarationWrongType P.ModuleName String P.Type
+ -- | A Type synonym has been rendered in an unexpected format
+ -- Fields: module name, declaration name, expected rendering, actual rendering
+ | TypeSynonymMismatch P.ModuleName String String String
deriving (Show)
data AssertionResult
@@ -149,6 +157,21 @@ runAssertion assertion Docs.Module{..} =
Fail (WrongDeclarationType mn decl "value"
(Docs.declInfoToString declInfo))
+ TypeSynonymShouldRenderAs mn decl expected ->
+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
+ Nothing ->
+ Fail (NotDocumented mn decl)
+ Just Docs.Declaration{..} ->
+ case declInfo of
+ Docs.TypeSynonymDeclaration [] ty ->
+ let actual = codeToString (Docs.renderType ty) in
+ if actual == expected
+ then Pass
+ else Fail (TypeSynonymMismatch mn decl expected actual)
+ _ ->
+ Fail (WrongDeclarationType mn decl "synonym"
+ (Docs.declInfoToString declInfo))
+
where
declarationsFor mn =
if mn == modName
@@ -261,6 +284,13 @@ testCases =
, ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
, ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
])
+
+ , ("ConstrainedArgument",
+ [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a"
+ , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a"
+ , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a"
+ , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a"
+ ])
]
where
diff --git a/tests/support/pscide/src/ImportsSpec.purs b/tests/support/pscide/src/ImportsSpec.purs
new file mode 100644
index 0000000..04a7227
--- /dev/null
+++ b/tests/support/pscide/src/ImportsSpec.purs
@@ -0,0 +1,5 @@
+module ImportsSpec where
+
+import Main (id)
+
+myId = id
diff --git a/tests/support/pscide/src/ImportsSpec1.purs b/tests/support/pscide/src/ImportsSpec1.purs
new file mode 100644
index 0000000..098a55d
--- /dev/null
+++ b/tests/support/pscide/src/ImportsSpec1.purs
@@ -0,0 +1,32 @@
+module ImportsSpec1
+ ( exportedFunction
+ , MyType
+ , MyParamType
+ , MyNewtype(..)
+ , MyMaybe(..)
+ , SpecialCase
+ , X(..)
+ , class ATypeClass
+ , typeClassFun
+ , OnlyTypeExported
+ )
+ where
+
+exportedFunction ∷ ∀ a. a → a
+exportedFunction x = x
+
+type MyType = String
+
+type MyParamType a = Array a
+
+newtype MyNewtype = MyNewtype String
+
+data MyMaybe a = MyJust a | MyNothing
+
+data SpecialCase
+data X = SpecialCase
+
+newtype OnlyTypeExported = OnlyTypeExported String
+
+class ATypeClass a where
+ typeClassFun ∷ a -> a
diff --git a/tests/support/pscide/src/Main.purs b/tests/support/pscide/src/Main.purs
new file mode 100644
index 0000000..ca67938
--- /dev/null
+++ b/tests/support/pscide/src/Main.purs
@@ -0,0 +1,7 @@
+module Main where
+
+id :: forall a. a -> a
+id x = x
+
+const :: forall a b. a -> b -> a
+const x _ = x