improve implicit cradle

hie-bios.cabal

@@ -172,6 +172,7 @@ Library
                         exceptions           ^>= 0.10,
                         cryptohash-sha1      >= 0.11.100 && < 0.12,
                         directory            >= 1.3.0 && < 1.4,
+                        implicit-hie         >= 0.1.4.0 && < 0.1.5,
                         filepath             >= 1.4.1 && < 1.5,
                         time                 >= 1.8.0 && < 1.13,
                         extra                >= 1.6.14 && < 1.8,

src/HIE/Bios/Cradle.hs

@@ -48,7 +48,7 @@
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Text as C
 import qualified Data.HashMap.Strict as Map
-import Data.Maybe (fromMaybe, maybeToList)
+import Data.Maybe (fromMaybe, maybeToList, catMaybes)
 import Data.List
 import Data.List.Extra (trimEnd)
 import Data.Ord (Down(..))
@@ -68,6 +68,10 @@
 import qualified HIE.Bios.Types as Types
 import qualified HIE.Bios.Ghc.Gap as Gap
 
+import Hie.Locate
+import Hie.Cabal.Parser
+import qualified Hie.Yaml as Implicit
+
 import GHC.Fingerprint (fingerprintString)
 import GHC.ResponseFile (escapeArgs)
 
@@ -143,7 +147,7 @@
 -- each prefix we know how to handle
 data ResolvedCradles a
  = ResolvedCradles
  { cradleRoot :: FilePath
  , resolvedCradles :: [ResolvedCradle a] -- ^ In order of decreasing specificity
  , cradleProgramVersions :: ProgramVersions
  }
@@ -316,22 +320,30 @@
 inferCradleTree :: FilePath -> MaybeT IO (CradleTree a, FilePath)
 inferCradleTree fp =
        maybeItsBios
-   <|> maybeItsStack
-   <|> maybeItsCabal
--- <|> maybeItsObelisk
--- <|> maybeItsObelisk
+   -- If we have both a config file (cabal.project/stack.yaml) and a work dir
+   -- (dist-newstyle/.stack-work), prefer that
+   <|> (cabalExecutable >> cabalConfigDir fp >>= \dir -> cabalWorkDir dir >> pure (cabalCradle dir))
+   <|> (stackExecutable >> stackConfigDir fp >>= \dir -> stackWorkDir dir >> stackCradle dir)
+   -- Redo the checks, but don't check for the work-dir, maybe the user hasn't run a build yet
+   <|> (cabalExecutable >> cabalConfigDir fp >>= pure . cabalCradle)
+   <|> (stackExecutable >> stackConfigDir fp >>= stackCradle)
 
   where
   maybeItsBios = (\wdir -> (Bios (Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir fp
 
-  maybeItsStack = stackExecutable >> (Stack $ StackType Nothing Nothing,) <$> stackWorkDir fp
-
-  maybeItsCabal = (Cabal $ CabalType Nothing Nothing,) <$> cabalWorkDir fp
-
-  -- maybeItsObelisk = (Obelisk,) <$> obeliskWorkDir fp
-
-  -- maybeItsBazel = (Bazel,) <$> rulesHaskellWorkDir fp
-
+  stackCradle :: FilePath -> MaybeT IO (CradleTree a, FilePath)
+  stackCradle fp = do
+    pkgs <- stackYamlPkgs fp
+    pkgsWithComps <- liftIO $ catMaybes <$> mapM (nestedPkg fp) pkgs
+    let yaml = fp </> "stack.yaml"
+    pure $ (,fp) $ case pkgsWithComps of
+      [] -> Stack (StackType Nothing (Just yaml))
+      ps -> StackMulti mempty $ do
+        Package n cs <- ps
+        c <- cs
+        let (prefix, comp) = Implicit.stackComponent n c
+        pure (prefix, StackType (Just comp) (Just yaml))
+  cabalCradle fp = (Cabal $ CabalType Nothing Nothing, fp)
 
 -- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies
 implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)
@@ -893,11 +905,17 @@
 removeVerbosityOpts = filter ((&&) <$> (/= "-v0") <*> (/= "-w"))
 
 
-cabalWorkDir :: FilePath -> MaybeT IO FilePath
-cabalWorkDir wdir =
-      findFileUpwards (== "cabal.project") wdir
-  <|> findFileUpwards (\fp -> takeExtension fp == ".cabal") wdir
+cabalConfigDir :: FilePath -> MaybeT IO FilePath
+cabalConfigDir wdir = findFileUpwards (== "cabal.project") wdir
+                  <|> findFileUpwards (\fp -> takeExtension fp == ".cabal") wdir
+
+cabalWorkDir :: FilePath -> MaybeT IO ()
+cabalWorkDir wdir = do
+  check <- liftIO $ doesDirectoryExist (wdir </> "dist-newstyle")
+  unless check $ fail "No dist-newstyle"
 
+cabalExecutable :: MaybeT IO FilePath
+cabalExecutable = MaybeT $ findExecutable "cabal"
 
 ------------------------------------------------------------------------
 
@@ -1016,11 +1034,16 @@
 stackExecutable :: MaybeT IO FilePath
 stackExecutable = MaybeT $ findExecutable "stack"
 
-stackWorkDir :: FilePath -> MaybeT IO FilePath
-stackWorkDir = findFileUpwards isStack
+stackConfigDir :: FilePath -> MaybeT IO FilePath
+stackConfigDir = findFileUpwards isStack
   where
     isStack name = name == "stack.yaml"
 
+stackWorkDir :: FilePath -> MaybeT IO ()
+stackWorkDir wdir = do
+  check <- liftIO $ doesDirectoryExist (wdir </> ".stack-work")
+  unless check $ fail "No .stack-work"
+
 {-
 -- Support removed for 0.3 but should be added back in the future
 ----------------------------------------------------------------------------