Skip to content

Commit 8220c57

Browse files
fendorfendor
committed
Extract cabal cradle out of Cradle.hs
Cradle.hs grew a lot and is becoming to be unwieldy. We fix this by extracting the most complicated cradle (cabal) into a separate module. To make this possible, we had to additionally extract a couple of types and functions into separate modules as well to avoid cyclic module dependencies. This commit should not change any behaviour, but merely adds documentation and moves definitions and data types.
1 parent dc8e137 commit 8220c57

File tree

10 files changed

+887
-737
lines changed

10 files changed

+887
-737
lines changed

‎hie-bios.cabal‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -156,6 +156,11 @@ Library
156156
HIE.Bios.Config
157157
HIE.Bios.Config.YAML
158158
HIE.Bios.Cradle
159+
HIE.Bios.Cradle.Cabal
160+
HIE.Bios.Cradle.ProgramVersions
161+
HIE.Bios.Cradle.ProjectConfig
162+
HIE.Bios.Cradle.Resolved
163+
HIE.Bios.Cradle.Utils
159164
HIE.Bios.Environment
160165
HIE.Bios.Internal.Debug
161166
HIE.Bios.Flags

‎src/HIE/Bios/Cradle.hs‎

Lines changed: 15 additions & 702 deletions
Large diffs are not rendered by default.

‎src/HIE/Bios/Cradle/Cabal.hs‎

Lines changed: 567 additions & 0 deletions
Large diffs are not rendered by default.

‎src/HIE/Bios/Cradle/ProgramVersions.hs‎

Lines changed: 72 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,72 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
module HIE.Bios.Cradle.ProgramVersions
4+
( ProgramVersions(..)
5+
, makeVersions
6+
, runCachedIO
7+
) where
8+
9+
10+
import HIE.Bios.Types
11+
import qualified HIE.Bios.Process as Process
12+
13+
import Colog.Core (LogAction (..), WithSeverity (..))
14+
import Data.Version
15+
import Data.IORef
16+
import Text.ParserCombinators.ReadP (readP_to_S)
17+
18+
data ProgramVersions =
19+
ProgramVersions { cabalVersion :: CachedIO (Maybe Version)
20+
, stackVersion :: CachedIO (Maybe Version)
21+
, ghcVersion :: CachedIO (Maybe Version)
22+
}
23+
24+
newtype CachedIO a = CachedIO (IORef (Either (IO a) a))
25+
26+
makeCachedIO :: IO a -> IO (CachedIO a)
27+
makeCachedIO act = CachedIO <$> newIORef (Left act)
28+
29+
runCachedIO :: CachedIO a -> IO a
30+
runCachedIO (CachedIO ref) =
31+
readIORef ref >>= \case
32+
Right x -> pure x
33+
Left act -> do
34+
x <- act
35+
writeIORef ref (Right x)
36+
pure x
37+
38+
makeVersions :: LogAction IO (WithSeverity Log) -> FilePath -> ([String] -> IO (CradleLoadResult String)) -> IO ProgramVersions
39+
makeVersions l wdir ghc = do
40+
cabalVersion <- makeCachedIO $ getCabalVersion l wdir
41+
stackVersion <- makeCachedIO $ getStackVersion l wdir
42+
ghcVersion <- makeCachedIO $ getGhcVersion ghc
43+
pure ProgramVersions{..}
44+
45+
getCabalVersion :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Maybe Version)
46+
getCabalVersion l wdir = do
47+
res <- Process.readProcessWithCwd l wdir "cabal" ["--numeric-version"] ""
48+
case res of
49+
CradleSuccess stdo ->
50+
pure $ versionMaybe stdo
51+
_ -> pure Nothing
52+
53+
getStackVersion :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Maybe Version)
54+
getStackVersion l wdir = do
55+
res <- Process.readProcessWithCwd l wdir "stack" ["--numeric-version"] ""
56+
case res of
57+
CradleSuccess stdo ->
58+
pure $ versionMaybe stdo
59+
_ -> pure Nothing
60+
61+
getGhcVersion :: ([String] -> IO (CradleLoadResult String)) -> IO (Maybe Version)
62+
getGhcVersion ghc = do
63+
res <- ghc ["--numeric-version"]
64+
case res of
65+
CradleSuccess stdo ->
66+
pure $ versionMaybe stdo
67+
_ -> pure Nothing
68+
69+
versionMaybe :: String -> Maybe Version
70+
versionMaybe xs = case reverse $ readP_to_S parseVersion xs of
71+
[] -> Nothing
72+
(x:_) -> Just (fst x)

