diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,10 +1,19 @@ # ChangeLog for HHP(Happy Haskell Programming) -## 2024-03-31 v1.0.4 +## 2026-09-07 v1.0.4 +- Bug fix for reading symbols from Emacs Lisp. +- Properly specifying hs-source-dir: Previously, all hs-source-dirs + were specified whenever there were multiple ones. If modules + happened to share the same name and the paths were specified in the + wrong order, syntax checks would fail. So, updating the + configuration to specify only the minimum necessary hs-source-dirs. + +## 2026-03-11 v1.0.4 + - Updating Emacs Lisp. -## 2024-03-31 v1.0.3 +## 2025-03-31 v1.0.3 - Supporting GHC 9.12 diff --git a/elisp/hhp-comp.el b/elisp/hhp-comp.el --- a/elisp/hhp-comp.el +++ b/elisp/hhp-comp.el @@ -111,10 +111,11 @@ nil)) (defun hhp-load-module (mod) - (prog2 - (message "Loading symbols for %s..." mod) - (hhp-sync-process (format "browse %s\n" mod)) - (message "Loading symbols for %s...done" mod))) + (progn + (message "Loading symbols for %s..." mod) + (let ((syms (hhp-sync-process (format "browse %s\n" mod)))) + (message "Loading symbols for %s...done" mod) + (if (listp syms) syms nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/hhp.cabal b/hhp.cabal --- a/hhp.cabal +++ b/hhp.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: hhp -version: 1.0.4 +version: 1.0.5 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto diff --git a/lib/Hhp/Boot.hs b/lib/Hhp/Boot.hs --- a/lib/Hhp/Boot.hs +++ b/lib/Hhp/Boot.hs @@ -13,7 +13,7 @@ -- | Printing necessary information for front-end booting. bootInfo :: Options -> Cradle -> IO String bootInfo opt cradle = withGHC' $ do - initializeFlagsWithCradle opt cradle + _ <- initializeFlagsWithCradle opt cradle Nothing boot opt -- | Printing necessary information for front-end booting. diff --git a/lib/Hhp/Browse.hs b/lib/Hhp/Browse.hs --- a/lib/Hhp/Browse.hs +++ b/lib/Hhp/Browse.hs @@ -45,7 +45,7 @@ -- ^ A module name. (e.g. \"Data.List\") -> IO String browseModule opt cradle pkgmdl = withGHC' $ do - initializeFlagsWithCradle opt cradle + _ <- initializeFlagsWithCradle opt cradle Nothing browse opt pkgmdl -- | Getting functions, classes, etc from a module. @@ -100,7 +100,7 @@ where removeOps | operators opt = id - | otherwise = filter (isAlpha . unsafeHead . getOccString) + | otherwise = filter (isAlpha . unsafeHead "processExports" . getOccString) showExport :: Options -> ModuleInfo -> Name -> Ghc String showExport opt minfo e = do diff --git a/lib/Hhp/CabalApi.hs b/lib/Hhp/CabalApi.hs --- a/lib/Hhp/CabalApi.hs +++ b/lib/Hhp/CabalApi.hs @@ -6,9 +6,11 @@ getCompilerOptions, parseCabalFile, cabalAllBuildInfo, + cabalAllBuildInfo', cabalDependPackages, cabalSourceDirs, cabalAllTargets, + getHsSourceDir, ) where import Distribution.Compiler (AbiTag (NoAbiTag), unknownCompilerInfo) @@ -17,7 +19,7 @@ import qualified Distribution.Package as C import Distribution.PackageDescription ( BuildInfo, - Executable, + Executable (..), PackageDescription, TestSuite, TestSuiteInterface (..), @@ -50,11 +52,12 @@ import Control.Exception (throwIO) import Control.Monad (filterM) -import Data.Maybe (fromMaybe, mapMaybe, maybeToList) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList) import Data.Set (fromList, toList) import System.Directory (doesFileExist) import System.Environment (lookupEnv) -import System.FilePath (dropExtension, takeFileName, ()) +import System.FilePath (dropExtension, takeDirectory, takeFileName, ()) import Hhp.GhcPkg import Hhp.Types @@ -66,17 +69,20 @@ :: [GHCOption] -> Cradle -> PackageDescription + -> Maybe FilePath -> IO CompilerOptions -getCompilerOptions ghcopts cradle pkgDesc = do - gopts <- getGHCOptions ghcopts cradle rdir $ unsafeHead buildInfos +getCompilerOptions ghcopts cradle pkgDesc hsFile = do + gopts <- + getGHCOptions ghcopts cradle rdir $ unsafeHead "getCompilerOptions" buildInfos dbPkgs <- ghcPkgListEx (cradlePkgDbStack cradle) - return $ CompilerOptions gopts idirs (depPkgs dbPkgs) + let compOpt = CompilerOptions gopts idirs (depPkgs dbPkgs) + return compOpt where wdir = cradleCurrentDir cradle rdir = cradleRootDir cradle cfile = fromMaybe "error getCompilerOptions" $ cradleCabalFile cradle thisPkg = dropExtension $ takeFileName cfile - buildInfos = cabalAllBuildInfo pkgDesc + buildInfos = cabalAllBuildInfo cradle pkgDesc hsFile idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos depPkgs ps = attachPackageIds ps $ @@ -172,14 +178,59 @@ ---------------------------------------------------------------- -- | Extracting all 'BuildInfo' for libraries, executables, and tests. -cabalAllBuildInfo :: PackageDescription -> [BuildInfo] -cabalAllBuildInfo pd = libBI ++ subBI ++ execBI ++ testBI ++ benchBI +cabalAllBuildInfo + :: Cradle -> PackageDescription -> Maybe FilePath -> [BuildInfo] +cabalAllBuildInfo cradle pd mHsFile = libBI ++ subBI ++ addBI where libBI = map P.libBuildInfo $ maybeToList $ P.library pd subBI = map P.libBuildInfo $ P.subLibraries pd + addBI = fst $ cabalExtraBuildInfo (Just cradle) pd mHsFile + +-- for testing +cabalAllBuildInfo' + :: PackageDescription -> [BuildInfo] +cabalAllBuildInfo' pd = libBI ++ subBI ++ addBI + where + libBI = map P.libBuildInfo $ maybeToList $ P.library pd + subBI = map P.libBuildInfo $ P.subLibraries pd + addBI = fst $ cabalExtraBuildInfo Nothing pd Nothing + +getHsSourceDir + :: Cradle -> PackageDescription -> Maybe FilePath -> Maybe FilePath +getHsSourceDir cradle pd mHsFile = + snd $ cabalExtraBuildInfo (Just cradle) pd mHsFile + +cabalExtraBuildInfo + :: Maybe Cradle + -> PackageDescription + -> Maybe FilePath + -> ([BuildInfo], Maybe FilePath) +cabalExtraBuildInfo mcradle pd mHsFile = (addBI, hsDir addBI) + where execBI = map P.buildInfo $ P.executables pd testBI = map P.testBuildInfo $ P.testSuites pd benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd + addBI0 = execBI ++ testBI ++ benchBI + addBI = case mHsFile of + Nothing -> addBI0 -- fixme: Is [] more suitable? + Just hsFile -> case mcradle of + Nothing -> addBI0 -- fixme: Is [] more suitable? + Just cradle -> do + let hsFile' = takeRelativePath cradle hsFile + in filter (include hsFile') addBI0 + include hsFile b = any (`match` hsFile) $ map toPath $ P.hsSourceDirs b + match "." _ = True + match dir fn = dir `isPrefixOf` fn + hsDir [] = Nothing + hsDir (b : _) = toPath <$> listToMaybe (P.hsSourceDirs b) + +takeRelativePath :: Cradle -> FilePath -> FilePath +takeRelativePath cradle fn = rp + where + root = cradleRootDir cradle + rp + | root `isPrefixOf` fn = takeDirectory $ drop (length root + 1) fn + | otherwise = takeDirectory fn ---------------------------------------------------------------- diff --git a/lib/Hhp/Check.hs b/lib/Hhp/Check.hs --- a/lib/Hhp/Check.hs +++ b/lib/Hhp/Check.hs @@ -12,6 +12,8 @@ import Hhp.Logger import Hhp.Types +import Data.Maybe + ---------------------------------------------------------------- -- | Checking syntax of a target file using GHC. @@ -24,7 +26,7 @@ -> IO String checkSyntax _ _ [] = return "" checkSyntax opt cradle files = withGHC sessionName $ do - initializeFlagsWithCradle opt cradle + _ <- initializeFlagsWithCradle opt cradle $ listToMaybe files either id id <$> check opt files where sessionName = case files of @@ -55,7 +57,7 @@ -> IO String expandTemplate _ _ [] = return "" expandTemplate opt cradle files = withGHC sessionName $ do - initializeFlagsWithCradle opt cradle + _ <- initializeFlagsWithCradle opt cradle $ listToMaybe files either id id <$> expand opt files where sessionName = case files of diff --git a/lib/Hhp/Debug.hs b/lib/Hhp/Debug.hs --- a/lib/Hhp/Debug.hs +++ b/lib/Hhp/Debug.hs @@ -43,7 +43,7 @@ simpleCompilerOption = CompilerOptions origGopts [] [] fromCabalFile = do pkgDesc <- parseCabalFile file - getCompilerOptions origGopts cradle pkgDesc + getCompilerOptions origGopts cradle pkgDesc Nothing where file = fromJust mCabalFile diff --git a/lib/Hhp/Find.hs b/lib/Hhp/Find.hs --- a/lib/Hhp/Find.hs +++ b/lib/Hhp/Find.hs @@ -37,7 +37,7 @@ -- | Finding modules to which the symbol belong. findSymbol :: Options -> Cradle -> Symbol -> IO String findSymbol opt cradle sym = withGHC' $ do - initializeFlagsWithCradle opt cradle + _ <- initializeFlagsWithCradle opt cradle Nothing lookupSym opt sym <$> getSymMdlDb -- | Creating 'SymMdlDb'. @@ -48,7 +48,7 @@ !m = force $ M.fromList sms return (SymMdlDb m) where - tieup x = (unsafeHead (map fst x), map snd x) + tieup x = (unsafeHead "getSymMdlDb" (map fst x), map snd x) -- | Looking up 'SymMdlDb' with 'Symbol' to find modules. lookupSym :: Options -> Symbol -> SymMdlDb -> String diff --git a/lib/Hhp/GHCApi.hs b/lib/Hhp/GHCApi.hs --- a/lib/Hhp/GHCApi.hs +++ b/lib/Hhp/GHCApi.hs @@ -16,6 +16,8 @@ setDeferTypeErrors, setPartialSignatures, setWarnTypedHoles, + Reset, + GetHSDir, ) where import GHC (DynFlags (..), Ghc, LoadHowMuch (..)) @@ -88,14 +90,18 @@ data Build = CabalPkg | SingleFile deriving (Eq) +type Reset = Maybe FilePath -> Ghc () +type GetHSDir = Maybe FilePath -> Maybe FilePath + -- | Initialize the 'DynFlags' relating to the compilation of a single -- file or GHC session according to the 'Cradle' and 'Options' -- provided. initializeFlagsWithCradle :: Options -> Cradle - -> Ghc () -initializeFlagsWithCradle opt cradle + -> Maybe FilePath + -> Ghc (Reset, GetHSDir) +initializeFlagsWithCradle opt cradle mHsFile | cabal = withCabal <|> withSandbox | otherwise = withSandbox where @@ -104,16 +110,27 @@ ghcopts = ghcOpts opt withCabal = do pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile - compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc - initSession CabalPkg opt compOpts - withSandbox = initSession SingleFile opt compOpts + let reset = makeReset pkgDesc + gethsd = getHsSourceDir cradle pkgDesc + reset mHsFile + return (reset, gethsd) where - pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle - compOpts - | null pkgOpts = CompilerOptions ghcopts importDirs [] - | otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir, rdir] [] - wdir = cradleCurrentDir cradle - rdir = cradleRootDir cradle + makeReset pkgDesc mfn = do + compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc mfn + initSession CabalPkg opt compOpts + withSandbox = do + reset mHsFile + return (reset, gethsd) + where + gethsd _ = Nothing + reset _ = initSession SingleFile opt compOpts + where + pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle + compOpts + | null pkgOpts = CompilerOptions ghcopts importDirs [] + | otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir, rdir] [] + wdir = cradleCurrentDir cradle + rdir = cradleRootDir cradle ---------------------------------------------------------------- diff --git a/lib/Hhp/Ghc.hs b/lib/Hhp/Ghc.hs --- a/lib/Hhp/Ghc.hs +++ b/lib/Hhp/Ghc.hs @@ -7,6 +7,8 @@ -- * Initializing DynFlags initializeFlagsWithCradle, + Reset, + GetHSDir, -- * Ghc utilities boot, diff --git a/lib/Hhp/GhcPkg.hs b/lib/Hhp/GhcPkg.hs --- a/lib/Hhp/GhcPkg.hs +++ b/lib/Hhp/GhcPkg.hs @@ -63,7 +63,7 @@ key = "package-db:" keyLen = length key - parse = unsafeHead . filter (key `isPrefixOf`) . lines + parse = unsafeHead "getSandboxDbDir" . filter (key `isPrefixOf`) . lines extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen getPackageDbStack diff --git a/lib/Hhp/Info.hs b/lib/Hhp/Info.hs --- a/lib/Hhp/Info.hs +++ b/lib/Hhp/Info.hs @@ -60,7 +60,7 @@ -- ^ A Haskell expression. -> IO String infoExpr opt cradle file expr = withGHC' $ do - initializeFlagsWithCradle opt cradle + _ <- initializeFlagsWithCradle opt cradle Nothing info opt file expr -- | Obtaining information of a target expression. (GHCi's info:) @@ -92,7 +92,7 @@ -- ^ Column number. -> IO String typeExpr opt cradle file lineNo colNo = withGHC' $ do - initializeFlagsWithCradle opt cradle + _ <- initializeFlagsWithCradle opt cradle Nothing types opt file lineNo colNo -- | Obtaining type of a target expression. (GHCi's type:) diff --git a/lib/Hhp/List.hs b/lib/Hhp/List.hs --- a/lib/Hhp/List.hs +++ b/lib/Hhp/List.hs @@ -18,7 +18,7 @@ -- | Listing installed modules. listModules :: Options -> Cradle -> IO String listModules opt cradle = withGHC' $ do - initializeFlagsWithCradle opt cradle + _ <- initializeFlagsWithCradle opt cradle Nothing modules opt -- | Listing installed modules. diff --git a/lib/Hhp/Types.hs b/lib/Hhp/Types.hs --- a/lib/Hhp/Types.hs +++ b/lib/Hhp/Types.hs @@ -220,6 +220,6 @@ x <|> y = x `catch` (\(_ :: IOException) -> y) empty = undefined -unsafeHead :: [a] -> a -unsafeHead [] = error "unsafeHead" -unsafeHead (x : _) = x +unsafeHead :: String -> [a] -> a +unsafeHead msg [] = error $ "unsafeHead: " ++ msg +unsafeHead _ (x : _) = x diff --git a/src/hhpi.hs b/src/hhpi.hs --- a/src/hhpi.hs +++ b/src/hhpi.hs @@ -23,6 +23,7 @@ import Control.Exception (Exception, SomeException (..)) import qualified Control.Exception as E import Control.Monad (void, when) +import Data.IORef import Data.Set (Set) import qualified Data.Set as S import Data.Version (showVersion) @@ -111,7 +112,8 @@ mvar <- liftIO newEmptyMVar mlibdir <- getSystemLibDir void $ forkIO $ setupDB cradle mlibdir opt mvar - run cradle mlibdir opt $ loop opt S.empty mvar + ref <- newIORef $ Just "." + run cradle mlibdir opt $ loop cradle opt S.empty mvar ref where -- this is just in case. -- If an error is caught here, it is a bug of Hhp library. @@ -125,29 +127,47 @@ ---------------------------------------------------------------- -run :: Cradle -> Maybe FilePath -> Options -> Ghc a -> IO a +run + :: Cradle + -> Maybe FilePath + -> Options + -> ((Reset, GetHSDir) -> Ghc a) + -> IO a run cradle mlibdir opt body = runGhc mlibdir $ do - initializeFlagsWithCradle opt cradle - body + x <- initializeFlagsWithCradle opt cradle Nothing + body x ---------------------------------------------------------------- setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> IO () setupDB cradle mlibdir opt mvar = E.handle handler $ do - db <- run cradle mlibdir opt getSymMdlDb + db <- run cradle mlibdir opt $ \_ -> getSymMdlDb putMVar mvar db where handler (SomeException _) = return () -- fixme: put emptyDb? ---------------------------------------------------------------- -loop :: Options -> Set FilePath -> MVar SymMdlDb -> Ghc () -loop opt set mvar = do +loop + :: Cradle + -> Options + -> Set FilePath + -> MVar SymMdlDb + -> IORef (Maybe FilePath) + -> (Reset, GetHSDir) + -> Ghc () +loop cradle opt set mvar ref ops@(reset, getHsDir) = do cmdArg <- liftIO getLine let (cmd, arg') = break (== ' ') cmdArg arg = dropWhile (== ' ') arg' (ret, ok, set') <- case cmd of - "check" -> checkStx opt set arg + "check" -> do + rp0 <- liftIO $ readIORef ref + let rp1 = getHsDir $ Just arg + when (rp0 /= rp1) $ do + liftIO $ writeIORef ref rp1 + reset $ Just arg + checkStx opt set arg "find" -> findSym opt set arg mvar "lint" -> lintStx opt set arg "info" -> showInfo opt set arg @@ -164,7 +184,7 @@ else do liftIO $ putStrLn $ "NG " ++ replace ret liftIO $ hFlush stdout - when ok $ loop opt set' mvar + when ok $ loop cradle opt set' mvar ref ops ---------------------------------------------------------------- diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -37,26 +37,26 @@ describe "cabalDependPackages" $ do it "extracts dependent packages" $ do pkgs <- - cabalDependPackages . cabalAllBuildInfo + cabalDependPackages . cabalAllBuildInfo' <$> parseCabalFile "test/data/cabalapi.cabal" pkgs `shouldBe` ["Cabal", "base", "template-haskell"] describe "cabalSourceDirs" $ do it "extracts all hs-source-dirs" $ do dirs <- - cabalSourceDirs . cabalAllBuildInfo + cabalSourceDirs . cabalAllBuildInfo' <$> parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal" dirs `shouldBe` ["src", "test"] it "extracts all hs-source-dirs including \".\"" $ do dirs <- - cabalSourceDirs . cabalAllBuildInfo + cabalSourceDirs . cabalAllBuildInfo' <$> parseCabalFile "test/data/cabalapi.cabal" dirs `shouldBe` [".", "test"] describe "cabal-subLibraries" $ do it "dependent packages with sublib" $ do pkgs <- - cabalDependPackages . cabalAllBuildInfo + cabalDependPackages . cabalAllBuildInfo' <$> parseCabalFile "test/data/check-sublib/check-sublib.cabal" pkgs `shouldBe` ["array", "base", "bytestring"] @@ -64,19 +64,19 @@ it "dependent packages without flags" $ do unsetEnv "HHP_CABAL_FLAGS" pkgs <- - cabalDependPackages . cabalAllBuildInfo + cabalDependPackages . cabalAllBuildInfo' <$> parseCabalFile "test/data/check-flags/check-flags.cabal" pkgs `shouldBe` ["base", "directory"] it "dependent packages with foo flag" $ do setEnv "HHP_CABAL_FLAGS" "foo" pkgs <- - cabalDependPackages . cabalAllBuildInfo + cabalDependPackages . cabalAllBuildInfo' <$> parseCabalFile "test/data/check-flags/check-flags.cabal" pkgs `shouldBe` ["base", "directory", "filepath"] it "dependent packages with foo and -bar flag" $ do setEnv "HHP_CABAL_FLAGS" "foo -bar" pkgs <- - cabalDependPackages . cabalAllBuildInfo + cabalDependPackages . cabalAllBuildInfo' <$> parseCabalFile "test/data/check-flags/check-flags.cabal" pkgs `shouldBe` ["base", "filepath"] diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -20,16 +20,17 @@ `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n" it - "can check even if a test module imports another test module located at different directory" $ do - withDirectory_ "test/data/check-test-subdir" $ do - cradle <- findCradleWithoutSandbox - res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"] - res - `shouldSatisfy` ( ( "test" - "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: String\n" - ) - `isSuffixOf` - ) + "can check even if a test module imports another test module located at different directory" + $ do + withDirectory_ "test/data/check-test-subdir" $ do + cradle <- findCradleWithoutSandbox + res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"] + res + `shouldSatisfy` ( ( "test" + "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: String\n" + ) + `isSuffixOf` + ) it "can detect mutually imported modules" $ do withDirectory_ "test/data" $ do