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.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 :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member Log r,
 Member (Embed IO) r, HasCallStack) =>
FilePath -> Sem (Reader Workspace : r) () -> Sem r ()
workspace FilePath
prefixPath Sem (Reader Workspace : r) ()
f = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
  FilePath
systemTemp <- Sem r FilePath
forall (r :: EffectRow).
(HasCallStack, Member (Embed IO) r) =>
Sem r FilePath
getCanonicalTemporaryDirectory
  Maybe FilePath
maybeKeepWorkspace <- FilePath -> Sem r (Maybe FilePath)
forall (r :: EffectRow).
(HasCallStack, Member (Embed IO) r) =>
FilePath -> Sem r (Maybe FilePath)
lookupEnv FilePath
"KEEP_WORKSPACE"
  FilePath
ws <- FilePath -> FilePath -> Sem r FilePath
forall (r :: EffectRow).
(HasCallStack, Member (Embed IO) r) =>
FilePath -> FilePath -> Sem r FilePath
createTempDirectory FilePath
systemTemp (FilePath -> Sem r FilePath) -> FilePath -> Sem r FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
prefixPath FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-test"
  FilePath -> Sem r ()
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack, ToString a) =>
a -> Sem r ()
jot_ (FilePath -> Sem r ()) -> FilePath -> Sem r ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Workspace: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
ws
  FilePath -> FilePath -> Sem (Error IOException : r) ()
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
 Member Log r) =>
FilePath -> FilePath -> Sem r ()
PIO.writeFile (FilePath
ws FilePath -> FilePath -> FilePath
</> FilePath
"module") FilePath
HasCallStack => FilePath
callerModuleName
    Sem (Error IOException : r) ()
-> (Sem (Error IOException : r) () -> Sem r ()) -> Sem r ()
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(Member Hedgehog r, HasCallStack, Show e) =>
Sem (Error e : r) a -> Sem r a
trapFail @IOException
  Workspace -> Sem (Reader Workspace : r) () -> Sem r ()
forall i (r :: EffectRow) a. i -> Sem (Reader i : r) a -> Sem r a
runReader (FilePath -> Workspace
Workspace FilePath
ws) Sem (Reader Workspace : r) ()
f
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
os FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"mingw32" Bool -> Bool -> Bool
&& Maybe FilePath
maybeKeepWorkspace Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"1") (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> Sem (Error IOException : r) ()
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
 Member Log r) =>
FilePath -> Sem r ()
removePathForcibly FilePath
ws
      Sem (Error IOException : r) ()
-> (Sem (Error IOException : r) () -> Sem r ()) -> Sem r ()
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(Member Hedgehog r, HasCallStack, Show e) =>
Sem (Error e : r) a -> Sem r a
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 :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member Log r,
 Member (Embed IO) r) =>
FilePath -> Sem (Reader Workspace : r) () -> Sem r ()
moduleWorkspace FilePath
prefix Sem (Reader Workspace : r) ()
f = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
  FilePath -> Sem (Reader Workspace : r) () -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member Log r,
 Member (Embed IO) r, HasCallStack) =>
FilePath -> Sem (Reader Workspace : r) () -> Sem r ()
workspace (FilePath
prefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
HasCallStack => FilePath
callerModuleName) Sem (Reader Workspace : r) ()
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 :: forall (r :: EffectRow).
(Member Hedgehog r, Member (Embed IO) r, Member Log r) =>
FilePath -> Sem r FilePath
findCabalProjectDir FilePath
dir = do
  Bool
atBase <- FilePath -> Sem (Error IOException : r) Bool
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
 Member Log r) =>
FilePath -> Sem r Bool
doesFileExist (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"cabal.project")
    Sem (Error IOException : r) Bool
-> (Sem (Error IOException : r) Bool -> Sem r Bool) -> Sem r Bool
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
Sem r a -> Sem (Error e : r) a -> Sem r a
trap_ @IOException (Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
  if Bool
atBase
    then FilePath -> Sem r FilePath
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
    else do
      let up :: FilePath
up = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
".."
      Bool
upExist <- FilePath -> Sem (Error IOException : r) Bool
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
 Member Log r) =>
FilePath -> Sem r Bool
doesDirectoryExist FilePath
up
        Sem (Error IOException : r) Bool
-> (Sem (Error IOException : r) Bool -> Sem r Bool) -> Sem r Bool
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
Sem r a -> Sem (Error e : r) a -> Sem r a
trap_ @IOException (Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
      if Bool
upExist
        then FilePath -> Sem r FilePath
forall (r :: EffectRow).
(Member Hedgehog r, Member (Embed IO) r, Member Log r) =>
FilePath -> Sem r FilePath
findCabalProjectDir FilePath
up
        else IO FilePath -> Sem r FilePath
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO FilePath -> Sem r FilePath) -> IO FilePath -> Sem r FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Could not detect project base directory (containing cabal.project)"