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