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 :: 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)"