summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorPhilFreeman <>2016-01-31 22:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-01-31 22:07:00 (GMT)
commit43cd0c9c2258e12e695109d47d435ca0634cf3b0 (patch)
tree5b7d353683d4df84425b35d56154e78000f234d8 /tests
parentd75ce7f45344db8d92286cd08068533fa7ffc910 (diff)
version 0.8.0.00.8.0.0
Diffstat (limited to 'tests')
-rw-r--r--tests/Main.hs28
-rw-r--r--tests/TestDocs.hs232
-rw-r--r--tests/TestPscPublish.hs65
-rw-r--r--tests/support/bower.json2
4 files changed, 325 insertions, 2 deletions
diff --git a/tests/Main.hs b/tests/Main.hs
index 1b5c834..9433b19 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -30,6 +30,7 @@
-- -- @shouldFailWith TypesDoNotUnify
-- -- @shouldFailWith TypesDoNotUnify
-- -- @shouldFailWith TransitiveExportError
+--
module Main (main) where
@@ -39,6 +40,7 @@ import Prelude.Compat
import qualified Language.PureScript as P
import qualified Language.PureScript.CodeGen.JS as J
import qualified Language.PureScript.CoreFn as CF
+import qualified Language.PureScript.Docs as Docs
import Data.Char (isSpace)
import Data.Maybe (mapMaybe, fromMaybe)
@@ -68,6 +70,8 @@ import qualified System.FilePath.Glob as Glob
import Text.Parsec (ParseError)
import TestsSetup
+import TestPscPublish
+import qualified TestDocs
modulesDir :: FilePath
modulesDir = ".test_modules" </> "node_modules"
@@ -171,6 +175,23 @@ assertDoesNotCompile inputFiles foreigns = do
main :: IO ()
main = do
+ heading "Main compiler test suite"
+ testCompiler
+ heading "Documentation test suite"
+ TestDocs.main
+ -- heading "psc-publish test suite"
+ -- testPscPublish
+
+ where
+ heading msg = do
+ putStrLn ""
+ putStrLn $ replicate 79 '#'
+ putStrLn $ "# " ++ msg
+ putStrLn $ replicate 79 '#'
+ putStrLn ""
+
+testCompiler :: IO ()
+testCompiler = do
fetchSupportCode
cwd <- getCurrentDirectory
@@ -195,7 +216,7 @@ main = do
assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
if null failures
- then exitSuccess
+ then pure ()
else do
putStrLn "Failures:"
forM_ failures $ \(fp, err) ->
@@ -203,6 +224,11 @@ main = do
in putStrLn $ fp' ++ ": " ++ err
exitFailure
+testPscPublish :: IO ()
+testPscPublish = do
+ testPackage "tests/support/prelude"
+
+
supportModules :: [String]
supportModules =
[ "Control.Monad.Eff.Class"
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
new file mode 100644
index 0000000..477cc13
--- /dev/null
+++ b/tests/TestDocs.hs
@@ -0,0 +1,232 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DataKinds #-}
+
+module TestDocs where
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.Version (Version(..))
+
+import Control.Monad hiding (forM_)
+import Control.Applicative
+import Control.Arrow
+import Data.Maybe (fromMaybe)
+import Data.List ((\\))
+import Data.Foldable
+import Data.Traversable
+import System.Exit
+import qualified Text.Parsec as Parsec
+
+import qualified Language.PureScript as P
+import qualified Language.PureScript.Docs as Docs
+import qualified Language.PureScript.Publish as Publish
+
+import qualified TestPscPublish
+
+publishOpts :: Publish.PublishOptions
+publishOpts = Publish.defaultPublishOptions
+ { Publish.publishGetVersion = return testVersion
+ , Publish.publishWorkingTreeDirty = return ()
+ }
+ where testVersion = ("v999.0.0", Version [999,0,0] [])
+
+main :: IO ()
+main = do
+ TestPscPublish.pushd "examples/docs" $ do
+ Docs.Package{..} <- Publish.preparePackage publishOpts
+ forM_ testCases $ \(mn, pragmas) ->
+ let mdl = takeJust ("module not found in docs: " ++ mn)
+ (find ((==) mn . Docs.modName) pkgModules)
+ in forM_ pragmas (flip runAssertionIO mdl)
+
+takeJust :: String -> Maybe a -> a
+takeJust msg = maybe (error msg) id
+
+data Assertion
+ -- | Assert that a particular declaration is documented with the given
+ -- children
+ = ShouldBeDocumented P.ModuleName String [String]
+ -- | Assert that a particular declaration is not documented
+ | ShouldNotBeDocumented P.ModuleName String
+ -- | Assert that a particular declaration exists, but without a particular
+ -- child.
+ | ChildShouldNotBeDocumented P.ModuleName String String
+ -- | Assert that a particular declaration has a particular type class
+ -- constraint.
+ | ShouldBeConstrained P.ModuleName String String
+ deriving (Show)
+
+data AssertionFailure
+ -- | A declaration was not documented, but should have been
+ = NotDocumented P.ModuleName String
+ -- | A child declaration was not documented, but should have been
+ | ChildrenNotDocumented P.ModuleName String [String]
+ -- | A declaration was documented, but should not have been
+ | Documented P.ModuleName String
+ -- | A child declaration was documented, but should not have been
+ | ChildDocumented P.ModuleName String String
+ -- | A constraint was missing.
+ | ConstraintMissing P.ModuleName 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
+ deriving (Show)
+
+data AssertionResult
+ = Pass
+ | Fail AssertionFailure
+ deriving (Show)
+
+runAssertion :: Assertion -> Docs.Module -> AssertionResult
+runAssertion assertion Docs.Module{..} =
+ case assertion of
+ ShouldBeDocumented mn decl children ->
+ case findChildren decl (declarationsFor mn) of
+ Nothing ->
+ Fail (NotDocumented mn decl)
+ Just actualChildren ->
+ case children \\ actualChildren of
+ [] -> Pass
+ cs -> Fail (ChildrenNotDocumented mn decl cs)
+
+ ShouldNotBeDocumented mn decl ->
+ case findChildren decl (declarationsFor mn) of
+ Just _ ->
+ Fail (Documented mn decl)
+ Nothing ->
+ Pass
+
+ ChildShouldNotBeDocumented mn decl child ->
+ case findChildren decl (declarationsFor mn) of
+ Just children ->
+ if child `elem` children
+ then Fail (ChildDocumented mn decl child)
+ else Pass
+ Nothing ->
+ Fail (NotDocumented mn decl)
+
+ ShouldBeConstrained mn decl tyClass ->
+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
+ Nothing ->
+ Fail (NotDocumented mn decl)
+ Just Docs.Declaration{..} ->
+ case declInfo of
+ Docs.ValueDeclaration ty ->
+ if checkConstrained ty tyClass
+ then Pass
+ else Fail (ConstraintMissing mn decl tyClass)
+ _ ->
+ Fail (WrongDeclarationType mn decl "value"
+ (Docs.declInfoToString declInfo))
+
+ where
+ declarationsFor mn =
+ if P.runModuleName mn == modName
+ then modDeclarations
+ else fromMaybe [] (lookup mn modReExports)
+
+ findChildren title =
+ fmap childrenTitles . find ((==) title . Docs.declTitle)
+
+ childrenTitles = map Docs.cdeclTitle . Docs.declChildren
+
+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.ForAll _ ty' _ ->
+ checkConstrained ty' tyClass
+ _ ->
+ False
+ where
+ matches className =
+ (==) className . P.runProperName . P.disqualify . fst
+
+runAssertionIO :: Assertion -> Docs.Module -> IO ()
+runAssertionIO assertion mdl = do
+ putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)
+ case runAssertion assertion mdl of
+ Pass -> pure ()
+ fail -> do
+ putStrLn (show fail)
+ exitFailure
+
+testCases :: [(String, [Assertion])]
+testCases =
+ [ ("Example",
+ [ -- From dependencies
+ ShouldBeDocumented (n "Prelude") "Unit" []
+ , ShouldNotBeDocumented (n "Prelude") "unit"
+
+ -- From local files
+ , ShouldBeDocumented (n "Example2") "one" []
+ , ShouldNotBeDocumented (n "Example2") "two"
+ ])
+ , ("Example2",
+ [ ShouldBeDocumented (n "Example2") "one" []
+ , ShouldBeDocumented (n "Example2") "two" []
+ ])
+
+ , ("UTF8",
+ [ ShouldBeDocumented (n "UTF8") "thing" []
+ ])
+
+ , ("Transitive1",
+ [ ShouldBeDocumented (n "Transitive2") "transitive3" []
+ ])
+
+ , ("NotAllCtors",
+ [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
+ , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
+ ])
+
+ , ("DuplicateNames",
+ [ ShouldBeDocumented (n "Prelude") "Unit" []
+ , ShouldBeDocumented (n "DuplicateNames") "unit" []
+ , ShouldNotBeDocumented (n "Prelude") "unit"
+ ])
+
+ , ("MultiVirtual",
+ [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
+ , ShouldBeDocumented (n "MultiVirtual2") "bar" []
+ , ShouldBeDocumented (n "MultiVirtual2") "baz" []
+ ])
+
+ , ("Clash",
+ [ ShouldBeDocumented (n "Clash1") "value" []
+ , ShouldBeDocumented (n "Clash1") "Type" []
+ , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
+ ])
+
+ , ("SolitaryTypeClassMember",
+ [ ShouldBeDocumented (n "SomeTypeClass") "member" []
+ , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
+ , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
+ ])
+
+ , ("ReExportedTypeClass",
+ [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
+ ])
+
+ , ("TypeClassWithoutMembers",
+ [ ShouldBeDocumented (n "Intermediate") "SomeClass" []
+ , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"
+ ])
+
+ -- Remove this after 0.9.
+ , ("OldOperators",
+ [ ShouldBeDocumented (n "OldOperators2") "(>>)" []
+ ])
+
+ , ("NewOperators",
+ [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
+ ])
+ ]
+
+ where
+ n = P.moduleNameFromString
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
new file mode 100644
index 0000000..657105d
--- /dev/null
+++ b/tests/TestPscPublish.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module TestPscPublish where
+
+import Control.Monad
+import Control.Applicative
+import Control.Exception
+import System.Process
+import System.Directory
+import System.IO
+import System.Exit
+import qualified Data.ByteString.Lazy as BL
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.Aeson as A
+import Data.Aeson.BetterErrors
+import Data.Version
+
+import Language.PureScript.Docs
+import Language.PureScript.Publish
+
+pushd :: forall a. FilePath -> IO a -> IO a
+pushd dir act = do
+ original <- getCurrentDirectory
+ setCurrentDirectory dir
+ result <- try act :: IO (Either IOException a)
+ setCurrentDirectory original
+ either throwIO return result
+
+data TestResult
+ = ParseFailed String
+ | Mismatch ByteString ByteString -- ^ encoding before, encoding after
+ | Pass ByteString
+ deriving (Show, Read)
+
+roundTrip :: UploadedPackage -> TestResult
+roundTrip pkg =
+ let before = A.encode pkg
+ in case A.eitherDecode before of
+ Left err -> ParseFailed err
+ Right parsed -> do
+ let after = A.encode (parsed :: UploadedPackage)
+ if before == after
+ then Pass before
+ else Mismatch before after
+
+testRunOptions :: PublishOptions
+testRunOptions = defaultPublishOptions
+ { publishGetVersion = return testVersion
+ }
+ where testVersion = ("v999.0.0", Version [999,0,0] [])
+
+-- | 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 = do
+ pushd dir $ do
+ r <- roundTrip <$> preparePackage testRunOptions
+ case r of
+ Pass _ -> pure ()
+ other -> do
+ putStrLn ("psc-publish tests failed on " ++ dir ++ ":")
+ putStrLn (show other)
+ exitFailure
diff --git a/tests/support/bower.json b/tests/support/bower.json
index 9d1b7d2..c29e6e8 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -2,7 +2,7 @@
"name": "purescript-test-suite-support",
"dependencies": {
"purescript-eff": "0.1.0",
- "purescript-prelude": "0.1.1",
+ "purescript-prelude": "0.1.3",
"purescript-assert": "0.1.1",
"purescript-st": "0.1.0",
"purescript-console": "0.1.0",