Merge branch 'master' into progressreport-redo

Author: pepeiborra

exe/Wrapper.hs

@@ -8,9 +8,8 @@ import           Data.Default
 import           Data.Foldable
 import           Data.List
 import           Data.Void
-import           Development.IDE.Session (findCradle)
-import           HIE.Bios                hiding (findCradle)
-import           HIE.Bios.Environment
+import qualified Development.IDE.Session as Session
+import qualified HIE.Bios.Environment    as HieBios
 import           HIE.Bios.Types
 import           Ide.Arguments
 import           Ide.Version
@@ -44,6 +43,9 @@ main = do
       VersionMode PrintNumericVersion ->
           putStrLn haskellLanguageServerNumericVersion
 
+      BiosMode PrintCradleType ->
+          print =<< findProjectCradle
+
       _ -> launchHaskellLanguageServer args
 
 launchHaskellLanguageServer :: Arguments -> IO ()
@@ -53,9 +55,11 @@ launchHaskellLanguageServer parsedArgs = do
     _                          -> pure ()
 
   d <- getCurrentDirectory
+  
+  -- search for the project cradle type
+  cradle <- findProjectCradle
 
-  -- Get the cabal directory from the cradle
-  cradle <- findLocalCradle (d </> "a")
+  -- Get the root directory from the cradle
   setCurrentDirectory $ cradleRootDir cradle
 
   case parsedArgs of
@@ -114,7 +118,7 @@ getRuntimeGhcVersion' cradle = do
     Direct  -> checkToolExists "ghc"
     _       -> pure ()
 
-  ghcVersionRes <- getRuntimeGhcVersion cradle
+  ghcVersionRes <- HieBios.getRuntimeGhcVersion cradle
   case ghcVersionRes of
     CradleSuccess ver -> do
       return ver
@@ -129,23 +133,16 @@ getRuntimeGhcVersion' cradle = do
           die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n"
            ++ show cradle
 
--- | Find the cradle that the given File belongs to.
---
--- First looks for a "hie.yaml" file in the directory of the file
--- or one of its parents. If this file is found, the cradle
--- is read from the config. If this config does not comply to the "hie.yaml"
--- specification, an error is raised.
---
--- If no "hie.yaml" can be found, the implicit config is used.
--- The implicit config uses different heuristics to determine the type
--- of the project that may or may not be accurate.
-findLocalCradle :: FilePath -> IO (Cradle Void)
-findLocalCradle fp = do
-  cradleConf <- findCradle def fp
-  crdl       <- case cradleConf of
-    Just yaml -> do
-      hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\""
-      loadCradle yaml
-    Nothing -> loadImplicitCradle fp
-  hPutStrLn stderr $ "Module \"" ++ fp ++ "\" is loaded by Cradle: " ++ show crdl
-  return crdl
+findProjectCradle :: IO (Cradle Void)
+findProjectCradle = do
+  d <- getCurrentDirectory
+
+  let initialFp = (d </> "a")
+  hieYaml <- Session.findCradle def initialFp
+
+  -- Some log messages
+  case hieYaml of
+    Just yaml -> hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ initialFp ++ "\""
+    Nothing -> hPutStrLn stderr "No 'hie.yaml' found. Try to discover the project type!"
+
+  Session.loadCradle def hieYaml d

ghcide/ghcide.cabal

@@ -14,7 +14,7 @@ description:
 homepage:           https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme
 bug-reports:        https://github.com/haskell/haskell-language-server/issues
 tested-with:        GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4
-extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md
+extra-source-files: README.md CHANGELOG.md
                     test/data/**/*.project
                     test/data/**/*.cabal
                     test/data/**/*.yaml
@@ -334,9 +334,9 @@ test-suite ghcide-tests
         extra,
         filepath,
         --------------------------------------------------------------
-        -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas
+        -- The MIN_VERSION_ghc macro relies on MIN_VERSION pragmas
         -- which require depending on ghc. So the tests need to depend
-        -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a
+        -- on ghc if they need to use MIN_VERSION_ghc. Maybe a
         -- better solution can be found, but this is a quick solution
         -- which works for now.
         ghc,

ghcide/include/ghc-api-version.h