‎src/HIE/Bios/Cradle/ProjectConfig.hs‎

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
module HIE.Bios.Cradle.ProjectConfig where
2+
3+
import System.FilePath
4+
5+
-- | Explicit data-type for project configuration location.
6+
-- It is basically a 'Maybe' type, but helps to document the API
7+
-- and helps to avoid incorrect usage.
8+
data CradleProjectConfig
9+
= NoExplicitConfig
10+
| ExplicitConfig FilePath
11+
deriving (Eq, Show)
12+
13+
-- | Create an explicit project configuration. Expects a working directory
14+
-- followed by an optional name of the project configuration.
15+
projectConfigFromMaybe :: FilePath -> Maybe FilePath -> CradleProjectConfig
16+
projectConfigFromMaybe _wdir Nothing = NoExplicitConfig
17+
projectConfigFromMaybe wdir (Just fp) = ExplicitConfig (wdir </> fp)

‎src/HIE/Bios/Cradle/Resolved.hs‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
module HIE.Bios.Cradle.Resolved
2+
( ResolvedCradles(..)
3+
, ResolvedCradle(..)
4+
, ConcreteCradle(..)
5+
) where
6+
7+
import HIE.Bios.Cradle.ProgramVersions
8+
import HIE.Bios.Config
9+
10+
-- | The final cradle config that specifies the cradle for
11+
-- each prefix we know how to handle
12+
data ResolvedCradles a = ResolvedCradles
13+
{ cradleRoot :: FilePath
14+
, resolvedCradles :: [ResolvedCradle a] -- ^ In order of decreasing specificity
15+
, cradleProgramVersions :: ProgramVersions
16+
}
17+
18+
-- | 'ConcreteCradle' augmented with information on which file the
19+
-- cradle applies
20+
data ResolvedCradle a = ResolvedCradle
21+
{ prefix :: FilePath -- ^ the prefix to match files
22+
, cradleDeps :: [FilePath] -- ^ accumulated dependencies
23+
, concreteCradle :: ConcreteCradle a
24+
} deriving Show
25+
26+
-- | The actual type of action we will be using to process a file
27+
data ConcreteCradle a
28+
= ConcreteCabal CabalType
29+
| ConcreteStack StackType
30+
| ConcreteBios Callable (Maybe Callable) (Maybe FilePath)
31+
| ConcreteDirect [String]
32+
| ConcreteNone
33+
| ConcreteOther a
34+
deriving Show
35+

‎src/HIE/Bios/Cradle/Utils.hs‎

Lines changed: 108 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,108 @@
1+
module HIE.Bios.Cradle.Utils
2+
(
3+
-- * Helper for process errors
4+
ProcessErrorDetails(..)
5+
, prettyProcessErrorDetails
6+
-- * Cradle utils
7+
, selectCradle
8+
-- * Processing of ghc-options
9+
, removeInteractive
10+
, removeRTS
11+
, removeVerbosityOpts
12+
, expandGhcOptionResponseFile
13+
)
14+
where
15+
16+
import HIE.Bios.Types (prettyCmdSpec)
17+
18+
import Data.List
19+
import System.Process.Extra
20+
import GHC.ResponseFile (expandResponse)
21+
22+
-- ----------------------------------------------------------------------------
23+
-- Process error details
24+
-- ----------------------------------------------------------------------------
25+
26+
data ProcessErrorDetails = ProcessErrorDetails
27+
{ processCmd :: CmdSpec
28+
-- ^ The 'CmdSpec' of the command.
29+
, processStdout :: [String]
30+
-- ^ The stdout of the command.
31+
, processStderr :: [String]
32+
-- ^ The stderr of the command.
33+
, processGhcOptions :: [String]
34+
-- ^ The ghc-options that were obtained via the command
35+
, processHieBiosEnvironment :: [(String, String)]
36+
-- ^ Environment variables populated by 'hie-bios' and their respective value.
37+
}
38+
39+
prettyProcessErrorDetails :: ProcessErrorDetails -> [String]
40+
prettyProcessErrorDetails p =
41+
[ "Failed command: " <> prettyCmdSpec (processCmd p),
42+
unlines (processStdout p),
43+
unlines (processStderr p),
44+
unlines (processGhcOptions p),
45+
"Process Environment:"
46+
] <> [ key <> ": " <> value
47+
| (key, value) <- processHieBiosEnvironment p
48+
]
49+
50+
-- ----------------------------------------------------------------------------
51+
-- Cradle utils
52+
-- ----------------------------------------------------------------------------
53+
54+
-- | Given a list of cradles, try to find the most likely cradle that
55+
-- this 'FilePath' belongs to.
56+
selectCradle :: (a -> FilePath) -> FilePath -> [a] -> Maybe a
57+
selectCradle _ _ [] = Nothing
58+
selectCradle k cur_fp (c: css) =
59+
if k c `isPrefixOf` cur_fp
60+
then Just c
61+
else selectCradle k cur_fp css
62+
63+
64+
-- ----------------------------------------------------------------------------
65+
-- Cradle utils
66+
-- ----------------------------------------------------------------------------
67+
68+
removeInteractive :: [String] -> [String]
69+
removeInteractive = filter (/= "--interactive")
70+
71+
-- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
72+
data InRTS = OutsideRTS | InsideRTS
73+
74+
-- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
75+
--
76+
-- >>> removeRTS ["option1", "+RTS -H32m -RTS", "option2"]
77+
-- ["option1", "option2"]
78+
--
79+
-- >>> removeRTS ["option1", "+RTS", "-H32m", "-RTS", "option2"]
80+
-- ["option1", "option2"]
81+
--
82+
-- >>> removeRTS ["option1", "+RTS -H32m"]
83+
-- ["option1"]
84+
--
85+
-- >>> removeRTS ["option1", "+RTS -H32m", "-RTS", "option2"]
86+
-- ["option1", "option2"]
87+
--
88+
-- >>> removeRTS ["option1", "+RTS -H32m", "-H32m -RTS", "option2"]
89+
-- ["option1", "option2"]
90+
removeRTS :: [String] -> [String]
91+
removeRTS = go OutsideRTS
92+
where
93+
go :: InRTS -> [String] -> [String]
94+
go _ [] = []
95+
go OutsideRTS (y:ys)
96+
| "+RTS" `isPrefixOf` y = go (if "-RTS" `isSuffixOf` y then OutsideRTS else InsideRTS) ys
97+
| otherwise = y : go OutsideRTS ys
98+
go InsideRTS (y:ys) = go (if "-RTS" `isSuffixOf` y then OutsideRTS else InsideRTS) ys
99+
100+
101+
removeVerbosityOpts :: [String] -> [String]
102+
removeVerbosityOpts = filter ((&&) <$> (/= "-v0") <*> (/= "-w"))
103+
104+
expandGhcOptionResponseFile :: [String] -> IO [String]
105+
expandGhcOptionResponseFile args = do
106+
expanded_args <- expandResponse args
107+
pure $ removeInteractive expanded_args
108+

