Skip to content

Instantly share code, notes, and snippets.

@bubba

bubba/gsoc-2020-work.md

Last active Aug 29, 2020
Star
Embed
What would you like to do?
Learn more about clone URLs
Download ZIP
Luke's list of work done for the Haskell organisation during Google Summer of Code 2020
Raw
gsoc-2020-work.md

Luke's list of work done for Haskell, GSoC 2020

Cabal show-build-info

  • PR
  • Reworked and revitalised to use the underlying nix-style build infrastructure
  • Much more reliable now, automatically builds dependencies
  • Proof of concept of it being integrated with hie-bios attached below (it's quite small)

Other PRs

Type-safe rework of haskell-lsp[-types]

  • PR
  • A large rewrite of the types and API by Zubin and I
  • This time, (should) fully implement 3.15 of the LSP specification
  • Touches haskell-lsp, haskell-lsp-types, lsp-test
  • Currently integrating it with ghcide to see what needs tweaked in practice

putDoc/getDoc and friends in Template Haskell

  • MR
  • Originally a yak shave to help out with the TH parts in the haskell-lsp rewrite
  • Approved, to be merged in GHC 8.14 (9.2 now?)

Other MRs

Distributable binaries for haskell-language-server

  • Main issue
  • Blog post
  • Tweet
  • Most of the work ended up being not in haskell-language-server, but in hie-bios
  • Also had to refactor a bit of ghcide
  • A lot of time spent wrestling with GitHub Actions
  • Got lots of help from Javier and others in the community testing, debugging and patching the builds!

PRs

Rework of the vscode-hie-server, and migrating it vscode-haskell

Raw
hie-bios-cabal-show-build-info.diff
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment