hie-bios 0.2.1 → 0.3.0

raw patch · 74 files changed

+1633/−686 lines, 74 filesdep +conduitdep +conduit-extradep +hsloggerdep ~basedep ~directorydep ~file-embedPVP ok

version bump matches the API change (PVP)

Dependencies added: conduit, conduit-extra, hslogger, tasty, tasty-hunit

Dependency ranges changed: base, directory, file-embed, filepath, ghc

API changes (from Hackage documentation)

Files

• ChangeLog +19/−0
• README.md +299/−0
• exe/Main.hs +26/−14
• hie-bios.cabal +95/−8
• src/HIE/Bios.hs +16/−3
• src/HIE/Bios/Config.hs +84/−29
• src/HIE/Bios/Cradle.hs +289/−128
• src/HIE/Bios/Debug.hs +0/−39
• src/HIE/Bios/Environment.hs +63/−52
• src/HIE/Bios/Flags.hs +7/−19
• src/HIE/Bios/Ghc/Api.hs +33/−73
• src/HIE/Bios/Ghc/Check.hs +36/−38
• src/HIE/Bios/Ghc/Doc.hs +1/−0
• src/HIE/Bios/Ghc/Gap.hs +38/−2
• src/HIE/Bios/Ghc/Load.hs +76/−40
• src/HIE/Bios/Ghc/Logger.hs +11/−17
• src/HIE/Bios/Ghc/Things.hs +0/−63
• src/HIE/Bios/Internal/Debug.hs +53/−0
• src/HIE/Bios/Internal/Log.hs +16/−0
• src/HIE/Bios/Types.hs +42/−145
• src/HIE/Bios/Wrappers.hs +12/−0
• tests/BiosTests.hs +118/−0
• tests/ParserTests.hs +50/−0
• tests/configs/bazel.yaml +2/−0
• tests/configs/bios-1.yaml +3/−0
• tests/configs/bios-2.yaml +4/−0
• tests/configs/cabal-1.yaml +2/−0
• tests/configs/cabal-multi.yaml +6/−0
• tests/configs/default.yaml +2/−0
• tests/configs/dependencies.yaml +5/−0
• tests/configs/direct.yaml +3/−0
• tests/configs/multi.yaml +6/−0
• tests/configs/nested-cabal-multi.yaml +8/−0
• tests/configs/nested-stack-multi.yaml +8/−0
• tests/configs/none.yaml +2/−0
• tests/configs/obelisk.yaml +2/−0
• tests/configs/stack-config.yaml +2/−0
• tests/configs/stack-multi.yaml +6/−0
• tests/projects/multi-cabal/Setup.hs +2/−0
• tests/projects/multi-cabal/app/Main.hs +4/−0
• tests/projects/multi-cabal/cabal.project +1/−0
• tests/projects/multi-cabal/hie.yaml +7/−0
• tests/projects/multi-cabal/multi-cabal.cabal +22/−0
• tests/projects/multi-cabal/src/Lib.hs +5/−0
• tests/projects/multi-stack/Setup.hs +2/−0
• tests/projects/multi-stack/app/Main.hs +4/−0
• tests/projects/multi-stack/cabal.project +1/−0
• tests/projects/multi-stack/hie.yaml +7/−0
• tests/projects/multi-stack/multi-stack.cabal +22/−0
• tests/projects/multi-stack/src/Lib.hs +5/−0
• tests/projects/simple-bios/A.hs +1/−0
• tests/projects/simple-bios/B.hs +3/−0
• tests/projects/simple-bios/hie-bios.sh +3/−0
• tests/projects/simple-bios/hie.yaml +2/−0
• tests/projects/simple-cabal/A.hs +1/−0
• tests/projects/simple-cabal/B.hs +3/−0
• tests/projects/simple-cabal/CHANGELOG.md +5/−0
• tests/projects/simple-cabal/Setup.hs +2/−0
• tests/projects/simple-cabal/cabal.project +1/−0
• tests/projects/simple-cabal/hie.yaml +2/−0
• tests/projects/simple-cabal/simple-cabal.cabal +22/−0
• tests/projects/simple-direct/A.hs +1/−0
• tests/projects/simple-direct/B.hs +3/−0
• tests/projects/simple-direct/hie.yaml +2/−0
• tests/projects/simple-stack/A.hs +1/−0
• tests/projects/simple-stack/B.hs +3/−0
• tests/projects/simple-stack/CHANGELOG.md +5/−0
• tests/projects/simple-stack/Setup.hs +2/−0
• tests/projects/simple-stack/cabal.project +1/−0
• tests/projects/simple-stack/hie.yaml +3/−0
• tests/projects/simple-stack/simple-stack.cabal +22/−0
• wrappers/bazel +0/−5
• wrappers/cabal +8/−4
• wrappers/cabal.hs +10/−7

