summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorPhilFreeman <>2017-03-25 21:11:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-03-25 21:11:00 (GMT)
commit56e4970922335ff5327c52d4f09624f9215e23da (patch)
treecd2ec701c4419d6adef868f5402c6444882f3c37 /tests
parent4192e9fef6d391884ce009b1a318b31f4ff93572 (diff)
version 0.11.00.11.0
Diffstat (limited to 'tests')
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs39
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs29
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/StateSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/Test.hs8
-rw-r--r--tests/TestDocs.hs14
-rw-r--r--tests/TestPscPublish.hs10
-rw-r--r--tests/TestPsci.hs126
-rw-r--r--tests/TestPsci/CommandTest.hs35
-rw-r--r--tests/TestPsci/CompletionTest.hs108
-rw-r--r--tests/TestPsci/TestEnv.hs81
-rw-r--r--tests/TestUtils.hs2
-rw-r--r--tests/support/bower.json29
-rw-r--r--tests/support/prelude-resolutions.json7
14 files changed, 328 insertions, 164 deletions
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index ce90f93..b4aabeb 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -14,6 +14,13 @@ import Language.PureScript.Ide.Types
import System.FilePath
import Test.Hspec
+noImportsFile :: [Text]
+noImportsFile =
+ [ "module Main where"
+ , ""
+ , "myFunc x y = x + y"
+ ]
+
simpleFile :: [Text]
simpleFile =
[ "module Main where"
@@ -22,6 +29,14 @@ simpleFile =
, "myFunc x y = x + y"
]
+syntaxErrorFile :: [Text]
+syntaxErrorFile =
+ [ "module Main where"
+ , "import Prelude"
+ , ""
+ , "myFunc ="
+ ]
+
splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text])
splitSimpleFile = fromRight (sliceImportSection simpleFile)
where
@@ -49,6 +64,14 @@ spec = do
describe "determining the importsection" $ do
let moduleSkeleton imports =
Right (P.moduleNameFromString "Main", take 1 simpleFile, imports, drop 2 simpleFile)
+ it "slices a file without imports and adds a newline after the module declaration" $
+ shouldBe (sliceImportSection noImportsFile)
+ (Right (P.moduleNameFromString "Main", take 1 noImportsFile ++ [""], [], drop 1 noImportsFile))
+
+ it "handles a file with syntax errors just fine" $
+ shouldBe (sliceImportSection syntaxErrorFile)
+ (Right (P.moduleNameFromString "Main", take 1 syntaxErrorFile, [preludeImport], drop 2 syntaxErrorFile))
+
it "finds a simple import" $
shouldBe (sliceImportSection simpleFile) (moduleSkeleton [preludeImport])
@@ -58,6 +81,14 @@ spec = do
, " cons)"
]))
(moduleSkeleton [preludeImport, arrayImport])
+ it "allows multiline import statements with hanging parens" $
+ 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"
@@ -80,12 +111,20 @@ spec = do
prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is)
addTypeImport i mn is =
prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.kindType)) mn is)
+ it "adds an implicit unqualified import to a file without any imports" $
+ shouldBe
+ (addImplicitImport' [] (P.moduleNameFromString "Data.Map"))
+ ["import Data.Map"]
it "adds an implicit unqualified import" $
shouldBe
(addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))
[ "import Prelude"
, "import Data.Map"
]
+ it "adds an explicit unqualified import to a file without any imports" $
+ shouldBe
+ (addValueImport "head" (P.moduleNameFromString "Data.Array") [])
+ ["import Data.Array (head)"]
it "adds an explicit unqualified import" $
shouldBe
(addValueImport "head" (P.moduleNameFromString "Data.Array") simpleFileImports)
diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs
index c260c4e..c810af8 100644
--- a/tests/Language/PureScript/Ide/ReexportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -18,6 +18,9 @@ m = P.moduleNameFromString
d :: IdeDeclaration -> IdeDeclarationAnn
d = IdeDeclarationAnn emptyAnn
+exportedFrom :: Text -> IdeDeclarationAnn -> IdeDeclarationAnn
+exportedFrom mn (IdeDeclarationAnn ann decl) = IdeDeclarationAnn (ann {_annExportedFrom = Just (m mn)}) decl
+
valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn
valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty))
typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.kindType))
@@ -32,34 +35,34 @@ env = Map.fromList
type Refs = [(P.ModuleName, P.DeclarationRef)]
-succTestCases :: [(Text, [IdeDeclarationAnn], Refs, [IdeDeclarationAnn])]
+succTestCases :: [(Text, Refs, [IdeDeclarationAnn])]
succTestCases =
- [ ("resolves a value reexport", [], [(m "A", P.ValueRef (P.Ident "valueA"))], [valueA])
+ [ ("resolves a value reexport", [(m "A", P.ValueRef (P.Ident "valueA"))], [exportedFrom "A" valueA])
, ("resolves a type reexport with explicit data constructors"
- , [], [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA, dtorA1])
+ , [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [exportedFrom "A" typeA, exportedFrom "A" dtorA1])
, ("resolves a type reexport with implicit data constructors"
- , [], [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], [typeA, dtorA1, dtorA2])
- , ("resolves a class reexport", [], [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], [classA])
+ , [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], map (exportedFrom "A") [typeA, dtorA1, dtorA2])
+ , ("resolves a class reexport", [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], [exportedFrom "A" classA])
]
-failTestCases :: [(Text, [IdeDeclarationAnn], Refs)]
+failTestCases :: [(Text, Refs)]
failTestCases =
- [ ("fails to resolve a non existing value", [], [(m "A", P.ValueRef (P.Ident "valueB"))])
- , ("fails to resolve a non existing type reexport" , [], [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)])
- , ("fails to resolve a non existing class reexport", [], [(m "A", P.TypeClassRef (P.ProperName "ClassB"))])
+ [ ("fails to resolve a non existing value", [(m "A", P.ValueRef (P.Ident "valueB"))])
+ , ("fails to resolve a non existing type reexport" , [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)])
+ , ("fails to resolve a non existing class reexport", [(m "A", P.TypeClassRef (P.ProperName "ClassB"))])
]
spec :: Spec
spec = do
describe "Successful Reexports" $
- for_ succTestCases $ \(desc, initial, refs, result) ->
+ for_ succTestCases $ \(desc, refs, result) ->
it (toS desc) $ do
- let reResult = resolveReexports' env initial refs
+ let reResult = resolveReexports' env refs
reResolved reResult `shouldBe` result
reResult `shouldSatisfy` not . reexportHasFailures
describe "Failed Reexports" $
- for_ failTestCases $ \(desc, initial, refs) ->
+ for_ failTestCases $ \(desc, refs) ->
it (toS desc) $ do
- let reResult = resolveReexports' env initial refs
+ let reResult = resolveReexports' env refs
reFailed reResult `shouldBe` refs
reResult `shouldSatisfy` reexportHasFailures
diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs
index e680c99..6c760aa 100644
--- a/tests/Language/PureScript/Ide/SourceFileSpec.hs
+++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs
@@ -18,7 +18,7 @@ span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3)
typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration
typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty
-value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left [])
+value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] []
synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty
class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] []
class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] []
diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs
index a4a546a..ac31866 100644
--- a/tests/Language/PureScript/Ide/StateSpec.hs
+++ b/tests/Language/PureScript/Ide/StateSpec.hs
@@ -67,6 +67,8 @@ ef = P.ExternsFile
mempty
-- }
]
+ --, efSourceSpan =
+ (P.internalModuleSourceSpan "<tests>")
-- }
moduleMap :: ModuleMap [IdeDeclarationAnn]
diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs
index 5d3841b..8feb9e2 100644
--- a/tests/Language/PureScript/Ide/Test.hs
+++ b/tests/Language/PureScript/Ide/Test.hs
@@ -47,13 +47,13 @@ ann :: IdeDeclarationAnn -> Annotation -> IdeDeclarationAnn
ann (IdeDeclarationAnn _ d) a = IdeDeclarationAnn a d
annLoc :: IdeDeclarationAnn -> P.SourceSpan -> IdeDeclarationAnn
-annLoc (IdeDeclarationAnn a d) loc = IdeDeclarationAnn a {annLocation = Just loc} d
+annLoc (IdeDeclarationAnn a d) loc = IdeDeclarationAnn a {_annLocation = Just loc} d
annExp :: IdeDeclarationAnn -> P.ModuleName -> IdeDeclarationAnn
-annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {annExportedFrom = Just e} d
+annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {_annExportedFrom = Just e} d
annTyp :: IdeDeclarationAnn -> P.Type -> IdeDeclarationAnn
-annTyp (IdeDeclarationAnn a d) ta = IdeDeclarationAnn a {annTypeAnnotation = Just ta} d
+annTyp (IdeDeclarationAnn a d) ta = IdeDeclarationAnn a {_annTypeAnnotation = Just ta} d
ida :: IdeDeclaration -> IdeDeclarationAnn
@@ -112,7 +112,7 @@ inProject f = do
compileTestProject :: IO Bool
compileTestProject = inProject $ do
(_, _, _, procHandle) <-
- createProcess $ (shell $ "psc \"src/**/*.purs\"")
+ createProcess $ (shell $ "purs compile \"src/**/*.purs\"")
r <- tryNTimes 10 (getProcessExitCode procHandle)
pure (fromMaybe False (isSuccess <$> r))
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 8c6abaf..34863ea 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -42,7 +42,7 @@ publishOpts = Publish.defaultPublishOptions
main :: IO ()
main = pushd "examples/docs" $ do
- res <- Publish.preparePackage publishOpts
+ res <- Publish.preparePackage "bower.json" "resolutions.json" publishOpts
case res of
Left e -> Publish.printErrorToStdout e >> exitFailure
Right pkg@Docs.Package{..} ->
@@ -276,12 +276,10 @@ runAssertion assertion linksCtx Docs.Module{..} =
checkConstrained :: P.Type -> Text -> Bool
checkConstrained ty tyClass =
- -- Note that we don't recurse on ConstrainedType if none of the constraints
- -- match; this is by design, as constraints should be moved to the front
- -- anyway.
case ty of
- P.ConstrainedType cs _ | any (matches tyClass) cs ->
- True
+ P.ConstrainedType c ty'
+ | matches tyClass c -> True
+ | otherwise -> checkConstrained ty' tyClass
P.ForAll _ ty' _ ->
checkConstrained ty' tyClass
_ ->
@@ -385,8 +383,8 @@ testCases =
, ("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"
+ , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. (Partial => Partial => a) -> a"
+ , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. (Foo a => Foo b => a) -> a"
])
, ("TypeOpAliases",
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
index a97ca1f..89c6f4c 100644
--- a/tests/TestPscPublish.hs
+++ b/tests/TestPscPublish.hs
@@ -18,7 +18,9 @@ import Language.PureScript.Publish.ErrorsWarnings as Publish
import TestUtils
main :: IO ()
-main = testPackage "tests/support/bower_components/purescript-prelude"
+main = testPackage
+ "tests/support/bower_components/purescript-prelude"
+ "../../prelude-resolutions.json"
data TestResult
= ParseFailed String
@@ -47,9 +49,9 @@ testRunOptions = defaultPublishOptions
-- | Given a directory which contains a package, produce JSON from it, and then
-- | attempt to parse it again, and ensure that it doesn't change.
-testPackage :: String -> IO ()
-testPackage dir = pushd dir $ do
- res <- preparePackage testRunOptions
+testPackage :: FilePath -> FilePath -> IO ()
+testPackage dir resolutionsFile = pushd dir $ do
+ res <- preparePackage "bower.json" resolutionsFile testRunOptions
case res of
Left e -> preparePackageError e
Right package -> case roundTrip package of
diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs
index 65c7173..cf40aa5 100644
--- a/tests/TestPsci.hs
+++ b/tests/TestPsci.hs
@@ -1,32 +1,15 @@
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
module TestPsci where
import Prelude ()
import Prelude.Compat
-import Control.Monad.Trans.State.Strict (evalStateT)
import Control.Monad (when)
-
-import Data.List (sort)
-import qualified Data.Text as T
-
import System.Exit (exitFailure)
-import System.Console.Haskeline
-import System.FilePath ((</>))
-import System.Directory (getCurrentDirectory)
-import qualified System.FilePath.Glob as Glob
-
import Test.HUnit
-
-import qualified Language.PureScript as P
-
-import Language.PureScript.Interactive.Module (loadAllModules)
-import Language.PureScript.Interactive.Completion
-import Language.PureScript.Interactive.Types
-
-import TestUtils (supportModules)
+import TestPsci.CommandTest (commandTests)
+import TestPsci.CompletionTest (completionTests)
main :: IO ()
main = do
@@ -34,105 +17,6 @@ main = do
when (errors + failures > 0) exitFailure
allTests :: Test
-allTests = completionTests
-
-completionTests :: Test
-completionTests =
- TestLabel "completionTests"
- (TestList (map (TestCase . assertCompletedOk) completionTestData))
-
--- If the cursor is at the right end of the line, with the 1st element of the
--- pair as the text in the line, then pressing tab should offer all the
--- elements of the list (which is the 2nd element) as completions.
-completionTestData :: [(String, [String])]
-completionTestData =
- -- basic directives
- [ (":h", [":help"])
- , (":re", [":reset"])
- , (":q", [":quit"])
- , (":b", [":browse"])
-
- -- :browse should complete module names
- , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
- , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
-
- -- import should complete module names
- , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
- , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
-
- -- :quit, :help, :reset should not complete
- , (":help ", [])
- , (":quit ", [])
- , (":reset ", [])
-
- -- :show should complete to "loaded" and "import"
- , (":show ", [":show import", ":show loaded"])
- , (":show a", [])
-
- -- :type should complete values and data constructors in scope
- , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log", ":type Control.Monad.Eff.Console.logShow"])
- --, (":type uni", [":type unit"])
- --, (":type E", [":type EQ"])
-
- -- :kind should complete types in scope
- --, (":kind C", [":kind Control.Monad.Eff.Pure"])
- --, (":kind O", [":kind Ordering"])
-
- -- Only one argument for directives should be completed
- , (":show import ", [])
- , (":type EQ ", [])
- , (":kind Ordering ", [])
-
- -- a few other import tests
- , ("impor", ["import"])
- , ("import ", map ("import " ++) supportModules)
- , ("import Prelude ", [])
-
- -- String and number literals should not be completed
- , ("\"hi", [])
- , ("34", [])
-
- -- Identifiers and data constructors should be completed
- --, ("uni", ["unit"])
- , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"])
- --, ("G", ["GT"])
- , ("Data.Ordering.L", ["Data.Ordering.LT"])
-
- -- if a module is imported qualified, values should complete under the
- -- qualified name, as well as the original name.
- , ("ST.new", ["ST.newSTRef"])
- , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])
- ]
-
-assertCompletedOk :: (String, [String]) -> Assertion
-assertCompletedOk (line, expecteds) = do
- (unusedR, completions) <- runCM (completion' (reverse line, ""))
- let unused = reverse unusedR
- let actuals = map ((unused ++) . replacement) completions
- sort expecteds @=? sort actuals
-
-runCM :: CompletionM a -> IO a
-runCM act = do
- psciState <- getPSCiState
- evalStateT (liftCompletionM act) psciState
-
-getPSCiState :: IO PSCiState
-getPSCiState = do
- cwd <- getCurrentDirectory
- let supportDir = cwd </> "tests" </> "support" </> "bower_components"
- let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir
- pursFiles <- supportFiles "purs"
-
- modulesOrFirstError <- loadAllModules pursFiles
- case modulesOrFirstError of
- Left err ->
- print err >> exitFailure
- Right modules ->
- let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)]
- dummyExterns = P.internalError "TestPsci: dummyExterns should not be used"
- in return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns)))
-
-controlMonadSTasST :: ImportedModule
-controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
- where
- s = P.moduleNameFromString . T.pack
+allTests = TestList [ completionTests
+ , commandTests
+ ]
diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs
new file mode 100644
index 0000000..543a844
--- /dev/null
+++ b/tests/TestPsci/CommandTest.hs
@@ -0,0 +1,35 @@
+module TestPsci.CommandTest where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.Trans.RWS.Strict (get)
+import Language.PureScript.Interactive
+import Test.HUnit
+import TestPsci.TestEnv
+
+commandTests :: Test
+commandTests = TestLabel "commandTests" $ TestList $ map (TestCase . execTestPSCi)
+ [ do
+ run "import Prelude"
+ run "import Data.Functor"
+ run "import Control.Monad"
+ before <- psciImportedModules <$> get
+ length before `equalsTo` 3
+ run ":clear"
+ after <- psciImportedModules <$> get
+ length after `equalsTo` 0
+ , do
+ run "import Prelude"
+ run "import Data.Functor"
+ run "import Control.Monad"
+ before <- psciImportedModules <$> get
+ length before `equalsTo` 3
+ run ":reload"
+ after <- psciImportedModules <$> get
+ length after `equalsTo` 3
+ , do
+ run "import Prelude"
+ run "import Data.Array"
+ "let fac n = foldl mul 1 (1..n) in fac 10" `evaluatesTo` "3628800"
+ ]
diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs
new file mode 100644
index 0000000..6ffb486
--- /dev/null
+++ b/tests/TestPsci/CompletionTest.hs
@@ -0,0 +1,108 @@
+module TestPsci.CompletionTest where
+
+import Prelude ()
+import Prelude.Compat
+
+import Test.HUnit
+
+import Control.Monad.Trans.State.Strict (evalStateT)
+import Data.List (sort)
+import qualified Data.Text as T
+import qualified Language.PureScript as P
+import Language.PureScript.Interactive
+import System.Console.Haskeline
+import TestPsci.TestEnv (initTestPSCiEnv)
+import TestUtils (supportModules)
+
+completionTests :: Test
+completionTests =
+ TestLabel "completionTests"
+ (TestList (map (TestCase . assertCompletedOk) completionTestData))
+
+-- If the cursor is at the right end of the line, with the 1st element of the
+-- pair as the text in the line, then pressing tab should offer all the
+-- elements of the list (which is the 2nd element) as completions.
+completionTestData :: [(String, [String])]
+completionTestData =
+ -- basic directives
+ [ (":h", [":help"])
+ , (":r", [":reload"])
+ , (":c", [":clear"])
+ , (":q", [":quit"])
+ , (":b", [":browse"])
+
+ -- :browse should complete module names
+ , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
+ , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
+
+ -- import should complete module names
+ , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
+ , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
+
+ -- :quit, :help, :reload, :clear should not complete
+ , (":help ", [])
+ , (":quit ", [])
+ , (":reload ", [])
+ , (":clear ", [])
+
+ -- :show should complete to "loaded" and "import"
+ , (":show ", [":show import", ":show loaded"])
+ , (":show a", [])
+
+ -- :type should complete values and data constructors in scope
+ , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log", ":type Control.Monad.Eff.Console.logShow"])
+ --, (":type uni", [":type unit"])
+ --, (":type E", [":type EQ"])
+
+ -- :kind should complete types in scope
+ --, (":kind C", [":kind Control.Monad.Eff.Pure"])
+ --, (":kind O", [":kind Ordering"])
+
+ -- Only one argument for directives should be completed
+ , (":show import ", [])
+ , (":type EQ ", [])
+ , (":kind Ordering ", [])
+
+ -- a few other import tests
+ , ("impor", ["import"])
+ , ("import ", map ("import " ++) supportModules)
+ , ("import Prelude ", [])
+
+ -- String and number literals should not be completed
+ , ("\"hi", [])
+ , ("34", [])
+
+ -- Identifiers and data constructors should be completed
+ --, ("uni", ["unit"])
+ , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"])
+ --, ("G", ["GT"])
+ , ("Data.Ordering.L", ["Data.Ordering.LT"])
+
+ -- if a module is imported qualified, values should complete under the
+ -- qualified name, as well as the original name.
+ , ("ST.new", ["ST.newSTRef"])
+ , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])
+ ]
+
+assertCompletedOk :: (String, [String]) -> Assertion
+assertCompletedOk (line, expecteds) = do
+ (unusedR, completions) <- runCM (completion' (reverse line, ""))
+ let unused = reverse unusedR
+ let actuals = map ((unused ++) . replacement) completions
+ sort expecteds @=? sort actuals
+
+runCM :: CompletionM a -> IO a
+runCM act = do
+ psciState <- getPSCiStateForCompletion
+ evalStateT (liftCompletionM act) psciState
+
+getPSCiStateForCompletion :: IO PSCiState
+getPSCiStateForCompletion = do
+ (PSCiState _ bs es, _) <- initTestPSCiEnv
+ let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)]
+ return $ PSCiState imports bs es
+
+controlMonadSTasST :: ImportedModule
+controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
+ where
+ s = P.moduleNameFromString . T.pack
diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs
new file mode 100644
index 0000000..35ae45d
--- /dev/null
+++ b/tests/TestPsci/TestEnv.hs
@@ -0,0 +1,81 @@
+module TestPsci.TestEnv where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.RWS.Strict (evalRWST, RWST)
+import qualified Language.PureScript as P
+import Language.PureScript.Interactive
+import System.Directory (getCurrentDirectory)
+import System.Exit
+import System.FilePath ((</>))
+import qualified System.FilePath.Glob as Glob
+import System.Process (readProcessWithExitCode)
+import Test.HUnit ((@?=))
+
+-- | A monad transformer for handle PSCi actions in tests
+type TestPSCi a = RWST PSCiConfig () PSCiState IO a
+
+-- | Initialise PSCi state and config for tests
+initTestPSCiEnv :: IO (PSCiState, PSCiConfig)
+initTestPSCiEnv = do
+ -- Load test support packages
+ cwd <- getCurrentDirectory
+ let supportDir = cwd </> "tests" </> "support" </> "bower_components"
+ let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir
+ pursFiles <- supportFiles "purs"
+ modulesOrError <- loadAllModules pursFiles
+ case modulesOrError of
+ Left err ->
+ print err >> exitFailure
+ Right modules -> do
+ -- Make modules
+ makeResultOrError <- runMake . make $ modules
+ case makeResultOrError of
+ Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
+ Right (externs, env) ->
+ return (PSCiState [] [] (zip (map snd modules) externs), PSCiConfig pursFiles env)
+
+-- | Execute a TestPSCi, returning IO
+execTestPSCi :: TestPSCi a -> IO a
+execTestPSCi i = do
+ (s, c) <- initTestPSCiEnv -- init state and config
+ fst <$> evalRWST i c s
+
+-- | Evaluate JS to which a PSCi input is compiled. The actual JS input is not
+-- needed as an argument, as it is already written in the file during the
+-- command evaluation.
+jsEval :: TestPSCi String
+jsEval = liftIO $ do
+ writeFile indexFile "require('$PSCI')['$main']();"
+ process <- findNodeProcess
+ result <- traverse (\node -> readProcessWithExitCode node [indexFile] "") process
+ case result of
+ Just (ExitSuccess, out, _) -> return out
+ Just (ExitFailure _, _, err) -> putStrLn err >> exitFailure
+ Nothing -> putStrLn "Couldn't find node.js" >> exitFailure
+
+-- | Run a PSCi command and evaluate the output with 'eval'.
+runAndEval :: String -> TestPSCi () -> TestPSCi ()
+runAndEval comm eval =
+ case parseCommand comm of
+ Left errStr -> liftIO $ putStrLn errStr >> exitFailure
+ Right command ->
+ -- the JS result can be ignored, as it's already written in a source file
+ -- for the detail, please refer to Interactive.hs
+ handleCommand (\_ -> eval) (return ()) command
+
+-- | Run a PSCi command and ignore the output
+run :: String -> TestPSCi ()
+run comm = runAndEval comm $ jsEval *> return ()
+
+-- | A lifted evaluation of HUnit '@?=' for the TestPSCi
+equalsTo :: (Eq a, Show a) => a -> a -> TestPSCi ()
+equalsTo x y = liftIO $ x @?= y
+
+-- | An assertion to check if a command evaluates to a string
+evaluatesTo :: String -> String -> TestPSCi ()
+evaluatesTo command expected = runAndEval command $ do
+ actual <- jsEval
+ actual `equalsTo` (expected ++ "\n")
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index ef9bbb5..3e04f69 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -105,6 +105,7 @@ supportModules =
, "Data.Functor.Invariant"
, "Data.Generic"
, "Data.Generic.Rep"
+ , "Data.Generic.Rep.Bounded"
, "Data.Generic.Rep.Eq"
, "Data.Generic.Rep.Monoid"
, "Data.Generic.Rep.Ord"
@@ -146,6 +147,7 @@ supportModules =
, "Data.Unfoldable"
, "Data.Unit"
, "Data.Void"
+ , "PSCI.Support"
, "Partial"
, "Partial.Unsafe"
, "Prelude"
diff --git a/tests/support/bower.json b/tests/support/bower.json
index aef7751..bae32d6 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -1,18 +1,21 @@
{
"name": "purescript-test-suite-support",
"dependencies": {
- "purescript-assert": "2.0.0",
- "purescript-console": "2.0.0",
- "purescript-eff": "2.0.0",
- "purescript-functions": "2.0.0",
- "purescript-prelude": "2.1.0",
- "purescript-st": "2.0.0",
- "purescript-partial": "1.1.2",
- "purescript-newtype": "1.1.0",
- "purescript-generics": "3.3.0",
- "purescript-generics-rep": "4.0.0",
- "purescript-symbols": "^2.0.0",
- "purescript-typelevel-prelude": "https://github.com/purescript/purescript-typelevel-prelude.git#29a7123a0c29c85d4b923fcf4a7df8e45ebf9bac",
- "purescript-unsafe-coerce": "^2.0.0"
+ "purescript-arrays": "ps-0.11",
+ "purescript-assert": "ps-0.11",
+ "purescript-console": "ps-0.11",
+ "purescript-eff": "ps-0.11",
+ "purescript-functions": "ps-0.11",
+ "purescript-generics": "ps-0.11",
+ "purescript-generics-rep": "ps-0.11",
+ "purescript-newtype": "ps-0.11",
+ "purescript-partial": "1.2.0",
+ "purescript-prelude": "ps-0.11",
+ "purescript-psci-support": "ps-0.11",
+ "purescript-st": "ps-0.11",
+ "purescript-symbols": "ps-0.11",
+ "purescript-tailrec": "ps-0.11",
+ "purescript-typelevel-prelude": "ps-0.11",
+ "purescript-unsafe-coerce": "ps-0.11"
}
}
diff --git a/tests/support/prelude-resolutions.json b/tests/support/prelude-resolutions.json
new file mode 100644
index 0000000..a5704c4
--- /dev/null
+++ b/tests/support/prelude-resolutions.json
@@ -0,0 +1,7 @@
+{
+ "canonicalDir": "bower_components/purescript-prelude",
+ "pkgMeta": {
+ "dependencies": {}
+ },
+ "dependencies": {}
+}