Workspace.hs

module HaskellWorks.Polysemy.Hedgehog.Workspace
  ( PackagePath(..),
    ProjectRoot(..),
    Workspace(..),
    workspace,
    moduleWorkspace,
    findCabalProjectDir,
  ) where

import           HaskellWorks.Polysemy.Error
import           HaskellWorks.Polysemy.Hedgehog.Assert
import           HaskellWorks.Polysemy.Hedgehog.Jot
import           HaskellWorks.Polysemy.Hedgehog.Workspace.Types
import           HaskellWorks.Polysemy.Prelude
import           HaskellWorks.Polysemy.Stack
import           HaskellWorks.Polysemy.System.Directory
import           HaskellWorks.Polysemy.System.Environment
import           HaskellWorks.Polysemy.System.IO.Temp
import           Polysemy
import           Polysemy.Log
import           Polysemy.Reader
import           System.FilePath                                ((</>))
import           System.Info

import qualified HaskellWorks.Polysemy.System.IO                as PIO

-- | Create a workspace directory which will exist for at least the duration of
-- the supplied block.
--
-- The directory will have the supplied prefix but contain a generated random
-- suffix to prevent interference between tests
--
-- The directory will be deleted if the block succeeds, but left behind if
-- the block fails.
workspace :: ()
  => HasCallStack
  => Member Hedgehog r
  => Member Log r
  => Member (Embed IO) r
  => HasCallStack
  => FilePath
  -> Sem (Reader Workspace : r) ()
  -> Sem r ()
workspace prefixPath f = withFrozenCallStack $ do
  systemTemp <- getCanonicalTemporaryDirectory
  maybeKeepWorkspace <- lookupEnv "KEEP_WORKSPACE"
  ws <- createTempDirectory systemTemp $ prefixPath <> "-test"
  jot_ $ "Workspace: " <> ws
  PIO.writeFile (ws </> "module") callerModuleName
    & trapFail @IOException
  runReader (Workspace ws) f
  when (os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do
    removePathForcibly ws
      & trapFail @IOException

-- | Create a workspace directory which will exist for at least the duration of
-- the supplied block.
--
-- The directory will have the prefix as "$prefixPath/$moduleName" but contain a generated random
-- suffix to prevent interference between tests
--
-- The directory will be deleted if the block succeeds, but left behind if
-- the block fails.
--
-- The 'prefix' argument should not contain directory delimeters.
moduleWorkspace ::  ()
  => HasCallStack
  => Member Hedgehog r
  => Member Log r
  => Member (Embed IO) r
  => String
  -> Sem (Reader Workspace : r) ()
  -> Sem r ()
moduleWorkspace prefix f = withFrozenCallStack $
  workspace (prefix <> "-" <> callerModuleName) f

-- | Compute the project base.  This will be the first parent directory that contains
-- the `cabal.project` file.
-- This should should point to the root directory of the Github project checkout.
findCabalProjectDir :: ()
  => Member Hedgehog r
  => Member (Embed IO) r
  => Member Log r
  => FilePath
  -> Sem r FilePath
findCabalProjectDir dir = do
  atBase <- doesFileExist (dir </> "cabal.project")
    & trap_ @IOException (pure False)
  if atBase
    then return dir
    else do
      let up = dir </> ".."
      upExist <- doesDirectoryExist up
        & trap_ @IOException (pure False)
      if upExist
        then findCabalProjectDir up
        else embed $ fail "Could not detect project base directory (containing cabal.project)"