Cradle.hs

{-# LANGUAGE ScopedTypeVariables #-}

-- Code is derived from https://github.com/mpickering/hie-bios/blob/master/src/HIE/Bios/Cradle.hs
-- git commit: 6460ab40709fe5cc6209b2094d32f80d46c889fd
-- Derived code subject to hie-bios's BSD 3-Clause "New" or "Revised" License
-- Hie-bios's license is distributed with the hie-bios dependency
-- Initial differences can be found at https://github.com/mpickering/hie-bios/pull/178

module Hie.Implicit.Cradle
  ( loadImplicitHieCradle,
  )
where

import Control.Applicative ((<|>))
import Control.Exception (handleJust)
import Control.Monad
import Control.Monad.Extra (ifM)
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.Void
import HIE.Bios.Config hiding (cabalComponent, stackComponent)
import HIE.Bios.Cradle
import HIE.Bios.Types hiding (ActionName (..))
import Hie.Cabal.Parser
import Hie.Locate
import Hie.Yaml
import System.Directory hiding (findFile)
import System.FilePath
import System.IO.Error (isPermissionError)
import System.Process (readProcess)

-- | Given root\/foo\/bar.hs, load an implicit cradle
loadImplicitHieCradle :: FilePath -> IO (Cradle a)
loadImplicitHieCradle wfile = do
  let wdir = takeDirectory wfile
  cfg <- runMaybeT (implicitConfig wdir)
  return $ case cfg of
    Just bc -> getCradle absurd bc
    Nothing -> defaultCradle wdir

implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig fp = do
  (crdType, wdir) <- implicitConfig' fp
  return (CradleConfig [] crdType, wdir)

implicitConfig' :: FilePath -> MaybeT IO (CradleType a, FilePath)
implicitConfig' fp =
  ( \wdir ->
      (Bios (Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)
  )
    <$> biosWorkDir fp
    --   <|> (Obelisk,) <$> obeliskWorkDir fp
    --   <|> (Bazel,) <$> rulesHaskellWorkDir fp
    <|> (cabalExecutable >> cabalProjectDir fp >> cabalDistDir fp >>= cabal)
    <|> (stackExecutable >> stackYamlDir fp >> stackWorkDir fp >>= stack)
    <|> (cabalExecutable >> (cabalProjectDir fp <|> cabalDistDir fp) >>= cabal)
    <|> (stackExecutable >> stackYamlDir fp >>= stack)
    <|> (cabalExecutable >> cabalFile fp >>= cabal)
  where
    readPkgs f gp p = do
      cfs <- gp p
      pkgs <- liftIO $ catMaybes <$> mapM (nestedPkg p) cfs
      pure $ concatMap (components f) pkgs
    build cn cc gp p = do
      c <- cn <$> readPkgs cc gp p
      pure (c, p)
    cabal :: FilePath -> MaybeT IO (CradleType a, FilePath)
    cabal fp = ifM ((>= "3.4") <$> liftIO cabalVersion) (pure (Cabal mempty, fp)) (build (CabalMulti mempty) cabalComponent' cabalPkgs fp)
    stack :: FilePath -> MaybeT IO (CradleType a, FilePath)
    stack = build (StackMulti mempty) stackComponent' stackYamlPkgs
    components f (Package n cs) = map (f n) cs

    cabalComponent' n c = CabalType . Just <$> cabalComponent n c
    stackComponent' n c = flip StackType Nothing . Just <$> stackComponent n c

------------------------------------------------------------------------

cabalExecutable :: MaybeT IO FilePath
cabalExecutable = MaybeT $ findExecutable "cabal"

cabalDistDir :: FilePath -> MaybeT IO FilePath
cabalDistDir = findSubdirUpwards isCabal
  where
    -- TODO do old style dist builds work?
    isCabal name = name == "dist-newstyle" || name == "dist"

cabalProjectDir :: FilePath -> MaybeT IO FilePath
cabalProjectDir = findFileUpwards isCabal
  where
    isCabal "cabal.project" = True
    isCabal "cabal.project.local" = True
    isCabal _ = False

cabalFile :: FilePath -> MaybeT IO FilePath
cabalFile = findFileUpwards isCabal
  where
    isCabal = (".cabal" ==) . takeExtension

------------------------------------------------------------------------
-- Stack Cradle
-- Works for by invoking `stack repl` with a wrapper script

stackExecutable :: MaybeT IO FilePath
stackExecutable = MaybeT $ findExecutable "stack"

stackWorkDir :: FilePath -> MaybeT IO FilePath
stackWorkDir = findSubdirUpwards isStack
  where
    isStack name = name == ".stack-work"

stackYamlDir :: FilePath -> MaybeT IO FilePath
stackYamlDir = findFileUpwards isStack
  where
    isStack name = name == "stack.yaml"

-- | Searches upwards for the first directory containing a subdirectory
-- to match the predicate.
findSubdirUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findSubdirUpwards p dir = findContentUpwards p' dir
  where
    p' subdir = do
      exists <- doesDirectoryExist $ dir </> subdir
      return $ (p subdir) && exists

-- | Searches upwards for the first directory containing a file to match
-- the predicate.
findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards p dir = findContentUpwards p' dir
  where
    p' file = do
      exists <- doesFileExist $ dir </> file
      return $ (p file) && exists

findContentUpwards :: (FilePath -> IO Bool) -> FilePath -> MaybeT IO FilePath
findContentUpwards p dir = do
  cnts <-
    liftIO $
      handleJust
        -- Catch permission errors
        (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)
        pure
        (findContent p dir)
  case cnts of
    []
      | dir' == dir -> fail "No cabal files"
      | otherwise -> findContentUpwards p dir'
    _ : _ -> return dir
  where
    dir' = takeDirectory dir

-- | Sees if any file in the directory matches the predicate
findContent :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
findContent p dir = do
  b <- doesDirectoryExist dir
  if b then getFiles else pure []
  where
    getFiles = getDirectoryContents dir >>= filterM p

biosWorkDir :: FilePath -> MaybeT IO FilePath
biosWorkDir = findFileUpwards (".hie-bios" ==)

cabalVersion :: IO String
cabalVersion = head . words <$> readProcess "cabal" ["--numeric-version"] ""