summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorPhilFreeman <>2016-12-11 02:42:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-12-11 02:42:00 (GMT)
commit79948f219fa19b886408053ae2e9ec97d28ccf45 (patch)
tree1f1314c04d2f2d1cec8060add8cb13e2847cf2f8 /tests
parentab4b395c66e5fb609628ec32fc9142fafc083207 (diff)
version 0.10.30.10.3
Diffstat (limited to 'tests')
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs3
-rw-r--r--tests/TestCompiler.hs39
-rw-r--r--tests/TestDocs.hs36
-rw-r--r--tests/TestPsci.hs5
-rw-r--r--tests/TestUtils.hs2
-rw-r--r--tests/support/bower.json4
6 files changed, 67 insertions, 22 deletions
diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs
index f273938..d5d394c 100644
--- a/tests/Language/PureScript/Ide/ReexportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -2,7 +2,6 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.PureScript.Ide.ReexportsSpec where
-import qualified Prelude
import Protolude
import qualified Data.Map as Map
@@ -11,7 +10,7 @@ import Language.PureScript.Ide.Types
import qualified Language.PureScript as P
import Test.Hspec
-m :: Prelude.String -> P.ModuleName
+m :: Text -> P.ModuleName
m = P.moduleNameFromString
d :: IdeDeclaration -> IdeDeclarationAnn
diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs
index a11babe..4fc8552 100644
--- a/tests/TestCompiler.hs
+++ b/tests/TestCompiler.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
module TestCompiler where
@@ -30,8 +31,8 @@ import Data.Function (on)
import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)
import Data.Maybe (mapMaybe)
import Data.Time.Clock (UTCTime())
-import Data.Tuple (swap)
import qualified Data.Text as T
+import Data.Tuple (swap)
import qualified Data.Map as M
@@ -46,6 +47,7 @@ import System.Exit
import System.Process hiding (cwd)
import System.FilePath
import System.Directory
+import System.IO
import System.IO.UTF8
import System.IO.Silently
import qualified System.FilePath.Glob as Glob
@@ -72,7 +74,7 @@ spec = do
supportPurs <- supportFiles "purs"
supportPursFiles <- readInput supportPurs
supportExterns <- runExceptT $ do
- modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles)
+ modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles
foreigns <- inferForeignModules modules
externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)
return (zip (map snd modules) externs)
@@ -80,10 +82,15 @@ spec = do
Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
Right externs -> return (externs, passingFiles, warningFiles, failingFiles)
+ outputFile <- runIO $ do
+ tmp <- getTemporaryDirectory
+ createDirectoryIfMissing False (tmp </> logpath)
+ openFile (tmp </> logpath </> logfile) WriteMode
+
context "Passing examples" $
forM_ passingTestCases $ \testPurs ->
it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $
- assertCompiles supportExterns testPurs
+ assertCompiles supportExterns testPurs outputFile
context "Warning examples" $
forM_ warningTestCases $ \testPurs -> do
@@ -169,20 +176,20 @@ makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActi
where
getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
getInputTimestamp mn
- | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
+ | isSupportModule (T.unpack (P.runModuleName mn)) = return (Left P.RebuildNever)
| otherwise = return (Left P.RebuildAlways)
where
isSupportModule = flip elem supportModules
getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
getOutputTimestamp mn = do
- let filePath = modulesDir </> P.runModuleName mn
+ let filePath = modulesDir </> T.unpack (P.runModuleName mn)
exists <- liftIO $ doesDirectoryExist filePath
return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
-readInput :: [FilePath] -> IO [(FilePath, String)]
+readInput :: [FilePath] -> IO [(FilePath, T.Text)]
readInput inputFiles = forM inputFiles $ \inputFile -> do
- text <- readUTF8File inputFile
+ text <- readUTF8FileT inputFile
return (inputFile, text)
runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)
@@ -195,7 +202,7 @@ compile
-> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
compile supportExterns inputFiles check = silence $ runTest $ do
fs <- liftIO $ readInput inputFiles
- ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs)
+ ms <- P.parseModulesFromFiles id fs
foreigns <- inferForeignModules ms
liftIO (check (map snd ms))
let actions = makeActions foreigns
@@ -222,15 +229,16 @@ checkMain ms =
checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String
checkShouldFailWith expected errs =
let actual = map P.errorCode $ P.runMultipleErrors errs
- in if sort expected == sort actual
+ in if sort expected == sort (map T.unpack actual)
then Nothing
else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
assertCompiles
:: [(P.Module, P.ExternsFile)]
-> [FilePath]
+ -> Handle
-> Expectation
-assertCompiles supportExterns inputFiles =
+assertCompiles supportExterns inputFiles outputFile =
assert supportExterns inputFiles checkMain $ \e ->
case e of
Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
@@ -239,10 +247,13 @@ assertCompiles supportExterns inputFiles =
let entryPoint = modulesDir </> "index.js"
writeFile entryPoint "require('Main').main()"
result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
+ hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"
case result of
Just (ExitSuccess, out, err)
| not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
- | not (null out) && trim (last (lines out)) == "Done" -> return Nothing
+ | not (null out) && trim (last (lines out)) == "Done" -> do
+ hPutStr outputFile out
+ return Nothing
| otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
Just (ExitFailure _, _, err) -> return $ Just err
Nothing -> return $ Just "Couldn't find node.js executable"
@@ -285,3 +296,9 @@ assertDoesNotCompile supportExterns inputFiles shouldFailWith =
where
noPreCheck = const (return ())
+
+logpath :: FilePath
+logpath = "purescript-output"
+
+logfile :: FilePath
+logfile = "psc-tests.out"
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 1d56293..c689437 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -13,6 +13,7 @@ import Data.Monoid
import Data.Maybe (fromMaybe)
import Data.List ((\\))
import Data.Foldable
+import qualified Data.Text as T
import System.Exit
import qualified Language.PureScript as P
@@ -36,8 +37,8 @@ main = pushd "examples/docs" $ do
case res of
Left e -> Publish.printErrorToStdout e >> exitFailure
Right Docs.Package{..} ->
- forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
- let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)
+ forM_ testCases $ \(P.moduleNameFromString . T.pack -> mn, pragmas) ->
+ let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))
(find ((==) mn . Docs.modName) pkgModules)
in forM_ pragmas (`runAssertionIO` mdl)
@@ -57,6 +58,9 @@ data Assertion
-- | Assert that a particular declaration has a particular type class
-- constraint.
| ShouldBeConstrained P.ModuleName String String
+ -- | Assert that a particular typeclass declaration has a functional
+ -- dependency list.
+ | ShouldHaveFunDeps P.ModuleName String [([String],[String])]
-- | Assert that a particular value declaration exists, and its type
-- satisfies the given predicate.
| ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))
@@ -82,6 +86,8 @@ data AssertionFailure
| ChildDocumented P.ModuleName String String
-- | A constraint was missing.
| ConstraintMissing P.ModuleName String String
+ -- | A functional dependency was missing.
+ | FunDepMissing P.ModuleName String [([String], [String])]
-- | A declaration had the wrong "type" (ie, value, type, type class)
-- Fields: declaration title, expected "type", actual "type".
| WrongDeclarationType P.ModuleName String String String
@@ -142,6 +148,20 @@ runAssertion assertion Docs.Module{..} =
Fail (WrongDeclarationType mn decl "value"
(Docs.declInfoToString declInfo))
+ ShouldHaveFunDeps mn decl fds ->
+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
+ Nothing ->
+ Fail (NotDocumented mn decl)
+ Just Docs.Declaration{..} ->
+ case declInfo of
+ Docs.TypeClassDeclaration _ _ fundeps ->
+ if fundeps == fds
+ then Pass
+ else Fail (FunDepMissing mn decl fds)
+ _ ->
+ Fail (WrongDeclarationType mn decl "value"
+ (Docs.declInfoToString declInfo))
+
ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
Nothing ->
@@ -197,11 +217,11 @@ checkConstrained ty tyClass =
False
where
matches className =
- (==) className . P.runProperName . P.disqualify . P.constraintClass
+ (==) className . T.unpack . P.runProperName . P.disqualify . P.constraintClass
runAssertionIO :: Assertion -> Docs.Module -> IO ()
runAssertionIO assertion mdl = do
- putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)
+ putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)
case runAssertion assertion mdl of
Pass -> pure ()
Fail reason -> do
@@ -270,6 +290,10 @@ testCases =
, ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"
])
+ , ("TypeClassWithFunDeps",
+ [ ShouldHaveFunDeps (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]
+ ])
+
, ("NewOperators",
[ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
])
@@ -298,12 +322,12 @@ testCases =
]
where
- n = P.moduleNameFromString
+ n = P.moduleNameFromString . T.pack
hasTypeVar varName =
getAny . P.everythingOnTypes (<>) (Any . isVar varName)
- isVar varName (P.TypeVar name) | varName == name = True
+ isVar varName (P.TypeVar name) | varName == T.unpack name = True
isVar _ _ = False
renderedType expected =
diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs
index 19eb961..f758acb 100644
--- a/tests/TestPsci.hs
+++ b/tests/TestPsci.hs
@@ -10,6 +10,7 @@ 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
@@ -127,11 +128,11 @@ getPSCiState = do
Left err ->
print err >> exitFailure
Right modules ->
- let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
+ 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
+ s = P.moduleNameFromString . T.pack
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index 6c8e099..cf67a38 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -104,6 +104,7 @@ supportModules =
, "Data.Ring"
, "Data.Semigroup"
, "Data.Semiring"
+ , "Data.Symbol"
, "Data.Show"
, "Data.Unit"
, "Data.Void"
@@ -112,6 +113,7 @@ supportModules =
, "Prelude"
, "Test.Assert"
, "Test.Main"
+ , "Unsafe.Coerce"
]
pushd :: forall a. FilePath -> IO a -> IO a
diff --git a/tests/support/bower.json b/tests/support/bower.json
index d2f01dd..2de10e8 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -9,6 +9,8 @@
"purescript-st": "1.0.0-rc.1",
"purescript-partial": "1.1.2",
"purescript-newtype": "0.1.0",
- "purescript-generics-rep": "2.0.0"
+ "purescript-generics-rep": "2.0.0",
+ "purescript-symbols": "^1.0.1",
+ "purescript-unsafe-coerce": "^1.0.0"
}
}