diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2019-09-18 - 0.2 + + * Compat with 8.2 and 8.8 + * Add support for explicitly specifying dependencies for a cradle + * Separate arguments by null bytes, so arguments can contain spaces + (cabal/stack wrapper) + * Add --help to CLI + * Fix the directories that certain processes run in + 2019-09-07 - 0.1.1 * Compat with GHC 8.4 diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, LambdaCase #-} module Main where @@ -6,16 +6,18 @@ import Control.Exception (Exception, Handler(..), ErrorCall(..)) import qualified Control.Exception as E +import Control.Monad ( forM ) import Data.Typeable (Typeable) import Data.Version (showVersion) import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) +import System.FilePath( () ) import HIE.Bios import HIE.Bios.Types -import HIE.Bios.Check +import HIE.Bios.Ghc.Check import HIE.Bios.Debug import Paths_hie_bios @@ -30,9 +32,12 @@ usage :: String usage = progVersion ++ "Usage:\n" - ++ "\t biosc check" ++ ghcOptHelp ++ "\n" - ++ "\t biosc version\n" - ++ "\t biosc help\n" + ++ "\t hie-bios check" ++ ghcOptHelp ++ "\n" + ++ "\t hie-bios expand \n" + ++ "\t hie-bios flags \n" + ++ "\t hie-bios debug\n" + ++ "\t hie-bios root\n" + ++ "\t hie-bios version\n" ---------------------------------------------------------------- @@ -52,7 +57,9 @@ args <- getArgs cradle <- getCurrentDirectory >>= \cwd -> -- find cradle does a takeDirectory on the argument, so make it into a file - findCradle $ cwd ++ "/File.hs" + findCradle (cwd "File.hs") >>= \case + Just yaml -> loadCradle yaml + Nothing -> loadImplicitCradle (cwd "File.hs") let cmdArg0 = args !. 0 remainingArgs = tail args opt = defaultOptions @@ -62,6 +69,18 @@ "debug" -> debugInfo opt cradle "root" -> rootInfo opt cradle "version" -> return progVersion + "flags" -> do + res <- forM remainingArgs $ \fp -> do + res <- getCompilerOptions fp cradle + case res of + Left err -> return $ "Failed to show flags for \"" ++ fp ++ "\": " ++ show err + Right opts -> return $ "CompilerOptions: " ++ show (ghcOptions opts) + return (unlines res) + + "help" -> return usage + "--help" -> return usage + "-h" -> return usage + cmd -> E.throw (NoSuchCommand cmd) putStr res where @@ -70,11 +89,13 @@ handler1 :: ErrorCall -> IO () handler1 = print -- for debug handler2 :: HhpcError -> IO () - handler2 SafeList = return () + handler2 SafeList = hPutStr stderr usage handler2 (TooManyArguments cmd) = do hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments" handler2 (NoSuchCommand cmd) = do hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" + hPutStrLn stderr "" + hPutStr stderr usage handler2 (CmdArg errs) = do mapM_ (hPutStr stderr) errs handler2 (FileNotExist file) = do diff --git a/hie-bios.cabal b/hie-bios.cabal --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -1,12 +1,12 @@ Name: hie-bios -Version: 0.1.1 +Version: 0.2.0 Author: Matthew Pickering Maintainer: Matthew Pickering License: BSD3 License-File: LICENSE Homepage: https://github.com/mpickering/hie-bios Synopsis: Set up a GHC API session -Description: +Description: Set up a GHC API session and obtain flags required to compile a source file Category: Development Cabal-Version: >= 1.10 @@ -16,38 +16,42 @@ wrappers/cabal wrappers/cabal.hs +tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2 + Library Default-Language: Haskell2010 GHC-Options: -Wall HS-Source-Dirs: src Exposed-Modules: HIE.Bios - HIE.Bios.Check + HIE.Bios.Config HIE.Bios.Cradle + HIE.Bios.Environment HIE.Bios.Debug - HIE.Bios.GHCApi - HIE.Bios.Gap - HIE.Bios.Doc - HIE.Bios.Load - HIE.Bios.Logger + HIE.Bios.Flags HIE.Bios.Types - HIE.Bios.Things - HIE.Bios.Config + HIE.Bios.Ghc.Api + HIE.Bios.Ghc.Check + HIE.Bios.Ghc.Doc + HIE.Bios.Ghc.Gap + HIE.Bios.Ghc.Load + HIE.Bios.Ghc.Logger + HIE.Bios.Ghc.Things Build-Depends: base >= 4.8 && < 5, base16-bytestring >= 0.1.1 && < 0.2, bytestring >= 0.10.8 && < 0.11, deepseq >= 1.4.3 && < 1.5, - containers >= 0.5.11 && < 0.7, + containers >= 0.5.10 && < 0.7, cryptohash-sha1 >= 0.11.100 && < 0.12, - directory >= 1.3.1 && < 1.4, - filepath >= 1.4.2 && < 1.5, - time >= 1.8.0 && < 1.9, + directory >= 1.3.0 && < 1.4, + filepath >= 1.4.1 && < 1.5, + time >= 1.8.0 && < 1.10, extra >= 1.6.18 && < 1.7, process >= 1.6.1 && < 1.7, file-embed >= 0.0.11 && < 0.1, - ghc >= 8.4.1 && < 8.7, - transformers >= 0.5.5 && < 0.6, - temporary >= 1.3 && < 1.4, + ghc >= 8.2.2 && < 8.9, + transformers >= 0.5.2 && < 0.6, + temporary >= 1.2 && < 1.4, text >= 1.2.3 && < 1.3, unix-compat >= 0.5.2 && < 0.6, unordered-containers >= 0.2.10 && < 0.3, diff --git a/src/HIE/Bios.hs b/src/HIE/Bios.hs --- a/src/HIE/Bios.hs +++ b/src/HIE/Bios.hs @@ -1,20 +1,20 @@ -- | The HIE Bios module HIE.Bios ( - -- * Initialise a session + -- * Find and load a Cradle Cradle(..) , findCradle + , loadCradle + , loadImplicitCradle , defaultCradle - , initializeFlagsWithCradle - , initializeFlagsWithCradleWithMessage - -- * Load a module into a session - , loadFile - , loadFileWithMessage - -- * Eliminate a session to IO - , withGhcT + -- * Compiler Options + , CompilerOptions(..) + , getCompilerOptions + -- * Initialise session + , initSession ) where import HIE.Bios.Cradle import HIE.Bios.Types -import HIE.Bios.GHCApi -import HIE.Bios.Load +import HIE.Bios.Flags +import HIE.Bios.Environment diff --git a/src/HIE/Bios/Check.hs b/src/HIE/Bios/Check.hs deleted file mode 100644 --- a/src/HIE/Bios/Check.hs +++ /dev/null @@ -1,75 +0,0 @@ -module HIE.Bios.Check ( - checkSyntax - , check - , expandTemplate - , expand - ) where - -import DynFlags (dopt_set, DumpFlag(Opt_D_dump_splices)) -import GHC (Ghc, DynFlags(..), GhcMonad) - -import HIE.Bios.GHCApi -import HIE.Bios.Logger -import HIE.Bios.Types -import HIE.Bios.Load -import Outputable - ----------------------------------------------------------------- - --- | Checking syntax of a target file using GHC. --- Warnings and errors are returned. -checkSyntax :: Options - -> Cradle - -> [FilePath] -- ^ The target files. - -> IO String -checkSyntax _ _ [] = return "" -checkSyntax opt cradle files = withGhcT $ do - pprTrace "cradble" (text $ show cradle) (return ()) - initializeFlagsWithCradle (head files) cradle - either id id <$> check opt files - where - {- - sessionName = case files of - [file] -> file - _ -> "MultipleFiles" - -} - ----------------------------------------------------------------- - --- | Checking syntax of a target file using GHC. --- Warnings and errors are returned. -check :: (GhcMonad m) - => Options - -> [FilePath] -- ^ The target files. - -> m (Either String String) -check opt fileNames = withLogger opt setAllWarningFlags $ setTargetFiles (map dup fileNames) - -dup :: a -> (a, a) -dup x = (x, x) - ----------------------------------------------------------------- - --- | Expanding Haskell Template. -expandTemplate :: Options - -> Cradle - -> [FilePath] -- ^ The target files. - -> IO String -expandTemplate _ _ [] = return "" -expandTemplate opt cradle files = withGHC sessionName $ do - initializeFlagsWithCradle (head files) cradle - either id id <$> expand opt files - where - sessionName = case files of - [file] -> file - _ -> "MultipleFiles" - ----------------------------------------------------------------- - --- | Expanding Haskell Template. -expand :: Options - -> [FilePath] -- ^ The target files. - -> Ghc (Either String String) -expand opt fileNames = withLogger opt (setDumpSplices . setNoWarningFlags) $ setTargetFiles (map dup fileNames) - -setDumpSplices :: DynFlags -> DynFlags -setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices diff --git a/src/HIE/Bios/Config.hs b/src/HIE/Bios/Config.hs --- a/src/HIE/Bios/Config.hs +++ b/src/HIE/Bios/Config.hs @@ -1,45 +1,117 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module HIE.Bios.Config( readConfig, Config(..), - CradleConfig(..) + CradleConfig(..), + CradleType(..) ) where import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.HashMap.Strict as Map -import Data.Yaml +import Data.Yaml +data CradleConfig = + CradleConfig + { cradleDependencies :: [FilePath] + -- ^ Dependencies of a cradle. + -- Dependencies are expected to be relative to the root directory. + -- The given files are not required to exist. + , cradleType :: CradleType + -- ^ Type of the cradle to use. Actions to obtain + -- compiler flags from are dependant on this field. + } + deriving (Show) -data CradleConfig = Cabal { component :: Maybe String } - | Stack - | Bazel - | Obelisk - | Bios { prog :: FilePath } - | Direct { arguments :: [String] } - | Default - deriving (Show) +data CradleType + = Cabal { component :: Maybe String } + | Stack + | Bazel + | Obelisk + | Bios + { prog :: FilePath + -- ^ Path to program that retrieves options to compile a file + , depsProg :: Maybe FilePath + -- ^ Optional Path to program to obtain cradle dependencies. + -- Each cradle dependency is to be expected to be on a separate line + -- and relative to the root dir of the cradle, not relative + -- to the location of this program. + } + | Direct { arguments :: [String] } + | Default + deriving (Show) -instance FromJSON CradleConfig where - parseJSON (Object (Map.toList -> [(key, val)])) - | key == "cabal" = case val of - Object x | Just (String v) <- Map.lookup "component" x -> return $ Cabal $ Just $ T.unpack v - _ -> return $ Cabal Nothing - | key == "stack" = return Stack - | key == "bazel" = return Bazel - | key == "obelisk" = return Obelisk - | key == "bios", Object x <- val, Just (String v) <- Map.lookup "program" x = return $ Bios $ T.unpack v - | key == "direct", Object x <- val, Just (Array v) <- Map.lookup "arguments" x = return $ Direct [T.unpack s | String s <- V.toList v] - | key == "default" = return Default - parseJSON _ = fail "Not a known configuration" +instance FromJSON CradleType where + parseJSON (Object o) = parseCradleType o + parseJSON _ = fail "Not a known cradle type. Possible are: cabal, stack, bazel, obelisk, bios, direct, default" +parseCradleType :: Object -> Parser CradleType +parseCradleType o + | Just val <- Map.lookup "cabal" o = parseCabal val + | Just _val <- Map.lookup "stack" o = return Stack + | Just _val <- Map.lookup "bazel" o = return Bazel + | Just _val <- Map.lookup "obelisk" o = return Obelisk + | Just val <- Map.lookup "bios" o = parseBios val + | Just val <- Map.lookup "direct" o = parseDirect val + | Just _val <- Map.lookup "default" o = return Default +parseCradleType o = fail $ "Unknown cradle type: " ++ show o + +parseCabal :: Value -> Parser CradleType +parseCabal (Object x) + | Map.size x == 1 + , Just (String cabalComponent) <- Map.lookup "component" x + = return $ Cabal $ Just $ T.unpack cabalComponent + + | Map.null x + = return $ Cabal Nothing + + | otherwise + = fail "Not a valid Cabal Configuration type, following keys are allowed: component" +parseCabal _ = fail "Cabal Configuration is expected to be an object." + +parseBios :: Value -> Parser CradleType +parseBios (Object x) + | 2 == Map.size x + , Just (String biosProgram) <- Map.lookup "program" x + , Just (String biosDepsProgram) <- Map.lookup "dependency-program" x + = return $ Bios (T.unpack biosProgram) (Just (T.unpack biosDepsProgram)) + + | 1 == Map.size x + , Just (String biosProgram) <- Map.lookup "program" x + = return $ Bios (T.unpack biosProgram) Nothing + + | otherwise + = fail "Not a valid Bios Configuration type, following keys are allowed: program, dependency-program" +parseBios _ = fail "Bios Configuration is expected to be an object." + +parseDirect :: Value -> Parser CradleType +parseDirect (Object x) + | Map.size x == 1 + , Just (Array v) <- Map.lookup "arguments" x + = return $ Direct [T.unpack s | String s <- V.toList v] + + | otherwise + = fail "Not a valid Direct Configuration type, following keys are allowed: arguments" +parseDirect _ = fail "Direct Configuration is expected to be an object." + data Config = Config { cradle :: CradleConfig } deriving (Show) instance FromJSON Config where - parseJSON (Object (Map.toList -> [("cradle", x)])) = Config <$> parseJSON x - parseJSON _ = fail "Expected a cradle: key containing the preferences" + parseJSON (Object val) = do + crd <- val .: "cradle" + crdDeps <- case Map.size val of + 1 -> return [] + 2 -> val .: "dependencies" + _ -> fail "Unknown key, following keys are allowed: cradle, dependencies" + return Config + { cradle = CradleConfig { cradleType = crd + , cradleDependencies = crdDeps + } + } + + parseJSON _ = fail "Expected a cradle: key containing the preferences, possible values: cradle, dependencies" + readConfig :: FilePath -> IO Config -readConfig fp = decodeFileThrow fp +readConfig = decodeFileThrow diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -2,7 +2,8 @@ {-# LANGUAGE TupleSections #-} module HIE.Bios.Cradle ( findCradle - , findCradleWithOpts + , loadCradle + , loadImplicitCradle , defaultCradle ) where @@ -21,50 +22,77 @@ import System.IO.Temp import Data.List -import Debug.Trace import System.PosixCompat.Files ---------------------------------------------------------------- -findCradle :: FilePath -> IO Cradle -findCradle = findCradleWithOpts defaultCradleOpts +-- | Given root/foo/bar.hs, return root/hie.yaml, or wherever the yaml file was found +findCradle :: FilePath -> IO (Maybe FilePath) +findCradle wfile = do + let wdir = takeDirectory wfile + runMaybeT (yamlConfig wdir) + +-- | Given root/hie.yaml load the Cradle +loadCradle :: FilePath -> IO Cradle +loadCradle = loadCradleWithOpts defaultCradleOpts + +-- | Given root/foo/bar.hs, load an implicit cradle +loadImplicitCradle :: FilePath -> IO Cradle +loadImplicitCradle wfile = do + let wdir = takeDirectory wfile + cfg <- runMaybeT (implicitConfig wdir) + return $ case cfg of + Just bc -> getCradle bc + Nothing -> defaultCradle wdir [] + -- | Finding 'Cradle'. -- Find a cabal file by tracing ancestor directories. -- Find a sandbox according to a cabal sandbox config -- in a cabal directory. -findCradleWithOpts :: CradleOpts -> FilePath -> IO Cradle -findCradleWithOpts _copts wfile = do - let wdir = takeDirectory wfile - cfg <- runMaybeT (dhallConfig wdir <|> implicitConfig wdir) - return $ case cfg of - Just bc -> getCradle bc - Nothing -> (defaultCradle wdir) - +loadCradleWithOpts :: CradleOpts -> FilePath -> IO Cradle +loadCradleWithOpts _copts wfile = do + cradleConfig <- readCradleConfig wfile + return $ getCradle (cradleConfig, takeDirectory wfile) getCradle :: (CradleConfig, FilePath) -> Cradle -getCradle (cc, wdir) = case cc of - Cabal mc -> cabalCradle wdir mc - Stack -> stackCradle wdir - Bazel -> rulesHaskellCradle wdir - Obelisk -> obeliskCradle wdir - Bios bios -> biosCradle wdir bios - Direct xs -> directCradle wdir xs - Default -> defaultCradle wdir +getCradle (cc, wdir) = case cradleType cc of + Cabal mc -> cabalCradle wdir mc cradleDeps + Stack -> stackCradle wdir cradleDeps + Bazel -> rulesHaskellCradle wdir cradleDeps + Obelisk -> obeliskCradle wdir cradleDeps + Bios bios deps -> biosCradle wdir bios deps cradleDeps + Direct xs -> directCradle wdir xs cradleDeps + Default -> defaultCradle wdir cradleDeps + where + cradleDeps = cradleDependencies cc implicitConfig :: FilePath -> MaybeT IO (CradleConfig, FilePath) -implicitConfig fp = - (\wdir -> (Bios (wdir ".hie-bios"), wdir)) <$> biosWorkDir fp +implicitConfig fp = do + (crdType, wdir) <- implicitConfig' fp + return (CradleConfig [] crdType, wdir) + +implicitConfig' :: FilePath -> MaybeT IO (CradleType, FilePath) +implicitConfig' fp = (\wdir -> + (Bios (wdir ".hie-bios") Nothing, wdir)) <$> biosWorkDir fp <|> (Obelisk,) <$> obeliskWorkDir fp <|> (Bazel,) <$> rulesHaskellWorkDir fp <|> (Stack,) <$> stackWorkDir fp <|> ((Cabal Nothing,) <$> cabalWorkDir fp) -dhallConfig :: FilePath -> MaybeT IO (CradleConfig, FilePath) -dhallConfig fp = do - wdir <- findFileUpwards (configFileName ==) fp - cfg <- liftIO $ readConfig (wdir configFileName) - return (cradle cfg, wdir) +yamlConfig :: FilePath -> MaybeT IO FilePath +yamlConfig fp = do + configDir <- yamlConfigDirectory fp + return (configDir configFileName) + +yamlConfigDirectory :: FilePath -> MaybeT IO FilePath +yamlConfigDirectory = findFileUpwards (configFileName ==) + +readCradleConfig :: FilePath -> IO CradleConfig +readCradleConfig yamlHie = do + cfg <- liftIO $ readConfig yamlHie + return (cradle cfg) + configFileName :: FilePath configFileName = "hie.yaml" @@ -73,38 +101,59 @@ -- Default cradle has no special options, not very useful for loading -- modules. -defaultCradle :: FilePath -> Cradle -defaultCradle cur_dir = - Cradle { - cradleRootDir = cur_dir - , cradleOptsProg = CradleAction "default" (const $ return (ExitSuccess, "", [])) +defaultCradle :: FilePath -> [FilePath] -> Cradle +defaultCradle cur_dir deps = + Cradle + { cradleRootDir = cur_dir + , cradleOptsProg = CradleAction + { actionName = "default" + , getDependencies = return deps + , getOptions = const $ return (ExitSuccess, "", []) + } } ------------------------------------------------------------------------- -directCradle :: FilePath -> [String] -> Cradle -directCradle wdir args = - Cradle { - cradleRootDir = wdir - , cradleOptsProg = CradleAction "direct" (const $ return (ExitSuccess, "", args)) - } - +directCradle :: FilePath -> [String] -> [FilePath] -> Cradle +directCradle wdir args deps = + Cradle + { cradleRootDir = wdir + , cradleOptsProg = CradleAction + { actionName = "direct" + , getDependencies = return deps + , getOptions = const $ return (ExitSuccess, "", args) + } + } ------------------------------------------------------------------------- -- | Find a cradle by finding an executable `hie-bios` file which will -- be executed to find the correct GHC options to use. -biosCradle :: FilePath -> FilePath -> Cradle -biosCradle wdir bios = do - Cradle { - cradleRootDir = wdir - , cradleOptsProg = CradleAction "bios" (biosAction wdir bios) - } +biosCradle :: FilePath -> FilePath -> Maybe FilePath -> [FilePath] -> Cradle +biosCradle wdir biosProg biosDepsProg deps = + Cradle + { cradleRootDir = wdir + , cradleOptsProg = CradleAction + { actionName = "bios" + , getDependencies = fmap (deps `union`) (biosDepsAction biosDepsProg) + -- Execute the bios action and add dependencies of the cradle. + -- Removes all duplicates. + , getOptions = biosAction wdir biosProg + } + } biosWorkDir :: FilePath -> MaybeT IO FilePath biosWorkDir = findFileUpwards (".hie-bios" ==) +biosDepsAction :: Maybe FilePath -> IO [FilePath] +biosDepsAction (Just biosDepsProg) = do + biosDeps' <- canonicalizePath biosDepsProg + (ex, sout, serr) <- readProcessWithExitCode biosDeps' [] [] + case ex of + ExitFailure _ -> error $ show (ex, sout, serr) + ExitSuccess -> return (lines sout) +biosDepsAction Nothing = return [] biosAction :: FilePath -> FilePath -> FilePath -> IO (ExitCode, String, [String]) biosAction _wdir bios fp = do @@ -117,13 +166,27 @@ -- Works for new-build by invoking `v2-repl` does not support components -- yet. -cabalCradle :: FilePath -> Maybe String -> Cradle -cabalCradle wdir mc = do - Cradle { - cradleRootDir = wdir - , cradleOptsProg = CradleAction "cabal" (cabalAction wdir mc) - } +cabalCradle :: FilePath -> Maybe String -> [FilePath] -> Cradle +cabalCradle wdir mc deps = + Cradle + { cradleRootDir = wdir + , cradleOptsProg = CradleAction + { actionName = "cabal" + , getDependencies = fmap (deps `union`) (cabalCradleDependencies wdir) + , getOptions = cabalAction wdir mc + } + } +cabalCradleDependencies :: FilePath -> IO [FilePath] +cabalCradleDependencies rootDir = do + cabalFiles <- findCabalFiles rootDir + return $ cabalFiles ++ ["cabal.project"] + +findCabalFiles :: FilePath -> IO [FilePath] +findCabalFiles wdir = do + dirContent <- listDirectory wdir + return $ filter ((== ".cabal") . takeExtension) dirContent + cabalWrapper :: String cabalWrapper = $(embedStringFile "wrappers/cabal") @@ -134,9 +197,20 @@ processCabalWrapperArgs args = case lines args of [dir, ghc_args] -> - let final_args = removeInteractive $ map (fixImportDirs dir) (words ghc_args) - in trace dir $ Just final_args + let final_args = + removeInteractive + $ map (fixImportDirs dir) + $ limited ghc_args + in Just final_args _ -> Nothing + where + limited :: String -> [String] + limited = unfoldr $ \argstr -> + if null argstr + then Nothing + else + let (arg, argstr') = break (== '\NUL') argstr + in Just (arg, drop 1 argstr') -- generate a fake GHC that can be passed to cabal -- when run with --interactive, it will print out its @@ -149,7 +223,9 @@ wrapper_hs <- writeSystemTempFile "wrapper.hs" cabalWrapperHs -- the initial contents will be overwritten immediately after by ghc wrapper_fp <- writeSystemTempFile "wrapper.exe" "" - callProcess "ghc" ["-o", wrapper_fp, wrapper_hs] + let ghc = (proc "ghc" ["-o", wrapper_fp, wrapper_hs]) + { cwd = Just (takeDirectory wrapper_hs) } + readCreateProcess ghc "" >>= putStr return wrapper_fp else do writeSystemTempFile "bios-wrapper" cabalWrapper @@ -163,7 +239,7 @@ let cab_args = ["v2-repl", "-v0", "--disable-documentation", "--with-compiler", wrapper_fp] ++ [component_name | Just component_name <- [mc]] (ex, args, stde) <- - withCurrentDirectory work_dir (readProcessWithExitCode "cabal" cab_args []) + readProcessWithExitCodeInDirectory work_dir "cabal" cab_args [] case processCabalWrapperArgs args of Nothing -> error (show (ex, stde, args)) Just final_args -> pure (ex, stde, final_args) @@ -175,7 +251,7 @@ fixImportDirs base_dir arg = if "-i" `isPrefixOf` arg then let dir = drop 2 arg - in if isRelative dir then ("-i" <> base_dir <> "/" <> dir) + in if isRelative dir then ("-i" ++ base_dir ++ "/" ++ dir) else arg else arg @@ -189,13 +265,22 @@ -- Stack Cradle -- Works for by invoking `stack repl` with a wrapper script -stackCradle :: FilePath -> Cradle -stackCradle wdir = - Cradle { - cradleRootDir = wdir - , cradleOptsProg = CradleAction "stack" (stackAction wdir) - } +stackCradle :: FilePath -> [FilePath] -> Cradle +stackCradle wdir deps = + Cradle + { cradleRootDir = wdir + , cradleOptsProg = CradleAction + { actionName = "stack" + , getDependencies = fmap (deps `union`) (stackCradleDependencies wdir) + , getOptions = stackAction wdir + } + } +stackCradleDependencies :: FilePath -> IO [FilePath] +stackCradleDependencies wdir = do + cabalFiles <- findCabalFiles wdir + return $ cabalFiles ++ ["package.yaml", "stack.yaml"] + -- Same wrapper works as with cabal stackWrapper :: String stackWrapper = $(embedStringFile "wrappers/cabal") @@ -205,12 +290,13 @@ wrapper_fp <- writeSystemTempFile "wrapper" stackWrapper -- TODO: This isn't portable for windows setFileMode wrapper_fp accessModes - check <- readFile wrapper_fp - traceM check + -- TODO: this is for debugging + -- check <- readFile wrapper_fp + -- traceM check (ex1, args, stde) <- - withCurrentDirectory work_dir (readProcessWithExitCode "stack" ["repl", "--silent", "--no-load", "--with-ghc", wrapper_fp, fp ] []) + readProcessWithExitCodeInDirectory work_dir "stack" ["repl", "--silent", "--no-load", "--with-ghc", wrapper_fp, fp ] [] (ex2, pkg_args, stdr) <- - withCurrentDirectory work_dir (readProcessWithExitCode "stack" ["path", "--ghc-package-path"] []) + readProcessWithExitCodeInDirectory work_dir "stack" ["path", "--ghc-package-path"] [] let split_pkgs = splitSearchPath (init pkg_args) pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs case processCabalWrapperArgs args of @@ -224,13 +310,11 @@ go a _ = a - stackWorkDir :: FilePath -> MaybeT IO FilePath stackWorkDir = findFileUpwards isStack where isStack name = name == "stack.yaml" - ---------------------------------------------------------------------------- -- rules_haskell - Thanks for David Smith for helping with this one. -- Looks for the directory containing a WORKSPACE file @@ -239,13 +323,19 @@ rulesHaskellWorkDir fp = findFileUpwards (== "WORKSPACE") fp -rulesHaskellCradle :: FilePath -> Cradle -rulesHaskellCradle wdir = do - Cradle { - cradleRootDir = wdir - , cradleOptsProg = CradleAction "bazel" (rulesHaskellAction wdir) +rulesHaskellCradle :: FilePath -> [FilePath] -> Cradle +rulesHaskellCradle wdir deps = + Cradle + { cradleRootDir = wdir + , cradleOptsProg = CradleAction + { actionName = "bazel" + , getDependencies = fmap (deps `union`) (rulesHaskellCradleDependencies wdir) + , getOptions = rulesHaskellAction wdir + } } +rulesHaskellCradleDependencies :: FilePath -> IO [FilePath] +rulesHaskellCradleDependencies _wdir = return ["BUILD.bazel", "WORKSPACE"] bazelCommand :: String bazelCommand = $(embedStringFile "wrappers/bazel") @@ -255,12 +345,9 @@ wrapper_fp <- writeSystemTempFile "wrapper" bazelCommand -- TODO: This isn't portable for windows setFileMode wrapper_fp accessModes - check <- readFile wrapper_fp - traceM check let rel_path = makeRelative work_dir fp - traceM rel_path (ex, args, stde) <- - withCurrentDirectory work_dir (readProcessWithExitCode wrapper_fp [rel_path] []) + readProcessWithExitCodeInDirectory work_dir wrapper_fp [rel_path] [] let args' = filter (/= '\'') args let args'' = filter (/= "\"$GHCI_LOCATION\"") (words args') return (ex, stde, args'') @@ -279,18 +366,24 @@ unless check (fail "Not obelisk dir") return wdir +obeliskCradleDependencies :: FilePath -> IO [FilePath] +obeliskCradleDependencies _wdir = return [] -obeliskCradle :: FilePath -> Cradle -obeliskCradle wdir = - Cradle { - cradleRootDir = wdir - , cradleOptsProg = CradleAction "obelisk" (obeliskAction wdir) +obeliskCradle :: FilePath -> [FilePath] -> Cradle +obeliskCradle wdir deps = + Cradle + { cradleRootDir = wdir + , cradleOptsProg = CradleAction + { actionName = "obelisk" + , getDependencies = fmap (deps `union`) (obeliskCradleDependencies wdir) + , getOptions = obeliskAction wdir + } } obeliskAction :: FilePath -> FilePath -> IO (ExitCode, String, [String]) obeliskAction work_dir _fp = do (ex, args, stde) <- - withCurrentDirectory work_dir (readProcessWithExitCode "ob" ["ide-args"] []) + readProcessWithExitCodeInDirectory work_dir "ob" ["ide-args"] [] return (ex, stde, words args) @@ -316,3 +409,11 @@ where getFiles = filter p <$> getDirectoryContents dir doesPredFileExist file = doesFileExist $ dir file + +-- | Call a process with the given arguments and the given stdin +-- in the given working directory. +readProcessWithExitCodeInDirectory + :: FilePath -> FilePath -> [String] -> String -> IO (ExitCode, String, String) +readProcessWithExitCodeInDirectory work_dir fp args stdin = + let process = (proc fp args) { cwd = Just work_dir } + in readCreateProcessWithExitCode process stdin diff --git a/src/HIE/Bios/Debug.hs b/src/HIE/Bios/Debug.hs --- a/src/HIE/Bios/Debug.hs +++ b/src/HIE/Bios/Debug.hs @@ -1,10 +1,11 @@ module HIE.Bios.Debug (debugInfo, rootInfo) where -import CoreMonad (liftIO) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Char as Char import Data.Maybe (fromMaybe) -import HIE.Bios.GHCApi +import HIE.Bios.Ghc.Api import HIE.Bios.Types ---------------------------------------------------------------- @@ -15,14 +16,19 @@ -> IO String debugInfo opt cradle = convert opt <$> do (_ex, _sterr, gopts) <- getOptions (cradleOptsProg cradle) (cradleRootDir cradle) + deps <- getDependencies (cradleOptsProg cradle) mglibdir <- liftIO getSystemLibDir return [ "Root directory: " ++ rootDir - , "GHC options: " ++ unwords gopts + , "GHC options: " ++ unwords (map quoteIfNeeded gopts) , "System libraries: " ++ fromMaybe "" mglibdir + , "Dependencies: " ++ unwords deps ] where rootDir = cradleRootDir cradle + quoteIfNeeded option + | any Char.isSpace option = "\"" ++ option ++ "\"" + | otherwise = option ---------------------------------------------------------------- diff --git a/src/HIE/Bios/Doc.hs b/src/HIE/Bios/Doc.hs deleted file mode 100644 --- a/src/HIE/Bios/Doc.hs +++ /dev/null @@ -1,24 +0,0 @@ -module HIE.Bios.Doc where - -import GHC (DynFlags, getPrintUnqual, pprCols, GhcMonad) -import Outputable (PprStyle, SDoc, withPprStyleDoc, neverQualify) -import Pretty (Mode(..), Doc, Style(..), renderStyle, style) - -import HIE.Bios.Gap (makeUserStyle) - -showPage :: DynFlags -> PprStyle -> SDoc -> String -showPage dflag stl = showDocWith dflag PageMode . withPprStyleDoc dflag stl - -showOneLine :: DynFlags -> PprStyle -> SDoc -> String -showOneLine dflag stl = showDocWith dflag OneLineMode . withPprStyleDoc dflag stl - -getStyle :: (GhcMonad m) => DynFlags -> m PprStyle -getStyle dflags = makeUserStyle dflags <$> getPrintUnqual - -styleUnqualified :: DynFlags -> PprStyle -styleUnqualified dflags = makeUserStyle dflags neverQualify - -showDocWith :: DynFlags -> Mode -> Doc -> String -showDocWith dflags md = renderStyle mstyle - where - mstyle = style { mode = md, lineLength = pprCols dflags } diff --git a/src/HIE/Bios/Environment.hs b/src/HIE/Bios/Environment.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Environment.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE RecordWildCards, CPP #-} +module HIE.Bios.Environment (initSession, getSystemLibDir, addCmdOpts, getDynamicFlags) where + +import CoreMonad (liftIO) +import GHC (DynFlags(..), GhcLink(..), HscTarget(..), GhcMonad) +import qualified GHC as G +import qualified DriverPhases as G +import qualified Util as G +import DynFlags + +import Control.Monad (void, when) + +import System.Process (readProcess) +import System.Directory +import System.FilePath + +import qualified Crypto.Hash.SHA1 as H +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Base16 +import Data.List + +import HIE.Bios.Types + +initSession :: (GhcMonad m) + => CompilerOptions + -> m [G.Target] +initSession CompilerOptions {..} = do + df <- G.getSessionDynFlags + -- traceShowM (length ghcOptions) + + let opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack ghcOptions) + fp <- liftIO $ getCacheDir opts_hash + -- For now, clear the cache initially rather than persist it across + -- sessions + liftIO $ clearInterfaceCache opts_hash + (df', targets) <- addCmdOpts ghcOptions df + void $ G.setSessionDynFlags + (disableOptimisation + $ setIgnoreInterfacePragmas + $ resetPackageDb + -- -- $ ignorePackageEnv + $ writeInterfaceFiles (Just fp) + $ setVerbosity 0 + + $ setLinkerOptions df' + ) + G.setLogAction (\_df _wr _s _ss _pp _m -> return ()) +#if __GLASGOW_HASKELL__ < 806 + (\_df -> return ()) +#endif + + return targets + +---------------------------------------------------------------- + +-- | Obtaining the directory for system libraries. +getSystemLibDir :: IO (Maybe FilePath) +getSystemLibDir = do + res <- readProcess "ghc" ["--print-libdir"] [] + return $ case res of + "" -> Nothing + dirn -> Just (init dirn) + +---------------------------------------------------------------- + + +cacheDir :: String +cacheDir = "haskell-ide-engine" + +clearInterfaceCache :: FilePath -> IO () +clearInterfaceCache fp = do + cd <- getCacheDir fp + res <- doesPathExist cd + when res (removeDirectoryRecursive cd) + +getCacheDir :: FilePath -> IO FilePath +getCacheDir fp = getXdgDirectory XdgCache (cacheDir fp) + +---------------------------------------------------------------- + +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscNothing + , ghcMode = CompManager + } + +resetPackageDb :: DynFlags -> DynFlags +resetPackageDb df = df { pkgDatabase = Nothing } + +--ignorePackageEnv :: DynFlags -> DynFlags +--ignorePackageEnv df = df { packageEnv = Just "-" } + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = gopt_set df Opt_IgnoreInterfacePragmas + +setVerbosity :: Int -> DynFlags -> DynFlags +setVerbosity n df = df { verbosity = n } + +writeInterfaceFiles :: Maybe FilePath -> DynFlags -> DynFlags +writeInterfaceFiles Nothing df = df +writeInterfaceFiles (Just hi_dir) df = setHiDir hi_dir (gopt_set df Opt_WriteInterface) + +setHiDir :: FilePath -> DynFlags -> DynFlags +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) + -- TODO: remove this trace + -- What about warnings? + -- traceShowM (map G.unLoc leftovers, length warns) + + let + -- To simplify the handling of filepaths, we normalise all filepaths right + -- away. Note the asymmetry of FilePath.normalise: + -- Linux: p/q -> p/q; p\q -> p\q + -- Windows: p/q -> p\q; p\q -> p\q + -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs + -- to -foo.hs. We have to re-prepend the current directory. + normalise_hyp fp + | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp + | otherwise = nfp + where +#if defined(mingw32_HOST_OS) + strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp +#else + strt_dot_sl = "./" `isPrefixOf` fp +#endif + cur_dir = '.' : [pathSeparator] + nfp = normalise fp + normal_fileish_paths = map (normalise_hyp . G.unLoc) leftovers + let + (srcs, objs) = partition_args normal_fileish_paths [] [] + df3 = df2 { ldInputs = map (FileOption "") objs ++ ldInputs df2 } + ts <- mapM (uncurry G.guessTarget) srcs + return (df3, ts) + -- TODO: Need to handle these as well + -- Ideally it requires refactoring to work in GHCi monad rather than + -- Ghc monad and then can just use newDynFlags. + {- + liftIO $ G.handleFlagWarnings idflags1 warns + when (not $ null leftovers) + (throwGhcException . CmdLineError + $ "Some flags have not been recognized: " + ++ (concat . intersperse ", " $ map unLoc leftovers)) + when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do + liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" + -} + +---------------------------------------------------------------- + +-- | Return the 'DynFlags' currently in use in the GHC session. +getDynamicFlags :: IO DynFlags +getDynamicFlags = do + mlibdir <- getSystemLibDir + G.runGhc mlibdir G.getSessionDynFlags + + +-- partition_args, along with some of the other code in this file, +-- was copied from ghc/Main.hs +-- ----------------------------------------------------------------------------- +-- Splitting arguments into source files and object files. This is where we +-- interpret the -x option, and attach a (Maybe Phase) to each source +-- file indicating the phase specified by the -x option in force, if any. +partition_args :: [String] -> [(String, Maybe G.Phase)] -> [String] + -> ([(String, Maybe G.Phase)], [String]) +partition_args [] srcs objs = (reverse srcs, reverse objs) +partition_args ("-x":suff:args) srcs objs + | "none" <- suff = partition_args args srcs objs + | G.StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = G.startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) +partition_args (arg:args) srcs objs + | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs + | otherwise = partition_args args srcs (arg:objs) + + {- + We split out the object files (.o, .dll) and add them + to ldInputs for use by the linker. + The following things should be considered compilation manager inputs: + - haskell source files (strings ending in .hs, .lhs or other + haskellish extension), + - module names (not forgetting hierarchical module names), + - things beginning with '-' are flags that were not recognised by + the flag parser, and we want them to generate errors later in + checkOptions, so we class them as source files (#5921) + - and finally we consider everything without an extension to be + a comp manager input, as shorthand for a .hs or .lhs filename. + Everything else is considered to be a linker object, and passed + straight through to the linker. + -} +looks_like_an_input :: String -> Bool +looks_like_an_input m = G.isSourceFilename m + || G.looksLikeModuleName m + || "-" `isPrefixOf` m + || not (hasExtension m) + +-- -------------------------------------------------------- + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df diff --git a/src/HIE/Bios/Flags.hs b/src/HIE/Bios/Flags.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Flags.hs @@ -0,0 +1,29 @@ +module HIE.Bios.Flags (getCompilerOptions, CradleError) where + +import Control.Monad.IO.Class +import Control.Exception ( Exception ) + +import System.Exit (ExitCode(..)) + +import HIE.Bios.Types (Cradle, CompilerOptions(..), getOptions, cradleOptsProg) + +-- | Initialize the 'DynFlags' relating to the compilation of a single +-- file or GHC session according to the 'Cradle' and 'Options' +-- provided. +getCompilerOptions :: + FilePath -- The file we are loading it because of + -> Cradle + -> IO (Either CradleError CompilerOptions) +getCompilerOptions fp cradle = do + (ex, err, ghcOpts) <- liftIO $ getOptions (cradleOptsProg cradle) fp + case ex of + ExitFailure _ -> return $ Left (CradleError err) + _ -> do + let compOpts = CompilerOptions ghcOpts + return $ Right compOpts + +data CradleError = CradleError String deriving (Show) + +instance Exception CradleError where + +---------------------------------------------------------------- diff --git a/src/HIE/Bios/GHCApi.hs b/src/HIE/Bios/GHCApi.hs deleted file mode 100644 --- a/src/HIE/Bios/GHCApi.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, RecordWildCards, CPP #-} - -module HIE.Bios.GHCApi ( - withGHC - , withGHC' - , withGhcT - , initializeFlagsWithCradle - , initializeFlagsWithCradleWithMessage - , getDynamicFlags - , getSystemLibDir - , withDynFlags - , withCmdFlags - , setNoWarningFlags - , setAllWarningFlags - , setDeferTypeErrors - , CradleError(..) - ) where - -import CoreMonad (liftIO) -import Exception (ghandle, SomeException(..), ExceptionMonad(..), throwIO, Exception(..)) -import GHC (Ghc, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..), GhcMonad, GhcT) -import qualified GHC as G -import qualified DriverPhases as G -import qualified Outputable as G -import qualified MonadUtils as G -import qualified HscMain as G -import qualified GhcMake as G -import qualified Util as G -import DynFlags - -import Control.Monad (void, when) -import System.Exit (exitSuccess, ExitCode(..)) -import System.IO (hPutStr, hPrint, stderr) -import System.IO.Unsafe (unsafePerformIO) -import System.Process (readProcess) - -import System.Directory -import System.FilePath - -import qualified HIE.Bios.Gap as Gap -import HIE.Bios.Types -import Debug.Trace -import qualified Crypto.Hash.SHA1 as H -import qualified Data.ByteString.Char8 as B -import Data.ByteString.Base16 -import Data.List - ----------------------------------------------------------------- - --- | Obtaining the directory for system libraries. -getSystemLibDir :: IO (Maybe FilePath) -getSystemLibDir = do - res <- readProcess "ghc" ["--print-libdir"] [] - return $ case res of - "" -> Nothing - dirn -> Just (init dirn) - ----------------------------------------------------------------- - --- | Converting the 'Ghc' monad to the 'IO' monad. -withGHC :: FilePath -- ^ A target file displayed in an error message. - -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities. - -> IO a -withGHC file body = ghandle ignore $ withGHC' body - where - ignore :: SomeException -> IO a - ignore e = do - hPutStr stderr $ file ++ ":0:0:Error:" - hPrint stderr e - exitSuccess - -withGHC' :: Ghc a -> IO a -withGHC' body = do - mlibdir <- getSystemLibDir - G.runGhc mlibdir body - -withGhcT :: (Exception.ExceptionMonad m, G.MonadIO m, Monad m) => GhcT m a -> m a -withGhcT body = do - mlibdir <- G.liftIO $ getSystemLibDir - G.runGhcT mlibdir body - ----------------------------------------------------------------- - -data Build = CabalPkg | SingleFile deriving Eq - -initializeFlagsWithCradle :: - (GhcMonad m) - => FilePath -- The file we are loading it because of - -> Cradle - -> m () -initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.batchMsg) - --- | Initialize the 'DynFlags' relating to the compilation of a single --- file or GHC session according to the 'Cradle' and 'Options' --- provided. -initializeFlagsWithCradleWithMessage :: - (GhcMonad m) - => Maybe G.Messager - -> FilePath -- The file we are loading it because of - -> Cradle - -> m () -initializeFlagsWithCradleWithMessage msg fp cradle = do - (ex, err, ghcOpts) <- liftIO $ getOptions (cradleOptsProg cradle) fp - G.pprTrace "res" (G.text (show (ex, err, ghcOpts, fp))) (return ()) - case ex of - ExitFailure _ -> throwCradleError err - _ -> return () - let compOpts = CompilerOptions ghcOpts - liftIO $ hPrint stderr ghcOpts - initSessionWithMessage msg compOpts - -data CradleError = CradleError String deriving (Show) - -instance Exception CradleError where - -throwCradleError :: GhcMonad m => String -> m () -throwCradleError = liftIO . throwIO . CradleError - ----------------------------------------------------------------- -cacheDir :: String -cacheDir = "haskell-ide-engine" - -clearInterfaceCache :: FilePath -> IO () -clearInterfaceCache fp = do - cd <- getCacheDir fp - res <- doesPathExist cd - when res (removeDirectoryRecursive cd) - -getCacheDir :: FilePath -> IO FilePath -getCacheDir fp = getXdgDirectory XdgCache (cacheDir ++ "/" ++ fp) - -initSessionWithMessage :: (GhcMonad m) - => Maybe G.Messager - -> CompilerOptions - -> m () -initSessionWithMessage msg CompilerOptions {..} = do - df <- G.getSessionDynFlags - traceShowM (length ghcOptions) - - let opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack ghcOptions) - fp <- liftIO $ getCacheDir opts_hash - -- For now, clear the cache initially rather than persist it across - -- sessions - liftIO $ clearInterfaceCache opts_hash - (df', targets) <- addCmdOpts ghcOptions df - void $ G.setSessionDynFlags - (disableOptimisation - $ setIgnoreInterfacePragmas - $ resetPackageDb --- $ ignorePackageEnv - $ writeInterfaceFiles (Just fp) - $ setVerbosity 0 - - $ setLinkerOptions df' - ) - G.setLogAction (\_df _wr _s _ss _pp _m -> return ()) -#if __GLASGOW_HASKELL__ < 806 - (\_df -> return ()) -#endif - G.setTargets targets - -- Get the module graph using the function `getModuleGraph` - mod_graph <- G.depanal [] True - void $ G.load' LoadAllTargets msg mod_graph - ----------------------------------------------------------------- - --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscNothing - , ghcMode = CompManager - } - -resetPackageDb :: DynFlags -> DynFlags -resetPackageDb df = df { pkgDatabase = Nothing } - ---ignorePackageEnv :: DynFlags -> DynFlags ---ignorePackageEnv df = df { packageEnv = Just "-" } - -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = gopt_set df Opt_IgnoreInterfacePragmas - -setVerbosity :: Int -> DynFlags -> DynFlags -setVerbosity n df = df { verbosity = n } - -writeInterfaceFiles :: Maybe FilePath -> DynFlags -> DynFlags -writeInterfaceFiles Nothing df = df -writeInterfaceFiles (Just hi_dir) df = setHiDir hi_dir (gopt_set df Opt_WriteInterface) - -setHiDir :: FilePath -> DynFlags -> DynFlags -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) - traceShowM (map G.unLoc leftovers, length warns) - - let - -- To simplify the handling of filepaths, we normalise all filepaths right - -- away. Note the asymmetry of FilePath.normalise: - -- Linux: p/q -> p/q; p\q -> p\q - -- Windows: p/q -> p\q; p\q -> p\q - -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs - -- to -foo.hs. We have to re-prepend the current directory. - normalise_hyp fp - | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp - | otherwise = nfp - where -#if defined(mingw32_HOST_OS) - strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp -#else - strt_dot_sl = "./" `isPrefixOf` fp -#endif - cur_dir = '.' : [pathSeparator] - nfp = normalise fp - normal_fileish_paths = map (normalise_hyp . G.unLoc) leftovers - let - (srcs, objs) = partition_args normal_fileish_paths [] [] - df3 = df2 { ldInputs = map (FileOption "") objs ++ ldInputs df2 } - ts <- mapM (uncurry G.guessTarget) srcs - return (df3, ts) - -- TODO: Need to handle these as well - -- Ideally it requires refactoring to work in GHCi monad rather than - -- Ghc monad and then can just use newDynFlags. - {- - liftIO $ G.handleFlagWarnings idflags1 warns - when (not $ null leftovers) - (throwGhcException . CmdLineError - $ "Some flags have not been recognized: " - ++ (concat . intersperse ", " $ map unLoc leftovers)) - when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do - liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" - -} - ----------------------------------------------------------------- - - ----------------------------------------------------------------- - --- | Return the 'DynFlags' currently in use in the GHC session. -getDynamicFlags :: IO DynFlags -getDynamicFlags = do - mlibdir <- getSystemLibDir - G.runGhc mlibdir G.getSessionDynFlags - -withDynFlags :: - (GhcMonad m) - => (DynFlags -> DynFlags) -> m a -> m a -withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body) - where - setup = do - dflag <- G.getSessionDynFlags - void $ G.setSessionDynFlags (setFlag dflag) - return dflag - teardown = void . G.setSessionDynFlags - -withCmdFlags :: - (GhcMonad m) - => [String] -> m a -> m a -withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) - where - setup = do - (dflag, _) <- G.getSessionDynFlags >>= addCmdOpts flags - void $ G.setSessionDynFlags dflag - return dflag - teardown = void . G.setSessionDynFlags - --- partition_args, along with some of the other code in this file, --- was copied from ghc/Main.hs --- ----------------------------------------------------------------------------- --- Splitting arguments into source files and object files. This is where we --- interpret the -x option, and attach a (Maybe Phase) to each source --- file indicating the phase specified by the -x option in force, if any. -partition_args :: [String] -> [(String, Maybe G.Phase)] -> [String] - -> ([(String, Maybe G.Phase)], [String]) -partition_args [] srcs objs = (reverse srcs, reverse objs) -partition_args ("-x":suff:args) srcs objs - | "none" <- suff = partition_args args srcs objs - | G.StopLn <- phase = partition_args args srcs (slurp ++ objs) - | otherwise = partition_args rest (these_srcs ++ srcs) objs - where phase = G.startPhase suff - (slurp,rest) = break (== "-x") args - these_srcs = zip slurp (repeat (Just phase)) -partition_args (arg:args) srcs objs - | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs - | otherwise = partition_args args srcs (arg:objs) - - {- - We split out the object files (.o, .dll) and add them - to ldInputs for use by the linker. - The following things should be considered compilation manager inputs: - - haskell source files (strings ending in .hs, .lhs or other - haskellish extension), - - module names (not forgetting hierarchical module names), - - things beginning with '-' are flags that were not recognised by - the flag parser, and we want them to generate errors later in - checkOptions, so we class them as source files (#5921) - - and finally we consider everything without an extension to be - a comp manager input, as shorthand for a .hs or .lhs filename. - Everything else is considered to be a linker object, and passed - straight through to the linker. - -} -looks_like_an_input :: String -> Bool -looks_like_an_input m = G.isSourceFilename m - || G.looksLikeModuleName m - || "-" `isPrefixOf` m - || not (hasExtension m) - - ----------------------------------------------------------------- - -setDeferTypeErrors :: DynFlags -> DynFlags -setDeferTypeErrors - = foldDFlags (flip wopt_set) [Opt_WarnTypedHoles, Opt_WarnDeferredTypeErrors, Opt_WarnDeferredOutOfScopeVariables] - . foldDFlags setGeneralFlag' [Opt_DeferTypedHoles, Opt_DeferTypeErrors, Opt_DeferOutOfScopeVariables] - -foldDFlags :: (a -> DynFlags -> DynFlags) -> [a] -> DynFlags -> DynFlags -foldDFlags f xs x = foldr f x xs - --- | Set 'DynFlags' equivalent to "-w:". -setNoWarningFlags :: DynFlags -> DynFlags -setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags} - --- | Set 'DynFlags' equivalent to "-Wall". -setAllWarningFlags :: DynFlags -> DynFlags -setAllWarningFlags df = df { warningFlags = allWarningFlags } - -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df - -{-# NOINLINE allWarningFlags #-} -allWarningFlags :: Gap.WarnFlags -allWarningFlags = unsafePerformIO $ do - mlibdir <- getSystemLibDir - G.runGhcT mlibdir $ do - df <- G.getSessionDynFlags - (df', _) <- addCmdOpts ["-Wall"] df - return $ G.warningFlags df' diff --git a/src/HIE/Bios/Gap.hs b/src/HIE/Bios/Gap.hs deleted file mode 100644 --- a/src/HIE/Bios/Gap.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} - -module HIE.Bios.Gap ( - WarnFlags - , emptyWarnFlags - , makeUserStyle - , getModuleName - , getTyThing - , fixInfo - , getModSummaries - , LExpression - , LBinding - , LPattern - , inTypes - , outType - ) where - -import DynFlags (DynFlags) -import GHC(LHsBind, LHsExpr, LPat, Type) -import HsExpr (MatchGroup) -import Outputable (PrintUnqualified, PprStyle, Depth(AllTheWay), mkUserStyle) - ----------------------------------------------------------------- ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 802 -#else -import GHC.PackageDb (ExposedModule(..)) -#endif - -#if __GLASGOW_HASKELL__ >= 804 -import DynFlags (WarningFlag) -import qualified EnumSet as E (EnumSet, empty) -import GHC (mgModSummaries, ModSummary, ModuleGraph) -#else -import qualified Data.IntSet as I (IntSet, empty) -#endif - -#if __GLASGOW_HASKELL__ >= 806 -import HsExpr (MatchGroupTc(..)) -import HsExtension (GhcTc) -import GHC (mg_ext) -#elif __GLASGOW_HASKELL__ >= 804 -import HsExtension (GhcTc) -import GHC (mg_res_ty, mg_arg_tys) -#else -import GHC (Id, mg_res_ty, mg_arg_tys) -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle -#if __GLASGOW_HASKELL__ >= 802 -makeUserStyle dflags style = mkUserStyle dflags style AllTheWay -#else -makeUserStyle _ style = mkUserStyle style AllTheWay -#endif - -#if __GLASGOW_HASKELL__ >= 802 -getModuleName :: (a, b) -> a -getModuleName = fst -#else -getModuleName :: ExposedModule unitid modulename -> modulename -getModuleName = exposedName -#endif - ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 804 -type WarnFlags = E.EnumSet WarningFlag -emptyWarnFlags :: WarnFlags -emptyWarnFlags = E.empty -#else -type WarnFlags = I.IntSet -emptyWarnFlags :: WarnFlags -emptyWarnFlags = I.empty -#endif - -#if __GLASGOW_HASKELL__ >= 804 -getModSummaries :: ModuleGraph -> [ModSummary] -getModSummaries = mgModSummaries - -getTyThing :: (a, b, c, d, e) -> a -getTyThing (t,_,_,_,_) = t - -fixInfo :: (a, b, c, d, e) -> (a, b, c, d) -fixInfo (t,f,cs,fs,_) = (t,f,cs,fs) -#else -getModSummaries :: a -> a -getModSummaries = id - -getTyThing :: (a, b, c, d) -> a -getTyThing (t,_,_,_) = t - -fixInfo :: (a, b, c, d) -> (a, b, c, d) -fixInfo = id -#endif - ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 806 -type LExpression = LHsExpr GhcTc -type LBinding = LHsBind GhcTc -type LPattern = LPat GhcTc - -inTypes :: MatchGroup GhcTc LExpression -> [Type] -inTypes = mg_arg_tys . mg_ext -outType :: MatchGroup GhcTc LExpression -> Type -outType = mg_res_ty . mg_ext -#elif __GLASGOW_HASKELL__ >= 804 -type LExpression = LHsExpr GhcTc -type LBinding = LHsBind GhcTc -type LPattern = LPat GhcTc - -inTypes :: MatchGroup GhcTc LExpression -> [Type] -inTypes = mg_arg_tys -outType :: MatchGroup GhcTc LExpression -> Type -outType = mg_res_ty -#else -type LExpression = LHsExpr Id -type LBinding = LHsBind Id -type LPattern = LPat Id - -inTypes :: MatchGroup Id LExpression -> [Type] -inTypes = mg_arg_tys -outType :: MatchGroup Id LExpression -> Type -outType = mg_res_ty -#endif diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Ghc/Api.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE ScopedTypeVariables, RecordWildCards, CPP #-} + +module HIE.Bios.Ghc.Api ( + withGHC + , withGHC' + , withGhcT + , initializeFlagsWithCradle + , initializeFlagsWithCradleWithMessage + , getDynamicFlags + , getSystemLibDir + , withDynFlags + , withCmdFlags + , setNoWarningFlags + , setAllWarningFlags + , setDeferTypeErrors + ) where + +import CoreMonad (liftIO) +import Exception (ghandle, SomeException(..), ExceptionMonad(..), throwIO) +import GHC (Ghc, LoadHowMuch(..), GhcMonad, GhcT) +import DynFlags + +import qualified GHC as G +import qualified MonadUtils as G +import qualified HscMain as G +import qualified GhcMake as G + +import Control.Monad (void) +import System.Exit (exitSuccess) +import System.IO (hPutStr, hPrint, stderr) +import System.IO.Unsafe (unsafePerformIO) + +import qualified HIE.Bios.Ghc.Gap as Gap +import HIE.Bios.Types +import HIE.Bios.Environment +import HIE.Bios.Flags + + + +---------------------------------------------------------------- + +-- | Converting the 'Ghc' monad to the 'IO' monad. +withGHC :: FilePath -- ^ A target file displayed in an error message. + -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities. + -> IO a +withGHC file body = ghandle ignore $ withGHC' body + where + ignore :: SomeException -> IO a + ignore e = do + hPutStr stderr $ file ++ ":0:0:Error:" + hPrint stderr e + exitSuccess + +withGHC' :: Ghc a -> IO a +withGHC' body = do + mlibdir <- getSystemLibDir + G.runGhc mlibdir body + +withGhcT :: (Exception.ExceptionMonad m, G.MonadIO m, Monad m) => GhcT m a -> m a +withGhcT body = do + mlibdir <- G.liftIO $ getSystemLibDir + G.runGhcT mlibdir body + +---------------------------------------------------------------- + + + +initializeFlagsWithCradle :: + GhcMonad m + => FilePath -- The file we are loading it because of + -> Cradle + -> m () +initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.batchMsg) + +initializeFlagsWithCradleWithMessage :: + GhcMonad m + => Maybe G.Messager + -> FilePath -- The file we are loading it because of + -> Cradle + -> m () +initializeFlagsWithCradleWithMessage msg fp cradle = do + compOpts <- liftIO $ getCompilerOptions fp cradle + case compOpts of + Left err -> liftIO $ throwIO err + Right opts -> initSessionWithMessage msg opts + +initSessionWithMessage :: (GhcMonad m) + => Maybe G.Messager + -> CompilerOptions + -> m () +initSessionWithMessage msg compOpts = do + targets <- initSession compOpts + G.setTargets targets + -- Get the module graph using the function `getModuleGraph` + mod_graph <- G.depanal [] True + void $ G.load' LoadAllTargets msg mod_graph + +---------------------------------------------------------------- + +withDynFlags :: + (GhcMonad m) + => (DynFlags -> DynFlags) -> m a -> m a +withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body) + where + setup = do + dflag <- G.getSessionDynFlags + void $ G.setSessionDynFlags (setFlag dflag) + return dflag + teardown = void . G.setSessionDynFlags + +withCmdFlags :: + (GhcMonad m) + => [String] -> m a -> m a +withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) + where + setup = do + (dflag, _) <- G.getSessionDynFlags >>= addCmdOpts flags + void $ G.setSessionDynFlags dflag + return dflag + teardown = void . G.setSessionDynFlags + +---------------------------------------------------------------- + +setDeferTypeErrors :: DynFlags -> DynFlags +setDeferTypeErrors + = foldDFlags (flip wopt_set) [Opt_WarnTypedHoles, Opt_WarnDeferredTypeErrors, Opt_WarnDeferredOutOfScopeVariables] + . foldDFlags setGeneralFlag' [Opt_DeferTypedHoles, Opt_DeferTypeErrors, Opt_DeferOutOfScopeVariables] + +foldDFlags :: (a -> DynFlags -> DynFlags) -> [a] -> DynFlags -> DynFlags +foldDFlags f xs x = foldr f x xs + +-- | Set 'DynFlags' equivalent to "-w:". +setNoWarningFlags :: DynFlags -> DynFlags +setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags} + +-- | Set 'DynFlags' equivalent to "-Wall". +setAllWarningFlags :: DynFlags -> DynFlags +setAllWarningFlags df = df { warningFlags = allWarningFlags } + + +{-# NOINLINE allWarningFlags #-} +allWarningFlags :: Gap.WarnFlags +allWarningFlags = unsafePerformIO $ do + mlibdir <- getSystemLibDir + G.runGhcT mlibdir $ do + df <- G.getSessionDynFlags + (df', _) <- addCmdOpts ["-Wall"] df + return $ G.warningFlags df' diff --git a/src/HIE/Bios/Ghc/Check.hs b/src/HIE/Bios/Ghc/Check.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Ghc/Check.hs @@ -0,0 +1,75 @@ +module HIE.Bios.Ghc.Check ( + checkSyntax + , check + , expandTemplate + , expand + ) where + +import DynFlags (dopt_set, DumpFlag(Opt_D_dump_splices)) +import GHC (Ghc, DynFlags(..), GhcMonad) + +import HIE.Bios.Ghc.Api +import HIE.Bios.Ghc.Logger +import HIE.Bios.Types +import HIE.Bios.Ghc.Load +import Outputable + +---------------------------------------------------------------- + +-- | Checking syntax of a target file using GHC. +-- Warnings and errors are returned. +checkSyntax :: Options + -> Cradle + -> [FilePath] -- ^ The target files. + -> IO String +checkSyntax _ _ [] = return "" +checkSyntax opt cradle files = withGhcT $ do + pprTrace "cradle" (text $ show cradle) (return ()) + initializeFlagsWithCradle (head files) cradle + either id id <$> check opt files + where + {- + sessionName = case files of + [file] -> file + _ -> "MultipleFiles" + -} + +---------------------------------------------------------------- + +-- | Checking syntax of a target file using GHC. +-- Warnings and errors are returned. +check :: (GhcMonad m) + => Options + -> [FilePath] -- ^ The target files. + -> m (Either String String) +check opt fileNames = withLogger opt setAllWarningFlags $ setTargetFiles (map dup fileNames) + +dup :: a -> (a, a) +dup x = (x, x) + +---------------------------------------------------------------- + +-- | Expanding Haskell Template. +expandTemplate :: Options + -> Cradle + -> [FilePath] -- ^ The target files. + -> IO String +expandTemplate _ _ [] = return "" +expandTemplate opt cradle files = withGHC sessionName $ do + initializeFlagsWithCradle (head files) cradle + either id id <$> expand opt files + where + sessionName = case files of + [file] -> file + _ -> "MultipleFiles" + +---------------------------------------------------------------- + +-- | Expanding Haskell Template. +expand :: Options + -> [FilePath] -- ^ The target files. + -> Ghc (Either String String) +expand opt fileNames = withLogger opt (setDumpSplices . setNoWarningFlags) $ setTargetFiles (map dup fileNames) + +setDumpSplices :: DynFlags -> DynFlags +setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices diff --git a/src/HIE/Bios/Ghc/Doc.hs b/src/HIE/Bios/Ghc/Doc.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Ghc/Doc.hs @@ -0,0 +1,24 @@ +module HIE.Bios.Ghc.Doc where + +import GHC (DynFlags, getPrintUnqual, pprCols, GhcMonad) +import Outputable (PprStyle, SDoc, withPprStyleDoc, neverQualify) +import Pretty (Mode(..), Doc, Style(..), renderStyle, style) + +import HIE.Bios.Ghc.Gap (makeUserStyle) + +showPage :: DynFlags -> PprStyle -> SDoc -> String +showPage dflag stl = showDocWith dflag PageMode . withPprStyleDoc dflag stl + +showOneLine :: DynFlags -> PprStyle -> SDoc -> String +showOneLine dflag stl = showDocWith dflag OneLineMode . withPprStyleDoc dflag stl + +getStyle :: (GhcMonad m) => DynFlags -> m PprStyle +getStyle dflags = makeUserStyle dflags <$> getPrintUnqual + +styleUnqualified :: DynFlags -> PprStyle +styleUnqualified dflags = makeUserStyle dflags neverQualify + +showDocWith :: DynFlags -> Mode -> Doc -> String +showDocWith dflags md = renderStyle mstyle + where + mstyle = style { mode = md, lineLength = pprCols dflags } diff --git a/src/HIE/Bios/Ghc/Gap.hs b/src/HIE/Bios/Ghc/Gap.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Ghc/Gap.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleInstances, CPP #-} + +module HIE.Bios.Ghc.Gap ( + WarnFlags + , emptyWarnFlags + , makeUserStyle + , getModuleName + , getTyThing + , fixInfo + , getModSummaries + , LExpression + , LBinding + , LPattern + , inTypes + , outType + , mapMG + , mgModSummaries + ) where + +import DynFlags (DynFlags) +import GHC(LHsBind, LHsExpr, LPat, Type, ModSummary, ModuleGraph) +import HsExpr (MatchGroup) +import Outputable (PrintUnqualified, PprStyle, Depth(AllTheWay), mkUserStyle) + +---------------------------------------------------------------- +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 802 +#else +import GHC.PackageDb (ExposedModule(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 804 +import DynFlags (WarningFlag) +import qualified EnumSet as E (EnumSet, empty) +import GHC (mgModSummaries, mapMG) +#else +import qualified Data.IntSet as I (IntSet, empty) +#endif + +#if __GLASGOW_HASKELL__ >= 806 +import HsExpr (MatchGroupTc(..)) +import HsExtension (GhcTc) +import GHC (mg_ext) +#elif __GLASGOW_HASKELL__ >= 804 +import HsExtension (GhcTc) +import GHC (mg_res_ty, mg_arg_tys) +#else +import GHC (Id, mg_res_ty, mg_arg_tys) +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle +#if __GLASGOW_HASKELL__ >= 802 +makeUserStyle dflags style = mkUserStyle dflags style AllTheWay +#else +makeUserStyle _ style = mkUserStyle style AllTheWay +#endif + +#if __GLASGOW_HASKELL__ >= 802 +getModuleName :: (a, b) -> a +getModuleName = fst +#else +getModuleName :: ExposedModule unitid modulename -> modulename +getModuleName = exposedName +#endif + +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 804 +type WarnFlags = E.EnumSet WarningFlag +emptyWarnFlags :: WarnFlags +emptyWarnFlags = E.empty +#else +type WarnFlags = I.IntSet +emptyWarnFlags :: WarnFlags +emptyWarnFlags = I.empty +#endif + +#if __GLASGOW_HASKELL__ >= 804 +getModSummaries :: ModuleGraph -> [ModSummary] +getModSummaries = mgModSummaries + +getTyThing :: (a, b, c, d, e) -> a +getTyThing (t,_,_,_,_) = t + +fixInfo :: (a, b, c, d, e) -> (a, b, c, d) +fixInfo (t,f,cs,fs,_) = (t,f,cs,fs) +#else +getModSummaries :: a -> a +getModSummaries = id + +getTyThing :: (a, b, c, d) -> a +getTyThing (t,_,_,_) = t + +fixInfo :: (a, b, c, d) -> (a, b, c, d) +fixInfo = id +#endif + +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 806 +type LExpression = LHsExpr GhcTc +type LBinding = LHsBind GhcTc +type LPattern = LPat GhcTc + +inTypes :: MatchGroup GhcTc LExpression -> [Type] +inTypes = mg_arg_tys . mg_ext +outType :: MatchGroup GhcTc LExpression -> Type +outType = mg_res_ty . mg_ext +#elif __GLASGOW_HASKELL__ >= 804 +type LExpression = LHsExpr GhcTc +type LBinding = LHsBind GhcTc +type LPattern = LPat GhcTc + +inTypes :: MatchGroup GhcTc LExpression -> [Type] +inTypes = mg_arg_tys +outType :: MatchGroup GhcTc LExpression -> Type +outType = mg_res_ty +#else +type LExpression = LHsExpr Id +type LBinding = LHsBind Id +type LPattern = LPat Id + +inTypes :: MatchGroup Id LExpression -> [Type] +inTypes = mg_arg_tys +outType :: MatchGroup Id LExpression -> Type +outType = mg_res_ty +#endif + +#if __GLASGOW_HASKELL__ >= 804 +#else +mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph +mapMG = map +#endif + +#if __GLASGOW_HASKELL__ >= 804 +#else +mgModSummaries :: ModuleGraph -> [ModSummary] +mgModSummaries = id +#endif diff --git a/src/HIE/Bios/Ghc/Load.hs b/src/HIE/Bios/Ghc/Load.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Ghc/Load.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module HIE.Bios.Ghc.Load ( loadFileWithMessage, loadFile, setTargetFiles, setTargetFilesWithMessage) where + +import CoreMonad (liftIO) +import GHC +import qualified GHC as G +import qualified GhcMake as G +import qualified HscMain as G +import HscTypes +import Outputable +import Control.Monad.IO.Class + +import Data.IORef + +import System.Directory +import Hooks +import TcRnTypes (FrontendResult(..)) +import Control.Monad (forM, void) +import GhcMonad +import HscMain +import Debug.Trace +import Data.List + +import Data.Time.Clock +import qualified HIE.Bios.Ghc.Gap as Gap + +#if __GLASGOW_HASKELL__ < 806 +pprTraceM :: Monad m => String -> SDoc -> m () +pprTraceM x s = pprTrace x s (return ()) +#endif + +-- | Obtaining type of a target expression. (GHCi's type:) +loadFileWithMessage :: GhcMonad m + => Maybe G.Messager + -> (FilePath, FilePath) -- ^ A target file. + -> m (Maybe TypecheckedModule, [TypecheckedModule]) +loadFileWithMessage msg file = do + dir <- liftIO $ getCurrentDirectory + pprTraceM "loadFile:2" (text dir) + df <- getSessionDynFlags + pprTraceM "loadFile:3" (ppr $ optLevel df) + (_, tcs) <- collectASTs $ do + (setTargetFilesWithMessage msg [file]) + pprTraceM "loaded" (text (fst file) $$ text (snd file)) + let get_fp = ml_hs_file . ms_location . pm_mod_summary . tm_parsed_module + traceShowM ("tms", (map get_fp tcs)) + let findMod [] = Nothing + findMod (x:xs) = case get_fp x of + Just fp -> if fp `isSuffixOf` (snd file) then Just x else findMod xs + Nothing -> findMod xs + return (findMod tcs, tcs) + +loadFile :: (GhcMonad m) + => (FilePath, FilePath) + -> m (Maybe TypecheckedModule, [TypecheckedModule]) +loadFile = loadFileWithMessage (Just G.batchMsg) + +{- +fileModSummary :: GhcMonad m => FilePath -> m ModSummary +fileModSummary file = do + mss <- getModSummaries <$> G.getModuleGraph + let [ms] = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) mss + return ms + -} + + +setTargetFiles :: GhcMonad m => [(FilePath, FilePath)] -> m () +setTargetFiles = setTargetFilesWithMessage (Just G.batchMsg) + +msTargetIs :: ModSummary -> Target -> Bool +msTargetIs ms t = case targetId t of + TargetModule m -> moduleName (ms_mod ms) == m + TargetFile f _ -> ml_hs_file (ms_location ms) == Just f + +-- | We bump the times for any ModSummary's that are Targets, to +-- fool the recompilation checker so that we can get the typechecked modules +updateTime :: MonadIO m => [Target] -> ModuleGraph -> m ModuleGraph +updateTime ts graph = liftIO $ do + cur_time <- getCurrentTime + let go ms + | any (msTargetIs ms) ts = ms {ms_hs_date = cur_time} + | otherwise = ms + pure $ Gap.mapMG go graph + +-- | Set the files as targets and load them. +setTargetFilesWithMessage :: (GhcMonad m) => Maybe G.Messager -> [(FilePath, FilePath)] -> m () +setTargetFilesWithMessage msg files = do + targets <- forM files guessTargetMapped + pprTrace "setTargets" (vcat (map (\(a,b) -> parens $ text a <+> text "," <+> text b) files) $$ ppr targets) (return ()) + G.setTargets (map (\t -> t { G.targetAllowObjCode = False }) targets) + mod_graph <- updateTime targets =<< depanal [] False + pprTrace "modGraph" (ppr $ Gap.mgModSummaries mod_graph) (return ()) + pprTrace "modGraph" (ppr $ map ms_location $ Gap.mgModSummaries mod_graph) (return ()) + dflags1 <- getSessionDynFlags + pprTrace "hidir" (ppr $ hiDir dflags1) (return ()) + void $ G.load' LoadAllTargets msg mod_graph + +collectASTs :: (GhcMonad m) => m a -> m (a, [TypecheckedModule]) +collectASTs action = do + dflags0 <- getSessionDynFlags + ref1 <- liftIO $ newIORef [] + let dflags1 = dflags0 { hooks = (hooks dflags0) + { hscFrontendHook = traceShow "Use hook" $ Just (astHook ref1) } + } + void $ setSessionDynFlags $ dflags1 -- gopt_set dflags1 Opt_ForceRecomp + res <- action + tcs <- liftIO $ readIORef ref1 + return (res, tcs) + +astHook :: IORef [TypecheckedModule] -> ModSummary -> Hsc FrontendResult +astHook tc_ref ms = ghcInHsc $ do + p <- G.parseModule ms + tcm <- G.typecheckModule p + let tcg_env = fst (tm_internals_ tcm) + liftIO $ modifyIORef tc_ref (tcm :) + return $ FrontendTypecheck tcg_env + +ghcInHsc :: Ghc a -> Hsc a +ghcInHsc gm = do + hsc_session <- getHscEnv + session <- liftIO $ newIORef hsc_session + liftIO $ reflectGhc gm (Session session) + + +guessTargetMapped :: (GhcMonad m) => (FilePath, FilePath) -> m Target +guessTargetMapped (orig_file_name, mapped_file_name) = do + t <- G.guessTarget orig_file_name Nothing + return (setTargetFilename mapped_file_name t) + +setTargetFilename :: FilePath -> Target -> Target +setTargetFilename fn t = + t { targetId = case targetId t of + TargetFile _ p -> TargetFile fn p + tid -> tid } diff --git a/src/HIE/Bios/Ghc/Logger.hs b/src/HIE/Bios/Ghc/Logger.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Ghc/Logger.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE BangPatterns #-} + +module HIE.Bios.Ghc.Logger ( + withLogger + , checkErrorPrefix + , getSrcSpan + ) where + +import Bag (Bag, bagToList) +import CoreMonad (liftIO) +import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices)) +import ErrUtils +import Exception (ghandle) +import FastString (unpackFS) +import GHC (DynFlags(..), SrcSpan(..), Severity(SevError), GhcMonad) +import qualified GHC as G +import HscTypes (SourceError, srcErrorMessages) +import Outputable (PprStyle, SDoc) + +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import System.FilePath (normalise) + +import HIE.Bios.Ghc.Doc (showPage, getStyle) +import HIE.Bios.Ghc.Api (withDynFlags, withCmdFlags) +import HIE.Bios.Types (Options(..), convert) + +---------------------------------------------------------------- + +type Builder = [String] -> [String] + +newtype LogRef = LogRef (IORef Builder) + +newLogRef :: IO LogRef +newLogRef = LogRef <$> newIORef id + +readAndClearLogRef :: Options -> LogRef -> IO String +readAndClearLogRef opt (LogRef ref) = do + b <- readIORef ref + writeIORef ref id + return $! convert opt (b []) + +appendLogRef :: DynFlags -> LogRef -> LogAction +appendLogRef df (LogRef ref) _ _ sev src style msg = do + let !l = ppMsg src sev df style msg + modifyIORef ref (\b -> b . (l:)) + +---------------------------------------------------------------- + +-- | Set the session flag (e.g. "-Wall" or "-w:") then +-- executes a body. Log messages are returned as 'String'. +-- Right is success and Left is failure. +withLogger :: + (GhcMonad m) + => Options -> (DynFlags -> DynFlags) -> m () -> m (Either String String) +withLogger opt setDF body = ghandle (sourceError opt) $ do + logref <- liftIO newLogRef + withDynFlags (setLogger logref . setDF) $ do + withCmdFlags wflags $ do + body + liftIO $ Right <$> readAndClearLogRef opt logref + where + setLogger logref df = df { log_action = appendLogRef df logref } + wflags = filter ("-fno-warn" `isPrefixOf`) $ ghcOpts opt + +---------------------------------------------------------------- + +-- | Converting 'SourceError' to 'String'. +sourceError :: + (GhcMonad m) + => Options -> SourceError -> m (Either String String) +sourceError opt err = do + dflag <- G.getSessionDynFlags + style <- getStyle dflag + let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err + return (Left ret) + +errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] +errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList + +---------------------------------------------------------------- + +ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String +ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext + where + spn = errMsgSpan err + msg = pprLocErrMsg err + -- fixme +-- ext = showPage dflag style (pprLocErrMsg $ errMsgReason err) + +ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String +ppMsg spn sev dflag style msg = prefix ++ cts + where + cts = showPage dflag style msg + defaultPrefix + | isDumpSplices dflag = "" + | otherwise = checkErrorPrefix + prefix = fromMaybe defaultPrefix $ do + (line,col,_,_) <- getSrcSpan spn + file <- normalise <$> getSrcFile spn + let severityCaption = showSeverityCaption sev + return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption + +checkErrorPrefix :: String +checkErrorPrefix = "Dummy:0:0:Error:" + +showSeverityCaption :: Severity -> String +showSeverityCaption SevWarning = "Warning: " +showSeverityCaption _ = "" + +getSrcFile :: SrcSpan -> Maybe String +getSrcFile (G.RealSrcSpan spn) = Just . unpackFS . G.srcSpanFile $ spn +getSrcFile _ = Nothing + +isDumpSplices :: DynFlags -> Bool +isDumpSplices dflag = dopt Opt_D_dump_splices dflag + +getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) +getSrcSpan (RealSrcSpan spn) = Just ( G.srcSpanStartLine spn + , G.srcSpanStartCol spn + , G.srcSpanEndLine spn + , G.srcSpanEndCol spn) +getSrcSpan _ = Nothing diff --git a/src/HIE/Bios/Ghc/Things.hs b/src/HIE/Bios/Ghc/Things.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Ghc/Things.hs @@ -0,0 +1,63 @@ +module HIE.Bios.Ghc.Things ( + GapThing(..) + , fromTyThing + , infoThing + ) where + +import ConLike (ConLike(..)) +import FamInstEnv +import GHC +import HscTypes +import qualified InstEnv +import NameSet +import Outputable +import PatSyn +import PprTyThing +import Var (varType) + +import Data.List (intersperse) +import Data.Maybe (catMaybes) + +import HIE.Bios.Ghc.Gap (getTyThing, fixInfo) + +-- from ghc/InteractiveUI.hs + +---------------------------------------------------------------- + +data GapThing = GtA Type + | GtT TyCon + | GtN + | GtPatSyn PatSyn + +fromTyThing :: TyThing -> GapThing +fromTyThing (AnId i) = GtA $ varType i +fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d +fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p +fromTyThing (ATyCon t) = GtT t +fromTyThing _ = GtN + +---------------------------------------------------------------- + +infoThing :: String -> Ghc SDoc +infoThing str = do + names <- parseName str + mb_stuffs <- mapM (getInfo False) names + let filtered = filterOutChildren getTyThing $ catMaybes mb_stuffs + return $ vcat (intersperse (text "") $ map (pprInfo . fixInfo) filtered) + +filterOutChildren :: (a -> TyThing) -> [a] -> [a] +filterOutChildren get_thing xs + = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] + where + implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] + +pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [FamInst]) -> SDoc +pprInfo (thing, fixity, insts, famInsts) + = pprTyThingInContextLoc thing + $$ show_fixity fixity + $$ InstEnv.pprInstances insts + $$ pprFamInsts famInsts + where + show_fixity fx + | fx == defaultFixity = Outputable.empty + | otherwise = ppr fx <+> ppr (getName thing) diff --git a/src/HIE/Bios/Load.hs b/src/HIE/Bios/Load.hs deleted file mode 100644 --- a/src/HIE/Bios/Load.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -module HIE.Bios.Load ( loadFileWithMessage, loadFile, setTargetFiles, setTargetFilesWithMessage) where - -import CoreMonad (liftIO) -import GHC -import qualified GHC as G -import qualified GhcMake as G -import qualified HscMain as G -import HscTypes -import Outputable -import Control.Monad.IO.Class - -import Data.IORef - -import System.Directory -import Hooks -import TcRnTypes (FrontendResult(..)) -import Control.Monad (forM, void) -import GhcMonad -import HscMain -import Debug.Trace -import Data.List - -import Data.Time.Clock - -#if __GLASGOW_HASKELL__ < 806 -pprTraceM :: Monad m => String -> SDoc -> m () -pprTraceM x s = pprTrace x s (return ()) -#endif - --- | Obtaining type of a target expression. (GHCi's type:) -loadFileWithMessage :: GhcMonad m - => Maybe G.Messager - -> (FilePath, FilePath) -- ^ A target file. - -> m (Maybe TypecheckedModule, [TypecheckedModule]) -loadFileWithMessage msg file = do - dir <- liftIO $ getCurrentDirectory - pprTraceM "loadFile:2" (text dir) - df <- getSessionDynFlags - pprTraceM "loadFile:3" (ppr $ optLevel df) - (_, tcs) <- collectASTs $ do - (setTargetFilesWithMessage msg [file]) - pprTraceM "loaded" (text (fst file) $$ text (snd file)) - let get_fp = ml_hs_file . ms_location . pm_mod_summary . tm_parsed_module - traceShowM ("tms", (map get_fp tcs)) - let findMod [] = Nothing - findMod (x:xs) = case get_fp x of - Just fp -> if fp `isSuffixOf` (snd file) then Just x else findMod xs - Nothing -> findMod xs - return (findMod tcs, tcs) - -loadFile :: (GhcMonad m) - => (FilePath, FilePath) - -> m (Maybe TypecheckedModule, [TypecheckedModule]) -loadFile = loadFileWithMessage (Just G.batchMsg) - -{- -fileModSummary :: GhcMonad m => FilePath -> m ModSummary -fileModSummary file = do - mss <- getModSummaries <$> G.getModuleGraph - let [ms] = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) mss - return ms - -} - - -setTargetFiles :: GhcMonad m => [(FilePath, FilePath)] -> m () -setTargetFiles = setTargetFilesWithMessage (Just G.batchMsg) - -msTargetIs :: ModSummary -> Target -> Bool -msTargetIs ms t = case targetId t of - TargetModule m -> moduleName (ms_mod ms) == m - TargetFile f _ -> ml_hs_file (ms_location ms) == Just f - --- | We bump the times for any ModSummary's that are Targets, to --- fool the recompilation checker so that we can get the typechecked modules -updateTime :: MonadIO m => [Target] -> ModuleGraph -> m ModuleGraph -updateTime ts graph = liftIO $ do - cur_time <- getCurrentTime - let go ms - | any (msTargetIs ms) ts = ms {ms_hs_date = cur_time} - | otherwise = ms - pure $ mapMG go graph - --- | Set the files as targets and load them. -setTargetFilesWithMessage :: (GhcMonad m) => Maybe G.Messager -> [(FilePath, FilePath)] -> m () -setTargetFilesWithMessage msg files = do - targets <- forM files guessTargetMapped - pprTrace "setTargets" (vcat (map (\(a,b) -> parens $ text a <+> text "," <+> text b) files) $$ ppr targets) (return ()) - G.setTargets (map (\t -> t { G.targetAllowObjCode = False }) targets) - mod_graph <- updateTime targets =<< depanal [] False - pprTrace "modGraph" (ppr $ mgModSummaries mod_graph) (return ()) - pprTrace "modGraph" (ppr $ map ms_location $ mgModSummaries mod_graph) (return ()) - dflags1 <- getSessionDynFlags - pprTrace "hidir" (ppr $ hiDir dflags1) (return ()) - void $ G.load' LoadAllTargets msg mod_graph - -collectASTs :: (GhcMonad m) => m a -> m (a, [TypecheckedModule]) -collectASTs action = do - dflags0 <- getSessionDynFlags - ref1 <- liftIO $ newIORef [] - let dflags1 = dflags0 { hooks = (hooks dflags0) - { hscFrontendHook = traceShow "Use hook" $ Just (astHook ref1) } - } - void $ setSessionDynFlags $ dflags1 -- gopt_set dflags1 Opt_ForceRecomp - res <- action - tcs <- liftIO $ readIORef ref1 - return (res, tcs) - -astHook :: IORef [TypecheckedModule] -> ModSummary -> Hsc FrontendResult -astHook tc_ref ms = ghcInHsc $ do - p <- G.parseModule ms - tcm <- G.typecheckModule p - let tcg_env = fst (tm_internals_ tcm) - liftIO $ modifyIORef tc_ref (tcm :) - return $ FrontendTypecheck tcg_env - -ghcInHsc :: Ghc a -> Hsc a -ghcInHsc gm = do - hsc_session <- getHscEnv - session <- liftIO $ newIORef hsc_session - liftIO $ reflectGhc gm (Session session) - - -guessTargetMapped :: (GhcMonad m) => (FilePath, FilePath) -> m Target -guessTargetMapped (orig_file_name, mapped_file_name) = do - t <- G.guessTarget orig_file_name Nothing - return (setTargetFilename mapped_file_name t) - -setTargetFilename :: FilePath -> Target -> Target -setTargetFilename fn t = - t { targetId = case targetId t of - TargetFile _ p -> TargetFile fn p - tid -> tid } diff --git a/src/HIE/Bios/Logger.hs b/src/HIE/Bios/Logger.hs deleted file mode 100644 --- a/src/HIE/Bios/Logger.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module HIE.Bios.Logger ( - withLogger - , checkErrorPrefix - , getSrcSpan - ) where - -import Bag (Bag, bagToList) -import CoreMonad (liftIO) -import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices)) -import ErrUtils -import Exception (ghandle) -import FastString (unpackFS) -import GHC (DynFlags(..), SrcSpan(..), Severity(SevError), GhcMonad) -import qualified GHC as G -import HscTypes (SourceError, srcErrorMessages) -import Outputable (PprStyle, SDoc) - -import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) -import Data.List (isPrefixOf) -import Data.Maybe (fromMaybe) -import System.FilePath (normalise) - -import HIE.Bios.Doc (showPage, getStyle) -import HIE.Bios.GHCApi (withDynFlags, withCmdFlags) -import HIE.Bios.Types (Options(..), convert) - ----------------------------------------------------------------- - -type Builder = [String] -> [String] - -newtype LogRef = LogRef (IORef Builder) - -newLogRef :: IO LogRef -newLogRef = LogRef <$> newIORef id - -readAndClearLogRef :: Options -> LogRef -> IO String -readAndClearLogRef opt (LogRef ref) = do - b <- readIORef ref - writeIORef ref id - return $! convert opt (b []) - -appendLogRef :: DynFlags -> LogRef -> LogAction -appendLogRef df (LogRef ref) _ _ sev src style msg = do - let !l = ppMsg src sev df style msg - modifyIORef ref (\b -> b . (l:)) - ----------------------------------------------------------------- - --- | Set the session flag (e.g. "-Wall" or "-w:") then --- executes a body. Log messages are returned as 'String'. --- Right is success and Left is failure. -withLogger :: - (GhcMonad m) - => Options -> (DynFlags -> DynFlags) -> m () -> m (Either String String) -withLogger opt setDF body = ghandle (sourceError opt) $ do - logref <- liftIO newLogRef - withDynFlags (setLogger logref . setDF) $ do - withCmdFlags wflags $ do - body - liftIO $ Right <$> readAndClearLogRef opt logref - where - setLogger logref df = df { log_action = appendLogRef df logref } - wflags = filter ("-fno-warn" `isPrefixOf`) $ ghcOpts opt - ----------------------------------------------------------------- - --- | Converting 'SourceError' to 'String'. -sourceError :: - (GhcMonad m) - => Options -> SourceError -> m (Either String String) -sourceError opt err = do - dflag <- G.getSessionDynFlags - style <- getStyle dflag - let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err - return (Left ret) - -errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] -errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList - ----------------------------------------------------------------- - -ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String -ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext - where - spn = errMsgSpan err - msg = pprLocErrMsg err - -- fixme --- ext = showPage dflag style (pprLocErrMsg $ errMsgReason err) - -ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String -ppMsg spn sev dflag style msg = prefix ++ cts - where - cts = showPage dflag style msg - defaultPrefix - | isDumpSplices dflag = "" - | otherwise = checkErrorPrefix - prefix = fromMaybe defaultPrefix $ do - (line,col,_,_) <- getSrcSpan spn - file <- normalise <$> getSrcFile spn - let severityCaption = showSeverityCaption sev - return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption - -checkErrorPrefix :: String -checkErrorPrefix = "Dummy:0:0:Error:" - -showSeverityCaption :: Severity -> String -showSeverityCaption SevWarning = "Warning: " -showSeverityCaption _ = "" - -getSrcFile :: SrcSpan -> Maybe String -getSrcFile (G.RealSrcSpan spn) = Just . unpackFS . G.srcSpanFile $ spn -getSrcFile _ = Nothing - -isDumpSplices :: DynFlags -> Bool -isDumpSplices dflag = dopt Opt_D_dump_splices dflag - -getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) -getSrcSpan (RealSrcSpan spn) = Just ( G.srcSpanStartLine spn - , G.srcSpanStartCol spn - , G.srcSpanEndLine spn - , G.srcSpanEndCol spn) -getSrcSpan _ = Nothing diff --git a/src/HIE/Bios/Things.hs b/src/HIE/Bios/Things.hs deleted file mode 100644 --- a/src/HIE/Bios/Things.hs +++ /dev/null @@ -1,63 +0,0 @@ -module HIE.Bios.Things ( - GapThing(..) - , fromTyThing - , infoThing - ) where - -import ConLike (ConLike(..)) -import FamInstEnv -import GHC -import HscTypes -import qualified InstEnv -import NameSet -import Outputable -import PatSyn -import PprTyThing -import Var (varType) - -import Data.List (intersperse) -import Data.Maybe (catMaybes) - -import HIE.Bios.Gap (getTyThing, fixInfo) - --- from ghc/InteractiveUI.hs - ----------------------------------------------------------------- - -data GapThing = GtA Type - | GtT TyCon - | GtN - | GtPatSyn PatSyn - -fromTyThing :: TyThing -> GapThing -fromTyThing (AnId i) = GtA $ varType i -fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d -fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p -fromTyThing (ATyCon t) = GtT t -fromTyThing _ = GtN - ----------------------------------------------------------------- - -infoThing :: String -> Ghc SDoc -infoThing str = do - names <- parseName str - mb_stuffs <- mapM (getInfo False) names - let filtered = filterOutChildren getTyThing $ catMaybes mb_stuffs - return $ vcat (intersperse (text "") $ map (pprInfo . fixInfo) filtered) - -filterOutChildren :: (a -> TyThing) -> [a] -> [a] -filterOutChildren get_thing xs - = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] - where - implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] - -pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [FamInst]) -> SDoc -pprInfo (thing, fixity, insts, famInsts) - = pprTyThingInContextLoc thing - $$ show_fixity fixity - $$ InstEnv.pprInstances insts - $$ pprFamInsts famInsts - where - show_fixity fx - | fx == defaultFixity = Outputable.empty - | otherwise = ppr fx <+> ppr (getName thing) diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -4,11 +4,6 @@ module HIE.Bios.Types where -import qualified Exception as GE -import GHC (Ghc) - -import Control.Exception (IOException) -import Control.Applicative (Alternative(..)) import System.Exit import System.IO @@ -161,18 +156,29 @@ data CradleAction = CradleAction { actionName :: String - , getOptions :: (FilePath -> IO (ExitCode, String, [String])) + -- ^ Name of the action + , getDependencies :: IO [FilePath] + -- ^ Dependencies of a cradle that might change the cradle. + -- Contains both files specified in hie.yaml as well as + -- specified by the build-tool if there is any. + -- FilePaths are expected to be relative to the `cradleRootDir` + -- to which this CradleAction belongs to. + -- Files returned by this action might not actually exist. + -- 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. + , getOptions :: FilePath -> IO (ExitCode, String, [String]) + -- ^ Options to compile the given file with. + -- The result consists of the return code of the operation + -- that has been run, the stdout of the process, and a list of + -- options that are needed to compile the given file. } instance Show CradleAction where - show (CradleAction name _) = "CradleAction: " ++ name + show CradleAction { actionName = name } = "CradleAction: " ++ name ---------------------------------------------------------------- -- | Option information for GHC data CompilerOptions = CompilerOptions { ghcOptions :: [String] -- ^ Command line options } deriving (Eq, Show) - -instance Alternative Ghc where - x <|> y = x `GE.gcatch` (\(_ :: IOException) -> y) - empty = undefined diff --git a/wrappers/cabal b/wrappers/cabal --- a/wrappers/cabal +++ b/wrappers/cabal @@ -1,7 +1,10 @@ #!/usr/bin/env bash if [ "$1" == "--interactive" ]; then pwd - echo "$@" + for arg in "$@"; do + echo -ne "$arg\x00" + done + echo -ne "\n" else ghc "$@" fi diff --git a/wrappers/cabal.hs b/wrappers/cabal.hs --- a/wrappers/cabal.hs +++ b/wrappers/cabal.hs @@ -10,9 +10,11 @@ case args of "--interactive":_ -> do getCurrentDirectory >>= putStrLn - -- note this probably breaks if paths have spaces in - putStrLn $ unwords args + putStrLn $ delimited args _ -> do ph <- spawnProcess "ghc" args code <- waitForProcess ph exitWith code + +delimited :: [String] -> String +delimited = concatMap (++ "\NUL")