packages feed

hie-bios (empty) → 0.1.0

raw patch · 20 files changed

+1628/−0 lines, 20 filesdep +basedep +base16-bytestringdep +bytestringsetup-changed

Dependencies added: base, base16-bytestring, bytestring, containers, cryptohash-sha1, deepseq, directory, extra, file-embed, filepath, ghc, hie-bios, process, temporary, text, time, transformers, unix-compat, unordered-containers, vector, yaml

Files

+ ChangeLog view
@@ -0,0 +1,2 @@+2019-10-06 - 0.1.0+	* First release
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2009, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.+  * Neither the name of the copyright holders nor the names of its+    contributors may be used to endorse or promote products derived+    from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exe/Main.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Main where++import Config (cProjectVersion)++import Control.Exception (Exception, Handler(..), ErrorCall(..))+import qualified Control.Exception as E+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 HIE.Bios+import HIE.Bios.Types+import HIE.Bios.Check+import HIE.Bios.Debug+import Paths_hie_bios++----------------------------------------------------------------++progVersion :: String+progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"++ghcOptHelp :: String+ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "++usage :: String+usage =    progVersion+        ++ "Usage:\n"+        ++ "\t biosc check" ++ ghcOptHelp ++ "<HaskellFiles...>\n"+        ++ "\t biosc version\n"+        ++ "\t biosc help\n"++----------------------------------------------------------------++data HhpcError = SafeList+               | TooManyArguments String+               | NoSuchCommand String+               | CmdArg [String]+               | FileNotExist String deriving (Show, Typeable)++instance Exception HhpcError++----------------------------------------------------------------++main :: IO ()+main = flip E.catches handlers $ do+    hSetEncoding stdout utf8+    args <- getArgs+    cradle <- getCurrentDirectory >>= \cwd ->+        -- find cradle does a takeDirectory on the argument, so make it into a file+        findCradle $ cwd ++ "/File.hs"+    let cmdArg0 = args !. 0+        remainingArgs = tail args+        opt = defaultOptions+    res <- case cmdArg0 of+      "check"   -> checkSyntax opt cradle remainingArgs+      "expand"  -> expandTemplate opt cradle remainingArgs+      "debug"   -> debugInfo opt cradle+      "root"    -> rootInfo opt cradle+      "version" -> return progVersion+      cmd       -> E.throw (NoSuchCommand cmd)+    putStr res+  where+    handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]+    handleThenExit handler e = handler e >> exitFailure+    handler1 :: ErrorCall -> IO ()+    handler1 = print -- for debug+    handler2 :: HhpcError -> IO ()+    handler2 SafeList = return ()+    handler2 (TooManyArguments cmd) = do+        hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments"+    handler2 (NoSuchCommand cmd) = do+        hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"+    handler2 (CmdArg errs) = do+        mapM_ (hPutStr stderr) errs+    handler2 (FileNotExist file) = do+        hPutStrLn stderr $ "\"" ++ file ++ "\" not found"+    xs !. idx+      | length xs <= idx = E.throw SafeList+      | otherwise = xs !! idx
+ hie-bios.cabal view
@@ -0,0 +1,71 @@+Name:                   hie-bios+Version:                0.1.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:++Category:               Development+Cabal-Version:          >= 1.10+Build-Type:             Simple+Extra-Source-Files:     ChangeLog+                        wrappers/bazel+                        wrappers/cabal+                        wrappers/cabal.bat++Library+  Default-Language:     Haskell2010+  GHC-Options:          -Wall+  HS-Source-Dirs:       src+  Exposed-Modules:      HIE.Bios+                        HIE.Bios.Check+                        HIE.Bios.Cradle+                        HIE.Bios.Debug+                        HIE.Bios.GHCApi+                        HIE.Bios.Gap+                        HIE.Bios.Doc+                        HIE.Bios.Load+                        HIE.Bios.Logger+                        HIE.Bios.Types+                        HIE.Bios.Things+                        HIE.Bios.Config+  Build-Depends:+                        base >= 4.9 && < 5,+                        base16-bytestring    >= 0.1.1 && < 0.2,+                        bytestring           >= 0.10.8 && < 0.11,+                        deepseq              >= 1.4.4 && < 1.5,+                        containers           >= 0.6.0 && < 0.7,+                        cryptohash-sha1      >= 0.11.100 && < 0.12,+                        directory            >= 1.3.3 && < 1.4,+                        filepath             >= 1.4.2 && < 1.5,+                        time                 >= 1.8.0 && < 1.9,+                        extra                >= 1.6.18 && < 1.7,+                        process              >= 1.6.5 && < 1.7,+                        file-embed           >= 0.0.11 && < 0.1,+                        ghc                  >= 8.6.1 && < 8.7,+                        transformers         >= 0.5.6 && < 0.6,+                        temporary            >= 1.3 && < 1.4,+                        text                 >= 1.2.3 && < 1.3,+                        unix-compat          >= 0.5.2 && < 0.6,+                        unordered-containers >= 0.2.10 && < 0.3,+                        vector               >= 0.12.0 && < 0.13,+                        yaml                 >= 0.11.1 && < 0.12++Executable hie-bios+  Default-Language:     Haskell2010+  Main-Is:              Main.hs+  Other-Modules:        Paths_hie_bios+  GHC-Options:          -Wall+  HS-Source-Dirs:       exe+  Build-Depends:        base >= 4.9 && < 5+                      , directory+                      , filepath+                      , ghc+                      , hie-bios++Source-Repository head+  Type:                 git+  Location:             git://github.com/mpickering/hie-bios.git
+ src/HIE/Bios.hs view
@@ -0,0 +1,20 @@+-- | The HIE Bios++module HIE.Bios (+  -- * Initialise a session+    Cradle(..)+  , findCradle+  , defaultCradle+  , initializeFlagsWithCradle+  , initializeFlagsWithCradleWithMessage+  -- * Load a module into a session+  , loadFile+  , loadFileWithMessage+  -- * Eliminate a session to IO+  , withGhcT+  ) where++import HIE.Bios.Cradle+import HIE.Bios.Types+import HIE.Bios.GHCApi+import HIE.Bios.Load
+ src/HIE/Bios/Check.hs view
@@ -0,0 +1,75 @@+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
+ src/HIE/Bios/Config.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+module HIE.Bios.Config(+    readConfig,+    Config(..),+    CradleConfig(..)+    ) where++import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as Map+import Data.Yaml+++data CradleConfig = Cabal { component :: Maybe String }+                  | Stack+                  | Bazel+                  | Obelisk+                  | Bios { prog :: FilePath }+                  | 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"++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"++readConfig :: FilePath -> IO Config+readConfig fp = decodeFileThrow fp
+ src/HIE/Bios/Cradle.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+module HIE.Bios.Cradle (+      findCradle+    , findCradleWithOpts+    , defaultCradle+  ) where++import System.Process+import System.Exit+import HIE.Bios.Types+import HIE.Bios.Config+import System.Directory hiding (findFile)+import Control.Monad.Trans.Maybe+import System.FilePath+import Control.Monad+import Control.Monad.IO.Class+import System.Info.Extra+import Control.Applicative ((<|>))+import Data.FileEmbed+import System.IO.Temp+import Data.List++import Debug.Trace+import System.PosixCompat.Files++----------------------------------------------------------------+findCradle :: FilePath -> IO Cradle+findCradle = findCradleWithOpts defaultCradleOpts++-- | 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)+++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++implicitConfig :: FilePath -> MaybeT IO (CradleConfig, FilePath)+implicitConfig fp =+         (\wdir -> (Bios (wdir </> ".hie-bios"), 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)++configFileName :: FilePath+configFileName = "hie.yaml"+++---------------------------------------------------------------+-- 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, "", []))+    }++-------------------------------------------------------------------------++directCradle :: FilePath -> [String] -> Cradle+directCradle wdir args =+  Cradle {+      cradleRootDir = wdir+    , cradleOptsProg = CradleAction "direct" (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)+  }++biosWorkDir :: FilePath -> MaybeT IO FilePath+biosWorkDir = findFileUpwards (".hie-bios" ==)+++biosAction :: FilePath -> FilePath -> FilePath -> IO (ExitCode, String, [String])+biosAction _wdir bios fp = do+  bios' <- canonicalizePath bios+  (ex, res, std) <- readProcessWithExitCode bios' [fp] []+  return (ex, std, words res)++------------------------------------------------------------------------+-- Cabal Cradle+-- 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)+  }++cabalWrapper :: String+cabalWrapper = $(embedStringFile "wrappers/cabal")++cabalWrapperBat :: String+cabalWrapperBat = $(embedStringFile "wrappers/cabal.bat")++processCabalWrapperArgs :: String -> Maybe [String]+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+        _ -> Nothing++cabalAction :: FilePath -> Maybe String -> FilePath -> IO (ExitCode, String, [String])+cabalAction work_dir mc _fp = do+  wrapper_fp <- writeSystemTempFile "wrapper.bat" $+    if isWindows then cabalWrapperBat else cabalWrapper+  -- TODO: This isn't portable for windows+  setFileMode wrapper_fp accessModes+  check <- readFile wrapper_fp+  traceM check+  let cab_args = ["v2-repl", "-v0", "--with-compiler", wrapper_fp]+                  ++ [component_name | Just component_name <- [mc]]+  (ex, args, stde) <-+      withCurrentDirectory work_dir (readProcessWithExitCode "cabal" cab_args [])+  case processCabalWrapperArgs args of+      Nothing -> error (show (ex, stde, args))+      Just final_args -> pure (ex, stde, final_args)++removeInteractive :: [String] -> [String]+removeInteractive = filter (/= "--interactive")++fixImportDirs :: FilePath -> String -> String+fixImportDirs base_dir arg =+  if "-i" `isPrefixOf` arg+    then let dir = drop 2 arg+         in if isRelative dir then ("-i" <> base_dir <> "/" <> dir)+                              else arg+    else arg+++cabalWorkDir :: FilePath -> MaybeT IO FilePath+cabalWorkDir = findFileUpwards isCabal+  where+    isCabal name = name == "cabal.project"++------------------------------------------------------------------------+-- 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)+  }++-- Same wrapper works as with cabal+stackWrapper :: String+stackWrapper = $(embedStringFile "wrappers/cabal")++stackAction :: FilePath -> FilePath -> IO (ExitCode, String, [String])+stackAction work_dir fp = do+  wrapper_fp <- writeSystemTempFile "wrapper" stackWrapper+  -- TODO: This isn't portable for windows+  setFileMode wrapper_fp accessModes+  check <- readFile wrapper_fp+  traceM check+  (ex1, args, stde) <-+      withCurrentDirectory work_dir (readProcessWithExitCode "stack" ["repl", "--silent", "--no-load", "--with-ghc", wrapper_fp, fp ] [])+  (ex2, pkg_args, stdr) <-+      withCurrentDirectory work_dir (readProcessWithExitCode "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+      Nothing -> error (show (ex1, stde, args))+      Just ghc_args -> return (combineExitCodes [ex1, ex2], stde ++ stdr, ghc_args ++ pkg_ghc_args)++combineExitCodes :: [ExitCode] -> ExitCode+combineExitCodes = foldr go ExitSuccess+  where+    go ExitSuccess b = b+    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+--+rulesHaskellWorkDir :: FilePath -> MaybeT IO FilePath+rulesHaskellWorkDir fp =+  findFileUpwards (== "WORKSPACE") fp++rulesHaskellCradle :: FilePath -> Cradle+rulesHaskellCradle wdir = do+  Cradle {+      cradleRootDir  = wdir+    , cradleOptsProg   = CradleAction "bazel" (rulesHaskellAction wdir)+    }+++bazelCommand :: String+bazelCommand = $(embedStringFile "wrappers/bazel")++rulesHaskellAction :: FilePath -> FilePath -> IO (ExitCode, String, [String])+rulesHaskellAction work_dir fp = do+  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] [])+  let args'  = filter (/= '\'') args+  let args'' = filter (/= "\"$GHCI_LOCATION\"") (words args')+  return (ex, stde, args'')+++------------------------------------------------------------------------------+-- Obelisk Cradle+-- Searches for the directory which contains `.obelisk`.++obeliskWorkDir :: FilePath -> MaybeT IO FilePath+obeliskWorkDir fp = do+  -- Find a possible root which will contain the cabal.project+  wdir <- findFileUpwards (== "cabal.project") fp+  -- Check for the ".obelisk" folder in this directory+  check <- liftIO $ doesDirectoryExist (wdir </> ".obelisk")+  unless check (fail "Not obelisk dir")+  return wdir+++obeliskCradle :: FilePath -> Cradle+obeliskCradle wdir =+  Cradle {+      cradleRootDir  = wdir+    , cradleOptsProg = CradleAction "obelisk" (obeliskAction wdir)+    }++obeliskAction :: FilePath -> FilePath -> IO (ExitCode, String, [String])+obeliskAction work_dir _fp = do+  (ex, args, stde) <-+      withCurrentDirectory work_dir (readProcessWithExitCode "ob" ["ide-args"] [])+  return (ex, stde, words args)+++------------------------------------------------------------------------------+-- Utilities+++-- | Searches upwards for the first directory containing a file to match+-- the predicate.+findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath+findFileUpwards p dir = do+    cnts <- liftIO $ findFile p dir+    case cnts of+        [] | dir' == dir -> fail "No cabal files"+           | otherwise   -> findFileUpwards p dir'+        _:_          -> return dir+  where+    dir' = takeDirectory dir++-- | Sees if any file in the directory matches the predicate+findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+findFile p dir = getFiles >>= filterM doesPredFileExist+  where+    getFiles = filter p <$> getDirectoryContents dir+    doesPredFileExist file = doesFileExist $ dir </> file
+ src/HIE/Bios/Debug.hs view
@@ -0,0 +1,33 @@+module HIE.Bios.Debug (debugInfo, rootInfo) where++import CoreMonad (liftIO)++import Data.Maybe (fromMaybe)++import HIE.Bios.GHCApi+import HIE.Bios.Types++----------------------------------------------------------------++-- | Obtaining debug information.+debugInfo :: Options+          -> Cradle+          -> IO String+debugInfo opt cradle = convert opt <$> do+    (_ex, _sterr, gopts) <- getOptions (cradleOptsProg cradle) (cradleRootDir cradle)+    mglibdir <- liftIO getSystemLibDir+    return [+        "Root directory:      " ++ rootDir+      , "GHC options:         " ++ unwords gopts+      , "System libraries:    " ++ fromMaybe "" mglibdir+      ]+  where+    rootDir    = cradleRootDir cradle++----------------------------------------------------------------++-- | Obtaining root information.+rootInfo :: Options+          -> Cradle+          -> IO String+rootInfo opt cradle = return $ convert opt $ cradleRootDir cradle
+ src/HIE/Bios/Doc.hs view
@@ -0,0 +1,24 @@+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 }
+ src/HIE/Bios/GHCApi.hs view
@@ -0,0 +1,293 @@+{-# 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 Outputable as G+import qualified MonadUtils as G+import qualified HscMain as G+import qualified GhcMake 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 ())+    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+  ts <- mapM (flip G.guessTarget Nothing) normal_fileish_paths+  return (df2, 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++----------------------------------------------------------------++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'
+ src/HIE/Bios/Gap.hs view
@@ -0,0 +1,129 @@+{-# 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
+ src/HIE/Bios/Load.hs view
@@ -0,0 +1,133 @@+{-# 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 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 }
+ src/HIE/Bios/Logger.hs view
@@ -0,0 +1,124 @@+{-# 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
+ src/HIE/Bios/Things.hs view
@@ -0,0 +1,63 @@+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)
+ src/HIE/Bios/Types.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}++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++data BIOSVerbosity = Silent | Verbose++data CradleOpts = CradleOpts+                { cradleOptsVerbosity :: BIOSVerbosity+                , cradleOptsHandle :: Maybe Handle+                -- ^ The handle where to send output to, if not set, stderr+                }++defaultCradleOpts :: CradleOpts+defaultCradleOpts = CradleOpts Silent Nothing++-- | Output style.+data OutputStyle = LispStyle  -- ^ S expression style.+                 | PlainStyle -- ^ Plain textstyle.++-- | The type for line separator. Historically, a Null string is used.+newtype LineSeparator = LineSeparator String++data Options = Options {+    outputStyle   :: OutputStyle+  , hlintOpts     :: [String]+  , ghcOpts       :: [String]+  -- | If 'True', 'browse' also returns operators.+  , operators     :: Bool+  -- | If 'True', 'browse' also returns types.+  , detailed      :: Bool+  -- | If 'True', 'browse' will return fully qualified name+  , qualified     :: Bool+  -- | Line separator string.+  , lineSeparator :: LineSeparator+  }++-- | A default 'Options'.+defaultOptions :: Options+defaultOptions = Options {+    outputStyle   = PlainStyle+  , hlintOpts     = []+  , ghcOpts       = []+  , operators     = False+  , detailed      = False+  , qualified     = False+  , lineSeparator = LineSeparator "\0"+  }++----------------------------------------------------------------++type Builder = String -> String++-- |+--+-- >>> replace '"' "\\\"" "foo\"bar" ""+-- "foo\\\"bar"+replace :: Char -> String -> String -> Builder+replace _ _  [] = id+replace c cs (x:xs)+  | x == c    = (cs ++) . replace c cs xs+  | otherwise = (x :) . replace c cs xs++inter :: Char -> [Builder] -> Builder+inter _ [] = id+inter c bs = foldr1 (\x y -> x . (c:) . y) bs++convert :: ToString a => Options -> a -> String+convert opt@Options { outputStyle = LispStyle  } x = toLisp  opt x "\n"+convert opt@Options { outputStyle = PlainStyle } x+  | str == "\n" = ""+  | otherwise   = str+  where+    str = toPlain opt x "\n"++class ToString a where+    toLisp  :: Options -> a -> Builder+    toPlain :: Options -> a -> Builder++lineSep :: Options -> String+lineSep opt = lsep+  where+    LineSeparator lsep = lineSeparator opt++-- |+--+-- >>> toLisp defaultOptions "fo\"o" ""+-- "\"fo\\\"o\""+-- >>> toPlain defaultOptions "foo" ""+-- "foo"+instance ToString String where+    toLisp  opt = quote opt+    toPlain opt = replace '\n' (lineSep opt)++-- |+--+-- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] ""+-- "(\"foo\" \"bar\" \"ba\\\"z\")"+-- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""+-- "foo\nbar\nbaz"+instance ToString [String] where+    toLisp  opt = toSexp1 opt+    toPlain opt = inter '\n' . map (toPlain opt)++-- |+--+-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]+-- >>> toLisp defaultOptions inp ""+-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"+-- >>> toPlain defaultOptions inp ""+-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""+instance ToString [((Int,Int,Int,Int),String)] where+    toLisp  opt = toSexp2 . map toS+      where+        toS x = ('(' :) . tupToString opt x . (')' :)+    toPlain opt = inter '\n' . map (tupToString opt)++toSexp1 :: Options -> [String] -> Builder+toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)++toSexp2 :: [Builder] -> Builder+toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)++tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder+tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)+                              . (show b ++) . (' ' :)+                              . (show c ++) . (' ' :)+                              . (show d ++) . (' ' :)+                              . quote opt s -- fixme: quote is not necessary++quote :: Options -> String -> Builder+quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)+  where+    lsep = lineSep opt+    quote' [] = []+    quote' (x:xs)+      | x == '\n' = lsep   ++ quote' xs+      | x == '\\' = "\\\\" ++ quote' xs+      | x == '"'  = "\\\"" ++ quote' xs+      | otherwise = x       : quote' xs++----------------------------------------------------------------++-- | The environment where this library is used.+data Cradle = Cradle {+  -- | The project root directory.+    cradleRootDir    :: FilePath+  -- | The action which needs to be executed to get the correct+  -- command line arguments+  , cradleOptsProg   :: CradleAction+  } deriving (Show)++data CradleAction = CradleAction {+                      actionName :: String+                      , getOptions ::  (FilePath -> IO (ExitCode, String, [String]))+                      }++instance Show CradleAction where+  show (CradleAction 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
+ wrappers/bazel view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+fullname=$(bazel query "$1")+attr=$(bazel query "kind(haskell_*, attr('srcs', $fullname, ${fullname//:*/}:*))")+bazel build "$attr@repl" --experimental_show_artifacts 2>&1 | sed -ne '/>>>/ s/^>>>\(.*\)$/\1/ p' | xargs tail -1+
+ wrappers/cabal view
@@ -0,0 +1,7 @@+#!/usr/bin/env bash+if [ "$1" == "--interactive" ]; then+  pwd+  echo "$@"+else+  ghc "$@"+fi
+ wrappers/cabal.bat view
@@ -0,0 +1,7 @@+@ECHO OFF
+IF "%i" == "--interactive" (
+  ECHO %CD%
+  ECHO %*
+) ELSE (
+  ghc %*
+)