hie-bios 0.1.1 → 0.2.0

raw patch · 26 files changed

+1334/−1052 lines, 26 filesdep ~containersdep ~directorydep ~filepathPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: containers, directory, filepath, ghc, temporary, time, transformers

API changes (from Hackage documentation)

Files

• ChangeLog +9/−0
• exe/Main.hs +28/−7
• hie-bios.cabal +21/−17
• src/HIE/Bios.hs +10/−10
• src/HIE/Bios/Check.hs +0/−75
• src/HIE/Bios/Config.hs +98/−26
• src/HIE/Bios/Cradle.hs +184/−83
• src/HIE/Bios/Debug.hs +9/−3
• src/HIE/Bios/Doc.hs +0/−24
• src/HIE/Bios/Environment.hs +209/−0
• src/HIE/Bios/Flags.hs +29/−0
• src/HIE/Bios/GHCApi.hs +0/−343
• src/HIE/Bios/Gap.hs +0/−129
• src/HIE/Bios/Ghc/Api.hs +148/−0
• src/HIE/Bios/Ghc/Check.hs +75/−0
• src/HIE/Bios/Ghc/Doc.hs +24/−0
• src/HIE/Bios/Ghc/Gap.hs +143/−0
• src/HIE/Bios/Ghc/Load.hs +135/−0
• src/HIE/Bios/Ghc/Logger.hs +124/−0
• src/HIE/Bios/Ghc/Things.hs +63/−0
• src/HIE/Bios/Load.hs +0/−134
• src/HIE/Bios/Logger.hs +0/−124
• src/HIE/Bios/Things.hs +0/−63
• src/HIE/Bios/Types.hs +17/−11
• wrappers/cabal +4/−1
• wrappers/cabal.hs +4/−2

@@ -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

@@ -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 ++ "<HaskellFiles...>\n"-        ++ "\t biosc version\n"-        ++ "\t biosc help\n"+        ++ "\t hie-bios check" ++ ghcOptHelp ++ "<HaskellFiles...>\n"+        ++ "\t hie-bios expand <HaskellFiles...>\n"+        ++ "\t hie-bios flags <HaskellFiles...>\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

@@ -1,12 +1,12 @@ Name:                   hie-bios-Version:                0.1.1+Version:                0.2.0 Author:                 Matthew Pickering <matthewtpickering@gmail.com> Maintainer:             Matthew Pickering <matthewtpickering@gmail.com> 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,

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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  ---------------------------------------------------------------- 

@@ -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 }

@@ -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 <suffix> 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

@@ -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++----------------------------------------------------------------

@@ -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 <suffix> 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'

@@ -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

@@ -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'

@@ -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

@@ -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 }

@@ -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

@@ -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 }

@@ -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

@@ -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)

@@ -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 }

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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")