‎src/HIE/Bios/Process.hs‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,8 @@ module HIE.Bios.Process
99
, readProcessWithCwd'
1010
, readProcessWithOutputs
1111
, getCleanEnvironment
12+
-- * File Caching
13+
, cacheFile
1214
-- * Find file utilities
1315
, findFileUpwards
1416
, findFileUpwardsPredicate
@@ -40,6 +42,9 @@ import System.IO.Error (isPermissionError)
4042
import System.IO.Temp
4143

4244
import HIE.Bios.Types
45+
import Control.Monad.Extra (unlessM)
46+
import System.PosixCompat (setFileMode, accessModes)
47+
import HIE.Bios.Environment (getCacheDir)
4348

4449
-- | Wrapper around 'readCreateProcess' that sets the working directory and
4550
-- clears the environment, suitable for invoking cabal/stack and raw ghc commands.
@@ -135,6 +140,31 @@ readProcessWithOutputs outputNames l workDir cp = flip runContT return $ do
135140
removeFileIfExists file
136141
action (name, file)
137142

143+
-- | Create and cache a file in hie-bios's cache directory.
144+
--
145+
-- @'cacheFile' fpName srcHash populate@. 'fpName' is the pattern name of the
146+
-- cached file you want to create. 'srcHash' is the hash that is appended to
147+
-- the file pattern and is expected to change whenever you want to invalidate
148+
-- the cache.
149+
--
150+
-- If the cached file's 'srcHash' changes, then a new file is created, but
151+
-- the old cached file name will not be deleted.
152+
--
153+
-- If the file does not exist yet, 'populate' is invoked with cached file
154+
-- location and it is expected that the caller persists the given filepath in
155+
-- the File System.
156+
cacheFile :: FilePath -> String -> (FilePath -> IO ()) -> IO FilePath
157+
cacheFile fpName srcHash populate = do
158+
cacheDir <- getCacheDir ""
159+
createDirectoryIfMissing True cacheDir
160+
let newFpName = cacheDir </> (dropExtensions fpName <> "-" <> srcHash) <.> takeExtensions fpName
161+
unlessM (doesFileExist newFpName) $ do
162+
populate newFpName
163+
setMode newFpName
164+
pure newFpName
165+
where
166+
setMode wrapper_fp = setFileMode wrapper_fp accessModes
167+
138168
------------------------------------------------------------------------------
139169
-- Utilities
140170

0 commit comments

Comments
 (0)