From f438ad7c8b2f7a951a7f8a74ea2afb65a29d49fd Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Fri, 14 Jun 2019 17:11:59 +0100 Subject: [PATCH] Initial commit, moving from haskell-ide-engine --- ChangeLog | 2 + LICENSE | 29 ++++ README.md | 132 ++++++++++++++++++ Setup.hs | 2 + cabal.project | 1 + exe/biosc.hs | 82 +++++++++++ hie-bios.cabal | 68 ++++++++++ src/HIE/Bios.hs | 20 +++ src/HIE/Bios/Check.hs | 75 +++++++++++ src/HIE/Bios/Config.hs | 48 +++++++ src/HIE/Bios/Cradle.hs | 284 +++++++++++++++++++++++++++++++++++++++ src/HIE/Bios/Debug.hs | 33 +++++ src/HIE/Bios/Doc.hs | 24 ++++ src/HIE/Bios/GHCApi.hs | 284 +++++++++++++++++++++++++++++++++++++++ src/HIE/Bios/Gap.hs | 129 ++++++++++++++++++ src/HIE/Bios/Ghc.hs | 16 +++ src/HIE/Bios/Internal.hs | 18 +++ src/HIE/Bios/Load.hs | 121 +++++++++++++++++ src/HIE/Bios/Logger.hs | 124 +++++++++++++++++ src/HIE/Bios/Things.hs | 63 +++++++++ src/HIE/Bios/Types.hs | 178 ++++++++++++++++++++++++ wrappers/bazel | 5 + wrappers/cabal | 7 + 23 files changed, 1745 insertions(+) create mode 100644 ChangeLog create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 cabal.project create mode 100644 exe/biosc.hs create mode 100644 hie-bios.cabal create mode 100644 src/HIE/Bios.hs create mode 100644 src/HIE/Bios/Check.hs create mode 100644 src/HIE/Bios/Config.hs create mode 100644 src/HIE/Bios/Cradle.hs create mode 100644 src/HIE/Bios/Debug.hs create mode 100644 src/HIE/Bios/Doc.hs create mode 100644 src/HIE/Bios/GHCApi.hs create mode 100644 src/HIE/Bios/Gap.hs create mode 100644 src/HIE/Bios/Ghc.hs create mode 100644 src/HIE/Bios/Internal.hs create mode 100644 src/HIE/Bios/Load.hs create mode 100644 src/HIE/Bios/Logger.hs create mode 100644 src/HIE/Bios/Things.hs create mode 100644 src/HIE/Bios/Types.hs create mode 100755 wrappers/bazel create mode 100755 wrappers/cabal diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 000000000..03256aa3e --- /dev/null +++ b/ChangeLog @@ -0,0 +1,2 @@ +2018-12-18 v0.0.0 + * First release diff --git a/LICENSE b/LICENSE new file mode 100644 index 000000000..542219308 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2009, IIJ Innovation Institute Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 000000000..7a9f7af1c --- /dev/null +++ b/README.md @@ -0,0 +1,132 @@ +# hie-bios + +`hie-bios` is the way which `hie` sets up a GHC API session. + +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. + +This means that 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 HIE to work correctly. + +## Explicit Configuration + +The user can place a `hie.dhall` 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: + +``` +{ cradle = CradleConfig.Stack {=} } +``` + +If you use `cabal` then you probably need to specify which component you want +to use. + +``` +{ cradle = CradleConfig.Cabal { component = Some "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. + +``` +{ cradle = CradleConfig.Bios { prog = ".hie-bios" } } +``` + +The complete dhall configuration is described by the following type + +``` +< cradle : +< Cabal : { component : Optional Text } + | Stack : {} + | Bazel : {} + | Obelisk : {} + | Bios : { prog : Text} + | Default : {} > > +``` + +## Implicit Configuration + +There are several built in modes which captures most common Haskell development +scenarios. If no `hie.dhall` configuration file is found then an implicit +configuration is searched for. + +### Priority + +The targets are searched for in following order. + +1. A specific `hie-bios` file. +2. An `obelisk` project +3. A `rules_haskell` project +4. A `stack` project +4. A `cabal` project +5. The default 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.dhall` file. + +### `rules_haskell` + +The workspace root is the folder containing a `WORKSPACE` file. + +The options are collected by querying `bazel`. + +### `obelisk` + +The workspace root is the folder containing a `.obelisk` directory. + +The options are collected by running `ob ide-args`. + +### `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 +the correct arguments in order to load that file successfully. + +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) /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. + + +## Relationship with `ghcid` + +The design of `hie-bios` is inspired by `ghcid`. Like `ghcid`, it does not depend +on any of the tools it supports. The success of `ghcid` is that it works reliably +in many situations. This is because of the fact that it delegates complicated +decisions about a build to the build tool. + +`ghcid` could be implemented using `hie-bios` using the `ghci $(./hie-bios Main.hs) Main.hs` +idiom described earlier. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal.project b/cabal.project new file mode 100644 index 000000000..e6fdbadb4 --- /dev/null +++ b/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/exe/biosc.hs b/exe/biosc.hs new file mode 100644 index 000000000..4fe85542b --- /dev/null +++ b/exe/biosc.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Main where + +import Config (cProjectVersion) + +import Control.Exception (Exception, Handler(..), ErrorCall(..)) +import qualified Control.Exception as E +import Data.Typeable (Typeable) +import Data.Version (showVersion) +import System.Directory (getCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) + +import HIE.Bios +import HIE.Bios.Types +import HIE.Bios.Check +import HIE.Bios.Debug +import Paths_hie_bios + +---------------------------------------------------------------- + +progVersion :: String +progVersion = "biosc version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n" + +ghcOptHelp :: String +ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] " + +usage :: String +usage = progVersion + ++ "Usage:\n" + ++ "\t biosc check" ++ ghcOptHelp ++ "\n" + ++ "\t biosc version\n" + ++ "\t biosc help\n" + +---------------------------------------------------------------- + +data HhpcError = SafeList + | TooManyArguments String + | NoSuchCommand String + | CmdArg [String] + | FileNotExist String deriving (Show, Typeable) + +instance Exception HhpcError + +---------------------------------------------------------------- + +main :: IO () +main = flip E.catches handlers $ do + hSetEncoding stdout utf8 + args <- getArgs + cradle <- getCurrentDirectory >>= findCradle + let cmdArg0 = args !. 0 + remainingArgs = tail args + opt = defaultOptions + res <- case cmdArg0 of + "check" -> checkSyntax opt cradle remainingArgs + "expand" -> expandTemplate opt cradle remainingArgs + "debug" -> debugInfo opt cradle + "root" -> rootInfo opt cradle + "version" -> return progVersion + cmd -> E.throw (NoSuchCommand cmd) + putStr res + where + handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)] + handleThenExit handler e = handler e >> exitFailure + handler1 :: ErrorCall -> IO () + handler1 = print -- for debug + handler2 :: HhpcError -> IO () + handler2 SafeList = return () + handler2 (TooManyArguments cmd) = do + hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments" + handler2 (NoSuchCommand cmd) = do + hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" + handler2 (CmdArg errs) = do + mapM_ (hPutStr stderr) errs + handler2 (FileNotExist file) = do + hPutStrLn stderr $ "\"" ++ file ++ "\" not found" + xs !. idx + | length xs <= idx = E.throw SafeList + | otherwise = xs !! idx diff --git a/hie-bios.cabal b/hie-bios.cabal new file mode 100644 index 000000000..3bd5dc0ca --- /dev/null +++ b/hie-bios.cabal @@ -0,0 +1,68 @@ +Name: hie-bios +Version: 0.0.0 +Author: Kazu Yamamoto and Matthew Pickering +Maintainer: Matthew Pickering +License: BSD3 +License-File: LICENSE +Homepage: https://github.com/mpickering/hie-bios +Synopsis: Set up a GHC API session +Description: + +Category: Development +Cabal-Version: >= 1.10 +Build-Type: Simple +Extra-Source-Files: ChangeLog + wrappers/bazel + wrappers/cabal + +Library + Default-Language: Haskell2010 + GHC-Options: -Wall + HS-Source-Dirs: src + Exposed-Modules: HIE.Bios + HIE.Bios.Check + HIE.Bios.Cradle + HIE.Bios.Debug + HIE.Bios.GHCApi + HIE.Bios.Gap + HIE.Bios.Doc + HIE.Bios.Load + HIE.Bios.Logger + HIE.Bios.Types + HIE.Bios.Things + HIE.Bios.Config + Build-Depends: base >= 4.9 && < 5 + , containers + , deepseq + , directory + , filepath + , ghc + , process + , transformers + , file-embed + , temporary + , unix-compat + , cryptohash-sha1 + , bytestring + , base16-bytestring + , dhall <= 1.20.1 + , text + , lens-family-core + if impl(ghc < 8.2) + Build-Depends: ghc-boot + +Executable biosc + Default-Language: Haskell2010 + Main-Is: biosc.hs + Other-Modules: Paths_hie_bios + GHC-Options: -Wall + HS-Source-Dirs: exe + Build-Depends: base >= 4.9 && < 5 + , directory + , filepath + , ghc + , hie-bios + +Source-Repository head + Type: git + Location: git://github.com/mpickering/hie-bios.git diff --git a/src/HIE/Bios.hs b/src/HIE/Bios.hs new file mode 100644 index 000000000..db2b0fd31 --- /dev/null +++ b/src/HIE/Bios.hs @@ -0,0 +1,20 @@ +-- | The HIE Bios + +module HIE.Bios ( + -- * Initialise a session + Cradle(..) + , findCradle + , defaultCradle + , initializeFlagsWithCradle + , initializeFlagsWithCradleWithMessage + -- * Load a module into a session + , loadFile + , loadFileWithMessage + -- * Eliminate a session to IO + , withGhcT + ) where + +import HIE.Bios.Cradle +import HIE.Bios.Types +import HIE.Bios.GHCApi +import HIE.Bios.Load diff --git a/src/HIE/Bios/Check.hs b/src/HIE/Bios/Check.hs new file mode 100644 index 000000000..001eb24bb --- /dev/null +++ b/src/HIE/Bios/Check.hs @@ -0,0 +1,75 @@ +module HIE.Bios.Check ( + checkSyntax + , check + , expandTemplate + , expand + ) where + +import DynFlags (dopt_set, DumpFlag(Opt_D_dump_splices)) +import GHC (Ghc, DynFlags(..), GhcMonad) + +import HIE.Bios.GHCApi +import HIE.Bios.Logger +import HIE.Bios.Types +import HIE.Bios.Load +import Outputable + +---------------------------------------------------------------- + +-- | Checking syntax of a target file using GHC. +-- Warnings and errors are returned. +checkSyntax :: Options + -> Cradle + -> [FilePath] -- ^ The target files. + -> IO String +checkSyntax _ _ [] = return "" +checkSyntax opt cradle files = withGhcT $ do + pprTrace "cradble" (text $ show cradle) (return ()) + initializeFlagsWithCradle (head files) cradle + either id id <$> check opt files + where + {- + sessionName = case files of + [file] -> file + _ -> "MultipleFiles" + -} + +---------------------------------------------------------------- + +-- | Checking syntax of a target file using GHC. +-- Warnings and errors are returned. +check :: (GhcMonad m) + => Options + -> [FilePath] -- ^ The target files. + -> m (Either String String) +check opt fileNames = withLogger opt setAllWaringFlags $ 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 . setNoWaringFlags) $ setTargetFiles (map dup fileNames) + +setDumpSplices :: DynFlags -> DynFlags +setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices diff --git a/src/HIE/Bios/Config.hs b/src/HIE/Bios/Config.hs new file mode 100644 index 000000000..f4cb86831 --- /dev/null +++ b/src/HIE/Bios/Config.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module HIE.Bios.Config where + +import Dhall +import qualified Data.Text.IO as T +import qualified Data.Text as T +-- import Lens.Family ( set ) +-- import qualified Dhall.Context as C + + +data CradleConfig = Cabal { component :: Maybe String } + | Stack + | Bazel + | Obelisk + | Bios { prog :: FilePath } + | Default + deriving (Generic, Show) + +instance Interpret CradleConfig + +data Config = Config { cradle :: CradleConfig } + deriving (Generic, Show) + +instance Interpret Config + +wrapper :: T.Text -> T.Text +wrapper t = + "let CradleConfig : Type = < Cabal : { component : Optional Text } | Stack : {} | Bazel : {} | Obelisk : {} | Bios : { prog : Text} | Default : {} > in\n" <> t + +readConfig :: FilePath -> IO Config +readConfig fp = T.readFile fp >>= input auto . wrapper + where + -- ip = (set startingContext sc defaultInputSettings) + -- sc = C.insert "CradleConfig" (expected (auto @CradleConfig)) C.empty + +{- +stringToCC :: T.Text -> CradleConfig +stringToCC t = case t of + "cabal" -> Cabal + "stack" -> Stack + "rules_haskell" -> Bazel + "obelisk" -> Obelisk + "bios" -> Bios + "default" -> Default + _ -> Default + -} diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs new file mode 100644 index 000000000..8d7705f45 --- /dev/null +++ b/src/HIE/Bios/Cradle.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +module HIE.Bios.Cradle ( + findCradle + , findCradleWithOpts + , defaultCradle + ) where + +import System.Process +import System.Exit +import HIE.Bios.Types +import HIE.Bios.Config +import System.Directory hiding (findFile) +import Control.Monad.Trans.Maybe +import System.FilePath +import Control.Monad +import Control.Monad.IO.Class +import Control.Applicative ((<|>)) +import Data.FileEmbed +import System.IO.Temp +import Data.List + +import Debug.Trace +import System.PosixCompat.Files + +---------------------------------------------------------------- +findCradle :: FilePath -> IO Cradle +findCradle = findCradleWithOpts defaultCradleOpts + +-- | Finding 'Cradle'. +-- Find a cabal file by tracing ancestor directories. +-- Find a sandbox according to a cabal sandbox config +-- in a cabal directory. +findCradleWithOpts :: CradleOpts -> FilePath -> IO Cradle +findCradleWithOpts _copts wfile = do + let wdir = takeDirectory wfile + cfg <- runMaybeT (dhallConfig wdir <|> implicitConfig wdir) + return $ case cfg of + Just bc -> getCradle bc + Nothing -> (defaultCradle wdir) + + +getCradle :: (CradleConfig, FilePath) -> Cradle +getCradle (cc, wdir) = case cc of + Cabal mc -> cabalCradle wdir mc + Stack -> stackCradle wdir + Bazel -> rulesHaskellCradle wdir + Obelisk -> obeliskCradle wdir + Bios bios -> biosCradle wdir bios + Default -> defaultCradle wdir + +implicitConfig :: FilePath -> MaybeT IO (CradleConfig, FilePath) +implicitConfig fp = + (\wdir -> (Bios (wdir ".hie-bios"), wdir)) <$> biosWorkDir fp + <|> (Obelisk,) <$> obeliskWorkDir fp + <|> (Bazel,) <$> rulesHaskellWorkDir fp + <|> (Stack,) <$> stackWorkDir fp + <|> ((Cabal Nothing,) <$> cabalWorkDir fp) + +dhallConfig :: FilePath -> MaybeT IO (CradleConfig, FilePath) +dhallConfig fp = do + wdir <- findFileUpwards ("hie.dhall" ==) fp + cfg <- liftIO $ readConfig (wdir "hie.dhall") + return (cradle cfg, wdir) + + + + +--------------------------------------------------------------- +-- Default cradle has no special options, not very useful for loading +-- modules. + +defaultCradle :: FilePath -> Cradle +defaultCradle cur_dir = + Cradle { + cradleRootDir = cur_dir + , cradleOptsProg = CradleAction "default" (const $ return (ExitSuccess, "", [])) + } + +------------------------------------------------------------------------- + + +-- | Find a cradle by finding an executable `hie-bios` file which will +-- be executed to find the correct GHC options to use. +biosCradle :: FilePath -> FilePath -> Cradle +biosCradle wdir bios = do + Cradle { + cradleRootDir = wdir + , cradleOptsProg = CradleAction "bios" (biosAction wdir bios) + } + +biosWorkDir :: FilePath -> MaybeT IO FilePath +biosWorkDir = findFileUpwards (".hie-bios" ==) + + +biosAction :: FilePath -> FilePath -> FilePath -> IO (ExitCode, String, [String]) +biosAction _wdir bios fp = do + bios' <- canonicalizePath bios + (ex, res, std) <- readProcessWithExitCode bios' [fp] [] + return (ex, std, words res) + +------------------------------------------------------------------------ +-- Cabal Cradle +-- Works for new-build by invoking `v2-repl` does not support components +-- yet. + +cabalCradle :: FilePath -> Maybe String -> Cradle +cabalCradle wdir mc = do + Cradle { + cradleRootDir = wdir + , cradleOptsProg = CradleAction "cabal" (cabalAction wdir mc) + } + +cabalWrapper :: String +cabalWrapper = $(embedStringFile "wrappers/cabal") + +cabalAction :: FilePath -> Maybe String -> FilePath -> IO (ExitCode, String, [String]) +cabalAction work_dir mc _fp = do + wrapper_fp <- writeSystemTempFile "wrapper" cabalWrapper + -- TODO: This isn't portable for windows + setFileMode wrapper_fp accessModes + check <- readFile wrapper_fp + traceM check + let cab_args = ["v2-repl", "-v0", "-w", wrapper_fp] + ++ [component_name | Just component_name <- [mc]] + (ex, args, stde) <- + withCurrentDirectory work_dir (readProcessWithExitCode "cabal" cab_args []) + case lines args of + [dir, ghc_args] -> do + let final_args = removeInteractive $ map (fixImportDirs dir) (words ghc_args) + traceM dir + return (ex, stde, final_args) + _ -> error (show (ex, args, stde)) + +removeInteractive :: [String] -> [String] +removeInteractive = filter (/= "--interactive") + +fixImportDirs :: FilePath -> String -> String +fixImportDirs base_dir arg = + if "-i" `isPrefixOf` arg + then let dir = drop 2 arg + in if isRelative dir then ("-i" <> base_dir <> "/" <> dir) + else arg + else arg + + +cabalWorkDir :: FilePath -> MaybeT IO FilePath +cabalWorkDir = findFileUpwards isCabal + where + isCabal name = name == "cabal.project" + +------------------------------------------------------------------------ +-- Stack Cradle +-- Works for by invoking `stack repl` with a wrapper script + +stackCradle :: FilePath -> Cradle +stackCradle wdir = + Cradle { + cradleRootDir = wdir + , cradleOptsProg = CradleAction "stack" (stackAction wdir) + } + +-- Same wrapper works as with cabal +stackWrapper :: String +stackWrapper = $(embedStringFile "wrappers/cabal") + +stackAction :: FilePath -> FilePath -> IO (ExitCode, String, [String]) +stackAction work_dir fp = do + wrapper_fp <- writeSystemTempFile "wrapper" stackWrapper + -- TODO: This isn't portable for windows + setFileMode wrapper_fp accessModes + check <- readFile wrapper_fp + traceM check + (ex1, args, stde) <- + withCurrentDirectory work_dir (readProcessWithExitCode "stack" ["repl", "--silent", "--no-load", "--with-ghc", wrapper_fp, fp ] []) + (ex2, pkg_args, stdr) <- + withCurrentDirectory work_dir (readProcessWithExitCode "stack" ["path", "--ghc-package-path"] []) + let split_pkgs = splitSearchPath (init pkg_args) + pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs + ghc_args = words args ++ pkg_ghc_args + return (combineExitCodes [ex1, ex2], stde ++ stdr, ghc_args) + +combineExitCodes :: [ExitCode] -> ExitCode +combineExitCodes = foldr go ExitSuccess + where + go ExitSuccess b = b + go a _ = a + + + +stackWorkDir :: FilePath -> MaybeT IO FilePath +stackWorkDir = findFileUpwards isStack + where + isStack name = name == "stack.yaml" + + +---------------------------------------------------------------------------- +-- rules_haskell - Thanks for David Smith for helping with this one. +-- Looks for the directory containing a WORKSPACE file +-- +rulesHaskellWorkDir :: FilePath -> MaybeT IO FilePath +rulesHaskellWorkDir fp = + findFileUpwards (== "WORKSPACE") fp + +rulesHaskellCradle :: FilePath -> Cradle +rulesHaskellCradle wdir = do + Cradle { + cradleRootDir = wdir + , cradleOptsProg = CradleAction "bazel" (rulesHaskellAction wdir) + } + + +bazelCommand :: String +bazelCommand = $(embedStringFile "wrappers/bazel") + +rulesHaskellAction :: FilePath -> FilePath -> IO (ExitCode, String, [String]) +rulesHaskellAction work_dir fp = do + wrapper_fp <- writeSystemTempFile "wrapper" bazelCommand + -- TODO: This isn't portable for windows + setFileMode wrapper_fp accessModes + check <- readFile wrapper_fp + traceM check + let rel_path = makeRelative work_dir fp + traceM rel_path + (ex, args, stde) <- + withCurrentDirectory work_dir (readProcessWithExitCode wrapper_fp [rel_path] []) + let args' = filter (/= '\'') args + let args'' = filter (/= "\"$GHCI_LOCATION\"") (words args') + return (ex, stde, args'') + + +------------------------------------------------------------------------------ +-- Obelisk Cradle +-- Searches for the directory which contains `.obelisk`. + +obeliskWorkDir :: FilePath -> MaybeT IO FilePath +obeliskWorkDir fp = do + -- Find a possible root which will contain the cabal.project + wdir <- findFileUpwards (== "cabal.project") fp + -- Check for the ".obelisk" folder in this directory + check <- liftIO $ doesDirectoryExist (wdir ".obelisk") + unless check (fail "Not obelisk dir") + return wdir + + +obeliskCradle :: FilePath -> Cradle +obeliskCradle wdir = + Cradle { + cradleRootDir = wdir + , cradleOptsProg = CradleAction "obelisk" (obeliskAction wdir) + } + +obeliskAction :: FilePath -> FilePath -> IO (ExitCode, String, [String]) +obeliskAction work_dir _fp = do + (ex, args, stde) <- + withCurrentDirectory work_dir (readProcessWithExitCode "ob" ["ide-args"] []) + return (ex, stde, words args) + + +------------------------------------------------------------------------------ +-- Utilities + + +-- | Searches upwards for the first directory containing a file to match +-- the predicate. +findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath +findFileUpwards p dir = do + cnts <- liftIO $ findFile p dir + case cnts of + [] | dir' == dir -> fail "No cabal files" + | otherwise -> findFileUpwards p dir' + _:_ -> return dir + where + dir' = takeDirectory dir + +-- | Sees if any file in the directory matches the predicate +findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +findFile p dir = getFiles >>= filterM doesPredFileExist + where + getFiles = filter p <$> getDirectoryContents dir + doesPredFileExist file = doesFileExist $ dir file + + + diff --git a/src/HIE/Bios/Debug.hs b/src/HIE/Bios/Debug.hs new file mode 100644 index 000000000..e9a0970e2 --- /dev/null +++ b/src/HIE/Bios/Debug.hs @@ -0,0 +1,33 @@ +module HIE.Bios.Debug (debugInfo, rootInfo) where + +import CoreMonad (liftIO) + +import Data.Maybe (fromMaybe) + +import HIE.Bios.GHCApi +import HIE.Bios.Types + +---------------------------------------------------------------- + +-- | Obtaining debug information. +debugInfo :: Options + -> Cradle + -> IO String +debugInfo opt cradle = convert opt <$> do + (_ex, _sterr, gopts) <- getOptions (cradleOptsProg cradle) (cradleRootDir cradle) + mglibdir <- liftIO getSystemLibDir + return [ + "Root directory: " ++ rootDir + , "GHC options: " ++ unwords gopts + , "System libraries: " ++ fromMaybe "" mglibdir + ] + where + rootDir = cradleRootDir cradle + +---------------------------------------------------------------- + +-- | Obtaining root information. +rootInfo :: Options + -> Cradle + -> IO String +rootInfo opt cradle = return $ convert opt $ cradleRootDir cradle diff --git a/src/HIE/Bios/Doc.hs b/src/HIE/Bios/Doc.hs new file mode 100644 index 000000000..3504de25f --- /dev/null +++ b/src/HIE/Bios/Doc.hs @@ -0,0 +1,24 @@ +module HIE.Bios.Doc where + +import GHC (DynFlags, getPrintUnqual, pprCols, GhcMonad) +import Outputable (PprStyle, SDoc, withPprStyleDoc, neverQualify) +import Pretty (Mode(..), Doc, Style(..), renderStyle, style) + +import HIE.Bios.Gap (makeUserStyle) + +showPage :: DynFlags -> PprStyle -> SDoc -> String +showPage dflag stl = showDocWith dflag PageMode . withPprStyleDoc dflag stl + +showOneLine :: DynFlags -> PprStyle -> SDoc -> String +showOneLine dflag stl = showDocWith dflag OneLineMode . withPprStyleDoc dflag stl + +getStyle :: (GhcMonad m) => DynFlags -> m PprStyle +getStyle dflags = makeUserStyle dflags <$> getPrintUnqual + +styleUnqualified :: DynFlags -> PprStyle +styleUnqualified dflags = makeUserStyle dflags neverQualify + +showDocWith :: DynFlags -> Mode -> Doc -> String +showDocWith dflags md = renderStyle mstyle + where + mstyle = style { mode = md, lineLength = pprCols dflags } diff --git a/src/HIE/Bios/GHCApi.hs b/src/HIE/Bios/GHCApi.hs new file mode 100644 index 000000000..5e9186e64 --- /dev/null +++ b/src/HIE/Bios/GHCApi.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE ScopedTypeVariables, RecordWildCards, CPP #-} + +module HIE.Bios.GHCApi ( + withGHC + , withGHC' + , withGhcT + , initializeFlagsWithCradle + , initializeFlagsWithCradleWithMessage + , getDynamicFlags + , getSystemLibDir + , withDynFlags + , withCmdFlags + , setNoWaringFlags + , setAllWaringFlags + , CradleError(..) + ) where + +import CoreMonad (liftIO) +import Exception (ghandle, SomeException(..), ExceptionMonad(..), throwIO, Exception(..)) +import GHC (Ghc, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..), GhcMonad, GhcT) +import qualified GHC as G +import qualified Outputable as G +import qualified MonadUtils as G +import qualified HscMain as G +import qualified GhcMake as G +import DynFlags + +import Control.Monad (void, when) +import System.Exit (exitSuccess, ExitCode(..)) +import System.IO (hPutStr, hPrint, stderr) +import System.IO.Unsafe (unsafePerformIO) +import System.Process (readProcess) + +import System.Directory +import System.FilePath + +import qualified HIE.Bios.Gap as Gap +import HIE.Bios.Types +import Debug.Trace +import qualified Crypto.Hash.SHA1 as H +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Base16 +import Data.List + +---------------------------------------------------------------- + +-- | Obtaining the directory for system libraries. +getSystemLibDir :: IO (Maybe FilePath) +getSystemLibDir = do + res <- readProcess "ghc" ["--print-libdir"] [] + return $ case res of + "" -> Nothing + dirn -> Just (init dirn) + +---------------------------------------------------------------- + +-- | Converting the 'Ghc' monad to the 'IO' monad. +withGHC :: FilePath -- ^ A target file displayed in an error message. + -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities. + -> IO a +withGHC file body = ghandle ignore $ withGHC' body + where + ignore :: SomeException -> IO a + ignore e = do + hPutStr stderr $ file ++ ":0:0:Error:" + hPrint stderr e + exitSuccess + +withGHC' :: Ghc a -> IO a +withGHC' body = do + mlibdir <- getSystemLibDir + G.runGhc mlibdir body + +withGhcT :: (Exception.ExceptionMonad m, G.MonadIO m, Monad m) => GhcT m a -> m a +withGhcT body = do + mlibdir <- G.liftIO $ getSystemLibDir + G.runGhcT mlibdir body + +---------------------------------------------------------------- + +data Build = CabalPkg | SingleFile deriving Eq + +initializeFlagsWithCradle :: + (GhcMonad m) + => FilePath -- The file we are loading it because of + -> Cradle + -> m () +initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.batchMsg) + +-- | Initialize the 'DynFlags' relating to the compilation of a single +-- file or GHC session according to the 'Cradle' and 'Options' +-- provided. +initializeFlagsWithCradleWithMessage :: + (GhcMonad m) + => Maybe G.Messager + -> FilePath -- The file we are loading it because of + -> Cradle + -> m () +initializeFlagsWithCradleWithMessage msg fp cradle = do + (ex, err, ghcOpts) <- liftIO $ getOptions (cradleOptsProg cradle) fp + G.pprTrace "res" (G.text (show (ex, err, ghcOpts, fp))) (return ()) + case ex of + ExitFailure _ -> throwCradleError err + _ -> return () + let compOpts = CompilerOptions ghcOpts + liftIO $ hPrint stderr ghcOpts + initSessionWithMessage msg compOpts + +data CradleError = CradleError String deriving (Show) + +instance Exception CradleError where + +throwCradleError :: GhcMonad m => String -> m () +throwCradleError = liftIO . throwIO . CradleError + +---------------------------------------------------------------- +cacheDir :: String +cacheDir = "haskell-ide-engine" + +clearInterfaceCache :: FilePath -> IO () +clearInterfaceCache fp = do + cd <- getCacheDir fp + res <- doesPathExist cd + when res (removeDirectoryRecursive cd) + +getCacheDir :: FilePath -> IO FilePath +getCacheDir fp = getXdgDirectory XdgCache (cacheDir ++ "/" ++ fp) + +initSessionWithMessage :: (GhcMonad m) + => Maybe G.Messager + -> CompilerOptions + -> m () +initSessionWithMessage msg CompilerOptions {..} = do + df <- G.getSessionDynFlags + traceShowM (length ghcOptions) + + let opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack ghcOptions) + fp <- liftIO $ getCacheDir opts_hash + -- For now, clear the cache initially rather than persist it across + -- sessions + liftIO $ clearInterfaceCache opts_hash + (df', targets) <- addCmdOpts ghcOptions df + void $ G.setSessionDynFlags + (disableOptimisation + $ setIgnoreInterfacePragmas + $ resetPackageDb +-- $ ignorePackageEnv + $ writeInterfaceFiles (Just fp) + $ setVerbosity 0 + + $ setLinkerOptions df' + ) + G.setLogAction (\_df _wr _s _ss _pp _m -> return ()) + G.setTargets targets + -- Get the module graph using the function `getModuleGraph` + mod_graph <- G.depanal [] True + void $ G.load' LoadAllTargets msg mod_graph + +---------------------------------------------------------------- + +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscNothing + , ghcMode = CompManager + } + +resetPackageDb :: DynFlags -> DynFlags +resetPackageDb df = df { pkgDatabase = Nothing } + +--ignorePackageEnv :: DynFlags -> DynFlags +--ignorePackageEnv df = df { packageEnv = Just "-" } + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = gopt_set df Opt_IgnoreInterfacePragmas + +setVerbosity :: Int -> DynFlags -> DynFlags +setVerbosity n df = df { verbosity = n } + +writeInterfaceFiles :: Maybe FilePath -> DynFlags -> DynFlags +writeInterfaceFiles Nothing df = df +writeInterfaceFiles (Just hi_dir) df = setHiDir hi_dir (gopt_set df Opt_WriteInterface) + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = d { hiDir = Just f} + + +addCmdOpts :: (GhcMonad m) + => [String] -> DynFlags -> m (DynFlags, [G.Target]) +addCmdOpts cmdOpts df1 = do + (df2, leftovers, warns) <- G.parseDynamicFlags df1 (map G.noLoc cmdOpts) + traceShowM (map G.unLoc leftovers, length warns) + + let + -- To simplify the handling of filepaths, we normalise all filepaths right + -- away. Note the asymmetry of FilePath.normalise: + -- Linux: p/q -> p/q; p\q -> p\q + -- Windows: p/q -> p\q; p\q -> p\q + -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs + -- to -foo.hs. We have to re-prepend the current directory. + normalise_hyp fp + | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp + | otherwise = nfp + where +#if defined(mingw32_HOST_OS) + strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp +#else + strt_dot_sl = "./" `isPrefixOf` fp +#endif + cur_dir = '.' : [pathSeparator] + nfp = normalise fp + normal_fileish_paths = map (normalise_hyp . G.unLoc) leftovers + ts <- mapM (flip G.guessTarget Nothing) normal_fileish_paths + return (df2, ts) + -- TODO: Need to handle these as well + -- Ideally it requires refactoring to work in GHCi monad rather than + -- Ghc monad and then can just use newDynFlags. + {- + liftIO $ G.handleFlagWarnings idflags1 warns + when (not $ null leftovers) + (throwGhcException . CmdLineError + $ "Some flags have not been recognized: " + ++ (concat . intersperse ", " $ map unLoc leftovers)) + when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do + liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" + -} + +---------------------------------------------------------------- + + +---------------------------------------------------------------- + +-- | Return the 'DynFlags' currently in use in the GHC session. +getDynamicFlags :: IO DynFlags +getDynamicFlags = do + mlibdir <- getSystemLibDir + G.runGhc mlibdir G.getSessionDynFlags + +withDynFlags :: + (GhcMonad m) + => (DynFlags -> DynFlags) -> m a -> m a +withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body) + where + setup = do + dflag <- G.getSessionDynFlags + void $ G.setSessionDynFlags (setFlag dflag) + return dflag + teardown = void . G.setSessionDynFlags + +withCmdFlags :: + (GhcMonad m) + => [String] -> m a -> m a +withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) + where + setup = do + (dflag, _) <- G.getSessionDynFlags >>= addCmdOpts flags + void $ G.setSessionDynFlags dflag + return dflag + teardown = void . G.setSessionDynFlags + +---------------------------------------------------------------- + +-- | Set 'DynFlags' equivalent to "-w:". +setNoWaringFlags :: DynFlags -> DynFlags +setNoWaringFlags df = df { warningFlags = Gap.emptyWarnFlags} + +-- | Set 'DynFlags' equivalent to "-Wall". +setAllWaringFlags :: DynFlags -> DynFlags +setAllWaringFlags df = df { warningFlags = allWarningFlags } + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +{-# NOINLINE allWarningFlags #-} +allWarningFlags :: Gap.WarnFlags +allWarningFlags = unsafePerformIO $ do + mlibdir <- getSystemLibDir + G.runGhcT mlibdir $ do + df <- G.getSessionDynFlags + (df', _) <- addCmdOpts ["-Wall"] df + return $ G.warningFlags df' diff --git a/src/HIE/Bios/Gap.hs b/src/HIE/Bios/Gap.hs new file mode 100644 index 000000000..6270705e9 --- /dev/null +++ b/src/HIE/Bios/Gap.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} + +module HIE.Bios.Gap ( + WarnFlags + , emptyWarnFlags + , makeUserStyle + , getModuleName + , getTyThing + , fixInfo + , getModSummaries + , LExpression + , LBinding + , LPattern + , inTypes + , outType + ) where + +import DynFlags (DynFlags) +import GHC(LHsBind, LHsExpr, LPat, Type) +import HsExpr (MatchGroup) +import Outputable (PrintUnqualified, PprStyle, Depth(AllTheWay), mkUserStyle) + +---------------------------------------------------------------- +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 802 +#else +import GHC.PackageDb (ExposedModule(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 804 +import DynFlags (WarningFlag) +import qualified EnumSet as E (EnumSet, empty) +import GHC (mgModSummaries, ModSummary, ModuleGraph) +#else +import qualified Data.IntSet as I (IntSet, empty) +#endif + +#if __GLASGOW_HASKELL__ >= 806 +import HsExpr (MatchGroupTc(..)) +import HsExtension (GhcTc) +import GHC (mg_ext) +#elif __GLASGOW_HASKELL__ >= 804 +import HsExtension (GhcTc) +import GHC (mg_res_ty, mg_arg_tys) +#else +import GHC (Id, mg_res_ty, mg_arg_tys) +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle +#if __GLASGOW_HASKELL__ >= 802 +makeUserStyle dflags style = mkUserStyle dflags style AllTheWay +#else +makeUserStyle _ style = mkUserStyle style AllTheWay +#endif + +#if __GLASGOW_HASKELL__ >= 802 +getModuleName :: (a, b) -> a +getModuleName = fst +#else +getModuleName :: ExposedModule unitid modulename -> modulename +getModuleName = exposedName +#endif + +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 804 +type WarnFlags = E.EnumSet WarningFlag +emptyWarnFlags :: WarnFlags +emptyWarnFlags = E.empty +#else +type WarnFlags = I.IntSet +emptyWarnFlags :: WarnFlags +emptyWarnFlags = I.empty +#endif + +#if __GLASGOW_HASKELL__ >= 804 +getModSummaries :: ModuleGraph -> [ModSummary] +getModSummaries = mgModSummaries + +getTyThing :: (a, b, c, d, e) -> a +getTyThing (t,_,_,_,_) = t + +fixInfo :: (a, b, c, d, e) -> (a, b, c, d) +fixInfo (t,f,cs,fs,_) = (t,f,cs,fs) +#else +getModSummaries :: a -> a +getModSummaries = id + +getTyThing :: (a, b, c, d) -> a +getTyThing (t,_,_,_) = t + +fixInfo :: (a, b, c, d) -> (a, b, c, d) +fixInfo = id +#endif + +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 806 +type LExpression = LHsExpr GhcTc +type LBinding = LHsBind GhcTc +type LPattern = LPat GhcTc + +inTypes :: MatchGroup GhcTc LExpression -> [Type] +inTypes = mg_arg_tys . mg_ext +outType :: MatchGroup GhcTc LExpression -> Type +outType = mg_res_ty . mg_ext +#elif __GLASGOW_HASKELL__ >= 804 +type LExpression = LHsExpr GhcTc +type LBinding = LHsBind GhcTc +type LPattern = LPat GhcTc + +inTypes :: MatchGroup GhcTc LExpression -> [Type] +inTypes = mg_arg_tys +outType :: MatchGroup GhcTc LExpression -> Type +outType = mg_res_ty +#else +type LExpression = LHsExpr Id +type LBinding = LHsBind Id +type LPattern = LPat Id + +inTypes :: MatchGroup Id LExpression -> [Type] +inTypes = mg_arg_tys +outType :: MatchGroup Id LExpression -> Type +outType = mg_res_ty +#endif diff --git a/src/HIE/Bios/Ghc.hs b/src/HIE/Bios/Ghc.hs new file mode 100644 index 000000000..dcef200a3 --- /dev/null +++ b/src/HIE/Bios/Ghc.hs @@ -0,0 +1,16 @@ +-- | The Happy Haskell Programming library. +-- API for interactive processes + +module HIE.Bios.Ghc ( + -- * Converting the Ghc monad to the IO monad + withGHC + , withGHC' + -- * Initializing DynFlags + , initializeFlagsWithCradle + -- * Ghc utilities + -- * Misc + , getSystemLibDir + ) where + +import HIE.Bios.Check +import HIE.Bios.GHCApi diff --git a/src/HIE/Bios/Internal.hs b/src/HIE/Bios/Internal.hs new file mode 100644 index 000000000..198f8f331 --- /dev/null +++ b/src/HIE/Bios/Internal.hs @@ -0,0 +1,18 @@ +-- | The Happy Haskell Programming library in low level. + +module HIE.Bios.Internal ( + -- * Types + CompilerOptions(..) + -- * IO + , getDynamicFlags + -- * Targets + , setTargetFiles + -- * Logging + , withLogger + , setNoWaringFlags + , setAllWaringFlags + ) where + +import HIE.Bios.GHCApi +import HIE.Bios.Logger +import HIE.Bios.Types diff --git a/src/HIE/Bios/Load.hs b/src/HIE/Bios/Load.hs new file mode 100644 index 000000000..3b3b37342 --- /dev/null +++ b/src/HIE/Bios/Load.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module HIE.Bios.Load ( loadFileWithMessage, loadFile, setTargetFiles, setTargetFilesWithMessage) where + +import CoreMonad (liftIO) +import DynFlags (gopt_set, wopt_set, WarningFlag(Opt_WarnTypedHoles)) +import GHC +import qualified GHC as G +import qualified GhcMake as G +import qualified HscMain as G +import HscTypes +import Outputable + +import Data.IORef + +import HIE.Bios.GHCApi +import System.Directory +import Hooks +import TcRnTypes (FrontendResult(..)) +import Control.Monad (forM, void) +import GhcMonad +import HscMain +import Debug.Trace +import Data.List + +#if __GLASGOW_HASKELL__ < 806 +pprTraceM x s = pprTrace x s (return ()) +#endif + +-- | Obtaining type of a target expression. (GHCi's type:) +loadFileWithMessage :: GhcMonad m + => Maybe G.Messager + -> (FilePath, FilePath) -- ^ A target file. + -> m (Maybe TypecheckedModule, [TypecheckedModule]) +loadFileWithMessage msg file = do + dir <- liftIO $ getCurrentDirectory + pprTraceM "loadFile:2" (text dir) + withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do + + df <- getSessionDynFlags + pprTraceM "loadFile:3" (ppr $ optLevel df) + (_, tcs) <- collectASTs (setTargetFilesWithMessage msg [file]) + pprTraceM "loaded" (text (fst file) $$ text (snd file)) + let get_fp = ml_hs_file . ms_location . pm_mod_summary . tm_parsed_module + traceShowM ("tms", (map get_fp tcs)) + let findMod [] = Nothing + findMod (x:xs) = case get_fp x of + Just fp -> if fp `isSuffixOf` (snd file) then Just x else findMod xs + Nothing -> findMod xs + return (findMod tcs, tcs) + +loadFile :: (GhcMonad m) + => (FilePath, FilePath) + -> m (Maybe TypecheckedModule, [TypecheckedModule]) +loadFile = loadFileWithMessage (Just G.batchMsg) + +{- +fileModSummary :: GhcMonad m => FilePath -> m ModSummary +fileModSummary file = do + mss <- getModSummaries <$> G.getModuleGraph + let [ms] = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) mss + return ms + -} + + +setDeferTypeErrors :: DynFlags -> DynFlags +setDeferTypeErrors dflag = gopt_set dflag G.Opt_DeferTypeErrors + +setWarnTypedHoles :: DynFlags -> DynFlags +setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles + +setTargetFiles :: GhcMonad m => [(FilePath, FilePath)] -> m () +setTargetFiles = setTargetFilesWithMessage (Just G.batchMsg) + +-- | Set the files as targets and load them. +setTargetFilesWithMessage :: (GhcMonad m) => Maybe G.Messager -> [(FilePath, FilePath)] -> m () +setTargetFilesWithMessage msg files = do + targets <- forM files guessTargetMapped + pprTrace "setTargets" (vcat (map ppr files) $$ ppr targets) (return ()) + G.setTargets (map (\t -> t { G.targetAllowObjCode = False }) targets) + mod_graph <- depanal [] False + void $ G.load' LoadAllTargets msg mod_graph + +collectASTs :: (GhcMonad m) => m a -> m (a, [TypecheckedModule]) +collectASTs action = do + dflags0 <- getSessionDynFlags + ref1 <- liftIO $ newIORef [] + let dflags1 = dflags0 { hooks = (hooks dflags0) + { hscFrontendHook = Just (astHook ref1) } } + void $ setSessionDynFlags dflags1 + res <- action + tcs <- liftIO $ readIORef ref1 + return (res, tcs) + +astHook :: IORef [TypecheckedModule] -> ModSummary -> Hsc FrontendResult +astHook tc_ref ms = ghcInHsc $ do + p <- G.parseModule ms + tcm <- G.typecheckModule p + let tcg_env = fst (tm_internals_ tcm) + liftIO $ modifyIORef tc_ref (tcm :) + return $ FrontendTypecheck tcg_env + +ghcInHsc :: Ghc a -> Hsc a +ghcInHsc gm = do + hsc_session <- getHscEnv + session <- liftIO $ newIORef hsc_session + liftIO $ reflectGhc gm (Session session) + + + + +guessTargetMapped :: (GhcMonad m) => (FilePath, FilePath) -> m Target +guessTargetMapped (orig_file_name, mapped_file_name) = do + t <- G.guessTarget orig_file_name Nothing + return (setTargetFilename mapped_file_name t) + +setTargetFilename :: FilePath -> Target -> Target +setTargetFilename fn t = + t { targetId = case targetId t of + TargetFile _ p -> TargetFile fn p + tid -> tid } diff --git a/src/HIE/Bios/Logger.hs b/src/HIE/Bios/Logger.hs new file mode 100644 index 000000000..d66ff27f3 --- /dev/null +++ b/src/HIE/Bios/Logger.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE BangPatterns #-} + +module HIE.Bios.Logger ( + withLogger + , checkErrorPrefix + , getSrcSpan + ) where + +import Bag (Bag, bagToList) +import CoreMonad (liftIO) +import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices)) +import ErrUtils +import Exception (ghandle) +import FastString (unpackFS) +import GHC (DynFlags(..), SrcSpan(..), Severity(SevError), GhcMonad) +import qualified GHC as G +import HscTypes (SourceError, srcErrorMessages) +import Outputable (PprStyle, SDoc) + +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import System.FilePath (normalise) + +import HIE.Bios.Doc (showPage, getStyle) +import HIE.Bios.GHCApi (withDynFlags, withCmdFlags) +import HIE.Bios.Types (Options(..), convert) + +---------------------------------------------------------------- + +type Builder = [String] -> [String] + +newtype LogRef = LogRef (IORef Builder) + +newLogRef :: IO LogRef +newLogRef = LogRef <$> newIORef id + +readAndClearLogRef :: Options -> LogRef -> IO String +readAndClearLogRef opt (LogRef ref) = do + b <- readIORef ref + writeIORef ref id + return $! convert opt (b []) + +appendLogRef :: DynFlags -> LogRef -> LogAction +appendLogRef df (LogRef ref) _ _ sev src style msg = do + let !l = ppMsg src sev df style msg + modifyIORef ref (\b -> b . (l:)) + +---------------------------------------------------------------- + +-- | Set the session flag (e.g. "-Wall" or "-w:") then +-- executes a body. Log messages are returned as 'String'. +-- Right is success and Left is failure. +withLogger :: + (GhcMonad m) + => Options -> (DynFlags -> DynFlags) -> m () -> m (Either String String) +withLogger opt setDF body = ghandle (sourceError opt) $ do + logref <- liftIO newLogRef + withDynFlags (setLogger logref . setDF) $ do + withCmdFlags wflags $ do + body + liftIO $ Right <$> readAndClearLogRef opt logref + where + setLogger logref df = df { log_action = appendLogRef df logref } + wflags = filter ("-fno-warn" `isPrefixOf`) $ ghcOpts opt + +---------------------------------------------------------------- + +-- | Converting 'SourceError' to 'String'. +sourceError :: + (GhcMonad m) + => Options -> SourceError -> m (Either String String) +sourceError opt err = do + dflag <- G.getSessionDynFlags + style <- getStyle dflag + let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err + return (Left ret) + +errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] +errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList + +---------------------------------------------------------------- + +ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String +ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext + where + spn = errMsgSpan err + msg = pprLocErrMsg err + -- fixme +-- ext = showPage dflag style (pprLocErrMsg $ errMsgReason err) + +ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String +ppMsg spn sev dflag style msg = prefix ++ cts + where + cts = showPage dflag style msg + defaultPrefix + | isDumpSplices dflag = "" + | otherwise = checkErrorPrefix + prefix = fromMaybe defaultPrefix $ do + (line,col,_,_) <- getSrcSpan spn + file <- normalise <$> getSrcFile spn + let severityCaption = showSeverityCaption sev + return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption + +checkErrorPrefix :: String +checkErrorPrefix = "Dummy:0:0:Error:" + +showSeverityCaption :: Severity -> String +showSeverityCaption SevWarning = "Warning: " +showSeverityCaption _ = "" + +getSrcFile :: SrcSpan -> Maybe String +getSrcFile (G.RealSrcSpan spn) = Just . unpackFS . G.srcSpanFile $ spn +getSrcFile _ = Nothing + +isDumpSplices :: DynFlags -> Bool +isDumpSplices dflag = dopt Opt_D_dump_splices dflag + +getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) +getSrcSpan (RealSrcSpan spn) = Just ( G.srcSpanStartLine spn + , G.srcSpanStartCol spn + , G.srcSpanEndLine spn + , G.srcSpanEndCol spn) +getSrcSpan _ = Nothing diff --git a/src/HIE/Bios/Things.hs b/src/HIE/Bios/Things.hs new file mode 100644 index 000000000..577eb5652 --- /dev/null +++ b/src/HIE/Bios/Things.hs @@ -0,0 +1,63 @@ +module HIE.Bios.Things ( + GapThing(..) + , fromTyThing + , infoThing + ) where + +import ConLike (ConLike(..)) +import FamInstEnv +import GHC +import HscTypes +import qualified InstEnv +import NameSet +import Outputable +import PatSyn +import PprTyThing +import Var (varType) + +import Data.List (intersperse) +import Data.Maybe (catMaybes) + +import HIE.Bios.Gap (getTyThing, fixInfo) + +-- from ghc/InteractiveUI.hs + +---------------------------------------------------------------- + +data GapThing = GtA Type + | GtT TyCon + | GtN + | GtPatSyn PatSyn + +fromTyThing :: TyThing -> GapThing +fromTyThing (AnId i) = GtA $ varType i +fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d +fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p +fromTyThing (ATyCon t) = GtT t +fromTyThing _ = GtN + +---------------------------------------------------------------- + +infoThing :: String -> Ghc SDoc +infoThing str = do + names <- parseName str + mb_stuffs <- mapM (getInfo False) names + let filtered = filterOutChildren getTyThing $ catMaybes mb_stuffs + return $ vcat (intersperse (text "") $ map (pprInfo . fixInfo) filtered) + +filterOutChildren :: (a -> TyThing) -> [a] -> [a] +filterOutChildren get_thing xs + = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] + where + implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] + +pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [FamInst]) -> SDoc +pprInfo (thing, fixity, insts, famInsts) + = pprTyThingInContextLoc thing + $$ show_fixity fixity + $$ InstEnv.pprInstances insts + $$ pprFamInsts famInsts + where + show_fixity fx + | fx == defaultFixity = Outputable.empty + | otherwise = ppr fx <+> ppr (getName thing) diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs new file mode 100644 index 000000000..1bee1ec9e --- /dev/null +++ b/src/HIE/Bios/Types.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module HIE.Bios.Types where + +import qualified Exception as GE +import GHC (Ghc) + +import Control.Exception (IOException) +import Control.Applicative (Alternative(..)) +import System.Exit +import System.IO + +data BIOSVerbosity = Silent | Verbose + +data CradleOpts = CradleOpts + { cradleOptsVerbosity :: BIOSVerbosity + , cradleOptsHandle :: Maybe Handle + -- ^ The handle where to send output to, if not set, stderr + } + +defaultCradleOpts :: CradleOpts +defaultCradleOpts = CradleOpts Silent Nothing + +-- | Output style. +data OutputStyle = LispStyle -- ^ S expression style. + | PlainStyle -- ^ Plain textstyle. + +-- | The type for line separator. Historically, a Null string is used. +newtype LineSeparator = LineSeparator String + +data Options = Options { + outputStyle :: OutputStyle + , hlintOpts :: [String] + , ghcOpts :: [String] + -- | If 'True', 'browse' also returns operators. + , operators :: Bool + -- | If 'True', 'browse' also returns types. + , detailed :: Bool + -- | If 'True', 'browse' will return fully qualified name + , qualified :: Bool + -- | Line separator string. + , lineSeparator :: LineSeparator + } + +-- | A default 'Options'. +defaultOptions :: Options +defaultOptions = Options { + outputStyle = PlainStyle + , hlintOpts = [] + , ghcOpts = [] + , operators = False + , detailed = False + , qualified = False + , lineSeparator = LineSeparator "\0" + } + +---------------------------------------------------------------- + +type Builder = String -> String + +-- | +-- +-- >>> replace '"' "\\\"" "foo\"bar" "" +-- "foo\\\"bar" +replace :: Char -> String -> String -> Builder +replace _ _ [] = id +replace c cs (x:xs) + | x == c = (cs ++) . replace c cs xs + | otherwise = (x :) . replace c cs xs + +inter :: Char -> [Builder] -> Builder +inter _ [] = id +inter c bs = foldr1 (\x y -> x . (c:) . y) bs + +convert :: ToString a => Options -> a -> String +convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" +convert opt@Options { outputStyle = PlainStyle } x + | str == "\n" = "" + | otherwise = str + where + str = toPlain opt x "\n" + +class ToString a where + toLisp :: Options -> a -> Builder + toPlain :: Options -> a -> Builder + +lineSep :: Options -> String +lineSep opt = lsep + where + LineSeparator lsep = lineSeparator opt + +-- | +-- +-- >>> toLisp defaultOptions "fo\"o" "" +-- "\"fo\\\"o\"" +-- >>> toPlain defaultOptions "foo" "" +-- "foo" +instance ToString String where + toLisp opt = quote opt + toPlain opt = replace '\n' (lineSep opt) + +-- | +-- +-- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] "" +-- "(\"foo\" \"bar\" \"ba\\\"z\")" +-- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" +-- "foo\nbar\nbaz" +instance ToString [String] where + toLisp opt = toSexp1 opt + toPlain opt = inter '\n' . map (toPlain opt) + +-- | +-- +-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] +-- >>> toLisp defaultOptions inp "" +-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" +-- >>> toPlain defaultOptions inp "" +-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" +instance ToString [((Int,Int,Int,Int),String)] where + toLisp opt = toSexp2 . map toS + where + toS x = ('(' :) . tupToString opt x . (')' :) + toPlain opt = inter '\n' . map (tupToString opt) + +toSexp1 :: Options -> [String] -> Builder +toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) + +toSexp2 :: [Builder] -> Builder +toSexp2 ss = ('(' :) . inter ' ' ss . (')' :) + +tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder +tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :) + . (show b ++) . (' ' :) + . (show c ++) . (' ' :) + . (show d ++) . (' ' :) + . quote opt s -- fixme: quote is not necessary + +quote :: Options -> String -> Builder +quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++) + where + lsep = lineSep opt + quote' [] = [] + quote' (x:xs) + | x == '\n' = lsep ++ quote' xs + | x == '\\' = "\\\\" ++ quote' xs + | x == '"' = "\\\"" ++ quote' xs + | otherwise = x : quote' xs + +---------------------------------------------------------------- + +-- | The environment where this library is used. +data Cradle = Cradle { + -- | The project root directory. + cradleRootDir :: FilePath + -- | The action which needs to be executed to get the correct + -- command line arguments + , cradleOptsProg :: CradleAction + } deriving (Show) + +data CradleAction = CradleAction { + actionName :: String + , getOptions :: (FilePath -> IO (ExitCode, String, [String])) + } + +instance Show CradleAction where + show (CradleAction name _) = "CradleAction: " ++ name +---------------------------------------------------------------- + +-- | Option information for GHC +data CompilerOptions = CompilerOptions { + ghcOptions :: [String] -- ^ Command line options + } deriving (Eq, Show) + +instance Alternative Ghc where + x <|> y = x `GE.gcatch` (\(_ :: IOException) -> y) + empty = undefined diff --git a/wrappers/bazel b/wrappers/bazel new file mode 100755 index 000000000..1624cea61 --- /dev/null +++ b/wrappers/bazel @@ -0,0 +1,5 @@ +#!/usr/bin/env bash +fullname=$(bazel query "$1") +attr=$(bazel query "kind(haskell_*, attr('srcs', $fullname, ${fullname//:*/}:*))") +bazel build "$attr@repl" --experimental_show_artifacts 2>&1 | sed -ne '/>>>/ s/^>>>\(.*\)$/\1/ p' | xargs tail -1 + diff --git a/wrappers/cabal b/wrappers/cabal new file mode 100755 index 000000000..a83ad3fdb --- /dev/null +++ b/wrappers/cabal @@ -0,0 +1,7 @@ +#!/usr/bin/env bash +if [ "$1" == "--interactive" ]; then + pwd + echo "$@" +else + ghc "$@" +fi