|
diff --git a/cabal.project b/cabal.project |
|
index e6fdbadb..4ccd4e4a 100644 |
|
--- a/cabal.project |
|
+++ b/cabal.project |
|
@@ -1 +1,4 @@ |
|
packages: . |
|
+ |
|
+package hie-bios |
|
+ ghc-options: "-dynamic" |
|
diff --git a/exe/Main.hs b/exe/Main.hs |
|
index 23add7c4..1c9a64ba 100644 |
|
--- a/exe/Main.hs |
|
+++ b/exe/Main.hs |
|
@@ -80,7 +80,11 @@ main = flip E.catches handlers $ do |
|
res <- forM remainingArgs $ \fp -> do |
|
res <- getCompilerOptions fp cradle |
|
case res of |
|
- CradleFail (CradleError _ex err) -> |
|
+ CradleFail (CradleFileError file _ err) -> |
|
+ return $ "Failed to show flags for \"" |
|
+ ++ fp |
|
+ ++ "\": " ++ file ++ "\n" ++ show err |
|
+ CradleFail (CradleGeneralError _ex err) -> |
|
return $ "Failed to show flags for \"" |
|
++ fp |
|
++ "\": " ++ show err |
|
diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs |
|
index 3e96c008..16e165bd 100644 |
|
--- a/src/HIE/Bios/Cradle.hs |
|
+++ b/src/HIE/Bios/Cradle.hs |
|
@@ -1,6 +1,8 @@ |
|
{-# LANGUAGE ScopedTypeVariables #-} |
|
{-# LANGUAGE TupleSections #-} |
|
{-# LANGUAGE BangPatterns #-} |
|
+{-# LANGUAGE DeriveGeneric #-} |
|
+{-# LANGUAGE OverloadedStrings #-} |
|
module HIE.Bios.Cradle ( |
|
findCradle |
|
, loadCradle |
|
@@ -19,6 +21,8 @@ module HIE.Bios.Cradle ( |
|
|
|
import Control.Exception (handleJust) |
|
import qualified Data.Yaml as Yaml |
|
+import Data.Char |
|
+import Data.List |
|
import Data.Void |
|
import System.Process |
|
import System.Exit |
|
@@ -38,6 +42,9 @@ import System.IO.Temp |
|
import System.IO.Error (isPermissionError) |
|
import Data.List |
|
import Data.Ord (Down(..)) |
|
+import Data.Aeson |
|
+import GHC.Generics |
|
+import qualified Data.ByteString.Lazy.Char8 as BS |
|
|
|
import System.PosixCompat.Files |
|
import HIE.Bios.Wrappers |
|
@@ -48,9 +55,11 @@ import Data.Conduit.Process |
|
import qualified Data.Conduit.Combinators as C |
|
import qualified Data.Conduit as C |
|
import qualified Data.Conduit.Text as C |
|
+import Data.Text (Text) |
|
import qualified Data.Text as T |
|
-import Data.Maybe (fromMaybe) |
|
+import Data.Maybe (fromJust, fromMaybe) |
|
import GHC.Fingerprint (fingerprintString) |
|
+import Debug.Trace (trace) |
|
---------------------------------------------------------------- |
|
|
|
-- | Given root\/foo\/bar.hs, return root\/hie.yaml, or wherever the yaml file was found. |
|
@@ -115,7 +124,7 @@ addCradleDeps deps c = |
|
addActionDeps :: CradleAction a -> CradleAction a |
|
addActionDeps ca = |
|
ca { runCradle = \l fp -> |
|
- (fmap (\(ComponentOptions os' dir ds) -> ComponentOptions os' dir (ds `union` deps))) |
|
+ (fmap (\(ComponentOptions os' dir ds ld) -> ComponentOptions os' dir (ds `union` deps) ld)) |
|
<$> runCradle ca l fp } |
|
|
|
implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath) |
|
@@ -200,7 +209,9 @@ defaultCradle cur_dir = |
|
{ cradleRootDir = cur_dir |
|
, cradleOptsProg = CradleAction |
|
{ actionName = Types.Default |
|
- , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions [] cur_dir [])) |
|
+ , runCradle = \_ _ -> do |
|
+ libDir <- dropWhileEnd isSpace <$> readProcess "ghc" ["--print-libdir"] "" |
|
+ return (CradleSuccess (ComponentOptions [] cur_dir [] (Just libDir))) |
|
} |
|
} |
|
|
|
@@ -280,7 +291,7 @@ multiAction buildCustomCradle cur_dir cs l cur_fp = |
|
<$> mapM (\(p, c) -> (,c) <$> (canonicalizePath (cur_dir </> p))) cs |
|
|
|
selectCradle [] = |
|
- return (CradleFail (CradleError ExitSuccess err_msg)) |
|
+ return (CradleFail (CradleGeneralError ExitSuccess err_msg)) |
|
selectCradle ((p, c): css) = |
|
if p `isPrefixOf` cur_fp |
|
then runCradle |
|
@@ -293,12 +304,15 @@ multiAction buildCustomCradle cur_dir cs l cur_fp = |
|
------------------------------------------------------------------------- |
|
|
|
directCradle :: FilePath -> [String] -> Cradle a |
|
-directCradle wdir args = |
|
+directCradle wdir args = |
|
Cradle |
|
{ cradleRootDir = wdir |
|
, cradleOptsProg = CradleAction |
|
{ actionName = Types.Direct |
|
- , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions args wdir [])) |
|
+ , runCradle = \_ _ -> do |
|
+ -- TODO: make this a maybe |
|
+ libDir <- dropWhileEnd isSpace <$> readProcess "ghc" ["--print-libdir"] "" |
|
+ return (CradleSuccess (ComponentOptions args wdir [] (Just libDir))) |
|
} |
|
} |
|
|
|
@@ -343,7 +357,7 @@ biosAction wdir bios bios_deps l fp = do |
|
-- delimited by newlines. |
|
-- Execute the bios action and add dependencies of the cradle. |
|
-- Removes all duplicates. |
|
- return $ makeCradleResult (ex, std, wdir, res) deps |
|
+ return $ makeCradleResult (ex, std, wdir, res, error "todo") deps |
|
|
|
------------------------------------------------------------------------ |
|
-- Cabal Cradle |
|
@@ -419,27 +433,106 @@ withCabalWrapperTool (ghcPath, ghcArgs) wdir k = do |
|
where |
|
setMode wrapper_fp = setFileMode wrapper_fp accessModes |
|
|
|
+data CabalBuildInfo = CabalBuildInfo |
|
+ { cabalVersion :: String |
|
+ , compilerInfo :: CompilerInfo |
|
+ , components :: [ComponentInfo] |
|
+ , dependentFiles :: [FilePath] |
|
+ } deriving (Generic, Show) |
|
+ |
|
+instance FromJSON CabalBuildInfo where |
|
+ parseJSON = withObject "CabalBuildInfo" $ \v -> |
|
+ CabalBuildInfo <$> v .: "cabal-version" |
|
+ <*> v .: "compiler" |
|
+ <*> v .: "components" |
|
+ <*> v .: "dependent-files" |
|
+ |
|
+data CompilerInfo = CompilerInfo |
|
+ { flavour :: String |
|
+ , compilerId :: String |
|
+ , path :: String |
|
+ } deriving (Generic, Show) |
|
+ |
|
+instance FromJSON CompilerInfo where |
|
+ parseJSON = genericParseJSON $ |
|
+ defaultOptions { fieldLabelModifier = camelTo2 '-' } |
|
+ |
|
+data ComponentInfo = ComponentInfo |
|
+ { componentType :: String |
|
+ , componentName :: String |
|
+ , componentUnitId :: String |
|
+ , componentCompilerArgs :: [String] |
|
+ , componentModules :: [String] |
|
+ , componentSrcFiles :: [FilePath] |
|
+ , componentHsSrcDirs :: [FilePath] |
|
+ , componentSrcDir :: FilePath |
|
+ , componentCabalFile :: FilePath |
|
+ } deriving (Generic, Show) |
|
+ |
|
+instance FromJSON ComponentInfo where |
|
+ parseJSON = genericParseJSON $ |
|
+ defaultOptions { fieldLabelModifier = camelTo2 '-' . fromJust . stripPrefix "component" } |
|
+ |
|
+data CabalBuildInfoError = CabalBuildInfoError |
|
+ { buildInfoErrorMessage :: String |
|
+ , buildInfoErrorFiles :: [FilePath] |
|
+ } deriving (Show) |
|
+ |
|
+instance FromJSON CabalBuildInfoError where |
|
+ parseJSON = withObject "CabalBuildInfoError" $ \v -> |
|
+ CabalBuildInfoError <$> (v .: "error") <*> (v .: "files") |
|
|
|
cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions) |
|
cabalAction work_dir mc l fp = do |
|
+ libDir <- dropWhileEnd isSpace <$> readProcess "cabal" ["v2-exec", "ghc", "--", "--print-libdir"] "" |
|
withCabalWrapperTool ("ghc", []) work_dir $ \wrapper_fp -> do |
|
let cab_args = ["v2-repl", "--with-compiler", wrapper_fp, fromMaybe (fixTargetPath fp) mc] |
|
(ex, output, stde, args) <- |
|
readProcessWithOutputFile l work_dir "cabal" cab_args |
|
deps <- cabalCradleDependencies work_dir |
|
case processCabalWrapperArgs args of |
|
- Nothing -> pure $ CradleFail (CradleError ex |
|
+ Nothing -> pure $ CradleFail (CradleGeneralError ex |
|
["Failed to parse result of calling cabal" |
|
, unlines output |
|
, unlines stde |
|
, unlines args]) |
|
- Just (componentDir, final_args) -> pure $ makeCradleResult (ex, stde, componentDir, final_args) deps |
|
+ Just (componentDir, final_args) -> pure $ makeCradleResult (ex, stde, componentDir, final_args, Just libDir) deps |
|
+ |
|
+ |
|
+ |
|
+-- cabalAction work_dir _mc l fp = do |
|
+-- (ex, stdo, stde, _) <- readProcessWithOutputFile l work_dir "/Users/luke/Source/cabal/dist-newstyle/build/x86_64-osx/ghc-8.10.1/cabal-install-3.3.0.0/x/cabal/build/cabal/cabal" $ ["show-build-info", "--pick-first-target", fixTargetPath fp] |
|
+-- if ex == ExitSuccess |
|
+-- then case eitherDecode (BS.pack (unlines stdo)) :: Either String CabalBuildInfo of |
|
+-- Right bi -> do |
|
+-- let comp = head (components bi) -- since we are passing a single file to show build info, we only want the flags needed for one of its possible components |
|
+-- srcDir = componentSrcDir comp |
|
+-- modules = componentModules comp |
|
+-- args = (removeVerbosityOpts $ removeRTS $ componentCompilerArgs comp) <> modules |
|
+-- deps = dependentFiles bi <> [srcDir </> componentCabalFile comp] |
|
+ |
|
+-- libDir <- dropWhileEnd isSpace <$> readProcess (path $ compilerInfo bi) ["--print-libdir"] "" |
|
+ |
|
+-- pure $ makeCradleResult (ex, stde, srcDir, args, libDir) deps |
|
+-- Left e -> pure $ CradleFail (CradleGeneralError ex ["Couldn't parse cabal show-build-info", e]) |
|
+-- else |
|
+-- case eitherDecode (BS.pack (unlines stdo)) :: Either String CabalBuildInfoError of |
|
+-- Right (CabalBuildInfoError msg (file:_)) -> pure $ CradleFail (CradleFileError file Nothing msg) |
|
+-- Right (CabalBuildInfoError msg []) -> pure $ CradleFail (CradleGeneralError ex [msg]) |
|
+-- Left _ -> mungeError stde ex |
|
where |
|
-- Need to make relative on Windows, due to a Cabal bug with how it |
|
-- parses file targets with a C: drive in it |
|
fixTargetPath x |
|
| isWindows && hasDrive x = makeRelative work_dir x |
|
| otherwise = x |
|
+ mungeError stde ex |
|
+ | "Unknown target" `isInfixOf` unlines stde = pure CradleNone |
|
+ | "Error parsing project file " `isInfixOf` unlines stde = |
|
+ let fp = dropEnd 3 $ last $ words $ head stde |
|
+ in pure $ CradleFail (CradleFileError fp Nothing (unlines stde)) |
|
+ | otherwise = pure $ CradleFail (CradleGeneralError ex stde) |
|
+ dropEnd n s = take (length s - n) s |
|
|
|
removeInteractive :: [String] -> [String] |
|
removeInteractive = filter (/= "--interactive") |
|
@@ -484,6 +577,9 @@ stackCradleDependencies wdir = do |
|
stackAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions) |
|
stackAction work_dir mc l _fp = do |
|
let ghcProcArgs = ("stack", ["exec", "ghc", "--"]) |
|
+ |
|
+ libDir <- dropWhileEnd isSpace <$> readProcess "stack" ["exec", "ghc", "--", "--print-libdir"] "" |
|
+ |
|
-- Same wrapper works as with cabal |
|
withCabalWrapperTool ghcProcArgs work_dir $ \wrapper_fp -> do |
|
(ex1, _stdo, stde, args) <- |
|
@@ -496,13 +592,13 @@ stackAction work_dir mc l _fp = do |
|
pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs |
|
deps <- stackCradleDependencies work_dir |
|
return $ case processCabalWrapperArgs args of |
|
- Nothing -> CradleFail (CradleError ex1 $ |
|
+ Nothing -> CradleFail (CradleGeneralError ex1 $ |
|
("Failed to parse result of calling stack": |
|
stde) |
|
++ args) |
|
|
|
Just (componentDir, ghc_args) -> |
|
- makeCradleResult (combineExitCodes [ex1, ex2], stde ++ stdr, componentDir, ghc_args ++ pkg_ghc_args) deps |
|
+ makeCradleResult (combineExitCodes [ex1, ex2], stde ++ stdr, componentDir, ghc_args ++ pkg_ghc_args, Just libDir) deps |
|
|
|
combineExitCodes :: [ExitCode] -> ExitCode |
|
combineExitCodes = foldr go ExitSuccess |
|
@@ -673,10 +769,10 @@ readProcessWithOutputFile l work_dir fp args = do |
|
readProcessInDirectory :: FilePath -> FilePath -> [String] -> CreateProcess |
|
readProcessInDirectory wdir p args = (proc p args) { cwd = Just wdir } |
|
|
|
-makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> CradleLoadResult ComponentOptions |
|
-makeCradleResult (ex, err, componentDir, gopts) deps = |
|
+makeCradleResult :: (ExitCode, [String], FilePath, [String], Maybe FilePath) -> [FilePath] -> CradleLoadResult ComponentOptions |
|
+makeCradleResult (ex, err, componentDir, gopts, libDir) deps = |
|
case ex of |
|
- ExitFailure _ -> CradleFail (CradleError ex err) |
|
+ ExitFailure _ -> CradleFail (CradleGeneralError ex err) |
|
_ -> |
|
- let compOpts = ComponentOptions gopts componentDir deps |
|
+ let compOpts = ComponentOptions gopts componentDir deps libDir |
|
in CradleSuccess compOpts |
|
diff --git a/src/HIE/Bios/Environment.hs b/src/HIE/Bios/Environment.hs |
|
index d1e0a924..dd56b81e 100644 |
|
--- a/src/HIE/Bios/Environment.hs |
|
+++ b/src/HIE/Bios/Environment.hs |
|
@@ -123,12 +123,25 @@ setHiDir f d = d { hiDir = Just f} |
|
addCmdOpts :: (GhcMonad m) |
|
=> [String] -> DynFlags -> m (DynFlags, [G.Target]) |
|
addCmdOpts cmdOpts df1 = do |
|
- (df2, leftovers', _warns) <- G.parseDynamicFlags df1 (map G.noLoc cmdOpts) |
|
+ -- liftIO $ print cmdOpts |
|
+ (df2, leftovers'', _warns) <- G.parseDynamicFlags df1 (map G.noLoc cmdOpts) |
|
+ |
|
+ -- remove any RTS flags from the leftovers |
|
+ let leftovers' = go False (G.unLoc <$> leftovers'') |
|
+ go _ [] = [] |
|
+ go _ ("+RTS":xs) = go True xs |
|
+ go True ("-RTS":xs) = go False xs |
|
+ go True (_:xs) = go True xs |
|
+ go False (x:xs) = x : go False xs |
|
+ |
|
+ -- liftIO $ putStrLn "leftovers'':" >> print (G.unLoc <$> leftovers'') |
|
+ -- liftIO $ putStrLn "leftovers':" >> print leftovers' |
|
+ |
|
-- parse targets from ghci-scripts. Only extract targets that have been ":add"'ed. |
|
additionalTargets <- concat <$> mapM (liftIO . getTargetsFromGhciScript) (ghciScripts df2) |
|
|
|
-- leftovers contains all Targets from the command line |
|
- let leftovers = leftovers' ++ map G.noLoc additionalTargets |
|
+ let leftovers = leftovers' ++ additionalTargets |
|
|
|
let |
|
-- To simplify the handling of filepaths, we normalise all filepaths right |
|
@@ -148,7 +161,7 @@ addCmdOpts cmdOpts df1 = do |
|
#endif |
|
cur_dir = '.' : [pathSeparator] |
|
nfp = normalise fp |
|
- normal_fileish_paths = map (normalise_hyp . G.unLoc) leftovers |
|
+ normal_fileish_paths = map normalise_hyp leftovers |
|
let |
|
(srcs, objs) = partition_args normal_fileish_paths [] [] |
|
df3 = df2 { ldInputs = map (FileOption "") objs ++ ldInputs df2 } |
|
diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs |
|
index 3b95f8f6..9666f1bd 100644 |
|
--- a/src/HIE/Bios/Internal/Debug.hs |
|
+++ b/src/HIE/Bios/Internal/Debug.hs |
|
@@ -35,7 +35,7 @@ debugInfo fp cradle = unlines <$> do |
|
conf <- findConfig canonFp |
|
crdl <- findCradle' canonFp |
|
case res of |
|
- CradleSuccess (ComponentOptions gopts croot deps) -> do |
|
+ CradleSuccess (ComponentOptions gopts croot deps libDir) -> do |
|
mglibdir <- liftIO getSystemLibDir |
|
return [ |
|
"Root directory: " ++ rootDir |
|
@@ -45,8 +45,9 @@ debugInfo fp cradle = unlines <$> do |
|
, "Config Location: " ++ conf |
|
, "Cradle: " ++ crdl |
|
, "Dependencies: " ++ unwords deps |
|
+ , "LibDir : " ++ show libDir |
|
] |
|
- CradleFail (CradleError ext stderr) -> |
|
+ CradleFail (CradleGeneralError ext stderr) -> |
|
return ["Cradle failed to load" |
|
, "Exit Code: " ++ show ext |
|
, "Stderr: " ++ unlines stderr] |
|
@@ -96,4 +97,4 @@ findCradle' fp = |
|
return $ show crdl |
|
Nothing -> do |
|
crdl <- loadImplicitCradle fp :: IO (Cradle Void) |
|
- return $ show crdl |
|
\ No newline at end of file |
|
+ return $ show crdl |
|
diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs |
|
index 584d3dc5..8d447f2f 100644 |
|
--- a/src/HIE/Bios/Types.hs |
|
+++ b/src/HIE/Bios/Types.hs |
|
@@ -73,7 +73,9 @@ data CradleLoadResult r |
|
deriving (Functor, Show) |
|
|
|
|
|
-data CradleError = CradleError ExitCode [String] deriving (Show) |
|
+data CradleError = CradleFileError FilePath (Maybe (Int, Int)) String |
|
+ | CradleGeneralError ExitCode [String] |
|
+ deriving (Show) |
|
|
|
instance Exception CradleError where |
|
---------------------------------------------------------------- |
|
@@ -94,4 +96,5 @@ data ComponentOptions = ComponentOptions { |
|
-- This is useful, because, sometimes, adding specific files |
|
-- changes the options that a Cradle may return, thus, needs reload |
|
-- as soon as these files are created. |
|
+ , ghcLibDir :: Maybe FilePath |
|
} deriving (Eq, Ord, Show) |
