diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Revision history for cabal-hoogle -## 0.1.0.0 -- 2022-07-22 +## 3.10.0.0 -- 2024-02-25 + +* Switch to Cabal 3.10 +* Support GHC 9.4 and 9.6 + +## 0.2.0 -- 2022-08-22 + +Powered by `cabal-install` 3.8, the usage is greatly simplified. `cabal-hoogle` +now statically links `cabal-install` and `hoogle`. You no longer need to worry about +`Cabal` minor version mismatch and manual installation of hoogle. + +## 0.1.0.0 -- 2022-07-23 * First version. Supports `cabal-hoogle generate` and `cabal-hoogle run` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,70 +8,34 @@ ## Installation -Compiling from source requires a minimum GHC version of 8.10. Having `cabal-hoogle` installed, you may use it on a wider range of GHC, -as long as the `Cabal` used to build `cabal-hoogle` and `cabal-install` match. - -Step 1, run `cabal update` to make sure you are using the latest hackage index - -Step 2, check the `Cabal` library version used by your cabal ``` -cabal --version -``` -It shows my cabal is using `3.6.3.0` of Cabal library. **`cabal-hoogle` requires at least Cabal 3.2**. Update it before continue. -``` -cabal-install version 3.6.2.0 -compiled using version 3.6.3.0 of the Cabal library -``` - -Step 3, use `cabal install` to install `cabal-hoogle` from Hackage, specifying the `Cabal` library version you fetched above. -``` -cabal install --constraint="Cabal == 3.6.3.0" cabal-hoogle +git clone https://github.com/kokobd/cabal-hoogle.git +cd cabal-hoogle +cabal install exe:cabal-hoogle ``` ## Usage -### Prerequisite - -#### Install Hoogle -Make sure `hoogle` is installed in your `$PATH`. You can do this by running `cabal install hoogle` - -#### Enable Hoogle for Cabal -Make sure your `~/.cabal/config` has the following entries. (DON'T remove existing entries!) [Check the official docs](https://cabal.readthedocs.io/en/3.6/installing-packages.html) if you don't know where is your cabal's global configuration file +### Generate +Within your project, run: ``` -documentation: True -haddock - hoogle: True - html: True -``` - -Or, run this command in bash: -``` -cabal user-config update -a "documentation: True -haddock - hoogle: True - html: True" +cabal-hoogle generate ``` -#### Build Project with Cabal - -Then, run `cabal build all` on your project, so that cabal will build haddock and -hoogle files for your local packages and dependencies. - -> NOTE: Adding `--enable-documentation --haddock-hoogle --haddock-html` to your build command won't work for dependencies as I tried. +This generates a hoogle database for all the local packages and their dependencies. -### Generate +You may specify targets, like below: ``` -cabal-hoogle generate +cabal-hoogle generate exe:haskell-language-server hls-code-range-plugin ``` - -This generates the hoogle database. You will see logs very similar to `stack hoogle --rebuild` +See [Cabal Docs](https://cabal.readthedocs.io/en/3.8/cabal-commands.html#target-forms) for target syntax ### Run Hoogle With `cabal-hoogle run --`, extra arguments are passed directly to `hoogle`. -You may start a server like this: +You may start an http server like this: ``` cabal-hoogle run -- server --local --port 9000 ``` @@ -83,31 +47,4 @@ ### More Options -Run `cabal-hoogle --help` to see more options. For example if you are using a non-default build dir (not `dist-newstyle`), or you have multiple GHC verisons on the same project. - -Below is a complex example: -``` -cabal-hoogle --compiler ghc-9.2.3 --platform "x86_64-linux" --builddir mydist generate -``` - -## FAQ - -### Many packages missing documentation - -If you see output like this when running `cabal-hoogle generate` -``` -Packages missing documentation: ansi-terminal ansi-wl-pprint async base-orphans base16-bytestring base64-bytestring Cabal cabal-hoogle clock colour extra hashable haskell-src-exts haskell-src-meta optparse-applicative primitive regex-base regex-tdfa safe split string-interpolate syb text-conversions th-abstraction th-compat th-expand-syns th-lift th-lift-instances th-orphans th-reify-many transformers-compat typed-process unliftio-core utf8-string vector vector-stream -Found 27 warnings when processing items -``` - -Probably you haven't built dependencies with hoogle enabled. Check [prerequisites](#prerequisite) more carefully. - -### Cabal version mismatch - -Make sure to build `cabal-hoogle` with the exact same `Cabal` library as your `cabal-install`. You can use `cabal --version` -to check the version of `Cabal` library. See [Installation](#installation). - -### Core libraries missing documentation - -If you are on macOS or Windows, and using `ghcup`, your `ghc` probably doesn't come with docs. -See [this](https://gitlab.haskell.org/ghc/ghc/-/issues/20903) and [this](https://github.com/haskell/haskell-language-server/issues/208#issuecomment-1162169087) for details of the upstream issue. +Run `cabal-hoogle --help` to see more options. diff --git a/cabal-hoogle.cabal b/cabal-hoogle.cabal --- a/cabal-hoogle.cabal +++ b/cabal-hoogle.cabal @@ -1,8 +1,10 @@ cabal-version: 3.0 name: cabal-hoogle -version: 0.1.0.0 -synopsis: Just like "stack hoogle", but for cabal projects -description: This tool +version: 3.10.0.0 +synopsis: generate hoogle database for cabal project and dependencies +description: + Please see the README on GitHub at + bug-reports: https://github.com/kokobd/cabal-hoogle/issues license: BSD-3-Clause author: kokobd @@ -12,55 +14,71 @@ category: Development build-type: Simple extra-source-files: - CHANGELOG.md - README.md + CHANGELOG.md + README.md +source-repository head + type: git + location: https://github.com/kokobd/cabal-hoogle + library - build-depends: - base >= 4.14 && < 5 - , Cabal >= 3.2.0.0 && < 4 - , containers ^>= 0.6.2.1 - , directory ^>= 1.3.6 - , filepath ^>= 1.4.2 - , optparse-applicative ^>= 0.17.0 - , regex-tdfa ^>= 1.3.1 - , string-interpolate ^>= 0.3.1.2 - , text ^>= 1.2.4 - , transformers ^>= 0.5.6 - , typed-process ^>= 0.2.10 - , extra ^>= 1.7.10 - default-language: Haskell2010 - ghc-options: -Wall - hs-source-dirs: src - default-extensions: - OverloadedStrings - QuasiQuotes - exposed-modules: - Hoogle.Cabal - Hoogle.Cabal.CmdOptions + build-depends: + , base >=4.14 && <5 + , Cabal ^>=3.10 + , cabal-install ^>=3.10 + , Cabal-syntax ^>=3.10 + , co-log-core >=0.2 && <0.4 + , containers ^>=0.6.2.1 + , directory ^>=1.3.6 + , extra ^>=1.7.10 + , filepath ^>=1.4.2 + , hoogle ^>=5.0.18 + , lens >=5 && <6 + , optparse-applicative >=0.16 && <1 + , regex-tdfa ^>=1.3.1 + , string-interpolate ^>=0.3.1.2 + , text ^>=1.2.4 || ^>=2.0 + , time >=1.10 && <2 + , transformers ^>=0.5.6 || ^>=0.6 + , typed-process ^>=0.2.10 + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + default-extensions: + OverloadedStrings + QuasiQuotes + + exposed-modules: Hoogle.Cabal + other-modules: + Hoogle.Cabal.Command + Hoogle.Cabal.Command.ActAsSetup + Hoogle.Cabal.Command.Common + Hoogle.Cabal.Command.Generate + Hoogle.Cabal.Command.Run + Hoogle.Cabal.Command.Version + Hoogle.Cabal.Logger + executable cabal-hoogle - main-is: Main.hs - hs-source-dirs: app - default-language: Haskell2010 - ghc-options: -threaded -rtsopts - build-depends: - base - , cabal-hoogle + main-is: Main.hs + hs-source-dirs: app + default-language: Haskell2010 + ghc-options: -threaded -rtsopts + build-depends: + , base + , cabal-hoogle test-suite tests - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: test - main-is: Main.hs - other-modules: - IntegrationTest + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + other-modules: IntegrationTest build-depends: - base + , base , cabal-hoogle - , tasty ^>= 1.4.2.3 - , tasty-hunit ^>= 0.10.0.3 - , silently ^>= 1.2.5.2 - build-tool-depends: - , tasty-discover:tasty-discover - , hoogle:hoogle + , silently ^>=1.2.5.2 + , tasty ^>=1.4.2.3 + , tasty-hunit ^>=0.10.0.3 + + build-tool-depends: tasty-discover:tasty-discover diff --git a/src/Hoogle/Cabal.hs b/src/Hoogle/Cabal.hs --- a/src/Hoogle/Cabal.hs +++ b/src/Hoogle/Cabal.hs @@ -1,131 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} module Hoogle.Cabal (main) where -import Control.Exception (catch, throw) -import Control.Monad (unless) -import Data.Bifunctor (Bifunctor (second)) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.List.NonEmpty.Extra as NonEmpty -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes) -import Data.String.Interpolate (i) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Traversable (forM) -import Distribution.InstalledPackageInfo (InstalledPackageInfo (haddockHTMLs, installedUnitId)) -import Distribution.Simple.Configure (getPersistBuildConfig) -import Distribution.Simple.PackageIndex (allPackagesByName) -import Distribution.Types.LocalBuildInfo (LocalBuildInfo, installedPkgs, localPkgDescr) -import Distribution.Types.PackageDescription (PackageDescription (package)) -import Distribution.Types.PackageId (pkgName) -import Distribution.Types.PackageName (PackageName, unPackageName) -import Hoogle.Cabal.CmdOptions -import System.Directory (createDirectoryIfMissing, createDirectoryLink, listDirectory, makeAbsolute, removeDirectoryLink, removeDirectoryRecursive, withCurrentDirectory) -import System.Exit (exitFailure) -import System.FilePath -import System.IO (stderr) -import System.IO.Error (isDoesNotExistError) -import System.Process.Typed -import Text.Regex.TDFA ((=~)) -import Prelude hiding (log) +import Hoogle.Cabal.Command (executeCommand) +import Hoogle.Cabal.Logger (stdoutLogger) main :: IO () -main = do - CmdOptions {..} <- readCmdOptions - localPackagesDir <- findLocalPackagesBuildDir cmdOptions_compiler cmdOptions_platform cmdOptions_builddir - let hoogleDir = localPackagesDir ".hoogle" - hoogleLocalPackagesDir = hoogleDir "local" - hoogleDependenciesDir = hoogleDir "dependencies" - - case cmdOptions_command of - CommandGenerate -> do - catch (removeDirectoryRecursive hoogleDir) $ \(err :: IOError) -> - if isDoesNotExistError err then pure () else throw err - createDirectoryIfMissing True hoogleLocalPackagesDir - createDirectoryIfMissing True hoogleDependenciesDir - localPackages <- symlinkLocalPackages localPackagesDir hoogleLocalPackagesDir - let localPkgsName = fmap (pkgName . package . localPkgDescr) localPackages - dependenciesName <- symlinkDependencies localPackages hoogleDependenciesDir - let nameStrs = fmap unPackageName (localPkgsName <> dependenciesName) - withCurrentDirectory hoogleDir $ do - runProcess_ . proc "hoogle" $ - ["generate", databaseArg, "--local=local", "--local=dependencies"] ++ nameStrs - CommandRun hoogleArgs -> do - let hoogleArgs' = case hoogleArgs of - (x : xs) -> x : databaseArg : xs - [] -> [databaseArg] - withCurrentDirectory hoogleDir . runProcess_ . proc "hoogle" $ - hoogleArgs' - where - databaseArg = "--database=all.hoo" - -findLocalPackagesBuildDir :: - -- | compiler - Maybe Text -> - -- | platform - Maybe Text -> - -- | cabal project build dir (often dist-newstyle) - FilePath -> - IO FilePath -findLocalPackagesBuildDir compiler platform projectBuildDir = do - -- directory layout: dist-newstyle/build/x86_64-linux/ghc-9.2.3/$PACKAGE_NAME - projectBuildDir' <- makeAbsolute projectBuildDir - platformDir <- enterSubDir (projectBuildDir' "build") "platform" (fmap T.unpack platform) - enterSubDir platformDir "compiler" (fmap T.unpack compiler) - -exitOnError :: Text -> IO a -exitOnError log = do - T.hPutStrLn stderr log - exitFailure - -enterSubDir :: FilePath -> Text -> Maybe FilePath -> IO FilePath -enterSubDir baseDir realm givenSubDir = do - subDirs <- listDirectory baseDir - case givenSubDir >>= (\d -> if d `notElem` subDirs then Just d else Nothing) of - Just wrongSubDir -> exitOnError [i|specified #{realm} #{wrongSubDir} doesn't not exist, make sure to build first|] - Nothing -> case selectSubDir subDirs givenSubDir of - Just subDir -> pure $ baseDir subDir - _ -> exitOnError [i|failed to guess #{realm}, please specify one|] - where - selectSubDir :: [FilePath] -> Maybe FilePath -> Maybe FilePath - selectSubDir [exactlyOne] _ = Just exactlyOne - selectSubDir _ given = given - -symlinkLocalPackages :: FilePath -> FilePath -> IO [LocalBuildInfo] -symlinkLocalPackages localPackagesDir destDir = do - localPackages <- filter (=~ packageNameRegex) <$> listDirectory localPackagesDir - forM localPackages $ \pkg -> do - catch (removeDirectoryLink (destDir pkg)) $ \(e :: IOError) -> - if isDoesNotExistError e then pure () else throw e - createDirectoryLink (localPackagesDir pkg) (destDir pkg) - getPersistBuildConfig (localPackagesDir pkg) - where - packageNameRegex :: String = - "[[:digit:]]*[[:alpha:]][[:alnum:]]*(-[[:digit:]]*[[:alpha:]][[:alnum:]]*)*-[0-9]+([.][0-9]+)*" - -symlinkDependencies :: [LocalBuildInfo] -> FilePath -> IO [PackageName] -symlinkDependencies localPackages hoogleDependenciesDir = do - let nameToPkgs = - fmap (NonEmpty.nubOrdOn installedUnitId) . Map.fromListWith (<>) $ - concatMap collectDependenciesForPkg localPackages - pkgs <- fmap catMaybes . forM (Map.toList nameToPkgs) $ \(name, allPkgs@(pkg NonEmpty.:| pkgs)) -> do - unless (null pkgs) $ - T.putStrLn [i|Warning: package #{name} has more than 1 version installed, this should not happen. all pkgs: #{fmap installedUnitId allPkgs}|] - case haddockHTMLs pkg of - [htmlDir] -> pure $ Just (name, htmlDir) - htmlDirs -> do - T.putStrLn [i|Warning: package #{name} doesn't have exactly one haddock html directory, actual: #{htmlDirs}|] - pure Nothing - forM pkgs $ \(name, dir) -> do - createDirectoryLink dir (hoogleDependenciesDir unPackageName name) - pure name - where - collectDependenciesForPkg pkg = - let depsWithName = allPackagesByName (installedPkgs pkg) - in fmap (second (NonEmpty.:| [])) - . concatMap (\(name, pkgs) -> fmap (name,) pkgs) - $ depsWithName +main = executeCommand stdoutLogger diff --git a/src/Hoogle/Cabal/CmdOptions.hs b/src/Hoogle/Cabal/CmdOptions.hs deleted file mode 100644 --- a/src/Hoogle/Cabal/CmdOptions.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Hoogle.Cabal.CmdOptions - ( CmdOptions (..), - readCmdOptions, - Command (..), - ) -where - -import Data.Text (Text) -import Options.Applicative - -data CmdOptions = CmdOptions - { cmdOptions_compiler :: Maybe Text, - cmdOptions_platform :: Maybe Text, - cmdOptions_builddir :: FilePath, - cmdOptions_command :: Command - } - deriving (Show, Eq) - -data Command - = CommandGenerate - | CommandRun [String] - deriving (Show, Eq) - -parser :: Parser CmdOptions -parser = - CmdOptions - <$> (optional . strOption) - ( long "compiler" - <> help "compiler name and version, for example 'ghc-9.2.3'" - ) - <*> (optional . strOption) - ( long "platform" - <> help "platform, for example x86_64-linux" - ) - <*> strOption - ( long "builddir" - <> value "dist-newstyle" - <> help "cabal project build dir" - ) - <*> hsubparser - ( command "generate" (info (pure CommandGenerate) (progDesc "generate hoogle database")) - <> command "run" (info commandRunParser (progDesc "run hoogle, with arbitrary arguments")) - ) - -commandRunParser :: Parser Command -commandRunParser = CommandRun <$> (many . strArgument) (metavar "ARGS") - -readCmdOptions :: IO CmdOptions -readCmdOptions = execParser parserInfo - where - parserInfo = - info - (parser <**> helper) - ( fullDesc - <> progDesc - ( "Run hoogle on your local packages and dependencies. " - <> "See https://github.com/kokobd/cabal-hoogle for more information" - ) - ) diff --git a/src/Hoogle/Cabal/Command.hs b/src/Hoogle/Cabal/Command.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Cabal/Command.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hoogle.Cabal.Command where + +import qualified Hoogle.Cabal.Command.ActAsSetup as ActAsSetup +import Hoogle.Cabal.Command.Common +import qualified Hoogle.Cabal.Command.Generate as Generate +import qualified Hoogle.Cabal.Command.Run as Run +import qualified Hoogle.Cabal.Command.Version as Version +import Hoogle.Cabal.Logger +import Options.Applicative + +data CmdOptions = CmdOptions + { _cmdOptions_global :: GlobalOptions, + _cmdOptions_command :: Maybe Command + } + deriving (Show, Eq) + +data Command + = CommandGenerate Generate.Command + | CommandRun Run.Command + | CommandActAsSetup ActAsSetup.Command + | CommandVersion Version.Command + deriving (Show, Eq) + +data Log + = LogGenerate Generate.Log + | LogRun Run.Log + +instance Show Log where + show (LogGenerate l) = show l + show (LogRun l) = show l + +executeCommand :: Logger Log -> IO () +executeCommand logger = do + CmdOptions {..} <- readCmdOptions + if _globalOptions_version _cmdOptions_global + then Version.action Version.Command + else case _cmdOptions_command of + Nothing -> pure () + Just cmd' -> case cmd' of + CommandGenerate cmd -> Generate.action (cmapLogger LogGenerate logger) _cmdOptions_global cmd + CommandActAsSetup cmd -> ActAsSetup.action cmd + CommandRun cmd -> Run.action (cmapLogger LogRun logger) _cmdOptions_global cmd + CommandVersion cmd -> Version.action cmd + +parser :: Parser CmdOptions +parser = + CmdOptions + <$> globalOptionsParser + <*> optional + ( hsubparser + ( Generate.command CommandGenerate + <> Run.command CommandRun + <> Version.command CommandVersion + <> ActAsSetup.command CommandActAsSetup + ) + ) + +readCmdOptions :: IO CmdOptions +readCmdOptions = execParser parserInfo + where + parserInfo = + info + (parser <**> helper) + ( fullDesc + <> progDesc + ( "Run hoogle on your local packages and dependencies. " + <> "See https://github.com/kokobd/cabal-hoogle for more information" + ) + ) diff --git a/src/Hoogle/Cabal/Command/ActAsSetup.hs b/src/Hoogle/Cabal/Command/ActAsSetup.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Cabal/Command/ActAsSetup.hs @@ -0,0 +1,43 @@ +module Hoogle.Cabal.Command.ActAsSetup + ( command, + Command, + action, + ) +where + +import Data.Maybe (fromJust) +import qualified Distribution.Make as Make +import Distribution.Parsec (simpleParsec) +import qualified Distribution.Simple as Simple +import Distribution.Types.BuildType +import qualified Options.Applicative as OptParse + +data Command = Command + { _buildType :: String, + _args :: [String] + } + deriving (Show, Eq) + +command :: (Command -> a) -> OptParse.Mod OptParse.CommandFields a +command f = + OptParse.command + "act-as-setup" + (OptParse.info (fmap f commandParser) (OptParse.progDesc "(Internal) Run as-if this was a Setup.hs")) + +commandParser :: OptParse.Parser Command +commandParser = + Command + <$> OptParse.strOption (OptParse.long "build-type") + <*> (OptParse.many . OptParse.strArgument) (OptParse.metavar "ARGS") + +action :: Command -> IO () +action (Command buildTypeStr args) = + let bt = fromJust $ simpleParsec buildTypeStr -- TODO: report error properly + in case bt of + Simple -> Simple.defaultMainArgs args + Configure -> + Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks + args + Make -> Make.defaultMainArgs args + Custom -> error "actAsSetupAction Custom" diff --git a/src/Hoogle/Cabal/Command/Common.hs b/src/Hoogle/Cabal/Command/Common.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Cabal/Command/Common.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hoogle.Cabal.Command.Common + ( GlobalOptions (..), + globalOptionsParser, + hoogleDatabaseArg, + Context (..), + readContext, + ) +where + +import qualified Data.Map.Strict as Map +import Distribution.Client.CmdBuild (BuildFlags, defaultBuildFlags, selectComponentTarget, selectPackageTargets) +import Distribution.Client.CmdErrorMessages (renderCannotPruneDependencies, reportTargetProblems) +import Distribution.Client.DistDirLayout (distDirectory) +import Distribution.Client.NixStyleOptions +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ScriptUtils +import Distribution.Client.Setup (GlobalFlags, InstallFlags (..), defaultGlobalFlags) +import Distribution.Simple (OptimisationLevel (NoOptimisation)) +import Distribution.Simple.Setup (ConfigFlags (..), Flag (..), HaddockFlags (..)) +import Distribution.Simple.Utils (die') +import qualified Distribution.Verbosity as Verbosity +import Options.Applicative +import System.FilePath (()) + +data GlobalOptions = GlobalOptions + { _globalOptions_builddir :: FilePath, + _globalOptions_version :: Bool + } + deriving (Show, Eq) + +globalOptionsParser :: Parser GlobalOptions +globalOptionsParser = + GlobalOptions + <$> strOption + ( long "builddir" + <> value "dist-newstyle/hoogle" + <> help "Cabal project build dir" + ) + <*> switch + ( long "version" + <> help "Print version" + ) + +hoogleDatabaseArg :: String +hoogleDatabaseArg = "--database=all.hoo" + +data Context = Context + { _context_baseCtx :: ProjectBaseContext, + _context_buildCtx :: ProjectBuildContext, + _context_hoogleDir :: FilePath, + _context_targetStrings :: [String], + _context_flags :: NixStyleFlags BuildFlags, + _context_globalFlags :: GlobalFlags + } + +-- | This is copied from the implementation of 'buildAction' +readContext :: + GlobalOptions -> + [String] -> + IO Context +readContext GlobalOptions {..} targetStrings = + withContextAndSelectors RejectNoTargets Nothing flags targetStrings' globalFlags HaddockCommand $ \targetCtx ctx targetSelectors -> do + let targetAction = TargetActionBuild + + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> return ctx + ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta + + let verbosity = Verbosity.normal + buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- + either (reportTargetProblems verbosity "build") return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = + pruneInstallPlanToTargets + targetAction + targets + elaboratedPlan + elaboratedPlan'' <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then + either (die' verbosity . renderCannotPruneDependencies) return $ + pruneInstallPlanToDependencies + (Map.keysSet targets) + elaboratedPlan' + else return elaboratedPlan' + + return (elaboratedPlan'', targets) + pure $ + Context + baseCtx + buildCtx + (distDirectory (distDirLayout baseCtx) ".hoogle") + targetStrings' + flags + globalFlags + where + defaultFlags = defaultNixStyleFlags defaultBuildFlags + flags = + defaultFlags + { configFlags = + (configFlags defaultFlags) + { configOptimization = Flag NoOptimisation, + configDistPref = Flag _globalOptions_builddir + }, + haddockFlags = + (haddockFlags defaultFlags) + { haddockHoogle = Flag True, + haddockHtml = Flag True, + haddockLinkedSource = Flag True, + haddockQuickJump = Flag True + }, + installFlags = + (installFlags defaultFlags) + { installDocumentation = Flag True + } + } + targetStrings' :: [String] + targetStrings' = if null targetStrings then ["all"] else targetStrings + globalFlags = defaultGlobalFlags diff --git a/src/Hoogle/Cabal/Command/Generate.hs b/src/Hoogle/Cabal/Command/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Cabal/Command/Generate.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Hoogle.Cabal.Command.Generate + ( Log, + command, + Command, + action, + ) +where + +import Control.Exception (catch, throw) +import Control.Monad (unless) +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Data.Bifunctor (Bifunctor (second)) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.List.NonEmpty.Extra as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.String.Interpolate (i) +import qualified Data.Text as T +import Data.Traversable (forM) +import Distribution.Client.CmdBuild + ( buildAction, + ) +import Distribution.Client.DistDirLayout (DistDirLayout (distBuildDirectory)) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectOrchestration + ( ProjectBaseContext (distDirLayout), + ProjectBuildContext (elaboratedPlanToExecute, elaboratedShared, targetsMap), + ) +import Distribution.Client.ProjectPlanning (ElaboratedConfiguredPackage) +import Distribution.Client.ProjectPlanning.Types (elabDistDirParams) +import Distribution.InstalledPackageInfo (InstalledPackageInfo (haddockHTMLs, installedUnitId, pkgRoot)) +import Distribution.Simple (UnitId) +import Distribution.Simple.Configure (ConfigStateFileError, tryGetPersistBuildConfig) +import Distribution.Simple.PackageIndex (allPackagesByName) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo) +import qualified Distribution.Types.LocalBuildInfo as LocalBuildInfo +import qualified Distribution.Types.PackageDescription as PackageDescription +import qualified Distribution.Types.PackageId as PackageId +import Distribution.Types.PackageName (PackageName) +import qualified Distribution.Types.PackageName as PackageName +import qualified Hoogle +import Hoogle.Cabal.Command.Common (Context (..), GlobalOptions (..), hoogleDatabaseArg, readContext) +import Hoogle.Cabal.Logger +import qualified Options.Applicative as OptParse +import System.Directory + ( createDirectoryIfMissing, + createDirectoryLink, + removeDirectoryLink, + removeDirectoryRecursive, + withCurrentDirectory, + ) +import System.FilePath +import System.IO.Error (isDoesNotExistError) +import Prelude hiding (log) + +data Log + = LogBadInstallPlan UnitId (Maybe (InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage)) + | LogCanNotReadSetupConfig String ConfigStateFileError + | LogPkgMoreThan1Version PackageName (NonEmpty UnitId) + | LogPkgBadHaddockHtml PackageName [FilePath] + +instance Show Log where + show (LogBadInstallPlan unitId Nothing) = "can not find " <> show unitId <> " from install plan" + show (LogBadInstallPlan unitId (Just (InstallPlan.PreExisting _))) = show unitId <> " is PreExisting" + show (LogBadInstallPlan unitId (Just (InstallPlan.Configured _))) = show unitId <> " is Configured" + show (LogBadInstallPlan unitId (Just (InstallPlan.Installed _))) = show unitId <> " is Installed" + show (LogCanNotReadSetupConfig pkg configStateFileErr) = + [i|Can not read setup-config file from #{pkg}, error: #{configStateFileErr}|] + show (LogPkgMoreThan1Version pkgName unitIds) = + [i|Warning: package #{pkgName} has more than 1 version installed, this should not happen. all pkgs: #{unitIds}|] + show (LogPkgBadHaddockHtml name htmlDirs) = + [i|Warning: package #{name} doesn't have exactly one haddock html directory, actual: #{htmlDirs}|] + +newtype Command = Command + { _targets :: [String] + } + deriving (Show, Eq) + +command :: (Command -> a) -> OptParse.Mod OptParse.CommandFields a +command f = + OptParse.command "generate" $ + OptParse.info + (fmap f commandParser) + (OptParse.progDesc "Generate hoogle database") + +commandParser :: OptParse.Parser Command +commandParser = + Command + <$> (OptParse.many . OptParse.strArgument) (OptParse.metavar "TARGETS") + +action :: Logger Log -> GlobalOptions -> Command -> IO () +action logger globalOptions (Command targets) = do + (Context baseCtx buildCtx hoogleDir targetStrings flags globalFlags) <- readContext globalOptions targets + buildAction flags targetStrings globalFlags + let targetIds = Map.keys (targetsMap buildCtx) + installPlan = elaboratedPlanToExecute buildCtx + hoogleLocalPackagesDir = hoogleDir "local" + hoogleDependenciesDir = hoogleDir "dependencies" + localPackages <- fmap catMaybes . forM targetIds $ \targetId -> + let handlePkg pkg = pure . Just $ distBuildDirectory (distDirLayout baseCtx) $ elabDistDirParams (elaboratedShared buildCtx) pkg + in case InstallPlan.lookup installPlan targetId of + Just (InstallPlan.Installed pkg) -> handlePkg pkg + Just (InstallPlan.Configured pkg) -> handlePkg pkg + pkg -> do + logWith logger Error (LogBadInstallPlan targetId pkg) + pure Nothing + catch (removeDirectoryRecursive hoogleDir) $ \(err :: IOError) -> + if isDoesNotExistError err then pure () else throw err + createDirectoryIfMissing True hoogleLocalPackagesDir + createDirectoryIfMissing True hoogleDependenciesDir + localPackagesBuildInfo <- symlinkLocalPackages logger localPackages hoogleLocalPackagesDir + let localPkgsName = fmap fst localPackagesBuildInfo + dependenciesName <- symlinkDependencies logger (fmap snd localPackagesBuildInfo) hoogleDependenciesDir + let nameStrs = localPkgsName <> fmap PackageName.unPackageName dependenciesName + withCurrentDirectory hoogleDir $ + Hoogle.hoogle $ + ["generate", hoogleDatabaseArg, "--local=local", "--local=dependencies"] ++ nameStrs + +symlinkLocalPackages :: Logger Log -> [FilePath] -> FilePath -> IO [(String, LocalBuildInfo)] +symlinkLocalPackages logger pkgsPath destDir = do + fmap catMaybes . forM pkgsPath $ \pkgPath -> runMaybeT $ do + lbiEither <- liftIO $ tryGetPersistBuildConfig pkgPath + lbi <- MaybeT $ case lbiEither of + Left configStateFileErr -> do + logWith logger Error $ LogCanNotReadSetupConfig pkgPath configStateFileErr + pure Nothing + Right lbi -> pure $ Just lbi + let pkgName = + PackageName.unPackageName + . PackageId.pkgName + . PackageDescription.package + . LocalBuildInfo.localPkgDescr + $ lbi + liftIO $ catch (removeDirectoryLink (destDir pkgName)) $ \(e :: IOError) -> + if isDoesNotExistError e then pure () else throw e + liftIO $ createDirectoryLink pkgPath (destDir pkgName) + pure (pkgName, lbi) + +symlinkDependencies :: Logger Log -> [LocalBuildInfo] -> FilePath -> IO [PackageName] +symlinkDependencies logger localPackages hoogleDependenciesDir = do + let nameToPkgs = + fmap (NonEmpty.nubOrdOn installedUnitId) . Map.fromListWith (<>) $ + concatMap collectDependenciesForPkg localPackages + pkgs <- fmap catMaybes . forM (Map.toList nameToPkgs) $ \(name, allPkgs@(pkg NonEmpty.:| pkgs)) -> do + unless (null pkgs) $ + logWith logger Warning $ + LogPkgMoreThan1Version name (fmap installedUnitId allPkgs) + case haddockHTMLs' pkg of + [htmlDir] -> pure $ Just (name, htmlDir) + htmlDirs -> do + logWith logger Warning $ LogPkgBadHaddockHtml name htmlDirs + pure Nothing + forM pkgs $ \(name, dir) -> do + createDirectoryLink dir (hoogleDependenciesDir PackageName.unPackageName name) + pure name + where + collectDependenciesForPkg :: LocalBuildInfo -> [(PackageName, NonEmpty InstalledPackageInfo)] + collectDependenciesForPkg pkg = + let depsWithName = allPackagesByName (LocalBuildInfo.installedPkgs pkg) + in fmap (second (NonEmpty.:| [])) + . concatMap (\(name, pkgs) -> fmap (name,) pkgs) + $ depsWithName + +haddockHTMLs' :: InstalledPackageInfo -> [FilePath] +haddockHTMLs' pkg = + fmap + ( case pkgRoot pkg of + Nothing -> id + Just pkgRoot' -> T.unpack . T.replace "${pkgroot}" (T.pack pkgRoot') . T.pack + ) + . haddockHTMLs + $ pkg diff --git a/src/Hoogle/Cabal/Command/Run.hs b/src/Hoogle/Cabal/Command/Run.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Cabal/Command/Run.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hoogle.Cabal.Command.Run + ( Command, + command, + action, + Log + ) +where + +import qualified Hoogle +import Hoogle.Cabal.Command.Common (Context (..), GlobalOptions, hoogleDatabaseArg, readContext) +import Hoogle.Cabal.Logger +import qualified Options.Applicative as OptParse +import System.Directory (doesDirectoryExist, withCurrentDirectory) + +newtype Command = Command + { _hoogleArgs :: [String] + } + deriving (Show, Eq) + +command :: (Command -> a) -> OptParse.Mod OptParse.CommandFields a +command f = OptParse.command "run" (OptParse.info (fmap f commandParser) (OptParse.progDesc "Run hoogle, with arbitrary arguments")) + +commandParser :: OptParse.Parser Command +commandParser = Command <$> (OptParse.many . OptParse.strArgument) (OptParse.metavar "ARGS") + +data Log = LogHoogleDirDoesNotExist + +instance Show Log where + show LogHoogleDirDoesNotExist = "please run 'cabal-hoogle generate' first" + +action :: Logger Log -> GlobalOptions -> Command -> IO () +action logger globalOptions Command {..} = do + Context {..} <- readContext globalOptions [] + hoogleDirExists <- doesDirectoryExist _context_hoogleDir + if not hoogleDirExists + then logWith logger Error LogHoogleDirDoesNotExist + else + withCurrentDirectory _context_hoogleDir . Hoogle.hoogle $ + hoogleArgs' + where + hoogleArgs' = case _hoogleArgs of + (x : xs) -> x : hoogleDatabaseArg : xs + [] -> [hoogleDatabaseArg] diff --git a/src/Hoogle/Cabal/Command/Version.hs b/src/Hoogle/Cabal/Command/Version.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Cabal/Command/Version.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} + +module Hoogle.Cabal.Command.Version + ( Command (..), + command, + action, + ) +where + +import qualified Options.Applicative as OptParse + +data Command = Command + deriving (Show, Eq) + +command :: (Command -> a) -> OptParse.Mod OptParse.CommandFields a +command f = + OptParse.command "version" $ + OptParse.info (pure (f Command)) (OptParse.progDesc "Show version") + +action :: Command -> IO () +action _ = do + putStrLn $ "cabal-hoogle version " ++ VERSION_cabal_hoogle + putStrLn $ "compiled using version " ++ VERSION_Cabal ++ " of the Cabal library" diff --git a/src/Hoogle/Cabal/Logger.hs b/src/Hoogle/Cabal/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Cabal/Logger.hs @@ -0,0 +1,34 @@ +module Hoogle.Cabal.Logger + ( Logger, + cmapLogger, + stdoutLogger, + logWith, + module Colog.Core, + ) +where + +import Colog.Core +import Data.Time (getCurrentTime) +import Control.Monad.IO.Class + +type Logger msg = LogAction IO (WithSeverity msg) + +cmapLogger :: (a -> b) -> Logger b -> Logger a +cmapLogger f = cmap (fmap f) + +stdoutLogger :: Show msg => Logger msg +stdoutLogger = LogAction $ \msg -> do + -- cmap showMsg logStringStdout + now <- getCurrentTime + putStrLn $ showMsg now msg + where + showMsg time (WithSeverity msg severity) = + "[" + ++ show severity + ++ "][" + ++ show time + ++ "] " + ++ show msg + +logWith :: MonadIO m => Logger msg -> Severity -> msg -> m () +logWith logger severity msg = liftIO $ unLogAction logger (WithSeverity msg severity) diff --git a/test/IntegrationTest.hs b/test/IntegrationTest.hs --- a/test/IntegrationTest.hs +++ b/test/IntegrationTest.hs @@ -18,7 +18,7 @@ wantResult `isInfixOf` output @? "actual output: " <> output pure - [ testCase' "test dependency doesn't work" ["testCase"] "No results found", + [ testCase' "test dependency" ["testCase"] "Test.QuickCheck failingTestCase :: Result -> [String]", testCase' "core library" ["lift"] "Control.Monad.Trans.Class lift", - testCase' "non-core library" ["runProcess_"] "System.Process.Typed runProcess_" + testCase' "non-core library" ["progDesc"] "Options.Applicative progDesc :: String -> InfoMod a" ]