diff --git a/hedgehog-extras.cabal b/hedgehog-extras.cabal --- a/hedgehog-extras.cabal +++ b/hedgehog-extras.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: hedgehog-extras -version: 0.4.0.1 +version: 0.4.1.0 synopsis: Supplemental library for hedgehog description: Supplemental library for hedgehog. category: Test diff --git a/src/Hedgehog/Extras/Stock/IO/Network/Sprocket.hs b/src/Hedgehog/Extras/Stock/IO/Network/Sprocket.hs --- a/src/Hedgehog/Extras/Stock/IO/Network/Sprocket.hs +++ b/src/Hedgehog/Extras/Stock/IO/Network/Sprocket.hs @@ -10,15 +10,16 @@ import Data.Bool (Bool) import Data.Char (Char) -import Data.Eq (Eq((==))) -import Data.Functor (Functor(fmap)) +import Data.Eq (Eq ((==))) +import Data.Functor (Functor (fmap)) import Data.Int (Int) -import Data.Semigroup (Semigroup((<>))) +import Data.Semigroup (Semigroup ((<>))) import Data.String (String) +import GHC.Generics (Generic) import Hedgehog.Extras.Stock.OS (isWin32) +import System.FilePath (()) import System.IO (FilePath, IO) import Text.Show (Show) -import GHC.Generics (Generic) import qualified Hedgehog.Extras.Stock.IO.Network.NamedPipe as IO import qualified Hedgehog.Extras.Stock.IO.Network.Socket as IO @@ -39,7 +40,7 @@ sprocketSystemName :: Sprocket -> FilePath sprocketSystemName sprocket@(Sprocket base name) = if isWin32 then sprocketNamedPipeName sprocket - else base <> "/" <> name + else base name -- | Use this when needing to pass a sprocket into a command line argument. sprocketArgumentName :: Sprocket -> FilePath diff --git a/src/Hedgehog/Extras/Test/Base.hs b/src/Hedgehog/Extras/Test/Base.hs --- a/src/Hedgehog/Extras/Test/Base.hs +++ b/src/Hedgehog/Extras/Test/Base.hs @@ -75,7 +75,7 @@ import Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void, when) import Control.Monad.Catch (MonadCatch) import Control.Monad.Morph (hoist) -import Control.Monad.Reader (MonadIO (..), MonadReader (..)) +import Control.Monad.Reader (MonadIO (..), MonadReader (ask)) import Control.Monad.Trans.Resource (ReleaseKey, runResourceT) import Data.Aeson (Result (..)) import Data.Bool (Bool, (&&)) @@ -87,7 +87,7 @@ import Data.Int (Int) import Data.Maybe (Maybe (..), listToMaybe, maybe) import Data.Monoid (Monoid (..)) -import Data.Ord (Ord (..)) +import Data.Ord (Ord ((<))) import Data.Semigroup (Semigroup (..)) import Data.String (String) import Data.Time.Clock (NominalDiffTime, UTCTime) @@ -103,6 +103,7 @@ import Hedgehog.Internal.Property (Diff, liftTest, mkTest) import Hedgehog.Internal.Source (getCaller) import Prelude (floor) +import System.FilePath (()) import System.IO (FilePath, IO) import Text.Show (Show (show)) @@ -150,7 +151,7 @@ maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE" ws <- H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test" H.annotate $ "Workspace: " <> ws - liftIO $ IO.writeFile (ws <> "/module") callerModuleName + liftIO $ IO.writeFile (ws "module") callerModuleName f ws when (IO.os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do H.evalIO $ IO.removeDirectoryRecursive ws @@ -291,7 +292,7 @@ -- | Return the test file path after annotating it relative to the project root directory noteTempFile :: (MonadTest m, HasCallStack) => FilePath -> FilePath -> m FilePath noteTempFile tempDir filePath = GHC.withFrozenCallStack $ do - let relPath = tempDir <> "/" <> filePath + let relPath = tempDir filePath H.annotate relPath return relPath diff --git a/src/Hedgehog/Extras/Test/File.hs b/src/Hedgehog/Extras/Test/File.hs --- a/src/Hedgehog/Extras/Test/File.hs +++ b/src/Hedgehog/Extras/Test/File.hs @@ -3,6 +3,9 @@ module Hedgehog.Extras.Test.File ( createDirectoryIfMissing + , createDirectoryIfMissing_ + , createSubdirectoryIfMissing + , createSubdirectoryIfMissing_ , copyFile , renameFile , createFileLink @@ -19,11 +22,13 @@ , copyRewriteJsonFile , readJsonFile + , readJsonFileOk , rewriteJsonFile , rewriteLbsJson , copyRewriteYamlFile , readYamlFile + , readYamlFileOk , rewriteYamlFile , rewriteLbsYaml @@ -40,6 +45,7 @@ , appendFileTimeDelta ) where +import Control.Applicative (Applicative (..)) import Control.Monad import Control.Monad.IO.Class import Data.Aeson (Value) @@ -70,14 +76,45 @@ import qualified Hedgehog as H import qualified Hedgehog.Extras.Test.Base as H import qualified System.Directory as IO +import System.FilePath (()) import qualified System.IO as IO --- | Create the 'filePath' directory if it is missing. -createDirectoryIfMissing :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m () -createDirectoryIfMissing filePath = GHC.withFrozenCallStack $ do - H.annotate $ "Creating directory if missing: " <> filePath - H.evalIO $ IO.createDirectoryIfMissing True filePath +-- | Create the 'directory' directory if it is missing. +createDirectoryIfMissing :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m FilePath +createDirectoryIfMissing directory = GHC.withFrozenCallStack $ do + H.annotate $ "Creating directory if missing: " <> directory + H.evalIO $ IO.createDirectoryIfMissing True directory + pure directory +-- | Create the 'directory' directory if it is missing. +createDirectoryIfMissing_ :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m () +createDirectoryIfMissing_ directory = GHC.withFrozenCallStack $ + void $ createDirectoryIfMissing directory + +-- | Create the 'subdirectory' subdirectory if it is missing. The subdirectory is returned. +createSubdirectoryIfMissing :: () + => HasCallStack + => MonadTest m + => MonadIO m + => FilePath + -> FilePath + -> m FilePath +createSubdirectoryIfMissing parent subdirectory = GHC.withFrozenCallStack $ do + H.annotate $ "Creating subdirectory if missing: " <> subdirectory + H.evalIO $ IO.createDirectoryIfMissing True $ parent subdirectory + pure subdirectory + +-- | Create the 'subdirectory' subdirectory if it is missing. The subdirectory is returned. +createSubdirectoryIfMissing_ :: () + => HasCallStack + => MonadTest m + => MonadIO m + => FilePath + -> FilePath + -> m () +createSubdirectoryIfMissing_ parent subdirectory = GHC.withFrozenCallStack $ + void $ createSubdirectoryIfMissing parent subdirectory + -- | Copy the contents of the 'src' file to the 'dst' file. copyFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> FilePath -> m () copyFile src dst = GHC.withFrozenCallStack $ do @@ -158,6 +195,11 @@ void . H.annotate $ "Reading JSON file: " <> filePath H.evalIO $ J.eitherDecode @Value <$> LBS.readFile filePath +-- | Read the 'filePath' file as JSON. Same as 'readJsonFile' but fails on error. +readJsonFileOk :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m Value +readJsonFileOk filePath = GHC.withFrozenCallStack $ + H.leftFailM $ readJsonFile filePath + rewriteLbsJson :: (MonadTest m, HasCallStack) => (Value -> Value) -> LBS.ByteString -> m LBS.ByteString rewriteLbsJson f lbs = GHC.withFrozenCallStack $ do case J.eitherDecode lbs of @@ -181,6 +223,11 @@ readYamlFile filePath = GHC.withFrozenCallStack $ do void . H.annotate $ "Reading YAML file: " <> filePath H.evalIO $ Y.decodeEither' @Value . LBS.toStrict <$> LBS.readFile filePath + +-- | Read the 'filePath' file as YAML. Same as 'readYamlFile' but fails on error. +readYamlFileOk :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m Value +readYamlFileOk filePath = GHC.withFrozenCallStack $ + H.leftFailM $ readYamlFile filePath rewriteLbsYaml :: (MonadTest m, HasCallStack) => (Value -> Value) -> LBS.ByteString -> m LBS.ByteString rewriteLbsYaml f lbs = GHC.withFrozenCallStack $ do diff --git a/src/Hedgehog/Extras/Test/Process.hs b/src/Hedgehog/Extras/Test/Process.hs --- a/src/Hedgehog/Extras/Test/Process.hs +++ b/src/Hedgehog/Extras/Test/Process.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Hedgehog.Extras.Test.Process ( createProcess @@ -16,22 +16,23 @@ , waitForProcess , maybeWaitForProcess , getPid + , getPidOk , waitSecondsForProcess , ExecConfig(..) , defaultExecConfig ) where -import Control.Monad (Monad(..), MonadFail(fail), void) +import Control.Monad (Monad (..), MonadFail (fail), void) import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register) import Data.Aeson (eitherDecode) -import Data.Bool (Bool(..)) -import Data.Either (Either(..)) -import Data.Eq (Eq(..)) +import Data.Bool (Bool (..)) +import Data.Either (Either (..)) +import Data.Eq (Eq (..)) import Data.Function (($), (&), (.)) -import Data.Functor (Functor(..)) +import Data.Functor (Functor (..)) import Data.Int (Int) import Data.Maybe (Maybe (..)) import Data.Monoid (Last (..), mempty, (<>)) @@ -40,7 +41,7 @@ import GHC.Stack (HasCallStack) import Hedgehog (MonadTest) import Hedgehog.Extras.Internal.Cli (argQuote) -import Hedgehog.Extras.Internal.Plan (Component(..), Plan(..)) +import Hedgehog.Extras.Internal.Plan (Component (..), Plan (..)) import Hedgehog.Extras.Stock.IO.Process (TimedOut (..)) import Prelude (error) import System.Exit (ExitCode) @@ -48,7 +49,7 @@ import System.FilePath.Posix (()) import System.IO (FilePath, Handle, IO) import System.Process (CmdSpec (..), CreateProcess (..), Pid, ProcessHandle) -import Text.Show (Show(show)) +import Text.Show (Show (show)) import qualified Data.ByteString.Lazy as LBS import qualified Data.List as L @@ -130,6 +131,14 @@ -> m (Maybe Pid) getPid hProcess = GHC.withFrozenCallStack . H.evalIO $ IO.getPid hProcess +-- | Get the process ID. +getPidOk + :: (MonadTest m, MonadIO m, HasCallStack) + => ProcessHandle + -> m Pid +getPidOk hProcess = GHC.withFrozenCallStack $ + H.nothingFailM $ getPid hProcess + -- | Create a process returning its stdout. -- -- Being a 'flex' function means that the environment determines how the process is launched. @@ -334,11 +343,11 @@ getProjectBase = do let findUp dir = do - atBase <- liftIO $ IO.doesFileExist (dir <> "/cabal.project") + atBase <- liftIO $ IO.doesFileExist (dir "cabal.project") if atBase then return dir else do - let up = dir <> "/.." + let up = dir ".." upExist <- liftIO $ IO.doesDirectoryExist up if upExist then findUp up