ghcide: support hs-boot files (#2827)

Author: hsenag

extension/package.json

@@ -22,7 +22,8 @@
 		"languages": [{
 			"id": "haskell",
 			"extensions": [
-				"hs"
+				"hs",
+				"hs-boot"
 			]
 		}],
 		"configuration": {

src/Development/IDE/Core/Compile.hs

@@ -45,6 +45,8 @@ import qualified GHC.LanguageExtensions as LangExt
 import Control.Monad.Extra
 import Control.Monad.Except
 import Control.Monad.Trans.Except
+import           Data.Function
+import           Data.Ord
 import qualified Data.Text as T
 import           Data.IORef
 import           Data.List.Extra
@@ -149,7 +151,12 @@ mkTcModuleResult tcm = do
 -- | Setup the environment that GHC needs according to our
 -- best understanding (!)
 setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
-setupEnv tms = do
+setupEnv tmsIn = do
+    -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
+    -- takes precedence, so put the .hs-boot file earlier in the list
+    let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
+        tms = sortBy (compare `on` Down . isSourceFile) tmsIn
+
     session <- getSession
 
     let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
@@ -191,24 +198,17 @@ loadModuleHome tmr = modifySession $ \e ->
 -- name and its imports.
 getImportsParsed ::  DynFlags ->
                GHC.ParsedSource ->
-               Either [FileDiagnostic] (GHC.ModuleName, [(Maybe FastString, Located GHC.ModuleName)])
+               Either [FileDiagnostic] (GHC.ModuleName, [(Bool, (Maybe FastString, Located GHC.ModuleName))])
 getImportsParsed dflags (L loc parsed) = do
   let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
 
-  -- refuse source imports
-  let srcImports = filter (ideclSource . GHC.unLoc) $ GHC.hsmodImports parsed
-  when (not $ null srcImports) $ Left $
-    concat
-      [ diagFromString "imports" mloc ("Illegal source import of " <> GHC.moduleNameString (GHC.unLoc $ GHC.ideclName i))
-      | L mloc i <- srcImports ]
-
   -- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
   -- but we want to avoid parsing the module twice
   let implicit_prelude = xopt GHC.ImplicitPrelude dflags
       implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
 
   -- filter out imports that come from packages
-  return (modName, [(fmap sl_fs $ ideclPkgQual i, ideclName i)
+  return (modName, [(ideclSource i, (fmap sl_fs $ ideclPkgQual i, ideclName i))
     | i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
     , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
     ])
@@ -227,10 +227,10 @@ getModSummaryFromBuffer fp contents dflags parsed = do
 
   let modLoc = ModLocation
           { ml_hs_file  = Just fp
-          , ml_hi_file  = replaceExtension fp "hi"
-          , ml_obj_file = replaceExtension fp "o"
+          , ml_hi_file  = derivedFile "hi"
+          , ml_obj_file = derivedFile "o"
 #ifndef GHC_STABLE
-          , ml_hie_file = replaceExtension fp "hie"
+          , ml_hie_file = derivedFile "hie"
 #endif
           -- This does not consider the dflags configuration
           -- (-osuf and -hisuf, object and hi dir.s).
@@ -245,21 +245,27 @@ getModSummaryFromBuffer fp contents dflags parsed = do
         -- To avoid silent issues where something is not processed because the date
         -- has not changed, we make sure that things blow up if they depend on the
         -- date.
-    , ms_textual_imps = imports
+    , ms_textual_imps = [imp | (False, imp) <- imports]
     , ms_hspp_file    = fp
     , ms_hspp_opts    = dflags
     , ms_hspp_buf     = Just contents
 
     -- defaults:
-    , ms_hsc_src      = HsSrcFile
+    , ms_hsc_src      = sourceType
     , ms_obj_date     = Nothing
     , ms_iface_date   = Nothing
 #ifndef GHC_STABLE
     , ms_hie_date     = Nothing
 #endif
-    , ms_srcimps      = []        -- source imports are not allowed
+    , ms_srcimps      = [imp | (True, imp) <- imports]
     , ms_parsed_mod   = Nothing
     }
+    where
+      (sourceType, derivedFile) =
+          let (stem, ext) = splitExtension fp in
+          if "-boot" `isSuffixOf` ext
+          then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
+          else (HsSrcFile , \newExt -> stem <.> newExt)
 
 -- | Run CPP on a file
 runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

src/Development/IDE/Core/Rules.hs

@@ -183,12 +183,12 @@ getLocatedImportsRule =
     define $ \GetLocatedImports file -> do
         pm <- use_ GetParsedModule file
         let ms = pm_mod_summary pm
-        let imports = ms_textual_imps ms
+        let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
         env <- useNoFile_ GhcSession
         let dflags = addRelativeImport pm $ hsc_dflags env
         opt <- getIdeOptions
-        (diags, imports') <- fmap unzip $ forM imports $ \(mbPkgName, modName) -> do
-            diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName
+        (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
+            diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
             case diagOrImp of
                 Left diags -> pure (diags, Left (modName, Nothing))
                 Right (FileImport path) -> pure ([], Left (modName, Just path))

src/Development/IDE/Import/FindImports.hs

@@ -42,11 +42,18 @@ locateModuleFile :: MonadIO m
              => DynFlags
              -> [String]
              -> (NormalizedFilePath -> m Bool)
+             -> Bool
              -> ModuleName
              -> m (Maybe NormalizedFilePath)
-locateModuleFile dflags exts doesExist modName = do
-  let candidates = [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> ext) | prefix <- importPaths dflags, ext <- exts]
+locateModuleFile dflags exts doesExist isSource modName = do
+  let candidates =
+        [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
+           | prefix <- importPaths dflags, ext <- exts]
   findM doesExist candidates
+  where
+    maybeBoot ext
+      | isSource = ext ++ "-boot"
+      | otherwise = ext
 
 -- | locate a module in either the file system or the package database. Where we go from *daml to
 -- Haskell
@@ -57,15 +64,16 @@ locateModule
     -> (NormalizedFilePath -> m Bool)
     -> Located ModuleName
     -> Maybe FastString
+    -> Bool
     -> m (Either [FileDiagnostic] Import)
-locateModule dflags exts doesExist modName mbPkgName = do
+locateModule dflags exts doesExist modName mbPkgName isSource = do
   case mbPkgName of
     -- if a package name is given we only go look for a package
     Just _pkgName -> lookupInPackageDB dflags
     Nothing -> do
       -- first try to find the module as a file. If we can't find it try to find it in the package
       -- database.
-      mbFile <- locateModuleFile dflags exts doesExist $ unLoc modName
+      mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
       case mbFile of
         Nothing -> lookupInPackageDB dflags
         Just file -> return $ Right $ FileImport file

test/exe/Main.hs

@@ -125,6 +125,47 @@ diagnosticTests = testGroup "diagnostics"
           , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
           )
         ]
+  , testSession "cyclic module dependency with hs-boot" $ do
+      let contentA = T.unlines
+            [ "module ModuleA where"
+            , "import {-# SOURCE #-} ModuleB"
+            ]
+      let contentB = T.unlines
+            [ "module ModuleB where"
+            , "import ModuleA"
+            ]
+      let contentBboot = T.unlines
+            [ "module ModuleB where"
+            ]
+      _ <- openDoc' "ModuleA.hs" "haskell" contentA
+      _ <- openDoc' "ModuleB.hs" "haskell" contentB
+      _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
+      expectDiagnostics []
+  , testSession "correct reference used with hs-boot" $ do
+      let contentB = T.unlines
+            [ "module ModuleB where"
+            , "import {-# SOURCE #-} ModuleA"
+            ]
+      let contentA = T.unlines
+            [ "module ModuleA where"
+            , "import ModuleB"
+            , "x = 5"
+            ]
+      let contentAboot = T.unlines
+            [ "module ModuleA where"
+            ]
+      let contentC = T.unlines
+            [ "module ModuleC where"
+            , "import ModuleA"
+            -- this reference will fail if it gets incorrectly
+            -- resolved to the hs-boot file
+            , "y = x"
+            ]
+      _ <- openDoc' "ModuleB.hs" "haskell" contentB
+      _ <- openDoc' "ModuleA.hs" "haskell" contentA
+      _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
+      _ <- openDoc' "ModuleC.hs" "haskell" contentC
+      expectDiagnostics []
   , testSession "redundant import" $ do
       let contentA = T.unlines ["module ModuleA where"]
       let contentB = T.unlines