@@ -1,6 +1,5 @@
 {-# LANGUAGE CPP          #-}
 {-# LANGUAGE TypeFamilies #-}
-#include "ghc-api-version.h"
 
 {-|
 The logic for setting up a ghcide session by tapping into hie-bios.
@@ -48,6 +47,7 @@ import           Development.IDE.GHC.Compat           hiding (Target,
                                                        TargetFile, TargetModule)
 import qualified Development.IDE.GHC.Compat           as GHC
 import           Development.IDE.GHC.Util
+import           Development.IDE.Graph                (Action)
 import           Development.IDE.Session.VersionCheck
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Exports
@@ -56,7 +56,6 @@ import           Development.IDE.Types.HscEnvEq       (HscEnvEq, newHscEnvEq,
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Logger
 import           Development.IDE.Types.Options
-import           Development.IDE.Graph                    (Action)
 import           GHC.Check
 import qualified HIE.Bios                             as HieBios
 import           HIE.Bios.Environment                 hiding (getCacheDir)
@@ -85,12 +84,10 @@ import           Control.Concurrent.STM               (atomically)
 import           Control.Concurrent.STM.TQueue
 import qualified Data.HashSet                         as Set
 import           Database.SQLite.Simple
-import           HIE.Bios.Cradle                      (yamlConfig)
+import           GHC.LanguageExtensions               (Extension (EmptyCase))
 import           HieDb.Create
 import           HieDb.Types
 import           HieDb.Utils
-import           Maybes                               (MaybeT (runMaybeT))
-import           GHC.LanguageExtensions               (Extension(EmptyCase))
 
 -- | Bump this version number when making changes to the format of the data stored in hiedb
 hiedbDataVersion :: String
@@ -100,15 +97,18 @@ data CacheDirs = CacheDirs
   { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}
 
 data SessionLoadingOptions = SessionLoadingOptions
-  { findCradle          :: FilePath -> IO (Maybe FilePath)
-  , loadCradle          :: FilePath -> IO (HieBios.Cradle Void)
+  { findCradle             :: FilePath -> IO (Maybe FilePath)
+  -- | Load the cradle with an optional 'hie.yaml' location.
+  -- If a 'hie.yaml' is given, use it to load the cradle.
+  -- Otherwise, use the provided project root directory to determine the cradle type.
+  , loadCradle             :: Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void)
   -- | Given the project name and a set of command line flags,
   --   return the path for storing generated GHC artifacts,
   --   or 'Nothing' to respect the cradle setting
-  , getCacheDirs        :: String -> [String] -> IO CacheDirs
+  , getCacheDirs           :: String -> [String] -> IO CacheDirs
   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
-  , getInitialGhcLibDir :: IO (Maybe LibDir)
-  , fakeUid             :: InstalledUnitId
+  , getInitialGhcLibDir    :: IO (Maybe LibDir)
+  , fakeUid                :: InstalledUnitId
     -- ^ unit id used to tag the internal component built by ghcide
     --   To reuse external interface files the unit ids must match,
     --   thus make sure to build them with `--this-unit-id` set to the
@@ -118,17 +118,39 @@ data SessionLoadingOptions = SessionLoadingOptions
 instance Default SessionLoadingOptions where
     def = SessionLoadingOptions
         {findCradle = HieBios.findCradle
-        ,loadCradle = HieBios.loadCradle
+        ,loadCradle = loadWithImplicitCradle
         ,getCacheDirs = getCacheDirsDefault
         ,getInitialGhcLibDir = getInitialGhcLibDirDefault
         ,fakeUid = toInstalledUnitId (stringToUnitId "main")
         }
 
+-- | Find the cradle for a given 'hie.yaml' configuration.
+--
+-- If a 'hie.yaml' is given, the cradle is read from the config.
+--  If this config does not comply to the "hie.yaml"
+-- specification, an error is raised.
+--
+-- If no location for "hie.yaml" is provided, the implicit config is used
+-- using the provided root directory for discovering the project.
+-- The implicit config uses different heuristics to determine the type
+-- of the project that may or may not be accurate.
+loadWithImplicitCradle :: Maybe FilePath
+                          -- ^ Optional 'hie.yaml' location. Will be used if given.
+                          -> FilePath
+                          -- ^ Root directory of the project. Required as a fallback
+                          -- if no 'hie.yaml' location is given.
+                          -> IO (HieBios.Cradle Void)
+loadWithImplicitCradle mHieYaml rootDir = do
+  crdl       <- case mHieYaml of
+    Just yaml -> HieBios.loadCradle yaml
+    Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir
+  return crdl
+
 getInitialGhcLibDirDefault :: IO (Maybe LibDir)
 getInitialGhcLibDirDefault = do
   dir <- IO.getCurrentDirectory
-  hieYaml <- runMaybeT $ yamlConfig dir
-  cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml
+  hieYaml <- findCradle def dir
+  cradle <- loadCradle def hieYaml dir
   hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle
   libDirRes <- getRuntimeGhcLibDir cradle
   case libDirRes of
@@ -400,7 +422,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
            when (isNothing hieYaml) $
              logWarning logger $ implicitCradleWarning lfp
 
-           cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
+           cradle <- loadCradle hieYaml dir
 
            when optTesting $ mRunLspT lspEnv $
             sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp)

ghcide/session-loader/Development/IDE/Session.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE CPP        #-}
 {-# LANGUAGE GADTs      #-}
 {-# LANGUAGE RankNTypes #-}
-#include "ghc-api-version.h"
 
 -- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API.
 --   Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
@@ -57,7 +56,7 @@ import           LoadIface                         (loadModuleInterface)
 
 import           Lexer
 import qualified Parser
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_VERSION_ghc(8,10,0)
 import           Control.DeepSeq                   (force, rnf)
 #else
 import           Control.DeepSeq                   (rnf)
@@ -234,7 +233,7 @@ mkHiFileResultNoCompile session tcm = do
       tcGblEnv = tmrTypechecked tcm
   details <- makeSimpleDetails hsc_env_tmp tcGblEnv
   sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_VERSION_ghc(8,10,0)
   iface <- mkIfaceTc hsc_env_tmp sf details tcGblEnv
 #else
   (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv
@@ -268,7 +267,7 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do
         (guts, details) <- tidyProgram session simplified_guts
         (diags, linkable) <- genLinkable session ms guts
         pure (linkable, details, diags)
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_VERSION_ghc(8,10,0)
   let !partial_iface = force (mkPartialIface session details simplified_guts)
   final_iface <- mkFullIface session partial_iface
 #else
@@ -330,14 +329,14 @@ generateObjectCode session summary guts = do
               (warnings, dot_o_fp) <-
                 withWarnings "object" $ \_tweak -> do
                       let summary' = _tweak summary
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_VERSION_ghc(8,10,0)
                           target = defaultObjectTarget $ hsc_dflags session
 #else
                           target = defaultObjectTarget $ targetPlatform $ hsc_dflags session
 #endif
                           session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}}
                       (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_VERSION_ghc(8,10,0)
                                 (ms_location summary')
 #else
                                 summary'
@@ -360,7 +359,7 @@ generateByteCode hscEnv summary guts = do
                       let summary' = _tweak summary
                           session = hscEnv { hsc_dflags = ms_hspp_opts summary' }
                       hscInteractive session guts
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_VERSION_ghc(8,10,0)
                                 (ms_location summary')
 #else
                                 summary'
@@ -419,7 +418,7 @@ unnecessaryDeprecationWarningFlags
     , Opt_WarnUnusedMatches
     , Opt_WarnUnusedTypePatterns
     , Opt_WarnUnusedForalls
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_VERSION_ghc(8,10,0)
     , Opt_WarnUnusedRecordWildcards
 #endif
     , Opt_WarnInaccessibleCode
@@ -738,7 +737,7 @@ getModSummaryFromImports env fp modTime contents = do
         msrModSummary =
             ModSummary
                 { ms_mod          = modl
-#if MIN_GHC_API_VERSION(8,8,0)
+#if MIN_VERSION_ghc(8,8,0)
                 , ms_hie_date     = Nothing
 #endif
                 , ms_hs_date      = modTime
@@ -782,7 +781,7 @@ parseHeader
 parseHeader dflags filename contents = do
    let loc  = mkRealSrcLoc (mkFastString filename) 1 1
    case unP Parser.parseHeader (mkPState dflags contents loc) of
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_VERSION_ghc(8,10,0)
      PFailed pst ->
         throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
 #else
@@ -820,7 +819,7 @@ parseFileContents env customPreprocessor filename ms = do
        dflags = ms_hspp_opts ms
        contents = fromJust $ ms_hspp_buf ms
    case unP Parser.parseModule (mkPState dflags contents loc) of
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_VERSION_ghc(8,10,0)
      PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
 #else
      PFailed _ locErr msgErr ->

ghcide/src/Development/IDE/Core/Compile.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE TypeFamilies          #-}
-#include "ghc-api-version.h"
 
 -- | A Shake implementation of the compiler service, built
 --   using the "Shaker" abstraction layer for in-memory use.

ghcide/src/Development/IDE/Core/Rules.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE NoApplicativeDo #-}
 {-# LANGUAGE CPP #-}
-#include "ghc-api-version.h"
 module Development.IDE.Core.Tracing
     ( otTracedHandler
     , otTracedAction
@@ -96,7 +95,7 @@ otTracedAction key file success act
             return res)
   | otherwise = act
 
-#if MIN_GHC_API_VERSION(8,8,0)
+#if MIN_VERSION_ghc(8,8,0)
 otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
 #else
 otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a