@@ -1,3 +1,22 @@+xxxx - 0.3++	* Add multi cradle, cabal multi cradle and none cradle+	* Remove obelisk, bazel and default cradle types+	* bios program now expects arguments to be separated by newlines rather than+		spaces. (#80)+	* Only try to use stack cradle if `stack` is executable.+	* Filter out `-w -v0` from cabal output when using cabal cradle.+	* Initialise plugins when loading a module.+	* Interface file cache persists between loads -- this greatly speeds up+	reloading a project if the options don't change.+	* Reuse wrapper executable on windows if one already exists.+	* Make stack cradle work more like the cabal cradle+		- Syntax for specifying a specific component+		- Targets are read from the ghci script file+	* Cradles now use a temporary file to communicate arguments to hie-bios.+	bios cradles should consult the HIE_BIOS_OUTPUT envvar for the filepath to+	write the arguments seperated by newlines.+ 2019-09-19 - 0.2.1  	* Make stack cradle use the same wrappers as cabal cradle. Fixes some issues

@@ -0,0 +1,299 @@+# hie-bios++`hie-bios` is the way to specify how+[`hie`](https://github.com/haskell/haskell-ide-engine) and+[`ghcide`](https://github.com/digital-asset/ghcide) sets up a GHC API session.++Given a Haskell project that is managed by Stack, Cabal, or other package tools,+`hie` needs to know the full set of flags to pass to GHC in order to build the+project. `hie-bios` satisfies this need.++Its design is motivated by the guiding principle:++> It is the responsibility of the build tool to describe the environment+> which a package should be built in.++Using this principle, it is possible+to easily support a wide range of tools including `cabal-install`, `stack`,+`rules_haskell`, `hadrian` and `obelisk` without major contortions.+`hie-bios` does not depend on the `Cabal` library nor does not+read any complicated build products and so on.++How does a tool specify a session? A session is fully specified by a set of+standard GHC flags. Most tools already produce this information if they support+a `repl` command. Launching a repl is achieved by calling `ghci` with the+right flags to specify the package database. `hie-bios` needs a way to get+these flags and then it can set up GHC API session correctly.++Futher it means that any failure to set up the API session is the responsibility+of the build tool. It is up to them to provide the correct information if they+want the tool to work correctly.++## Explicit Configuration++The user can place a `hie.yaml` file in the root of the workspace which+describes how to setup the environment. For example, to explicitly state+that you want to use `stack` then the configuration file would look like:++```yaml+cradle: {stack: {component: "haskell-ide-engine:lib" }}+```++While the component is optional, this is recommended to make sure the correct+component is loaded.++To use `cabal`, the explicit configuration looks similar.+Note that `cabal` and `stack` have different way of specifying their+components.++```yaml+cradle: {cabal: {component: "lib:haskell-ide-engine"}}+```++Or you can explicitly state the program which should be used to collect+the options by supplying the path to the program. It is interpreted+relative to the current working directory if it is not an absolute path.+The bios program should consult the `HIE_BIOS_OUTPUT` env var and write a list of+options to this file separated by newlines. Once the program finishes running `hie-bios`+reads this file and uses the arguments to set up the GHC session. This is how GHC's+build system is able to support `hie-bios`.++```yaml+cradle: {bios: {program: ".hie-bios"}}+```++The `direct` cradle allows you to specify exactly the GHC options that should be used to load+a project. This is good for debugging but not a very good approach in general as the set of options+will quickly get out of sync with a cabal file.++```yaml+cradle: {direct: [arg1, arg2]}+```++The `none` cradle says that the IDE shouldn't even try to load the project. It+is most useful when combined with the multi-cradle which is specified in the next section.++```yaml+cradle: {none: }+```++## Multi-Cradle++For a multi-component project you can use the multi-cradle to specify how each+subdirectory of the project should be handled by the IDE.++The multi-cradle is a list of relative paths and cradle configurations.+The path is relative to the configuration file and specifies the scope of+the cradle. For example, this configuration specificies that files in the+`src` subdirectory should be handled with the `lib:hie-bios` component and+files in the `test` directory using the `test` component.++```yaml+cradle:+  multi:+    - path: "./src"+      config: { cradle: {cabal: {component: "lib:hie-bios"}} }+    - path: "./test"+      config: { cradle: {cabal: {component: "test"}} }+```++If a file matches multiple prefixes, the most specific one is chosen.+Once a prefix is matched, the selected cradle is used to find the options. This+is usually a specific cradle such as `cabal` or `stack` but it could be another+multi-cradle, in which case, matching works in exactly the same way until a+specific cradle is chosen.++This cradle type is experimental and may not be supported correctly by+some libraries which use `hie-bios`. It requires some additional care to+correctly manage multiple components.++Note: Remember you can use the multi-cradle to declare that certain directories+shouldn't be loaded by an IDE, in conjunction with the `none` cradle.++```yaml+cradle:+  multi:+    - path: "./src"+      config: { cradle: {cabal: {component: "lib:hie-bios"}} }+    - path: "./test"+      config: { cradle: {cabal: {component: "test"}} }+    - path: "./test/test-files"+      config: { cradle: { none: } }+```++For cabal and stack projects there is a shorthand to specify how to load each component.++```yaml+cradle:+  cabal:+    - path: "./src"+      component: "lib:hie-bios"+    - path: "./test"+      component: "test:bios-tests"+```++```yaml+cradle:+  stack:+    - path: "./src"+      component: "hie-bios:lib"+    - path: "./test"+      component: "hie-bios:test:bios-tests"+```++Remember you can combine this shorthand with more complicated configuration+as well.++```yaml+cradle:+  multi:+    - path: "./test/testdata"+      config: { cradle: { none:  } }+    - path: "./"+      config: { cradle: { cabal:+                            [ { path: "./src", component: "lib:hie-bios" }+                            , { path: "./tests", component: "parser-tests" } ] } }+```++### Cradle Dependencies++Sometimes it is necessary to reload a component, for example when a package+dependency is added to the project. Each type of cradle defines a list of+files that might cause an existing cradle to no longer provide accurate+diagnostics if changed. These are expected to be relative to the root of+the cradle.++This makes it possible to watch for changes to these files and reload the+cradle appropiately.+However, if there are files that are not covered by+the cradle dependency resolution, you can add these files explicitly to+`hie.yaml`.+These files are not required to actually exist, since it can be useful+to know when these files are created, e.g. if there was no `cabal.project`+in the project before and now there is, it might change how a file in the+project is compiled.++Here's an example of how you would add cradle dependencies that may not be covered+by the `cabal` cradle.++```yaml+cradle:+  cabal:+    component: "lib:hie-bios"++dependencies:+  - package.yaml+  - shell.nix+  - default.nix+```++For the `Bios` cradle type, there is an optional field to specify a program+to obtain cradle dependencies from:++```yaml+cradle:+  bios:+    program: ./flags.sh+    dependency-program: ./dependency.sh+```++The program `./dependency.sh` is executed with no paramaters and it is+expected to output on stdout on each line exactly one filepath relative+to the root of the cradle, not relative to the location of the program.++## Configuration specification++The complete configuration is a subset of++```yaml+cradle:+  cabal:+    component: "optional component name"+  stack:+    component: "optional component name"+  bios:+    program: "program to run"+    dependency-program: "optional program to run"+  direct:+    arguments: ["list","of","ghc","arguments"]+  none:+  multi: - path: ./+           config: { cradle: ... }++dependencies:+  - someDep+```++## Testing your configuration++The provided `hie-bios` executable is provided to test your configuration.++The `flags` command will print out the options that `hie-bios` thinks you will need to load a file.++```+hie-bios flags exe/Main.hs+```++The `check` command will try to use these flags to load the module into the GHC API.++```+hie-bios check exe/Main.hs+```++## Implicit Configuration++There are several built in modes which captures most common Haskell development+scenarios. If no `hie.yaml` configuration file is found then an implicit+configuration is searched for. It is strongly recommended to just explicitly+configure your project.++### Priority++The targets are searched for in following order.++1. A specific `hie-bios` file.+2. A `stack` project+3. A `cabal` project+4. The direct cradle which has no specific options.++### `cabal-install`++The workspace root is the first folder containing a `cabal.project` file.++The arguments are collected by running `cabal v2-repl`.++If `cabal v2-repl` fails, then the user needs to configure the correct+target to use by writing a `hie.yaml` file.++### `stack`++The workspace root is the first folder containing a `stack.yaml` file.++The arguments are collected by executing `stack repl`.++### `bios`++The most general form is the `bios` mode which allows a user to specify themselves+which flags to provide.++In this mode, an executable file called `.hie-bios` is placed in the root+of the workspace directory. The script takes one argument, the filepath+to the current file we want to load into the session. The script returns+a list of GHC arguments separated by newlines which will setup the correct session.++A good guiding specification for this file is that the following command+should work for any file in your project.++```+ghci $(./hie-bios /path/to/foo.hs | tr '\n' ' ') /path/to/foo.hs+```++This is useful if you are designing a new build system or the other modes+fail to setup the correct session for some reason. For example, this is+how hadrian (GHC's build system) is integrated into `hie-bios`.++## Supporting Bazel and Obelisk++In previous versions of `hie-bios` there was also support for projects using `rules_haskell` and `obelisk`.+This was removed in the 0.3 release as they were unused and broken. There is no conceptual barrier to adding+back support but it requires a user of these two approaches to maintain them.

@@ -16,9 +16,8 @@ import System.FilePath( (</>) )  import HIE.Bios-import HIE.Bios.Types import HIE.Bios.Ghc.Check-import HIE.Bios.Debug+import HIE.Bios.Internal.Debug import Paths_hie_bios  ----------------------------------------------------------------@@ -35,7 +34,7 @@         ++ "\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 debug [<ComponentDir>]\n"         ++ "\t hie-bios root\n"         ++ "\t hie-bios version\n" @@ -43,6 +42,7 @@  data HhpcError = SafeList                | TooManyArguments String+               | NotEnoughArguments String                | NoSuchCommand String                | CmdArg [String]                | FileNotExist String deriving (Show, Typeable)@@ -62,19 +62,27 @@           Nothing -> loadImplicitCradle (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+      "check"   -> checkSyntax cradle remainingArgs+      "debug"+        | null remainingArgs -> debugInfo (cradleRootDir cradle) cradle+        | (fp:_) <- remainingArgs -> debugInfo fp cradle+      "root"    -> rootInfo cradle       "version" -> return progVersion-      "flags"   -> do+      "flags"+        | null remainingArgs -> E.throw $ NotEnoughArguments cmdArg0+        | otherwise -> 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)+                    CradleFail (CradleError _ex err) ->+                      return $ "Failed to show flags for \""+                                                ++ fp+                                                ++ "\": " ++ show err+                    CradleSuccess opts ->+                      return $ unlines ["Options: " ++ show (componentOptions opts)+                                       ,"Dependencies: " ++ show (componentDependencies opts) ]+                    CradleNone -> return "No flags: this component should not be loaded"         return (unlines res)        "help"    -> return usage@@ -90,15 +98,19 @@     handler1 = print -- for debug     handler2 :: HhpcError -> IO ()     handler2 SafeList = hPutStr stderr usage-    handler2 (TooManyArguments cmd) = do+    handler2 (TooManyArguments cmd) =         hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments"+    handler2 (NotEnoughArguments cmd) = do+        hPutStrLn stderr $ "\"" ++ cmd ++ "\": Not enough arguments"+        hPutStrLn stderr ""+        hPutStr stderr usage     handler2 (NoSuchCommand cmd) = do         hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"         hPutStrLn stderr ""         hPutStr stderr usage-    handler2 (CmdArg errs) = do+    handler2 (CmdArg errs) =         mapM_ (hPutStr stderr) errs-    handler2 (FileNotExist file) = do+    handler2 (FileNotExist file) =         hPutStrLn stderr $ "\"" ++ file ++ "\" not found"     xs !. idx       | length xs <= idx = E.throw SafeList

@@ -1,21 +1,71 @@+Cabal-Version:          2.2 Name:                   hie-bios-Version:                0.2.1+Version:                0.3.0 Author:                 Matthew Pickering <matthewtpickering@gmail.com> Maintainer:             Matthew Pickering <matthewtpickering@gmail.com>-License:                BSD3+License:                BSD-3-Clause License-File:           LICENSE Homepage:               https://github.com/mpickering/hie-bios Synopsis:               Set up a GHC API session Description:            Set up a GHC API session and obtain flags required to compile a source file  Category:               Development-Cabal-Version:          >= 1.10 Build-Type:             Simple+-- No glob syntax until GHC 8.6 because of stack Extra-Source-Files:     ChangeLog-                        wrappers/bazel+                        README.md                         wrappers/cabal                         wrappers/cabal.hs+                        tests/configs/bazel.yaml+                        tests/configs/bios-1.yaml+                        tests/configs/bios-2.yaml+                        tests/configs/cabal-1.yaml+                        tests/configs/cabal-multi.yaml+                        tests/configs/default.yaml+                        tests/configs/dependencies.yaml+                        tests/configs/direct.yaml+                        tests/configs/multi.yaml+                        tests/configs/nested-cabal-multi.yaml+                        tests/configs/nested-stack-multi.yaml+                        tests/configs/none.yaml+                        tests/configs/obelisk.yaml+                        tests/configs/stack-config.yaml+                        tests/configs/stack-multi.yaml+                        tests/projects/multi-cabal/Setup.hs+                        tests/projects/multi-cabal/app/Main.hs+                        tests/projects/multi-cabal/cabal.project+                        tests/projects/multi-cabal/hie.yaml+                        tests/projects/multi-cabal/multi-cabal.cabal+                        tests/projects/multi-cabal/src/Lib.hs+                        tests/projects/multi-stack/Setup.hs+                        tests/projects/multi-stack/app/Main.hs+                        tests/projects/multi-stack/cabal.project+                        tests/projects/multi-stack/hie.yaml+                        tests/projects/multi-stack/multi-stack.cabal+                        tests/projects/multi-stack/src/Lib.hs+                        tests/projects/simple-bios/A.hs+                        tests/projects/simple-bios/B.hs+                        tests/projects/simple-bios/hie-bios.sh+                        tests/projects/simple-bios/hie.yaml+                        tests/projects/simple-cabal/A.hs+                        tests/projects/simple-cabal/B.hs+                        tests/projects/simple-cabal/CHANGELOG.md+                        tests/projects/simple-cabal/Setup.hs+                        tests/projects/simple-cabal/cabal.project+                        tests/projects/simple-cabal/hie.yaml+                        tests/projects/simple-cabal/simple-cabal.cabal+                        tests/projects/simple-direct/A.hs+                        tests/projects/simple-direct/B.hs+                        tests/projects/simple-direct/hie.yaml+                        tests/projects/simple-stack/A.hs+                        tests/projects/simple-stack/B.hs+                        tests/projects/simple-stack/CHANGELOG.md+                        tests/projects/simple-stack/Setup.hs+                        tests/projects/simple-stack/cabal.project+                        tests/projects/simple-stack/hie.yaml+                        tests/projects/simple-stack/simple-stack.cabal + tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2  Library@@ -26,16 +76,19 @@                         HIE.Bios.Config                         HIE.Bios.Cradle                         HIE.Bios.Environment-                        HIE.Bios.Debug+                        HIE.Bios.Internal.Debug                         HIE.Bios.Flags                         HIE.Bios.Types+                        HIE.Bios.Internal.Log                         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+                        HIE.Bios.Wrappers+  Other-Modules:        Paths_hie_bios+  autogen-modules:      Paths_hie_bios   Build-Depends:                         base >= 4.8 && < 5,                         base16-bytestring    >= 0.1.1 && < 0.2,@@ -48,7 +101,6 @@                         time                 >= 1.8.0 && < 1.10,                         extra                >= 1.6.14 && < 1.7,                         process              >= 1.6.1 && < 1.7,-                        file-embed           >= 0.0.10 && < 0.1,                         ghc                  >= 8.2.2 && < 8.9,                         transformers         >= 0.5.2 && < 0.6,                         temporary            >= 1.2 && < 1.4,@@ -56,8 +108,13 @@                         unix-compat          >= 0.5.1 && < 0.6,                         unordered-containers >= 0.2.9 && < 0.3,                         vector               >= 0.12.0 && < 0.13,-                        yaml                 >= 0.8.32 && < 0.12+                        yaml                 >= 0.8.32 && < 0.12,+                        hslogger             >= 1.2 && < 1.4,+                        file-embed           >= 0.0.11 && < 1,+                        conduit              >= 1.3 && < 2,+                        conduit-extra        >= 1.3 && < 2 + Executable hie-bios   Default-Language:     Haskell2010   Main-Is:              Main.hs@@ -69,6 +126,36 @@                       , filepath                       , ghc                       , hie-bios++test-suite parser-tests+  type: exitcode-stdio-1.0+  default-language: Haskell2010+  build-depends:+      base,+      tasty,+      tasty-hunit,+      hie-bios,+      filepath++  hs-source-dirs: tests/+  ghc-options: -threaded -Wall+  main-is: ParserTests.hs++test-suite bios-tests+  type: exitcode-stdio-1.0+  default-language: Haskell2010+  build-depends:+      base,+      tasty,+      tasty-hunit,+      hie-bios,+      filepath,+      directory,+      ghc++  hs-source-dirs: tests/+  ghc-options: -threaded -Wall+  main-is: BiosTests.hs  Source-Repository head   Type:                 git

@@ -1,20 +1,33 @@--- | The HIE Bios+{- | The HIE Bios +Provides an abstraction over the GHC Api to initialise a GHC session and+loading modules in a project.++Defines the `hie.yaml` file specification. This is used to explicitly configure+how a project should be built by GHC.++-} module HIE.Bios (   -- * Find and load a Cradle     Cradle(..)+  , CradleLoadResult(..)+  , CradleError(..)   , findCradle   , loadCradle   , loadImplicitCradle   , defaultCradle   -- * Compiler Options-  , CompilerOptions(..)+  , ComponentOptions(..)   , getCompilerOptions-  -- * Initialise session+  -- * Initialising a GHC session from a Cradle   , initSession+  -- * Loading targets into a GHC session+  , loadFile+   ) where  import HIE.Bios.Cradle import HIE.Bios.Types import HIE.Bios.Flags import HIE.Bios.Environment+import HIE.Bios.Ghc.Load

@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+-- | Logic and datatypes for parsing @hie.yaml@ files. module HIE.Bios.Config(     readConfig,     Config(..),@@ -9,6 +11,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.HashMap.Strict as Map+import Data.Foldable (foldrM) import           Data.Yaml  data CradleConfig =@@ -21,13 +24,17 @@         -- ^ Type of the cradle to use. Actions to obtain         -- compiler flags from are dependant on this field.         }-        deriving (Show)+        deriving (Show, Eq)  data CradleType     = Cabal { component :: Maybe String }-    | Stack-    | Bazel-    | Obelisk+    | CabalMulti [ (FilePath, String) ]+    | Stack { component :: Maybe String }+    | StackMulti [ (FilePath, String) ]+--  Bazel and Obelisk used to be supported but bit-rotted and no users have complained.+--  They can be added back if a user+--    | Bazel+--    | Obelisk     | Bios         { prog :: FilePath         -- ^ Path to program that retrieves options to compile a file@@ -38,37 +45,59 @@         -- to the location of this program.         }     | Direct { arguments :: [String] }-    | Default-    deriving (Show)+    | None+    | Multi [ (FilePath, CradleConfig) ]+    deriving (Show, Eq)  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"+    parseJSON _ = fail "Not a known cradle type. Possible are: cabal, stack, bios, direct, default, none, multi"  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 "stack" o = parseStack val+--    | 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+    | Just _val <- Map.lookup "none" o = return None+    | Just val  <- Map.lookup "multi" o = parseMulti val 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+parseStackOrCabal+  :: (Maybe String -> CradleType)+  -> ([(FilePath, String)] -> CradleType)+  -> Value+  -> Parser CradleType+parseStackOrCabal singleConstructor _ (Object x)+  | Map.size x == 1, Just (String stackComponent) <- Map.lookup "component" x+  = return $ singleConstructor $ Just $ T.unpack stackComponent+  | Map.null x+  = return $ singleConstructor Nothing+  | otherwise+  = fail "Not a valid Configuration type, following keys are allowed: component"+parseStackOrCabal _ multiConstructor (Array x) = do+  let parseOne e+        | Object v <- e+        , Just (String prefix) <- Map.lookup "path" v+        , Just (String comp) <- Map.lookup "component" v+        , Map.size v == 2+        = return (T.unpack prefix, T.unpack comp)+        | otherwise+        = fail "Expected an object with path and component keys" -    | Map.null x-    = return $ Cabal Nothing+  xs <- foldrM (\v cs -> (: cs) <$> parseOne v) [] x+  return $ multiConstructor xs+parseStackOrCabal singleConstructor _ Null = return $ singleConstructor Nothing+parseStackOrCabal _ _ _ = fail "Configuration is expected to be an object." -    | otherwise-    = fail "Not a valid Cabal Configuration type, following keys are allowed: component"-parseCabal _ = fail "Cabal Configuration is expected to be an object."+parseStack :: Value -> Parser CradleType+parseStack = parseStackOrCabal Stack StackMulti +parseCabal :: Value -> Parser CradleType+parseCabal = parseStackOrCabal Cabal CabalMulti+ parseBios :: Value -> Parser CradleType parseBios (Object x)     | 2 == Map.size x@@ -94,10 +123,30 @@     = 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)+parseMulti :: Value -> Parser CradleType+parseMulti (Array x)+    = Multi <$> mapM parsePath (V.toList x)+parseMulti _ = fail "Multi Configuration is expected to be an array." -instance FromJSON Config where+parsePath :: Value -> Parser (FilePath, CradleConfig)+parsePath (Object v)+  | Just (String path) <- Map.lookup "path" v+  , Just c <- Map.lookup "config" v+  = (T.unpack path,) <$> parseJSON c+parsePath o = fail ("Multi component is expected to be an object." ++ show o)++-- | Configuration that can be used to load a 'Cradle'.+-- A configuration has roughly the following form:+--+-- @+-- cradle:+--   cabal:+--     component: "lib:hie-bios"+-- @+newtype Config = Config { cradle :: CradleConfig }+    deriving (Show, Eq)++instance FromJSON CradleConfig where     parseJSON (Object val) = do             crd     <- val .: "cradle"             crdDeps <- case Map.size val of@@ -105,13 +154,19 @@                 2 -> val .: "dependencies"                 _ -> fail "Unknown key, following keys are allowed: cradle, dependencies" -            return Config-                { cradle = CradleConfig { cradleType         = crd-                                        , cradleDependencies = crdDeps-                                        }-                }+            return $ CradleConfig { cradleType         = crd+                                  , cradleDependencies = crdDeps+                                  }      parseJSON _ = fail "Expected a cradle: key containing the preferences, possible values: cradle, dependencies" ++instance FromJSON Config where+    parseJSON o = Config <$> parseJSON o+++-- | Decode given file to a 'Config' value.+-- If the contents of the file is not a valid 'Config',+-- an 'Control.Exception.IOException' is thrown. readConfig :: FilePath -> IO Config readConfig = decodeFileThrow

@@ -1,5 +1,5 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-} module HIE.Bios.Cradle (       findCradle     , loadCradle@@ -15,35 +15,49 @@ import Control.Monad.Trans.Maybe import System.FilePath import Control.Monad-import Control.Monad.IO.Class import System.Info.Extra+import Control.Monad.IO.Class+import System.Environment import Control.Applicative ((<|>))-import Data.FileEmbed import System.IO.Temp import Data.List+import Data.Ord (Down(..))  import System.PosixCompat.Files+import HIE.Bios.Wrappers+import System.IO+import Control.DeepSeq +import Data.Version (showVersion)+import Paths_hie_bios+import Data.Conduit.Process+import qualified Data.Conduit.Combinators as C+import qualified Data.Conduit as C+import qualified Data.Conduit.Text as C+import qualified Data.Text as T+import           Data.Maybe                     ( maybeToList+                                                , fromMaybe+                                                ) ---------------------------------------------------------------- --- | Given root/foo/bar.hs, return root/hie.yaml, or wherever the yaml file was found+-- | 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+-- | Given root\/hie.yaml load the Cradle. loadCradle :: FilePath -> IO Cradle loadCradle = loadCradleWithOpts defaultCradleOpts --- | Given root/foo/bar.hs, load an implicit cradle+-- | 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 []+    Nothing -> defaultCradle wdir  -- | Finding 'Cradle'. --   Find a cabal file by tracing ancestor directories.@@ -55,17 +69,38 @@     return $ getCradle (cradleConfig, takeDirectory wfile)  getCradle :: (CradleConfig, FilePath) -> Cradle-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+getCradle (cc, wdir) = addCradleDeps cradleDeps $ case cradleType cc of+    Cabal mc -> cabalCradle wdir mc+    CabalMulti ms ->+      getCradle $+        (CradleConfig cradleDeps+          (Multi [(p, CradleConfig [] (Cabal (Just c))) | (p, c) <- ms])+        , wdir)+    Stack mc -> stackCradle wdir mc+    StackMulti ms ->+      getCradle $+        (CradleConfig cradleDeps+          (Multi [(p, CradleConfig [] (Stack (Just c))) | (p, c) <- ms])+        , wdir)+ --   Bazel -> rulesHaskellCradle wdir+ --   Obelisk -> obeliskCradle wdir+    Bios bios deps  -> biosCradle wdir bios deps+    Direct xs -> directCradle wdir xs+    None      -> noneCradle wdir+    Multi ms  -> multiCradle wdir ms     where       cradleDeps = cradleDependencies cc +addCradleDeps :: [FilePath] -> Cradle -> Cradle+addCradleDeps deps c =+  c { cradleOptsProg = addActionDeps (cradleOptsProg c) }+  where+    addActionDeps :: CradleAction -> CradleAction+    addActionDeps ca =+      ca { runCradle = \l fp ->+            (fmap (\(ComponentOptions os' ds) -> ComponentOptions os' (ds `union` deps)))+              <$> runCradle ca l fp }+ implicitConfig :: FilePath -> MaybeT IO (CradleConfig, FilePath) implicitConfig fp = do   (crdType, wdir) <- implicitConfig' fp@@ -74,9 +109,9 @@ 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+  --   <|> (Obelisk,) <$> obeliskWorkDir fp+  --   <|> (Bazel,) <$> rulesHaskellWorkDir fp+     <|> (stackExecutable >> (Stack Nothing,) <$> stackWorkDir fp)      <|> ((Cabal Nothing,) <$> cabalWorkDir fp)  @@ -96,32 +131,85 @@ configFileName :: FilePath configFileName = "hie.yaml" - ------------------------------------------------------------------ Default cradle has no special options, not very useful for loading--- modules. -defaultCradle :: FilePath -> [FilePath] -> Cradle-defaultCradle cur_dir deps =+-- | Default cradle has no special options, not very useful for loading+-- modules.+defaultCradle :: FilePath -> Cradle+defaultCradle cur_dir =   Cradle     { cradleRootDir = cur_dir     , cradleOptsProg = CradleAction         { actionName = "default"-        , getDependencies = return deps-        , getOptions = const $ return (ExitSuccess, "", [])+        , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions [] []))         }     } +---------------------------------------------------------------+-- The none cradle tells us not to even attempt to load a certain directory++noneCradle :: FilePath -> Cradle+noneCradle cur_dir =+  Cradle+    { cradleRootDir = cur_dir+    , cradleOptsProg = CradleAction+        { actionName = "none"+        , runCradle = \_ _ -> return CradleNone+        }+    }++---------------------------------------------------------------+-- The multi cradle selects a cradle based on the filepath++multiCradle :: FilePath -> [(FilePath, CradleConfig)] -> Cradle+multiCradle cur_dir cs =+  Cradle+    { cradleRootDir = cur_dir+    , cradleOptsProg = CradleAction+        { actionName = "multi"+        , runCradle = \l fp -> canonicalizePath fp >>= multiAction cur_dir cs l+        }+    }++multiAction :: FilePath+            -> [(FilePath, CradleConfig)]+            -> LoggingFunction+            -> FilePath+            -> IO (CradleLoadResult ComponentOptions)+multiAction cur_dir cs l cur_fp = selectCradle =<< canonicalizeCradles++  where+    err_msg = ["Multi Cradle: No prefixes matched"+                      , "pwd: " ++ cur_dir+                      , "filepath" ++ cur_fp+                      , "prefixes:"+                      ] ++ [show (pf, cradleType cc) | (pf, cc) <- cs]++    -- Canonicalize the relative paths present in the multi-cradle and+    -- also order the paths by most specific first. In the cradle selection+    -- function we want to choose the most specific cradle possible.+    canonicalizeCradles :: IO [(FilePath, CradleConfig)]+    canonicalizeCradles =+      sortOn (Down . fst)+        <$> mapM (\(p, c) -> (,c) <$> (canonicalizePath (cur_dir </> p))) cs++    selectCradle [] =+      return (CradleFail (CradleError ExitSuccess err_msg))+    selectCradle ((p, c): css) =+        if p `isPrefixOf` cur_fp+          then runCradle (cradleOptsProg (getCradle (c, cur_dir))) l cur_fp+          else selectCradle css++ ------------------------------------------------------------------------- -directCradle :: FilePath -> [String] -> [FilePath] -> Cradle-directCradle wdir args deps =+directCradle :: FilePath -> [String] -> Cradle+directCradle wdir args  =   Cradle     { cradleRootDir = wdir     , cradleOptsProg = CradleAction         { actionName = "direct"-        , getDependencies = return deps-        , getOptions = const $ return (ExitSuccess, "", args)+        , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions args []))         }     } @@ -130,50 +218,56 @@  -- | 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 -> Maybe FilePath -> [FilePath] -> Cradle-biosCradle wdir biosProg biosDepsProg deps =+biosCradle :: FilePath -> FilePath -> Maybe FilePath -> Cradle+biosCradle wdir biosProg biosDepsProg =   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+        , runCradle = biosAction wdir biosProg biosDepsProg         }     }  biosWorkDir :: FilePath -> MaybeT IO FilePath biosWorkDir = findFileUpwards (".hie-bios" ==) -biosDepsAction :: Maybe FilePath -> IO [FilePath]-biosDepsAction (Just biosDepsProg) = do+biosDepsAction :: LoggingFunction -> FilePath -> Maybe FilePath -> IO [FilePath]+biosDepsAction l wdir (Just biosDepsProg) = do   biosDeps' <- canonicalizePath biosDepsProg-  (ex, sout, serr) <- readProcessWithExitCode biosDeps' [] []+  (ex, sout, serr, args) <- readProcessWithOutputFile l Nothing wdir biosDeps' []   case ex of     ExitFailure _ ->  error $ show (ex, sout, serr)-    ExitSuccess -> return (lines sout)-biosDepsAction Nothing = return []+    ExitSuccess -> return args+biosDepsAction _ _ Nothing = return [] -biosAction :: FilePath -> FilePath -> FilePath -> IO (ExitCode, String, [String])-biosAction _wdir bios fp = do+biosAction :: FilePath+           -> FilePath+           -> Maybe FilePath+           -> LoggingFunction+           -> FilePath+           -> IO (CradleLoadResult ComponentOptions)+biosAction wdir bios bios_deps l fp = do   bios' <- canonicalizePath bios-  (ex, res, std) <- readProcessWithExitCode bios' [fp] []-  return (ex, std, words res)+  (ex, _stdo, std, res) <- readProcessWithOutputFile l Nothing wdir bios' [fp]+  deps <- biosDepsAction l wdir bios_deps+        -- Output from the program should be written to the output file and+        -- delimited by newlines.+        -- Execute the bios action and add dependencies of the cradle.+        -- Removes all duplicates.+  return $ makeCradleResult (ex, std, res) deps  ------------------------------------------------------------------------ -- Cabal Cradle -- Works for new-build by invoking `v2-repl` does not support components -- yet. -cabalCradle :: FilePath -> Maybe String -> [FilePath] -> Cradle-cabalCradle wdir mc deps =+cabalCradle :: FilePath -> Maybe String -> Cradle+cabalCradle wdir mc =   Cradle     { cradleRootDir    = wdir     , cradleOptsProg   = CradleAction         { actionName = "cabal"-        , getDependencies = fmap (deps `union`) (cabalCradleDependencies wdir)-        , getOptions = cabalAction wdir mc+        , runCradle = cabalAction wdir mc         }     } @@ -187,72 +281,78 @@   dirContent <- listDirectory wdir   return $ filter ((== ".cabal") . takeExtension) dirContent -cabalWrapper :: String-cabalWrapper = $(embedStringFile "wrappers/cabal") -cabalWrapperHs :: String-cabalWrapperHs = $(embedStringFile "wrappers/cabal.hs")--processCabalWrapperArgs :: String -> Maybe [String]+processCabalWrapperArgs :: [String] -> Maybe [String] processCabalWrapperArgs args =-    case lines args of-        [dir, ghc_args] ->+    case args of+        (dir: ghc_args) ->             let final_args =-                    removeInteractive+                    removeVerbosityOpts+                    $ removeInteractive                     $ map (fixImportDirs dir)-                    $ limited ghc_args+                    $ 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') +-- | GHC process information.+-- Consists of the filepath to the ghc executable and+-- arguments to the executable.+type GhcProc = (FilePath, [String])+ -- generate a fake GHC that can be passed to cabal -- when run with --interactive, it will print out its -- command-line arguments and exit-getCabalWrapperTool :: IO FilePath-getCabalWrapperTool = do+getCabalWrapperTool :: GhcProc -> IO FilePath+getCabalWrapperTool (ghcPath, ghcArgs) = do   wrapper_fp <-     if isWindows       then do-        wrapper_hs <- writeSystemTempFile "wrapper.hs" cabalWrapperHs-        -- the initial contents will be overwritten immediately after by ghc-        wrapper_fp <- writeSystemTempFile "wrapper.exe" ""-        let ghc = (proc "ghc" ["-o", wrapper_fp, wrapper_hs])-                    { cwd = Just (takeDirectory wrapper_hs) }-        readCreateProcess ghc "" >>= putStr+        cacheDir <- getXdgDirectory XdgCache "hie-bios"+        let wrapper_name = "wrapper-" ++ showVersion version+        let wrapper_fp = cacheDir </> wrapper_name <.> "exe"+        exists <- doesFileExist wrapper_fp+        unless exists $ do+            tempDir <- getTemporaryDirectory+            let wrapper_hs = tempDir </> wrapper_name <.> "hs"+            writeFile wrapper_hs cabalWrapperHs+            createDirectoryIfMissing True cacheDir+            let ghc = (proc ghcPath $ ghcArgs ++ ["-o", wrapper_fp, wrapper_hs])+                        { cwd = Just (takeDirectory wrapper_hs) }+            readCreateProcess ghc "" >>= putStr         return wrapper_fp-      else do-        writeSystemTempFile "bios-wrapper" cabalWrapper+      else writeSystemTempFile "bios-wrapper" cabalWrapper    setFileMode wrapper_fp accessModes   _check <- readFile wrapper_fp   return wrapper_fp -cabalAction :: FilePath -> Maybe String -> FilePath -> IO (ExitCode, String, [String])-cabalAction work_dir mc _fp = do-  wrapper_fp <- getCabalWrapperTool-  let cab_args = ["v2-repl", "-v0", "--disable-documentation", "--with-compiler", wrapper_fp]+cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)+cabalAction work_dir mc l _fp = do+  wrapper_fp <- getCabalWrapperTool ("ghc", [])+  let cab_args = ["v2-repl", "--with-compiler", wrapper_fp]                   ++ [component_name | Just component_name <- [mc]]-  (ex, args, stde) <--    readProcessWithExitCodeInDirectory work_dir "cabal" cab_args []+  (ex, output, stde, args) <-+    readProcessWithOutputFile l Nothing work_dir "cabal" cab_args+  deps <- cabalCradleDependencies work_dir   case processCabalWrapperArgs args of-      Nothing -> error (show (ex, stde, args))-      Just final_args -> pure (ex, stde, final_args)+      Nothing -> pure $ CradleFail (CradleError ex+                  ["Failed to parse result of calling cabal"+                   , unlines output+                   , unlines stde+                   , unlines args])+      Just final_args -> pure $ makeCradleResult (ex, stde, final_args) deps  removeInteractive :: [String] -> [String] removeInteractive = filter (/= "--interactive") +removeVerbosityOpts :: [String] -> [String]+removeVerbosityOpts = filter ((&&) <$> (/= "-v0") <*> (/= "-w"))+ 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)+         in if not (null dir) && isRelative dir then "-i" ++ base_dir </> dir                               else arg     else arg @@ -266,51 +366,60 @@ -- Stack Cradle -- Works for by invoking `stack repl` with a wrapper script -stackCradle :: FilePath -> [FilePath] -> Cradle-stackCradle wdir deps =+stackCradle :: FilePath -> Maybe String -> Cradle+stackCradle wdir mc =   Cradle     { cradleRootDir    = wdir     , cradleOptsProg   = CradleAction         { actionName = "stack"-        , getDependencies = fmap (deps `union`) (stackCradleDependencies wdir)-        , getOptions = stackAction wdir+        , runCradle = stackAction wdir mc         }     } -stackCradleDependencies :: FilePath -> IO [FilePath]+stackCradleDependencies :: FilePath-> IO [FilePath] stackCradleDependencies wdir = do-    cabalFiles <- findCabalFiles wdir-    return $ cabalFiles ++ ["package.yaml", "stack.yaml"]+  cabalFiles <- findCabalFiles wdir+  return $ cabalFiles ++ ["package.yaml", "stack.yaml"] -stackAction :: FilePath -> FilePath -> IO (ExitCode, String, [String])-stackAction work_dir fp = do+stackAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)+stackAction work_dir mc l _fp = do+  let ghcProcArgs = ("stack", ["exec", "ghc", "--"])   -- Same wrapper works as with cabal-  wrapper_fp <- getCabalWrapperTool-  -- TODO: this is for debugging-  -- check <- readFile wrapper_fp-  -- traceM check-  (ex1, args, stde) <--      readProcessWithExitCodeInDirectory work_dir "stack" ["repl", "--silent", "--no-load", "--with-ghc", wrapper_fp, fp ] []-  (ex2, pkg_args, stdr) <--      readProcessWithExitCodeInDirectory work_dir "stack" ["path", "--ghc-package-path"] []-  let split_pkgs = splitSearchPath (init pkg_args)+  wrapper_fp <- getCabalWrapperTool ghcProcArgs++  (ex1, _stdo, stde, args) <-+    readProcessWithOutputFile l Nothing work_dir+            "stack" $ ["repl", "--no-nix-pure", "--with-ghc", wrapper_fp] ++ maybeToList mc+  (ex2, pkg_args, stdr, _) <-+    readProcessWithOutputFile l Nothing work_dir "stack" ["path", "--ghc-package-path"]+  let split_pkgs = concatMap splitSearchPath 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)+  deps <- stackCradleDependencies work_dir+  return $ case processCabalWrapperArgs args of+      Nothing -> CradleFail (CradleError ex1 $+                  ("Failed to parse result of calling stack":+                    stde)+                   ++ args) +      Just ghc_args ->+        makeCradleResult (combineExitCodes [ex1, ex2], stde ++ stdr, ghc_args ++ pkg_ghc_args) deps+ combineExitCodes :: [ExitCode] -> ExitCode combineExitCodes = foldr go ExitSuccess   where     go ExitSuccess b = b     go a _ = a +stackExecutable :: MaybeT IO FilePath+stackExecutable = MaybeT $ findExecutable "stack"  stackWorkDir :: FilePath -> MaybeT IO FilePath stackWorkDir = findFileUpwards isStack   where     isStack name = name == "stack.yaml" +{-+-- Support removed for 0.3 but should be added back in the future ---------------------------------------------------------------------------- -- rules_haskell - Thanks for David Smith for helping with this one. -- Looks for the directory containing a WORKSPACE file@@ -319,14 +428,13 @@ rulesHaskellWorkDir fp =   findFileUpwards (== "WORKSPACE") fp -rulesHaskellCradle :: FilePath -> [FilePath] -> Cradle-rulesHaskellCradle wdir deps =+rulesHaskellCradle :: FilePath -> Cradle+rulesHaskellCradle wdir =   Cradle     { cradleRootDir  = wdir     , cradleOptsProg   = CradleAction         { actionName = "bazel"-        , getDependencies = fmap (deps `union`) (rulesHaskellCradleDependencies wdir)-        , getOptions = rulesHaskellAction wdir+        , runCradle = rulesHaskellAction wdir         }     } @@ -336,16 +444,17 @@ bazelCommand :: String bazelCommand = $(embedStringFile "wrappers/bazel") -rulesHaskellAction :: FilePath -> FilePath -> IO (ExitCode, String, [String])+rulesHaskellAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions) rulesHaskellAction work_dir fp = do   wrapper_fp <- writeSystemTempFile "wrapper" bazelCommand   setFileMode wrapper_fp accessModes   let rel_path = makeRelative work_dir fp   (ex, args, stde) <--      readProcessWithExitCodeInDirectory work_dir wrapper_fp [rel_path] []+      readProcessWithOutputFile work_dir wrapper_fp [rel_path] []   let args'  = filter (/= '\'') args   let args'' = filter (/= "\"$GHCI_LOCATION\"") (words args')-  return (ex, stde, args'')+  deps <- rulesHaskellCradleDependencies work_dir+  return $ makeCradleResult (ex, stde, args'') deps   ------------------------------------------------------------------------------@@ -364,24 +473,25 @@ obeliskCradleDependencies :: FilePath -> IO [FilePath] obeliskCradleDependencies _wdir = return [] -obeliskCradle :: FilePath -> [FilePath] -> Cradle-obeliskCradle wdir deps =+obeliskCradle :: FilePath -> Cradle+obeliskCradle wdir =   Cradle     { cradleRootDir  = wdir     , cradleOptsProg = CradleAction         { actionName = "obelisk"-        , getDependencies = fmap (deps `union`) (obeliskCradleDependencies wdir)-        , getOptions = obeliskAction wdir+        , runCradle = obeliskAction wdir         }     } -obeliskAction :: FilePath -> FilePath -> IO (ExitCode, String, [String])+obeliskAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions) obeliskAction work_dir _fp = do   (ex, args, stde) <--      readProcessWithExitCodeInDirectory work_dir "ob" ["ide-args"] []-  return (ex, stde, words args)+      readProcessWithOutputFile work_dir "ob" ["ide-args"] [] +  o_deps <- obeliskCradleDependencies work_dir+  return (makeCradleResult (ex, stde, words args) o_deps ) +-} ------------------------------------------------------------------------------ -- Utilities @@ -400,15 +510,66 @@  -- | Sees if any file in the directory matches the predicate findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]-findFile p dir = getFiles >>= filterM doesPredFileExist+findFile p dir = do+  b <- doesDirectoryExist dir+  if b then getFiles >>= filterM doesPredFileExist else return []   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+-- | Call a process with the given arguments.+-- * A special file is created for the process to write to, the process can discover the name of+-- the file by reading the @HIE_BIOS_OUTPUT@ environment variable. The contents of this file is+-- returned by the function.+-- * The logging function is called every time the process emits anything to stdout or stderr.+-- it can be used to report progress of the process to a user.+-- * The process is executed in the given directory.+-- * The path to the GHC version to use is supplied in the environment variable @HIE_BIOS_GHC@.+--   Additionally, arguments to ghc are supplied via @HIE_BIOS_GHC_ARGS@+readProcessWithOutputFile+  :: LoggingFunction -- ^ Output of the process is streamed into this function.+  -> Maybe GhcProc -- ^ Optional FilePath to GHC and arguments that should+                   -- be passed to ghc.+                   -- In the process to call, filepath and arguments+  -> FilePath -- ^ Working directory. Process is executed in this directory.+  -> FilePath -- ^ Process to call.+  -> [String] -- ^ Arguments to the process.+  -> IO (ExitCode, [String], [String], [String])+readProcessWithOutputFile l ghcProc work_dir fp args =+  withSystemTempFile "bios-output" $ \output_file h -> do+    hSetBuffering h LineBuffering+    old_env <- getEnvironment+    let (ghcPath, ghcArgs) = case ghcProc of+            Just (p, a) -> (p, unwords a)+            Nothing ->+              ( fromMaybe "ghc" (lookup hieBiosGhc old_env)+              , fromMaybe "" (lookup hieBiosGhcArgs old_env)+              )+    -- Pipe stdout directly into the logger+    let process = (readProcessInDirectory work_dir fp args)+                      { env = Just+                              $ (hieBiosGhc, ghcPath)+                              : (hieBiosGhcArgs, ghcArgs)+                              : ("HIE_BIOS_OUTPUT", output_file)+                              : old_env+                      }+        -- Windows line endings are not converted so you have to filter out `'r` characters+        loggingConduit = (C.decodeUtf8  C..| C.lines C..| C.filterE (/= '\r')  C..| C.map T.unpack C..| C.iterM l C..| C.sinkList)+    (ex, stdo, stde) <- sourceProcessWithStreams process mempty loggingConduit loggingConduit+    !res <- force <$> hGetContents h+    return (ex, stdo, stde, lines (filter (/= '\r') res))++    where+      hieBiosGhc = "HIE_BIOS_GHC"+      hieBiosGhcArgs = "HIE_BIOS_GHC_ARGS"++readProcessInDirectory :: FilePath -> FilePath -> [String] -> CreateProcess+readProcessInDirectory wdir p args = (proc p args) { cwd = Just wdir }++makeCradleResult :: (ExitCode, [String], [String]) -> [FilePath] -> CradleLoadResult ComponentOptions+makeCradleResult (ex, err, gopts) deps =+  case ex of+    ExitFailure _ -> CradleFail (CradleError ex err)+    _ ->+        let compOpts = ComponentOptions gopts deps+        in CradleSuccess compOpts

@@ -1,39 +0,0 @@-module HIE.Bios.Debug (debugInfo, rootInfo) where--import Control.Monad.IO.Class (liftIO)--import qualified Data.Char as Char-import Data.Maybe (fromMaybe)--import HIE.Bios.Ghc.Api-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)-    deps  <- getDependencies (cradleOptsProg cradle)-    mglibdir <- liftIO getSystemLibDir-    return [-        "Root directory:      " ++ rootDir-      , "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---------------------------------------------------------------------- | Obtaining root information.-rootInfo :: Options-          -> Cradle-          -> IO String-rootInfo opt cradle = return $ convert opt $ cradleRootDir cradle

@@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards, CPP #-}-module HIE.Bios.Environment (initSession, getSystemLibDir, addCmdOpts, getDynamicFlags) where+module HIE.Bios.Environment (initSession, getSystemLibDir, addCmdOpts) where  import CoreMonad (liftIO) import GHC (DynFlags(..), GhcLink(..), HscTarget(..), GhcMonad)@@ -8,7 +8,7 @@ import qualified Util as G import DynFlags -import Control.Monad (void, when)+import Control.Monad (void)  import System.Process (readProcess) import System.Directory@@ -20,40 +20,36 @@ import Data.List  import HIE.Bios.Types+import HIE.Bios.Ghc.Gap +-- | Start a GHC session and set some sensible options for tooling to use.+-- Creates a folder in the cache directory to cache interface files to make+-- reloading faster. initSession :: (GhcMonad m)-    => CompilerOptions+    => ComponentOptions     -> m [G.Target]-initSession  CompilerOptions {..} = do+initSession  ComponentOptions {..} = 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+    -- Create a unique folder per set of different GHC options, assuming that each different set of+    -- GHC options will create incompatible interface files.+    let opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack componentOptions)+    cache_dir <- liftIO $ getCacheDir opts_hash+    -- Add the user specified options to a fresh GHC session.+    (df', targets) <- addCmdOpts componentOptions df     void $ G.setSessionDynFlags-        (disableOptimisation-        $ setIgnoreInterfacePragmas-        $ resetPackageDb-        -- --  $ ignorePackageEnv-        $ writeInterfaceFiles (Just fp)-        $ setVerbosity 0--        $ setLinkerOptions df'+        (disableOptimisation -- Compile with -O0 as we are not going to produce object files.+        $ setIgnoreInterfacePragmas            -- Ignore any non-essential information in interface files such as unfoldings changing.+        $ writeInterfaceFiles (Just cache_dir) -- Write interface files to the cache+        $ setVerbosity 0                       -- Set verbosity to zero just in case the user specified `-vx` in the options.+        $ setLinkerOptions df'                 -- Set `-fno-code` to avoid generating object files, unless we have to.         )-    G.setLogAction (\_df _wr _s _ss _pp _m -> return ())-#if __GLASGOW_HASKELL__ < 806-        (\_df -> return ())-#endif-+    -- Unset the default log action to avoid output going to stdout.+    unsetLogAction     return targets  ---------------------------------------------------------------- --- | Obtaining the directory for system libraries.+-- | Obtain the directory for system libraries. getSystemLibDir :: IO (Maybe FilePath) getSystemLibDir = do     res <- readProcess "ghc" ["--print-libdir"] []@@ -63,16 +59,22 @@  ---------------------------------------------------------------- -+-- | What to call the cache directory in the cache folder. cacheDir :: String-cacheDir = "haskell-ide-engine"+cacheDir = "hie-bios" -clearInterfaceCache :: FilePath -> IO ()-clearInterfaceCache fp = do-  cd <- getCacheDir fp-  res <- doesPathExist cd-  when res (removeDirectoryRecursive cd)+{- |+Back in the day we used to clear the cache at the start of each session,+however, it's not really necessary as+1. There is one cache dir for any change in options.+2. Interface files are resistent to bad option changes anyway. +> 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) @@ -88,12 +90,6 @@   , 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 @@ -108,14 +104,21 @@ setHiDir f d = d { hiDir      = Just f}  +-- | Interpret and set the specific command line options.+-- A lot of this code is just copied from ghc/Main.hs+-- It would be good to move this code into a library module so we can just use it+-- rather than copy it. 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)+  (df2, leftovers', _warns) <- G.parseDynamicFlags df1 (map G.noLoc cmdOpts) +  -- parse targets from ghci-scripts. Only extract targets that have been ":add"'ed.+  additionalTargets <- concat <$> mapM (liftIO . getTargetsFromGhciScript) (ghciScripts df2)++  -- leftovers contains all Targets from the command line+  let leftovers = leftovers' ++ map G.noLoc additionalTargets+   let      -- To simplify the handling of filepaths, we normalise all filepaths right      -- away. Note the asymmetry of FilePath.normalise:@@ -153,15 +156,6 @@        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 -- -----------------------------------------------------------------------------@@ -207,3 +201,20 @@  disableOptimisation :: DynFlags -> DynFlags disableOptimisation df = updOptLevel 0 df++-- --------------------------------------------------------++-- | Read a ghci script and extract all targets to load form it.+-- The ghci script is expected to have the following format:+-- @+--  :add Foo Bar Main.hs+-- @+--+-- We strip away ":add" and parse the Targets.+getTargetsFromGhciScript :: FilePath -> IO [String]+getTargetsFromGhciScript script = do+  contents <- lines <$> readFile script+  return+    $ concatMap (tail {- first element is ":add" which we want to remove -}+                      . words)+    $ filter (":add" `isPrefixOf`) contents

@@ -1,29 +1,17 @@-module HIE.Bios.Flags (getCompilerOptions, CradleError) where+module HIE.Bios.Flags (getCompilerOptions) where -import Control.Monad.IO.Class-import Control.Exception ( Exception )+import HIE.Bios.Types+import HIE.Bios.Internal.Log -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.+-- file or GHC session according to the provided 'Cradle'. 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)+    -> IO (CradleLoadResult ComponentOptions)+getCompilerOptions fp cradle =+  runCradle (cradleOptsProg cradle) logm fp -instance Exception CradleError where  ----------------------------------------------------------------

@@ -1,22 +1,19 @@-{-# LANGUAGE ScopedTypeVariables, RecordWildCards, CPP #-}-+{-# LANGUAGE ScopedTypeVariables, CPP #-}+-- | These functions are for conveniently implementing the simple CLI module HIE.Bios.Ghc.Api (-    withGHC+    initializeFlagsWithCradle+  , initializeFlagsWithCradleWithMessage+  , G.SuccessFlag(..)+  -- * Utility functions for running the GHC monad and implementing internal utilities+  , withGHC   , withGHC'   , withGhcT-  , initializeFlagsWithCradle-  , initializeFlagsWithCradleWithMessage-  , getDynamicFlags   , getSystemLibDir   , withDynFlags-  , withCmdFlags-  , setNoWarningFlags-  , setAllWarningFlags-  , setDeferTypeErrors   ) where  import CoreMonad (liftIO)-import Exception (ghandle, SomeException(..), ExceptionMonad(..), throwIO)+import Exception (ghandle, SomeException(..), ExceptionMonad(..)) import GHC (Ghc, LoadHowMuch(..), GhcMonad, GhcT) import DynFlags @@ -27,19 +24,14 @@  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 qualified HIE.Bios.Internal.Log as Log import HIE.Bios.Environment import HIE.Bios.Flags -- ---------------------------------------------------------------- --- | Converting the 'Ghc' monad to the 'IO' monad.+-- | Converting the 'Ghc' monad to the 'IO' monad. All exceptions are ignored and logged. withGHC :: FilePath  -- ^ A target file displayed in an error message.         -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities.         -> IO a@@ -47,12 +39,15 @@   where     ignore :: SomeException -> IO a     ignore e = do-        hPutStr stderr $ file ++ ":0:0:Error:"-        hPrint stderr e+        Log.logm $ file ++ ":0:0:Error:"+        Log.logm (show e)         exitSuccess +-- | Run a Ghc monad computation with an automatically discovered libdir.+-- It calculates the lib dir by calling ghc with the `--print-libdir` flag. withGHC' :: Ghc a -> IO a withGHC' body = do+    -- TODO: Why is this not using ghc-paths?     mlibdir <- getSystemLibDir     G.runGhc mlibdir body @@ -63,37 +58,39 @@  ---------------------------------------------------------------- --+-- | Initialize a GHC session by loading a given file into a given cradle. initializeFlagsWithCradle ::     GhcMonad m-    => FilePath -- The file we are loading it because of-    -> Cradle-    -> m ()+    => FilePath -- ^ The file we are loading the 'Cradle' because of+    -> Cradle   -- ^ The cradle we want to load+    -> m (CradleLoadResult (m G.SuccessFlag)) initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.batchMsg) +-- | The same as 'initializeFlagsWithCradle' but with an additional argument to control+-- how the loading progress messages are displayed to the user. In @haskell-ide-engine@+-- the module loading progress is displayed in the UI by using a progress notification. 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+  -> FilePath -- ^ The file we are loading the 'Cradle' because of+  -> Cradle   -- ^ The cradle we want to load+  -> m (CradleLoadResult (m G.SuccessFlag)) -- ^ Whether we actually loaded the cradle or not.+initializeFlagsWithCradleWithMessage msg fp cradle =+    fmap (initSessionWithMessage msg) <$> (liftIO $ getCompilerOptions fp cradle) +-- | Actually perform the initialisation of the session. Initialising the session corresponds to+-- parsing the command line flags, setting the targets for the session and then attempting to load+-- all the targets. initSessionWithMessage :: (GhcMonad m)             => Maybe G.Messager-            -> CompilerOptions-            -> m ()+            -> ComponentOptions+            -> m G.SuccessFlag 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+    G.load' LoadAllTargets msg mod_graph  ---------------------------------------------------------------- @@ -108,41 +105,4 @@         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'

@@ -1,32 +1,43 @@ 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 GHC (DynFlags(..), GhcMonad)+import Exception  import HIE.Bios.Ghc.Api import HIE.Bios.Ghc.Logger+import qualified HIE.Bios.Internal.Log as Log import HIE.Bios.Types import HIE.Bios.Ghc.Load-import Outputable+import Control.Monad.IO.Class +import System.IO.Unsafe (unsafePerformIO)+import qualified HIE.Bios.Ghc.Gap as Gap++import qualified GHC as G+import HIE.Bios.Environment+ ----------------------------------------------------------------  -- | Checking syntax of a target file using GHC. --   Warnings and errors are returned.-checkSyntax :: Options-            -> Cradle+checkSyntax :: 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+checkSyntax _      []    = return ""+checkSyntax cradle files = withGhcT $ do+    Log.debugm $ "Cradle: " ++ show cradle+    res <- initializeFlagsWithCradle (head files) cradle+    case res of+      CradleSuccess ini -> do+        _sf <- ini+        either id id <$> check files+      CradleFail ce -> liftIO $ throwIO ce+      CradleNone -> return "No cradle"++   where     {-     sessionName = case files of@@ -39,37 +50,24 @@ -- | Checking syntax of a target file using GHC. --   Warnings and errors are returned. check :: (GhcMonad m)-      => Options-      -> [FilePath]  -- ^ The target files.+      => [FilePath]  -- ^ The target files.       -> m (Either String String)-check opt fileNames = withLogger opt setAllWarningFlags $ setTargetFiles (map dup fileNames)+check fileNames = withLogger 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)+-- | Set 'DynFlags' equivalent to "-Wall".+setAllWarningFlags :: DynFlags -> DynFlags+setAllWarningFlags df = df { warningFlags = allWarningFlags } -setDumpSplices :: DynFlags -> DynFlags-setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices+{-# 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,3 +1,4 @@+-- | Pretty printer utilities module HIE.Bios.Ghc.Doc where  import GHC (DynFlags, getPrintUnqual, pprCols, GhcMonad)

@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances, CPP #-}-+-- | All the CPP for GHC version compability should live in this module. module HIE.Bios.Ghc.Gap (     WarnFlags   , emptyWarnFlags@@ -15,13 +15,25 @@   , outType   , mapMG   , mgModSummaries+  , numLoadedPlugins+  , initializePlugins+  , unsetLogAction   ) where  import DynFlags (DynFlags)-import GHC(LHsBind, LHsExpr, LPat, Type, ModSummary, ModuleGraph)+import GHC(LHsBind, LHsExpr, LPat, Type, ModSummary, ModuleGraph, HscEnv, setLogAction, GhcMonad) import HsExpr (MatchGroup) import Outputable (PrintUnqualified, PprStyle, Depth(AllTheWay), mkUserStyle) +#if __GLASGOW_HASKELL__ >= 808+import qualified DynamicLoading (initializePlugins)+import qualified Plugins (plugins)+#endif+++++ ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -49,6 +61,7 @@ import GHC (Id, mg_res_ty, mg_arg_tys) #endif + ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -140,4 +153,27 @@ #else mgModSummaries :: ModuleGraph -> [ModSummary] mgModSummaries = id+#endif++numLoadedPlugins :: DynFlags -> Int+#if __GLASGOW_HASKELL__ >= 808+numLoadedPlugins = length . Plugins.plugins+#else+-- Plugins are loaded just as they are used+numLoadedPlugins _ = 0+#endif++initializePlugins :: HscEnv -> DynFlags -> IO DynFlags+#if __GLASGOW_HASKELL__ >= 808+initializePlugins = DynamicLoading.initializePlugins+#else+-- In earlier versions of GHC plugins are just loaded before they are used.+initializePlugins _ df = return df+#endif++unsetLogAction :: GhcMonad m => m ()+unsetLogAction =+    setLogAction (\_df _wr _s _ss _pp _m -> return ())+#if __GLASGOW_HASKELL__ < 806+        (\_df -> return ()) #endif

@@ -1,70 +1,85 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-}+-- | Convenience functions for loading a file into a GHC API session 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+import qualified HIE.Bios.Internal.Log as Log --- | Obtaining type of a target expression. (GHCi's type:)+-- | Load a target into the GHC session.+--+-- The target is represented as a tuple. The tuple consists of the+-- original filename and another file that contains the actual+-- source code to compile.+--+-- The optional messager can be used to log diagnostics, warnings or errors+-- that occurred during loading the target.+--+-- If the loading succeeds, the typechecked module is returned+-- together with all the typechecked modules that had to be loaded+-- in order to typecheck the given target. loadFileWithMessage :: GhcMonad m-         => Maybe G.Messager-         -> (FilePath, FilePath)     -- ^ A target file.+         => Maybe G.Messager -- ^ Optional messager hook+                             -- to log messages produced by GHC.+         -> (FilePath, FilePath)  -- ^ Target file to load.          -> m (Maybe TypecheckedModule, [TypecheckedModule])+         -- ^ Typechecked module and modules that had to+         -- be loaded for the target. 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))+  -- STEP 1: Load the file into the session, using collectASTs to also retrieve+  -- typechecked and parsed modules.+  (_, tcs) <- collectASTs $ (setTargetFilesWithMessage msg [file])+  Log.debugm $ "loaded " ++ fst file ++ " - " ++ snd file   let get_fp = ml_hs_file . ms_location . pm_mod_summary . tm_parsed_module-  traceShowM ("tms", (map get_fp tcs))+  Log.debugm $ "Typechecked modules for: " ++ (unlines $ map (show . get_fp) tcs)+  -- Find the specific module in the list of returned typechecked modules if it exists.   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) +-- | Load a target into the GHC session with the default messager+--  which outputs updates in the same format as normal GHC.+--+-- The target is represented as a tuple. The tuple consists of the+-- original filename and another file that contains the actual+-- source code to compile.+--+-- If the message should configured, use 'loadFileWithMessage'.+--+-- If the loading succeeds, the typechecked module is returned+-- together with all the typechecked modules that had to be loaded+-- in order to typecheck the given target. loadFile :: (GhcMonad m)-         => (FilePath, FilePath)+         => (FilePath, FilePath) -- ^ Target file to load.          -> m (Maybe TypecheckedModule, [TypecheckedModule])+         -- ^ Typechecked module and modules that had to+         -- be loaded for the target. 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-    -} -+-- | Set the files as targets and load them. This will reset GHC's targets so only the modules you+-- set as targets and its dependencies will be loaded or reloaded.+-- Produced diagnostics will be printed similar to the normal output of GHC.+-- To configure this, use 'setTargetFilesWithMessage'. setTargetFiles :: GhcMonad m => [(FilePath, FilePath)] -> m () setTargetFiles = setTargetFilesWithMessage (Just G.batchMsg) @@ -83,46 +98,67 @@         | otherwise = ms   pure $ Gap.mapMG go graph --- | Set the files as targets and load them.+-- | Set the files as targets and load them. This will reset GHC's targets so only the modules you+-- set as targets and its dependencies will be loaded or reloaded. 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)+    Log.debugm $ "setTargets: " ++ show files+    G.setTargets 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 ())+    Log.debugm $ "modGraph: " ++ show (map ms_location $ Gap.mgModSummaries mod_graph)     void $ G.load' LoadAllTargets msg mod_graph +-- | Add a hook to record the contents of any 'TypecheckedModule's which are produced+-- during compilation. 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) }+                          { hscFrontendHook = Just (astHook ref1) }                         }-  void $ setSessionDynFlags $ dflags1 -- gopt_set dflags1 Opt_ForceRecomp+  -- Modify session is much faster than `setSessionDynFlags`.+  modifySession $ \h -> h{ hsc_dflags = dflags1 }   res <- action   tcs <- liftIO $ readIORef ref1+  -- Unset the hook so that we don't retain the reference ot the IORef so it can be gced.+  -- This stops the typechecked modules being retained in some cases.+  liftIO $ writeIORef ref1 []+  dflags_old <- getSessionDynFlags+  let dflags2 = dflags1 { hooks = (hooks dflags_old)+                          { hscFrontendHook = Nothing }+                        }+  modifySession $ \h -> h{ hsc_dflags = dflags2 }+   return (res, tcs) +-- | This hook overwrites the default frontend action of GHC. astHook :: IORef [TypecheckedModule] -> ModSummary -> Hsc FrontendResult astHook tc_ref ms = ghcInHsc $ do-  p <- G.parseModule ms+  p <- G.parseModule =<< initializePluginsGhc ms   tcm <- G.typecheckModule p   let tcg_env = fst (tm_internals_ tcm)   liftIO $ modifyIORef tc_ref (tcm :)   return $ FrontendTypecheck tcg_env +initializePluginsGhc :: ModSummary -> Ghc ModSummary+initializePluginsGhc ms = do+  hsc_env <- getSession+  df <- liftIO $ Gap.initializePlugins hsc_env (ms_hspp_opts  ms)+  Log.debugm ("init-plugins(loaded):" ++ show (Gap.numLoadedPlugins df))+  Log.debugm ("init-plugins(specified):" ++ show (length $ pluginModNames df))+  return (ms { ms_hspp_opts = df })++ ghcInHsc :: Ghc a -> Hsc a ghcInHsc gm = do   hsc_session <- getHscEnv   session <- liftIO $ newIORef hsc_session   liftIO $ reflectGhc gm (Session session) -+-- | A variant of 'guessTarget' which after guessing the target for a filepath, overwrites the+-- target file to be a temporary file. guessTargetMapped :: (GhcMonad m) => (FilePath, FilePath) -> m Target guessTargetMapped (orig_file_name, mapped_file_name) = do   t <- G.guessTarget orig_file_name Nothing

@@ -2,8 +2,6 @@  module HIE.Bios.Ghc.Logger (     withLogger-  , checkErrorPrefix-  , getSrcSpan   ) where  import Bag (Bag, bagToList)@@ -18,13 +16,11 @@ 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)+import HIE.Bios.Ghc.Api (withDynFlags)  ---------------------------------------------------------------- @@ -35,11 +31,11 @@ newLogRef :: IO LogRef newLogRef = LogRef <$> newIORef id -readAndClearLogRef :: Options -> LogRef -> IO String-readAndClearLogRef opt (LogRef ref) = do+readAndClearLogRef :: LogRef -> IO String+readAndClearLogRef (LogRef ref) = do     b <- readIORef ref     writeIORef ref id-    return $! convert opt (b [])+    return $! unlines (b [])  appendLogRef :: DynFlags -> LogRef -> LogAction appendLogRef df (LogRef ref) _ _ sev src style msg = do@@ -53,27 +49,25 @@ --   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+  => (DynFlags -> DynFlags) -> m () -> m (Either String String)+withLogger setDF body = ghandle sourceError $ do     logref <- liftIO newLogRef     withDynFlags (setLogger logref . setDF) $ do-        withCmdFlags wflags $ do-            body-            liftIO $ Right <$> readAndClearLogRef opt logref+      body+      liftIO $ Right <$> readAndClearLogRef 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+  => SourceError -> m (Either String String)+sourceError err = do     dflag <- G.getSessionDynFlags     style <- getStyle dflag-    let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err+    let ret = unlines . errBagToStrList dflag style . srcErrorMessages $ err     return (Left ret)  errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]

@@ -1,63 +0,0 @@-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)

@@ -0,0 +1,53 @@+module HIE.Bios.Internal.Debug (debugInfo, rootInfo) where++import Control.Monad.IO.Class (liftIO)++import qualified Data.Char as Char+import Data.Maybe (fromMaybe)++import HIE.Bios.Ghc.Api+import HIE.Bios.Types+import HIE.Bios.Flags++----------------------------------------------------------------++-- | Obtain debug information for a 'Cradle'.+--+-- Tries to load the 'Cradle' and dump any information associated with it.+-- If loading succeeds, contains information such as the root directory of+-- the cradle, the compiler options to compile a module in this 'Cradle',+-- the file dependencies and so on.+--+-- Otherwise, shows the error message and exit-code.+debugInfo :: FilePath+          -> Cradle+          -> IO String+debugInfo fp cradle = unlines <$> do+    res <- getCompilerOptions fp cradle+    case res of+      CradleSuccess (ComponentOptions gopts deps) -> do+        mglibdir <- liftIO getSystemLibDir+        return [+            "Root directory:      " ++ rootDir+          , "GHC options:         " ++ unwords (map quoteIfNeeded gopts)+          , "System libraries:    " ++ fromMaybe "" mglibdir+          , "Dependencies:        " ++ unwords deps+          ]+      CradleFail (CradleError ext stderr) ->+        return ["Cradle failed to load"+               , "Exit Code: " ++ show ext+               , "Stderr: " ++ unlines stderr]+      CradleNone ->+        return ["No cradle"]+  where+    rootDir    = cradleRootDir cradle+    quoteIfNeeded option+      | any Char.isSpace option = "\"" ++ option ++ "\""+      | otherwise = option++----------------------------------------------------------------++-- | Get the root directory of the given Cradle.+rootInfo :: Cradle+          -> IO String+rootInfo cradle = return $ cradleRootDir cradle

@@ -0,0 +1,16 @@+module HIE.Bios.Internal.Log where++import Control.Monad.IO.Class+import System.Log.Logger++logm :: MonadIO m => String -> m ()+logm s = liftIO $ infoM "hie-bios" s++debugm :: MonadIO m => String -> m ()+debugm s = liftIO $ debugM "hie-bios" s++warningm :: MonadIO m => String -> m ()+warningm s = liftIO $ warningM "hie-bios" s++errorm :: MonadIO m => String -> m ()+errorm s = liftIO $ errorM "hie-bios" s

@@ -1,184 +1,81 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wno-orphans #-}  module HIE.Bios.Types where -import System.Exit-import System.IO+import           System.Exit+import           System.IO+import           Control.Exception              ( Exception )  data BIOSVerbosity = Silent | Verbose  data CradleOpts = CradleOpts                 { cradleOptsVerbosity :: BIOSVerbosity                 , cradleOptsHandle :: Maybe Handle-                -- ^ The handle where to send output to, if not set, stderr+                -- ^ 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)---- |+-- | The environment of a single 'Cradle'.+-- A 'Cradle' is a unit for the respective build-system. ----- >>> 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)---- |+-- It contains the root directory of the 'Cradle', the name of+-- the 'Cradle' (for debugging purposes), and knows how to set up+-- a GHC session that is able to compile files that are part of this 'Cradle'. ----- >>> 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.+-- A 'Cradle' may be a single unit in the \"cabal-install\" context, or+-- the whole package, comparable to how \"stack\" works. data Cradle = Cradle {   -- | The project root directory.     cradleRootDir    :: FilePath   -- | The action which needs to be executed to get the correct-  -- command line arguments+  -- command line arguments.   , cradleOptsProg   :: CradleAction   } deriving (Show) +type LoggingFunction = String -> IO ()+ data CradleAction = CradleAction {                       actionName :: 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])+                      -- ^ Name of the action.+                      , runCradle :: LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)                       -- ^ 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 { actionName = name } = "CradleAction: " ++ name++-- | Result of an attempt to set up a GHC session for a 'Cradle'.+-- This is the go-to error handling mechanism. When possible, this+-- should be preferred over throwing exceptions.+data CradleLoadResult r = CradleSuccess r -- ^ The cradle succeeded and returned these options.+                      | CradleFail CradleError -- ^ We tried to load the cradle and it failed.+                      | CradleNone -- ^ No attempt was made to load the cradle.+                      deriving (Functor)+++data CradleError = CradleError ExitCode [String] deriving (Show)++instance Exception CradleError where ----------------------------------------------------------------  -- | Option information for GHC-data CompilerOptions = CompilerOptions {-    ghcOptions  :: [String]  -- ^ Command line options+data ComponentOptions = ComponentOptions {+    componentOptions  :: [String]  -- ^ Command line options.+  , componentDependencies :: [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.   } deriving (Eq, Show)

@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module HIE.Bios.Wrappers (cabalWrapper, cabalWrapperHs) where++import Data.FileEmbed++cabalWrapper :: String+cabalWrapper = $(embedStringFile "wrappers/cabal")++cabalWrapperHs :: String+cabalWrapperHs = $(embedStringFile "wrappers/cabal.hs")+

@@ -0,0 +1,118 @@+{-# LANGUAGE CPP #-}+module Main where++import Test.Tasty+import Test.Tasty.HUnit+import HIE.Bios+import HIE.Bios.Ghc.Api+import HIE.Bios.Ghc.Load+import Control.Monad.IO.Class+import Control.Monad ( unless, forM_ )+import System.Directory+import System.FilePath ( makeRelative, (</>) )++main :: IO ()+main = do+  writeStackYamlFiles+  defaultMain $+    testGroup "Bios-tests"+      [ testGroup "Find cradle"+        [ testCaseSteps "simple-cabal"+                (findCradleForModule+                  "./tests/projects/simple-cabal/B.hs"+                  (Just "./tests/projects/simple-cabal/hie.yaml")+                )++        -- Checks if we can find a hie.yaml even when the given filepath+        -- is unknown. This functionality is required by Haskell IDE Engine.+        , testCaseSteps "simple-cabal-unknown-path"+                (findCradleForModule+                  "./tests/projects/simple-cabal/Foo.hs"+                  (Just "./tests/projects/simple-cabal/hie.yaml")+                )+        ]+      , testGroup "Loading tests" [+        testCaseSteps "simple-cabal" $ testDirectory "./tests/projects/simple-cabal/B.hs"+        , testCaseSteps "simple-stack" $ testDirectory "./tests/projects/simple-stack/B.hs"+        , testCaseSteps "simple-direct" $ testDirectory "./tests/projects/simple-direct/B.hs"+        , testCaseSteps "simple-bios" $ testDirectory "./tests/projects/simple-bios/B.hs"+        , testCaseSteps "multi-cabal" {- tests if both components can be loaded -}+                      $  testDirectory "./tests/projects/multi-cabal/app/Main.hs"+                      >> testDirectory "./tests/projects/multi-cabal/src/Lib.hs"+        , testCaseSteps "multi-stack" {- tests if both components can be loaded -}+                      $  testDirectory "./tests/projects/multi-stack/app/Main.hs"+                      >> testDirectory "./tests/projects/multi-stack/src/Lib.hs"+        ]+      ]++++testDirectory :: FilePath -> (String -> IO ()) -> IO ()+testDirectory fp step = do+  a_fp <- canonicalizePath fp+  step "Finding Cradle"+  mcfg <- findCradle a_fp+  step "Loading Cradle"+  crd <- case mcfg of+          Just cfg -> loadCradle cfg+          Nothing -> loadImplicitCradle a_fp+  step "Initialise Flags"+  withCurrentDirectory (cradleRootDir crd) $+    withGHC' $ do+      let relFp = makeRelative (cradleRootDir crd) a_fp+      res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd+      case res of+        CradleSuccess ini -> do+          liftIO (step "Initial module load")+          sf <- ini+          case sf of+            -- Test resetting the targets+            Succeeded -> setTargetFilesWithMessage (Just (\_ n _ _ -> step (show n))) [(a_fp, a_fp)]+            Failed -> error "Module loading failed"+        CradleNone -> error "None"+        CradleFail (CradleError _ex stde) -> error (unlines stde)++findCradleForModule :: FilePath -> Maybe FilePath -> (String -> IO ()) -> IO ()+findCradleForModule fp expected' step = do+  expected <- maybe (return Nothing) (fmap Just . canonicalizePath) expected'+  a_fp <- canonicalizePath fp+  step "Finding cradle"+  mcfg <- findCradle a_fp+  unless (mcfg == expected)+    $  error+    $  "Expected cradle: "+    ++ show expected+    ++ ", Actual: "+    ++ show mcfg+++writeStackYamlFiles :: IO ()+writeStackYamlFiles = do+  let yamlFile = stackYaml stackYamlResolver+  forM_ stackProjects $ \proj ->+    writeFile (proj </> "stack.yaml") yamlFile++stackProjects :: [FilePath]+stackProjects =+  [ "tests" </> "projects" </> "multi-stack"+  , "tests" </> "projects" </> "simple-stack"+  ]++stackYaml :: String -> String+stackYaml resolver = unlines ["resolver: " ++ resolver, "packages:", "- ."]++stackYamlResolver :: String+stackYamlResolver =+#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)))+  "nightly-2019-12-13"+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,5,0)))+  "lts-14.17"+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,4,0)))+  "lts-13.19"+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,4,0)))+  "lts-12.26"+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)))+  "lts-12.26"+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)))+  "lts-11.22"+#endif

@@ -0,0 +1,50 @@+module Main where++import Test.Tasty+import Test.Tasty.HUnit+import HIE.Bios.Config+import System.FilePath++configDir :: FilePath+configDir = "tests/configs"++main :: IO ()+main = defaultMain $+  testCase "Parser Tests" $ do+    assertParser "cabal-1.yaml" (noDeps (Cabal (Just "lib:hie-bios")))+    assertParser "stack-config.yaml" (noDeps (Stack Nothing))+    --assertParser "bazel.yaml" (noDeps Bazel)+    assertParser "bios-1.yaml" (noDeps (Bios "program" Nothing))+    assertParser "bios-2.yaml" (noDeps (Bios "program" (Just "dep-program")))+    assertParser "dependencies.yaml" (Config (CradleConfig ["depFile"] (Cabal (Just "lib:hie-bios"))))+    assertParser "direct.yaml" (noDeps (Direct ["list", "of", "arguments"]))+    assertParser "none.yaml" (noDeps None)+    --assertParser "obelisk.yaml" (noDeps Obelisk)+    assertParser "multi.yaml" (noDeps (Multi [("./src", CradleConfig [] (Cabal (Just "lib:hie-bios")))+                                             , ("./test", CradleConfig [] (Cabal (Just "test")) ) ]))++    assertParser "cabal-multi.yaml" (noDeps (CabalMulti [("./src", "lib:hie-bios")+                                                    ,("./", "lib:hie-bios")]))++    assertParser "stack-multi.yaml" (noDeps (StackMulti [("./src", "lib:hie-bios")+                                                    ,("./", "lib:hie-bios")]))++    assertParser "nested-cabal-multi.yaml" (noDeps (Multi [("./test/testdata", CradleConfig [] None)+                                                          ,("./", CradleConfig [] (+                                                                    CabalMulti [("./src", "lib:hie-bios")+                                                                               ,("./tests", "parser-tests")]))]))++    assertParser "nested-stack-multi.yaml" (noDeps (Multi [("./test/testdata", CradleConfig [] None)+                                                          ,("./", CradleConfig [] (+                                                                    StackMulti [("./src", "lib:hie-bios")+                                                                              ,("./tests", "parser-tests")]))]))++assertParser :: FilePath -> Config -> Assertion+assertParser fp cc = do+  conf <- readConfig (configDir </> fp)+  (conf == cc) @? (unlines [("Parser Failed: " ++ fp)+                           , "Expected: " ++ show cc+                           , "Actual: " ++ show conf ])++noDeps :: CradleType -> Config+noDeps c = Config (CradleConfig [] c)

@@ -0,0 +1,2 @@+cradle:+  { bazel: }

@@ -0,0 +1,3 @@+cradle:+  bios:+    program: "program"

@@ -0,0 +1,4 @@+cradle:+  bios:+    program: "program"+    dependency-program: "dep-program"

@@ -0,0 +1,2 @@+cradle:+  { cabal: {component: "lib:hie-bios"} }

@@ -0,0 +1,6 @@+cradle:+  cabal:+    - path: "./src"+      component: "lib:hie-bios"+    - path: "./"+      component: "lib:hie-bios"

@@ -0,0 +1,2 @@+cradle:+  default:

@@ -0,0 +1,5 @@+cradle:+  { cabal: {component: "lib:hie-bios"} }++dependencies:+  - "depFile"

@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: ["list", "of", "arguments"]

@@ -0,0 +1,6 @@+cradle:+  multi:+    - path: "./src"+      config: { cradle: {cabal: {component: "lib:hie-bios"}} }+    - path: "./test"+      config: { cradle: {cabal: {component: "test"}} }

@@ -0,0 +1,8 @@+cradle:+  multi:+    - path: "./test/testdata"+      config: { cradle: { none:  } }+    - path: "./"+      config: { cradle: { cabal:+                            [ { path: "./src", component: "lib:hie-bios" }+                            , { path: "./tests", component: "parser-tests" } ] } }

@@ -0,0 +1,8 @@+cradle:+  multi:+    - path: "./test/testdata"+      config: { cradle: { none:  } }+    - path: "./"+      config: { cradle: { stack:+                            [ { path: "./src", component: "lib:hie-bios" }+                            , { path: "./tests", component: "parser-tests" } ] } }

@@ -0,0 +1,2 @@+cradle:+  none:

@@ -0,0 +1,2 @@+cradle:+  { obelisk: }

@@ -0,0 +1,2 @@+cradle:+  { stack: {}}

@@ -0,0 +1,6 @@+cradle:+  stack:+    - path: "./src"+      component: "lib:hie-bios"+    - path: "./"+      component: "lib:hie-bios"

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,4 @@++import System.Directory (getCurrentDirectory)++main = return ()

@@ -0,0 +1,1 @@+packages: ./

@@ -0,0 +1,7 @@+cradle:+  cabal:+      - path: ./src+        component: "lib:multi-cabal"++      - path: ./app+        component: "exe:multi-cabal"

@@ -0,0 +1,22 @@+cabal-version:       >=2.0+name:                multi-cabal+version:             0.1.0.0+build-type:          Simple++library+  exposed-modules: Lib+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.10 && < 5, filepath+  hs-source-dirs:      src+  default-language:    Haskell2010++++executable multi-cabal+  main-is:              app/Main.hs+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.10 && < 5, directory+  -- hs-source-dirs:+  default-language:    Haskell2010

@@ -0,0 +1,5 @@+module Lib where++import System.FilePath ((</>))++foo = "test" </> "me"

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,4 @@++import System.Directory (getCurrentDirectory)++main = return ()

@@ -0,0 +1,1 @@+packages: ./

@@ -0,0 +1,7 @@+cradle:+  stack:+      - path: ./src+        component: "multi-stack:lib"++      - path: ./app+        component: "multi-stack:exe:multi-stack"

@@ -0,0 +1,22 @@+cabal-version:       >=2.0+name:                multi-stack+version:             0.1.0.0+build-type:          Simple++library+  exposed-modules: Lib+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.10 && < 5, filepath+  hs-source-dirs:      src+  default-language:    Haskell2010++++executable multi-stack+  main-is:              app/Main.hs+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.10 && < 5, directory+  -- hs-source-dirs:+  default-language:    Haskell2010

@@ -0,0 +1,5 @@+module Lib where++import System.FilePath ((</>))++foo = "test" </> "me"

@@ -0,0 +1,1 @@+module A where

@@ -0,0 +1,3 @@+module B where++import A

@@ -0,0 +1,3 @@+echo "-Wall" >> $HIE_BIOS_OUTPUT+echo "A" >> $HIE_BIOS_OUTPUT+echo "B" >> $HIE_BIOS_OUTPUT

@@ -0,0 +1,2 @@+cradle:+  bios: {program: ./hie-bios.sh }

@@ -0,0 +1,1 @@+module A where

@@ -0,0 +1,3 @@+module B where++import A

@@ -0,0 +1,5 @@+# Revision history for simple-cabal++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,1 @@+packages: .

@@ -0,0 +1,2 @@+cradle:+  cabal: {component: "lib:simple-cabal"}

@@ -0,0 +1,22 @@+cabal-version:       >=2.0+name:                simple-cabal+version:             0.1.0.0+-- synopsis:+-- description:+-- bug-reports:+-- license:+license-file:        LICENSE+author:              Matthew Pickering+maintainer:          matthewtpickering@gmail.com+-- copyright:+-- category:+build-type:          Simple+extra-source-files:  CHANGELOG.md++library+  exposed-modules: A B+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.10 && < 5+  -- hs-source-dirs:+  default-language:    Haskell2010

@@ -0,0 +1,1 @@+module A where

@@ -0,0 +1,3 @@+module B where++import A

@@ -0,0 +1,2 @@+cradle:+  direct: {arguments: ["-Walaaal", "A", "B"] }

@@ -0,0 +1,1 @@+module A where

@@ -0,0 +1,3 @@+module B where++import A

@@ -0,0 +1,5 @@+# Revision history for simple-cabal++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,1 @@+packages: .

@@ -0,0 +1,3 @@+cradle:+  stack:+    component: "simple-stack:lib"

@@ -0,0 +1,22 @@+cabal-version:       >=2.0+name:                simple-stack+version:             0.1.0.0+-- synopsis:+-- description:+-- bug-reports:+-- license:+license-file:        LICENSE+author:              Matthew Pickering+maintainer:          matthewtpickering@gmail.com+-- copyright:+-- category:+build-type:          Simple+extra-source-files:  CHANGELOG.md++library+  exposed-modules: A B+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.10 && < 5+  -- hs-source-dirs:+  default-language:    Haskell2010

@@ -1,5 +0,0 @@-#!/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-

@@ -1,10 +1,14 @@ #!/usr/bin/env bash++function out(){+  echo "$1" >> $HIE_BIOS_OUTPUT+}+ if [ "$1" == "--interactive" ]; then-  pwd+  out $(pwd)   for arg in "$@"; do-    echo -ne "$arg\x00"+    out "$arg"   done-  echo -ne "\n" else-  ghc "$@"+  "${HIE_BIOS_GHC}" ${HIE_BIOS_GHC_ARGS} "$@" fi

@@ -1,20 +1,23 @@ module Main (main) where  import System.Directory (getCurrentDirectory)-import System.Environment (getArgs)+import System.Environment (getArgs, getEnv) import System.Exit (exitWith) import System.Process (spawnProcess, waitForProcess)+import System.IO (openFile, hClose, hPutStrLn, IOMode(..))  main = do   args <- getArgs+  output_file <- getEnv "HIE_BIOS_OUTPUT"+  ghcPath <- getEnv "HIE_BIOS_GHC"+  ghcPathArgs <- fmap unwords (getEnv "HIE_BIOS_GHC_ARGS")   case args of     "--interactive":_ -> do-      getCurrentDirectory >>= putStrLn-      putStrLn $ delimited args+      h <- openFile output_file AppendMode+      getCurrentDirectory >>= hPutStrLn h+      mapM_ (hPutStrLn h) args+      hClose h     _ -> do-      ph <- spawnProcess "ghc" args+      ph <- spawnProcess ghcPath (ghcPathArgs ++ args)       code <- waitForProcess ph       exitWith code--delimited :: [String] -> String-delimited = concatMap (++ "\NUL")