{-# LANGUAGE GADTs, TypeFamilies, DataKinds #-}
module Distribution.Helper.Discover
( findProjects
, getDefaultDistDir
, isValidDistDir
) where
import Control.Monad.Writer
import System.Directory
import System.FilePath
import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Cabal
findProjects :: FilePath -> IO [Ex ProjLoc]
findProjects :: FilePath -> IO [Ex ProjLoc]
findProjects dir :: FilePath
dir = WriterT [Ex ProjLoc] IO () -> IO [Ex ProjLoc]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT [Ex ProjLoc] IO () -> IO [Ex ProjLoc])
-> WriterT [Ex ProjLoc] IO () -> IO [Ex ProjLoc]
forall a b. (a -> b) -> a -> b
$ do
let cabalProject :: FilePath
cabalProject = FilePath
dir FilePath -> FilePath -> FilePath
</> "cabal.project"
WriterT [Ex ProjLoc] IO Bool
-> WriterT [Ex ProjLoc] IO () -> WriterT [Ex ProjLoc] IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> WriterT [Ex ProjLoc] IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> WriterT [Ex ProjLoc] IO Bool)
-> IO Bool -> WriterT [Ex ProjLoc] IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
cabalProject) (WriterT [Ex ProjLoc] IO () -> WriterT [Ex ProjLoc] IO ())
-> WriterT [Ex ProjLoc] IO () -> WriterT [Ex ProjLoc] IO ()
forall a b. (a -> b) -> a -> b
$
[Ex ProjLoc] -> WriterT [Ex ProjLoc] IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ProjLoc ('Cabal 'CV2) -> Ex ProjLoc
forall k (a :: k -> *) (x :: k). a x -> Ex a
Ex (ProjLoc ('Cabal 'CV2) -> Ex ProjLoc)
-> ProjLoc ('Cabal 'CV2) -> Ex ProjLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> ProjLoc ('Cabal 'CV2)
ProjLocV2File FilePath
cabalProject FilePath
dir]
let stackYaml :: FilePath
stackYaml = FilePath
dir FilePath -> FilePath -> FilePath
</> "stack.yaml"
WriterT [Ex ProjLoc] IO Bool
-> WriterT [Ex ProjLoc] IO () -> WriterT [Ex ProjLoc] IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> WriterT [Ex ProjLoc] IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> WriterT [Ex ProjLoc] IO Bool)
-> IO Bool -> WriterT [Ex ProjLoc] IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
stackYaml) (WriterT [Ex ProjLoc] IO () -> WriterT [Ex ProjLoc] IO ())
-> WriterT [Ex ProjLoc] IO () -> WriterT [Ex ProjLoc] IO ()
forall a b. (a -> b) -> a -> b
$
[Ex ProjLoc] -> WriterT [Ex ProjLoc] IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ProjLoc 'Stack -> Ex ProjLoc
forall k (a :: k -> *) (x :: k). a x -> Ex a
Ex (ProjLoc 'Stack -> Ex ProjLoc) -> ProjLoc 'Stack -> Ex ProjLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ProjLoc 'Stack
ProjLocStackYaml FilePath
stackYaml]
Maybe FilePath
maybeCabalDir <- IO (Maybe FilePath) -> WriterT [Ex ProjLoc] IO (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
takeDirectory (Maybe FilePath -> Maybe FilePath)
-> IO (Maybe FilePath) -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
findCabalFile FilePath
dir)
[FilePath -> Ex ProjLoc]
-> ((FilePath -> Ex ProjLoc) -> WriterT [Ex ProjLoc] IO (Maybe ()))
-> WriterT [Ex ProjLoc] IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProjLoc ('Cabal 'CV2) -> Ex ProjLoc
forall k (a :: k -> *) (x :: k). a x -> Ex a
Ex (ProjLoc ('Cabal 'CV2) -> Ex ProjLoc)
-> (FilePath -> ProjLoc ('Cabal 'CV2)) -> FilePath -> Ex ProjLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ProjLoc ('Cabal 'CV2)
ProjLocV2Dir, ProjLoc ('Cabal 'CV1) -> Ex ProjLoc
forall k (a :: k -> *) (x :: k). a x -> Ex a
Ex (ProjLoc ('Cabal 'CV1) -> Ex ProjLoc)
-> (FilePath -> ProjLoc ('Cabal 'CV1)) -> FilePath -> Ex ProjLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ProjLoc ('Cabal 'CV1)
ProjLocV1Dir] (((FilePath -> Ex ProjLoc) -> WriterT [Ex ProjLoc] IO (Maybe ()))
-> WriterT [Ex ProjLoc] IO ())
-> ((FilePath -> Ex ProjLoc) -> WriterT [Ex ProjLoc] IO (Maybe ()))
-> WriterT [Ex ProjLoc] IO ()
forall a b. (a -> b) -> a -> b
$ \proj :: FilePath -> Ex ProjLoc
proj -> (FilePath -> WriterT [Ex ProjLoc] IO ())
-> Maybe FilePath -> WriterT [Ex ProjLoc] IO (Maybe ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Ex ProjLoc] -> WriterT [Ex ProjLoc] IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([Ex ProjLoc] -> WriterT [Ex ProjLoc] IO ())
-> (FilePath -> [Ex ProjLoc])
-> FilePath
-> WriterT [Ex ProjLoc] IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ex ProjLoc -> [Ex ProjLoc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ex ProjLoc -> [Ex ProjLoc])
-> (FilePath -> Ex ProjLoc) -> FilePath -> [Ex ProjLoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Ex ProjLoc
proj) Maybe FilePath
maybeCabalDir
getDefaultDistDir :: ProjLoc pt -> DistDir pt
getDefaultDistDir :: ProjLoc pt -> DistDir pt
getDefaultDistDir (ProjLocV1CabalFile _cabal_file :: FilePath
_cabal_file pkgdir :: FilePath
pkgdir) =
SCabalProjType 'CV1 -> FilePath -> DistDir ('Cabal 'CV1)
forall (pt :: CabalProjType).
SCabalProjType pt -> FilePath -> DistDir ('Cabal pt)
DistDirCabal SCabalProjType 'CV1
SCV1 (FilePath -> DistDir pt) -> FilePath -> DistDir pt
forall a b. (a -> b) -> a -> b
$ FilePath
pkgdir FilePath -> FilePath -> FilePath
</> "dist"
getDefaultDistDir (ProjLocV1Dir pkgdir :: FilePath
pkgdir) =
SCabalProjType 'CV1 -> FilePath -> DistDir ('Cabal 'CV1)
forall (pt :: CabalProjType).
SCabalProjType pt -> FilePath -> DistDir ('Cabal pt)
DistDirCabal SCabalProjType 'CV1
SCV1 (FilePath -> DistDir pt) -> FilePath -> DistDir pt
forall a b. (a -> b) -> a -> b
$ FilePath
pkgdir FilePath -> FilePath -> FilePath
</> "dist"
getDefaultDistDir (ProjLocV2File _cabal_project :: FilePath
_cabal_project projdir :: FilePath
projdir) =
SCabalProjType 'CV2 -> FilePath -> DistDir ('Cabal 'CV2)
forall (pt :: CabalProjType).
SCabalProjType pt -> FilePath -> DistDir ('Cabal pt)
DistDirCabal SCabalProjType 'CV2
SCV2 (FilePath -> DistDir pt) -> FilePath -> DistDir pt
forall a b. (a -> b) -> a -> b
$ FilePath
projdir FilePath -> FilePath -> FilePath
</> "dist-newstyle"
getDefaultDistDir (ProjLocV2Dir projdir :: FilePath
projdir) =
SCabalProjType 'CV2 -> FilePath -> DistDir ('Cabal 'CV2)
forall (pt :: CabalProjType).
SCabalProjType pt -> FilePath -> DistDir ('Cabal pt)
DistDirCabal SCabalProjType 'CV2
SCV2 (FilePath -> DistDir pt) -> FilePath -> DistDir pt
forall a b. (a -> b) -> a -> b
$ FilePath
projdir FilePath -> FilePath -> FilePath
</> "dist-newstyle"
getDefaultDistDir (ProjLocStackYaml _) =
Maybe RelativePath -> DistDir 'Stack
DistDirStack Maybe RelativePath
forall a. Maybe a
Nothing
isValidDistDir :: DistDir pt -> IO (Maybe Bool)
isValidDistDir :: DistDir pt -> IO (Maybe Bool)
isValidDistDir (DistDirCabal cpt :: SCabalProjType pt
cpt dir :: FilePath
dir) = do
(Bool -> Maybe Bool) -> IO Bool -> IO (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Maybe Bool
forall a. a -> Maybe a
Just (IO Bool -> IO (Maybe Bool)) -> IO Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> SCabalProjType pt -> FilePath
forall (pt :: CabalProjType). SCabalProjType pt -> FilePath
cabalProjTypeMarkerFile SCabalProjType pt
cpt
isValidDistDir DistDirStack{} =
Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
cabalProjTypeMarkerFile :: SCabalProjType pt -> FilePath
cabalProjTypeMarkerFile :: SCabalProjType pt -> FilePath
cabalProjTypeMarkerFile SCV1 = "setup-config"
cabalProjTypeMarkerFile SCV2 = "cache" FilePath -> FilePath -> FilePath
</> "plan.json"
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: m Bool -> m () -> m ()
whenM p :: m Bool
p x :: m ()
x = m Bool
p m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` m ()
x)