├── Setup.hs ├── .gitignore ├── test └── doctests.hs ├── src ├── Program.hs ├── gendoc.hs ├── Doc.hs ├── Types.hs ├── Run.hs ├── Help.hs ├── Options.hs ├── Main.hs └── Commands.hs ├── Distribution ├── Cab.hs └── Cab │ ├── Version.hs │ ├── GenPaths.hs │ ├── VerDB.hs │ ├── Printer.hs │ ├── Sandbox.hs │ ├── Utils.hs │ ├── PkgDB.hs │ └── Commands.hs ├── hcar-cab.tex ├── LICENSE ├── fourmolu.yaml ├── .travis.yml ├── cab.cabal └── .github └── workflows └── main.yml /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | cabal.config 12 | -------------------------------------------------------------------------------- /test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = 7 | doctest 8 | [ "-optP-include" 9 | , "-optPdist/build/autogen/cabal_macros.h" 10 | , "Distribution/Cab" 11 | ] 12 | -------------------------------------------------------------------------------- /src/Program.hs: -------------------------------------------------------------------------------- 1 | module Program ( 2 | version, 3 | showVersion, 4 | programName, 5 | description, 6 | ) where 7 | 8 | import Data.Version 9 | import Paths_cab 10 | 11 | programName :: String 12 | programName = "cab" 13 | 14 | description :: String 15 | description = "A maintenance command of Haskell cabal packages" 16 | -------------------------------------------------------------------------------- /Distribution/Cab.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Cab ( 2 | -- * Types 3 | Option (..), 4 | FunctionCommand, 5 | 6 | -- * Commands 7 | deps, 8 | revdeps, 9 | installed, 10 | outdated, 11 | uninstall, 12 | search, 13 | genpaths, 14 | check, 15 | add, 16 | initSandbox, 17 | ghci, 18 | ) where 19 | 20 | import Distribution.Cab.Commands 21 | -------------------------------------------------------------------------------- /hcar-cab.tex: -------------------------------------------------------------------------------- 1 | % {ttcab}AMaintenanceComman-K{.tex 2 | \begin{hcarentry}{{\tt cab} --- A Maintenance Command of Haskell Cabal Packages} 3 | \report{Kazu Yamamoto}%05/17 4 | \status{open source, actively developed} 5 | \makeheader 6 | 7 | {\tt cab} is a MacPorts-like maintenance command of Haskell cabal packages. 8 | Some parts of this program are a wrapper to {\tt ghc-pkg} and {\tt cabal}. 9 | 10 | If you are always confused due to inconsistency of {\tt ghc-pkg} and {\tt 11 | cabal}, or if you want a way to check all outdated packages, or if you want a 12 | way to remove outdated packages recursively, this command helps you. 13 | 14 | Since the last HCAR, Cabal 2.0 was supported thanks to Ryan Scott. 15 | 16 | \FurtherReading 17 | \url{http://www.mew.org/~kazu/proj/cab/en/} 18 | \end{hcarentry} 19 | -------------------------------------------------------------------------------- /src/gendoc.hs: -------------------------------------------------------------------------------- 1 | -- runghc -- -package-db --ghc-arg=../.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d gendoc.hs 2 | 3 | module Main where 4 | 5 | import Commands 6 | import Doc 7 | import Options 8 | import Types 9 | 10 | main :: IO () 11 | main = do 12 | putStrLn "The following commands are provided:" 13 | putStr "\n" 14 | putStrLn "?cab" 15 | putStrLn "!Display the help message." 16 | -- undefined prevents to import "Path_cab.hs" 17 | mapM_ prCmdSpec (commandDB undefined) 18 | putStr "\n" 19 | putStrLn "The following options are provided:" 20 | putStr "\n" 21 | mapM_ prOptSpec optionDB 22 | 23 | prCmdSpec :: CommandSpec -> IO () 24 | prCmdSpec cmdspec = do 25 | putStrLn $ "?cab " ++ escape usage 26 | putStrLn $ "!" ++ doc ++ "." ++ aliases 27 | where 28 | (usage, doc, alias) = usageDocAlias cmdspec 29 | aliases 30 | | alias == "" = "" 31 | | otherwise = "\\
Command aliases: " ++ escape alias 32 | 33 | prOptSpec :: OptionSpec -> IO () 34 | prOptSpec spec = do 35 | putStrLn $ "?" ++ option 36 | putStrLn $ "!" ++ doc 37 | where 38 | (option, doc) = optionDoc spec 39 | 40 | escape :: String -> String 41 | escape [] = [] 42 | escape ('[' : rest) = "\\[" ++ escape rest 43 | escape (']' : rest) = "\\]" ++ escape rest 44 | escape (c : rest) = c : escape rest 45 | -------------------------------------------------------------------------------- /Distribution/Cab/Version.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Distribution.Cab.Version ( 4 | Ver, 5 | toVer, 6 | toVersion, 7 | verToString, 8 | version, 9 | versionToString, 10 | ) where 11 | 12 | import Distribution.Cab.Utils 13 | import Distribution.Version 14 | 15 | -- | Package version. 16 | newtype Ver = Ver [Int] deriving (Eq, Ord, Read, Show) 17 | 18 | -- | Creating 'Ver'. 19 | -- 20 | -- >>> toVer [1,2,3] 21 | -- Ver [1,2,3] 22 | toVer :: [Int] -> Ver 23 | toVer is = Ver is 24 | 25 | -- | Creating 'Version' in Cabal. 26 | toVersion :: [Int] -> Version 27 | #if MIN_VERSION_Cabal(2,0,0) 28 | toVersion is = mkVersion is 29 | #else 30 | toVersion is = Version is [] 31 | #endif 32 | 33 | -- | From 'Version' to 'String' 34 | -- 35 | -- >>> verToString $ toVer [1,2,3] 36 | -- "1.2.3" 37 | verToString :: Ver -> String 38 | verToString (Ver ver) = toDotted ver 39 | 40 | -- | From 'Version' in Cabal to 'Ver'. 41 | -- 42 | -- >>> version $ toVersion [1,2,3] 43 | -- Ver [1,2,3] 44 | version :: Version -> Ver 45 | #if MIN_VERSION_Cabal(2,0,0) 46 | version = Ver . versionNumbers 47 | #else 48 | version = Ver . versionBranch 49 | #endif 50 | 51 | -- | From 'Version' in Cabal to 'String'. 52 | -- 53 | -- >>> versionToString $ toVersion [1,2,3] 54 | -- "1.2.3" 55 | versionToString :: Version -> String 56 | versionToString = verToString . version 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011, IIJ Innovation Institute Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 4 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: 80 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: leading 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: diff-friendly 15 | 16 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | indent-wheres: false 18 | 19 | # Whether to leave a space before an opening record brace 20 | record-brace-space: false 21 | 22 | # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | 25 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | haddock-style: single-line 27 | 28 | # How to print module docstring 29 | haddock-style-module: null 30 | 31 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | let-style: inline 33 | 34 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | in-style: right-align 36 | 37 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | single-constraint-parens: never 39 | 40 | # Output Unicode syntax (choices: detect, always, or never) 41 | unicode: never 42 | 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: true 45 | 46 | # Fixity information for operators 47 | fixities: [] 48 | 49 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # NB: don't set `language: haskell` here 2 | 3 | # The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for. 4 | env: 5 | - CABALVER=1.18 GHCVER=7.6.3 6 | - CABALVER=1.18 GHCVER=7.8.4 7 | - CABALVER=1.22 GHCVER=7.10.3 8 | - CABALVER=1.24 GHCVER=8.0.1 9 | - CABALVER=head GHCVER=head # see section about GHC HEAD snapshots 10 | 11 | matrix: 12 | allow_failures: 13 | # GHC head cannot not compile QuickCheck at this moment. 14 | - env: CABALVER=head GHCVER=head 15 | 16 | # Note: the distinction between `before_install` and `install` is not important. 17 | before_install: 18 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 19 | - travis_retry sudo apt-get update 20 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex 21 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 22 | 23 | install: 24 | - cabal --version 25 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 26 | - travis_retry cabal update 27 | - cabal install --only-dependencies --enable-tests 28 | 29 | # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. 30 | script: 31 | - if [ -f configure.ac ]; then autoreconf -i; fi 32 | - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging 33 | - cabal build # this builds all libraries and executables (including tests) 34 | - cabal test 35 | - cabal check 36 | -------------------------------------------------------------------------------- /src/Doc.hs: -------------------------------------------------------------------------------- 1 | module Doc where 2 | 3 | import Data.List (intercalate) 4 | import System.Console.GetOpt (ArgDescr (..), OptDescr (..)) 5 | 6 | import Options 7 | import Types 8 | 9 | commandSpecByName :: String -> CommandDB -> Maybe CommandSpec 10 | commandSpecByName _ [] = Nothing 11 | commandSpecByName x (ent : ents) 12 | | x `elem` commandNames ent = Just ent 13 | | otherwise = commandSpecByName x ents 14 | 15 | ---------------------------------------------------------------- 16 | 17 | usageDocAlias :: CommandSpec -> (String, String, String) 18 | usageDocAlias cmdspec = (usage, doc, alias) 19 | where 20 | usage = cmd ++ " " ++ showOptions ++ showArgs 21 | doc = document cmdspec 22 | alias = showAliases cmdspec 23 | cmd : _ = commandNames cmdspec 24 | options = opts cmdspec 25 | showOptions 26 | | null options = "" 27 | | otherwise = 28 | "[" 29 | ++ intercalate "] [" (concatMap (masterOption optionDB) (opts cmdspec)) 30 | ++ "]" 31 | showArgs = maybe "" (" " ++) $ manual cmdspec 32 | opts = map fst . switches 33 | masterOption [] _ = [] 34 | masterOption (spec : specs) o 35 | | fst spec == o = optionName spec : masterOption specs o 36 | | otherwise = masterOption specs o 37 | showAliases = intercalate ", " . tail . commandNames 38 | 39 | ---------------------------------------------------------------- 40 | 41 | optionDoc :: OptionSpec -> (String, String) 42 | optionDoc spec = (key, doc) 43 | where 44 | key = intercalate ", " . reverse . optionNames $ spec 45 | doc = optionDesc spec 46 | 47 | optionName :: OptionSpec -> String 48 | optionName (_, Option (c : _) _ (ReqArg _ arg) _) = '-' : c : ' ' : arg 49 | optionName (_, Option (c : _) _ _ _) = '-' : [c] 50 | optionName _ = "" 51 | 52 | optionNames :: OptionSpec -> [String] 53 | optionNames (_, Option (c : _) (s : _) _ _) = ['-' : [c], '-' : '-' : s] 54 | optionNames _ = [] 55 | 56 | optionDesc :: OptionSpec -> String 57 | optionDesc (_, Option _ _ _ desc) = desc 58 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import Distribution.Cab 4 | import System.Console.GetOpt 5 | 6 | ---------------------------------------------------------------- 7 | 8 | type Arg = String 9 | 10 | ---------------------------------------------------------------- 11 | 12 | data Switch 13 | = SwNoharm 14 | | SwRecursive 15 | | SwAll 16 | | SwInfo 17 | | SwFlag 18 | | SwTest 19 | | SwBench 20 | | SwDepsOnly 21 | | SwLibProfile 22 | | SwExecProfile 23 | | SwDebug 24 | | SwJobs 25 | | SwImport 26 | | SwStatic 27 | | SwFuture 28 | | SwAllowNewer 29 | | SwCleanUp 30 | deriving (Eq, Show) 31 | 32 | ---------------------------------------------------------------- 33 | 34 | data SwitchKind = None | Solo String | WithEqArg String | FollowArg String 35 | 36 | type SwitchSpec = (Switch, SwitchKind) 37 | type SwitchDB = [SwitchSpec] 38 | 39 | type GetOptSpec = OptDescr Option 40 | type GetOptDB = [GetOptSpec] 41 | 42 | type OptionSpec = (Switch, GetOptSpec) 43 | type OptionDB = [OptionSpec] 44 | 45 | ---------------------------------------------------------------- 46 | 47 | data Command 48 | = Sync 49 | | Install 50 | | Uninstall 51 | | Installed 52 | | Configure 53 | | Build 54 | | Clean 55 | | Outdated 56 | | Sdist 57 | | Upload 58 | | Unpack 59 | | Info 60 | | Deps 61 | | RevDeps 62 | | Check 63 | | GenPaths 64 | | Search 65 | | Add 66 | | Ghci 67 | | Test 68 | | Bench 69 | | Doc 70 | | Init 71 | | DocTest 72 | | Help 73 | deriving (Eq, Show) 74 | 75 | data CommandSpec = CommandSpec 76 | { command :: Command 77 | , commandNames :: [String] 78 | , document :: String 79 | , routing :: Route 80 | , switches :: SwitchDB 81 | , manual :: Maybe String 82 | } 83 | 84 | type CommandDB = [CommandSpec] 85 | 86 | ---------------------------------------------------------------- 87 | 88 | data Route 89 | = RouteFunc FunctionCommand 90 | | RouteCabal [String] 91 | -------------------------------------------------------------------------------- /Distribution/Cab/GenPaths.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Distribution.Cab.GenPaths (genPaths) where 4 | 5 | import Control.Exception 6 | import Control.Monad 7 | import Data.List (isSuffixOf) 8 | import Distribution.Cab.Utils (readGenericPackageDescription, unPackageName) 9 | import Distribution.Package (pkgName, pkgVersion) 10 | import Distribution.PackageDescription (package, packageDescription) 11 | import Distribution.Verbosity (silent) 12 | import Distribution.Version 13 | import System.Directory 14 | 15 | genPaths :: IO () 16 | genPaths = do 17 | (nm, ver) <- getCabalFile >>= getNameVersion 18 | let file = "Paths_" ++ nm ++ ".hs" 19 | check file >> do 20 | putStrLn $ "Writing " ++ file ++ "..." 21 | writeFile file $ 22 | "module Paths_" 23 | ++ nm 24 | ++ " where\n" 25 | ++ "import Data.Version\n" 26 | ++ "\n" 27 | ++ "version :: Version\n" 28 | ++ "version = " 29 | ++ show ver 30 | ++ "\n" 31 | where 32 | check file = do 33 | exist <- doesFileExist file 34 | when exist . throwIO . userError $ file ++ " already exists" 35 | 36 | getNameVersion :: FilePath -> IO (String, Version) 37 | getNameVersion file = do 38 | desc <- readGenericPackageDescription silent file 39 | let pkg = package . packageDescription $ desc 40 | nm = unPackageName $ pkgName pkg 41 | name = map (trans '-' '_') nm 42 | version = pkgVersion pkg 43 | return (name, version) 44 | where 45 | trans c1 c2 c 46 | | c == c1 = c2 47 | | otherwise = c 48 | 49 | getCabalFile :: IO FilePath 50 | getCabalFile = do 51 | cnts <- 52 | (filter isCabal <$> getDirectoryContents ".") 53 | >>= filterM doesFileExist 54 | case cnts of 55 | [] -> throwIO $ userError "Cabal file does not exist" 56 | cfile : _ -> return cfile 57 | where 58 | isCabal :: String -> Bool 59 | isCabal nm = ".cabal" `isSuffixOf` nm && length nm > 6 60 | -------------------------------------------------------------------------------- /cab.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: cab 3 | version: 0.2.22 4 | license: BSD3 5 | license-file: LICENSE 6 | maintainer: Kazu Yamamoto 7 | author: Kazu Yamamoto 8 | homepage: http://www.mew.org/~kazu/proj/cab/ 9 | synopsis: A maintenance command of Haskell cabal packages 10 | description: 11 | This is a MacPorts-like maintenance command of 12 | Haskell cabal packages. Some part of this program is a wrapper to 13 | "ghc-pkg" and "cabal". 14 | If you are always confused due to inconsistency of two commands, 15 | or if you want a way to check all outdated packages, 16 | or if you want a way to remove outdated packages recursively, 17 | this command helps you. 18 | 19 | category: Distribution 20 | build-type: Simple 21 | 22 | source-repository head 23 | type: git 24 | location: git://github.com/kazu-yamamoto/cab.git 25 | 26 | library 27 | exposed-modules: 28 | Distribution.Cab 29 | Distribution.Cab.PkgDB 30 | Distribution.Cab.Printer 31 | Distribution.Cab.Sandbox 32 | Distribution.Cab.VerDB 33 | Distribution.Cab.Version 34 | 35 | other-modules: 36 | Distribution.Cab.Commands 37 | Distribution.Cab.GenPaths 38 | Distribution.Cab.Utils 39 | 40 | default-language: Haskell2010 41 | ghc-options: -Wall 42 | build-depends: 43 | base >=4.0 && <5, 44 | Cabal >=1.18, 45 | attoparsec >=0.10, 46 | bytestring, 47 | conduit >=1.1, 48 | conduit-extra >=1.1.2, 49 | containers, 50 | directory, 51 | filepath, 52 | process, 53 | resourcet 54 | 55 | executable cab 56 | main-is: Main.hs 57 | hs-source-dirs: src 58 | other-modules: 59 | Commands 60 | Doc 61 | Help 62 | Options 63 | Program 64 | Run 65 | Types 66 | Paths_cab 67 | 68 | default-language: Haskell2010 69 | ghc-options: -Wall -threaded 70 | build-depends: 71 | base >=4.0 && <5, 72 | cab, 73 | Cabal >=1.18, 74 | attoparsec >=0.10, 75 | bytestring, 76 | conduit >=1.1, 77 | conduit-extra >=1.1.2, 78 | containers, 79 | directory, 80 | filepath, 81 | process 82 | -------------------------------------------------------------------------------- /src/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Run (run, toSwitch) where 4 | 5 | import Data.List (intercalate) 6 | import Distribution.Cab 7 | #if MIN_VERSION_process(1,2,0) 8 | import System.Process (callCommand) 9 | #else 10 | import Control.Monad (void) 11 | import System.Cmd (system) 12 | #endif 13 | 14 | import Types 15 | 16 | ---------------------------------------------------------------- 17 | 18 | toSwitch :: Option -> Switch 19 | toSwitch OptNoharm = SwNoharm 20 | toSwitch OptRecursive = SwRecursive 21 | toSwitch OptAll = SwAll 22 | toSwitch OptInfo = SwInfo 23 | toSwitch (OptFlag _) = SwFlag 24 | toSwitch OptTest = SwTest 25 | toSwitch OptBench = SwBench 26 | toSwitch OptDepsOnly = SwDepsOnly 27 | toSwitch OptLibProfile = SwLibProfile 28 | toSwitch OptExecProfile = SwExecProfile 29 | toSwitch OptDebug = SwDebug 30 | toSwitch (OptJobs _) = SwJobs 31 | toSwitch (OptImport _) = SwImport 32 | toSwitch OptStatic = SwStatic 33 | toSwitch OptFuture = SwFuture 34 | toSwitch OptAllowNewer = SwAllowNewer 35 | toSwitch OptCleanUp = SwCleanUp 36 | toSwitch _ = error "toSwitch" 37 | 38 | ---------------------------------------------------------------- 39 | 40 | optionArg :: Option -> String 41 | optionArg (OptFlag str) = str 42 | optionArg (OptJobs str) = str 43 | optionArg (OptImport str) = str 44 | optionArg _ = "" 45 | 46 | optionsToString :: [Option] -> SwitchDB -> [String] 47 | optionsToString opts swdb = concatMap suboption opts 48 | where 49 | suboption opt = case lookup (toSwitch opt) swdb of 50 | Nothing -> [] 51 | Just None -> [] 52 | Just (Solo x) -> [x] 53 | Just (WithEqArg x) -> [x ++ "=" ++ optionArg opt] 54 | Just (FollowArg x) -> [x ++ optionArg opt] 55 | 56 | ---------------------------------------------------------------- 57 | 58 | run :: CommandSpec -> [Arg] -> [Option] -> IO () 59 | run cmdspec params opts = case routing cmdspec of 60 | RouteFunc func -> func params opts options 61 | RouteCabal subargs -> callProcess pro subargs params options 62 | where 63 | pro = "cabal" 64 | sws = switches cmdspec 65 | options = optionsToString opts sws 66 | 67 | callProcess :: String -> [String] -> [Arg] -> [String] -> IO () 68 | callProcess pro args0 args1 options = systemCommand script 69 | where 70 | #if MIN_VERSION_process(1,2,0) 71 | systemCommand = callCommand 72 | #else 73 | systemCommand = void . system 74 | #endif 75 | script = intercalate " " $ pro : args0 ++ cat args1 ++ options 76 | cat [pkg, ver] = [pkg ++ "-" ++ ver] 77 | cat x = x 78 | -------------------------------------------------------------------------------- /src/Help.hs: -------------------------------------------------------------------------------- 1 | -- Only Main.hs depends on Help.hs 2 | -- Only Help.hs depends on Path_cab.hs 3 | 4 | module Help ( 5 | helpAndExit, 6 | helpCommandAndExit, 7 | ) where 8 | 9 | import Control.Monad (forM_) 10 | import Data.List (intersperse) 11 | import Distribution.Cab 12 | import System.Exit (exitSuccess) 13 | 14 | import Commands 15 | import Doc 16 | import Options 17 | import Program 18 | import Types 19 | 20 | ---------------------------------------------------------------- 21 | 22 | helpCommandAndExit :: FunctionCommand 23 | helpCommandAndExit [] _ _ = helpAndExit 24 | helpCommandAndExit (cmd : _) _ _ = do 25 | case mcmdspec of 26 | Nothing -> helpAndExit 27 | Just cmdspec -> do 28 | let (usage, doc, alias) = usageDocAlias cmdspec 29 | putStrLn $ "Usage: " ++ usage 30 | putStr "\n" 31 | putStrLn $ doc 32 | putStr "\n" 33 | putStrLn $ "Aliases: " ++ alias 34 | putStr "\n" 35 | printOptions cmdspec 36 | exitSuccess 37 | where 38 | mcmdspec = commandSpecByName cmd (commandDB helpCommandAndExit) 39 | 40 | printOptions :: CommandSpec -> IO () 41 | printOptions cmdspec = 42 | forM_ opts (printOption optionDB) 43 | where 44 | opts = map fst $ switches cmdspec 45 | printOption [] _ = return () 46 | printOption (spec : specs) o 47 | | fst spec == o = do 48 | let (key, doc) = optionDoc spec 49 | putStrLn $ key ++ "\t" ++ doc 50 | | otherwise = printOption specs o 51 | 52 | ---------------------------------------------------------------- 53 | 54 | helpAndExit :: IO () 55 | helpAndExit = do 56 | putStrLn $ programName ++ " " ++ " -- " ++ description 57 | putStrLn "" 58 | putStrLn $ "Version: " ++ showVersion version 59 | putStrLn "Usage:" 60 | putStrLn $ "\t" ++ programName 61 | putStrLn $ "\t" ++ programName ++ " [args...]" 62 | putStrLn "\t where" 63 | printCommands . getCommands . commandDB $ helpCommandAndExit 64 | exitSuccess 65 | where 66 | getCommands = 67 | map concat 68 | . split helpCommandNumber 69 | . intersperse ", " 70 | . map (head . commandNames) 71 | printCommands [] = return () 72 | printCommands (x : xs) = do 73 | putStrLn $ "\t = " ++ x 74 | mapM_ (\cmds -> putStrLn $ "\t " ++ cmds) xs 75 | 76 | helpCommandNumber :: Int 77 | helpCommandNumber = 10 78 | 79 | ---------------------------------------------------------------- 80 | 81 | -- | 82 | -- >>> split 4 "0123457689" 83 | -- ["0123","4576","89"] 84 | split :: Int -> [a] -> [[a]] 85 | split _ [] = [] 86 | split n ss = x : split n rest 87 | where 88 | (x, rest) = splitAt n ss 89 | -------------------------------------------------------------------------------- /Distribution/Cab/VerDB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Distribution.Cab.VerDB ( 4 | -- * Types 5 | PkgName, 6 | VerDB, 7 | HowToObtain (..), 8 | 9 | -- * Creating 10 | getVerDB, 11 | 12 | -- * Converting 13 | toList, 14 | toMap, 15 | ) where 16 | 17 | import Control.Applicative 18 | import Control.Arrow (second) 19 | import Control.Monad.Trans.Resource (runResourceT) 20 | import Data.Attoparsec.ByteString.Char8 21 | import Data.Conduit.Attoparsec 22 | import Data.Conduit.Process 23 | import Data.Map.Strict (Map) 24 | import qualified Data.Map.Strict as M 25 | import Data.Maybe 26 | import Distribution.Cab.Version 27 | 28 | ---------------------------------------------------------------- 29 | 30 | type PkgName = String 31 | 32 | type VerInfo = (PkgName, Maybe [Int]) 33 | 34 | newtype VerDB = VerDB [(PkgName, Ver)] deriving (Eq, Show) 35 | 36 | data HowToObtain = InstalledOnly | AllRegistered 37 | 38 | ---------------------------------------------------------------- 39 | 40 | getVerDB :: HowToObtain -> IO VerDB 41 | getVerDB how = VerDB . justOnly <$> verInfos 42 | where 43 | script = case how of 44 | InstalledOnly -> "cabal list --installed" 45 | AllRegistered -> "cabal list" 46 | verInfos = runResourceT $ sourceCmdWithConsumer script cabalListParser 47 | justOnly = map (second (toVer . fromJust)) . filter (isJust . snd) . snd 48 | cabalListParser = sinkParser verinfos 49 | 50 | ---------------------------------------------------------------- 51 | 52 | -- | Converting 'VerDB' to alist. 53 | -- 54 | -- >>> db <- getVerDB InstalledOnly 55 | -- >>> elem "base" . map fst . toList $ db 56 | -- True 57 | toList :: VerDB -> [(PkgName, Ver)] 58 | toList (VerDB alist) = alist 59 | 60 | -- | Converting 'VerDB' to 'Map'. 61 | toMap :: VerDB -> Map PkgName Ver 62 | toMap (VerDB alist) = M.fromList alist 63 | 64 | ---------------------------------------------------------------- 65 | 66 | verinfos :: Parser [VerInfo] 67 | verinfos = many1 verinfo 68 | 69 | verinfo :: Parser VerInfo 70 | verinfo = do 71 | name <- string "* " *> nonEols <* endOfLine 72 | synpsis 73 | lat <- latestLabel *> latest <* endOfLine 74 | _ <- many skip 75 | endOfLine 76 | return (name, lat) 77 | where 78 | latestLabel = 79 | string " Default available version: " -- cabal 0.10 80 | <|> string " Latest version available: " -- cabal 0.8 81 | skip = many1 nonEols *> endOfLine 82 | synpsis = 83 | string " Synopsis:" *> nonEols *> endOfLine *> more 84 | <|> return () 85 | where 86 | more = () <$ many (string " " *> nonEols *> endOfLine) 87 | latest = 88 | Nothing <$ (char '[' *> nonEols) 89 | <|> Just <$> dotted 90 | 91 | dotted :: Parser [Int] 92 | dotted = decimal `sepBy` char '.' 93 | 94 | nonEols :: Parser String 95 | nonEols = many1 $ satisfy (notInClass "\r\n") 96 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ 'main', 'ci' ] 6 | pull_request: 7 | branches: [ 'main' ] 8 | 9 | jobs: 10 | build: 11 | runs-on: ${{ matrix.os }} 12 | 13 | strategy: 14 | fail-fast: false 15 | matrix: 16 | os: [ 'ubuntu-latest', 'macOS-latest' ] 17 | ghc: [ '9.2', '9.4', '9.6', '9.8', '9.10', '9.12' ] 18 | 19 | env: 20 | cache-name: cabal-ghc 21 | target-config: --test-show-details=streaming --enable-tests --disable-benchmarks 22 | 23 | steps: 24 | - run: git config --global core.autocrlf false 25 | 26 | - uses: actions/checkout@v4 27 | 28 | - uses: haskell-actions/setup@v2 29 | with: 30 | ghc-version: ${{ matrix.ghc }} 31 | cabal-version: latest 32 | 33 | - name: Hackage index, Cache Key 34 | id: params 35 | shell: bash 36 | run: | 37 | ghc_version=$(ghc --numeric-version) 38 | cabal update 39 | echo "cache=${{ runner.os }}-build-${{ env.cache-name }}-${ghc_version}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}" > "$GITHUB_OUTPUT" 40 | echo "ghc_version=$ghc_version" >> "$GITHUB_OUTPUT" 41 | 42 | - name: Restore Cache 43 | uses: actions/cache/restore@v4 44 | if: ${{ github.ref_name != 'ci-uc' }} 45 | with: 46 | path: ~/.cabal 47 | key: ${{ steps.params.outputs.cache }} 48 | 49 | - name: Install doctest 50 | id: doctest-dep 51 | if: ${{ runner.os == 'Linux' }} 52 | shell: bash 53 | run: | 54 | if cabal install --offline --overwrite-policy=always doctest 55 | then 56 | echo "installed=false" >> "$GITHUB_OUTPUT" 57 | else 58 | cabal install doctest --overwrite-policy=always 59 | echo "installed=true" >> "$GITHUB_OUTPUT" 60 | fi 61 | 62 | - name: Install dependencies 63 | id: inst-dep 64 | shell: bash 65 | run: | 66 | if cabal build --offline --only-dependencies ${{ env.target-config }} all 67 | then 68 | echo "installed=false" >> "$GITHUB_OUTPUT" 69 | else 70 | cabal build --only-dependencies ${{ env.target-config }} all 71 | echo "installed=true" >> "$GITHUB_OUTPUT" 72 | fi 73 | 74 | - name: Save Cache 75 | uses: actions/cache/save@v4 76 | if: ${{ steps.inst-dep.outputs.installed == 'true' || steps.doctest-dep.outputs.installed == 'true' }} 77 | with: 78 | path: ~/.cabal 79 | key: ${{ steps.params.outputs.cache }} 80 | 81 | - name: Build 82 | run: cabal build ${{ env.target-config }} all 83 | 84 | - name: Run tests 85 | run: cabal test ${{ env.target-config }} all 86 | 87 | - name: Run doctest 88 | if: ${{ runner.os == 'Linux' }} 89 | run: | 90 | cabal repl --build-depends=QuickCheck --with-ghc=doctest ${{ env.target-config }} 91 | -------------------------------------------------------------------------------- /src/Options.hs: -------------------------------------------------------------------------------- 1 | module Options (optionDB, getOptDB) where 2 | 3 | import Distribution.Cab 4 | import System.Console.GetOpt 5 | 6 | import Types 7 | 8 | ---------------------------------------------------------------- 9 | 10 | getOptDB :: GetOptDB 11 | getOptDB = 12 | [ Option 13 | ['n'] 14 | ["dry-run"] 15 | (NoArg OptNoharm) 16 | "Run without destructive operations" 17 | , Option 18 | ['r'] 19 | ["recursive"] 20 | (NoArg OptRecursive) 21 | "Follow dependencies recursively" 22 | , Option 23 | ['a'] 24 | ["all"] 25 | (NoArg OptAll) 26 | "Show global packages in addition to user packages" 27 | , Option 28 | ['m'] 29 | ["info"] 30 | (NoArg OptInfo) 31 | "Show license and author information" 32 | , Option 33 | ['f'] 34 | ["flags"] 35 | (ReqArg OptFlag "") 36 | "Specify flags" 37 | , Option 38 | ['t'] 39 | ["test"] 40 | (NoArg OptTest) 41 | "Enable test" 42 | , Option 43 | ['b'] 44 | ["bench"] 45 | (NoArg OptBench) 46 | "Enable benchmark" 47 | , Option 48 | ['d'] 49 | ["dep-only"] 50 | (NoArg OptDepsOnly) 51 | "Target only dependencies" 52 | , Option 53 | ['p'] 54 | ["lib-prof"] 55 | (NoArg OptLibProfile) 56 | "Enable library profiling" 57 | , Option 58 | ['e'] 59 | ["exec-prof"] 60 | (NoArg OptExecProfile) 61 | "Enable library profiling" 62 | , Option 63 | ['g'] 64 | ["debug"] 65 | (NoArg OptDebug) 66 | "Enable debug trace" 67 | , Option 68 | ['j'] 69 | ["jobs"] 70 | (ReqArg OptJobs "") 71 | "Run N jobs" 72 | , Option 73 | ['i'] 74 | ["import"] 75 | (ReqArg OptImport ":") 76 | "Add module import paths" 77 | , Option 78 | ['s'] 79 | ["static"] 80 | (NoArg OptStatic) 81 | "Create static libraries only" 82 | , Option 83 | ['u'] 84 | ["future"] 85 | (NoArg OptFuture) 86 | "Show packages with versions ahead of Hackage" 87 | , Option 88 | ['x'] 89 | ["newer"] 90 | (NoArg OptAllowNewer) 91 | "Allow newer versions" 92 | , Option 93 | ['c'] 94 | ["cleanup"] 95 | (NoArg OptCleanUp) 96 | "Remove outdated packages" 97 | , Option 98 | ['h'] 99 | ["help"] 100 | (NoArg OptHelp) 101 | "Show help message" 102 | ] 103 | 104 | optionDB :: OptionDB 105 | optionDB = 106 | zip 107 | [ SwNoharm 108 | , SwRecursive 109 | , SwAll 110 | , SwInfo 111 | , SwFlag 112 | , SwTest 113 | , SwBench 114 | , SwDepsOnly 115 | , SwLibProfile 116 | , SwExecProfile 117 | , SwDebug 118 | , SwJobs 119 | , SwImport 120 | , SwStatic 121 | , SwFuture 122 | , SwAllowNewer 123 | , SwCleanUp 124 | ] 125 | getOptDB 126 | -------------------------------------------------------------------------------- /Distribution/Cab/Printer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Distribution.Cab.Printer ( 4 | printDeps, 5 | printRevDeps, 6 | extraInfo, 7 | ) where 8 | 9 | import Control.Monad 10 | import Data.Function 11 | import Data.List 12 | import Data.Map.Strict (Map) 13 | import qualified Data.Map.Strict as M 14 | import Distribution.Cab.PkgDB 15 | import Distribution.Cab.Utils (UnitId, installedUnitId, lookupUnitId) 16 | import Distribution.Cab.Version 17 | import Distribution.InstalledPackageInfo (author, depends, license) 18 | import Distribution.License (License (..)) 19 | import Distribution.Simple.PackageIndex (allPackages) 20 | 21 | #if MIN_VERSION_Cabal(2,2,0) 22 | import Distribution.License (licenseFromSPDX) 23 | #endif 24 | 25 | ---------------------------------------------------------------- 26 | 27 | type RevDB = Map UnitId [UnitId] 28 | 29 | makeRevDepDB :: PkgDB -> RevDB 30 | makeRevDepDB db = M.fromList revdeps 31 | where 32 | pkgs = allPackages db 33 | deps = map idDeps pkgs 34 | idDeps pkg = (installedUnitId pkg, depends pkg) 35 | kvs = sort $ concatMap decomp deps 36 | decomp (k, vs) = map (\v -> (v, k)) vs 37 | kvss = groupBy ((==) `on` fst) kvs 38 | comp xs = (fst (head xs), map snd xs) 39 | revdeps = map comp kvss 40 | 41 | ---------------------------------------------------------------- 42 | 43 | printDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO () 44 | printDeps rec info db n pkgi = mapM_ (printDep rec info db n) $ depends pkgi 45 | 46 | printDep :: Bool -> Bool -> PkgDB -> Int -> UnitId -> IO () 47 | printDep rec info db n uid = case lookupUnitId db uid of 48 | Nothing -> return () 49 | Just uniti -> do 50 | putStr $ prefix ++ fullNameOfPkgInfo uniti 51 | extraInfo info uniti 52 | putStrLn "" 53 | when rec $ printDeps rec info db (n + 1) uniti 54 | where 55 | prefix = replicate (n * 4) ' ' 56 | 57 | ---------------------------------------------------------------- 58 | 59 | printRevDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO () 60 | printRevDeps rec info db n pkgi = printRevDeps' rec info db revdb n pkgi 61 | where 62 | revdb = makeRevDepDB db 63 | 64 | printRevDeps' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO () 65 | printRevDeps' rec info db revdb n pkgi = case M.lookup unitid revdb of 66 | Nothing -> return () 67 | Just unitids -> mapM_ (printRevDep' rec info db revdb n) unitids 68 | where 69 | unitid = installedUnitId pkgi 70 | 71 | printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> UnitId -> IO () 72 | printRevDep' rec info db revdb n uid = case lookupUnitId db uid of 73 | Nothing -> return () 74 | Just uniti -> do 75 | putStr $ prefix ++ fullNameOfPkgInfo uniti 76 | extraInfo info uniti 77 | putStrLn "" 78 | when rec $ printRevDeps' rec info db revdb (n + 1) uniti 79 | where 80 | prefix = replicate (n * 4) ' ' 81 | 82 | ---------------------------------------------------------------- 83 | 84 | extraInfo :: Bool -> PkgInfo -> IO () 85 | extraInfo False _ = return () 86 | extraInfo True pkgi = putStr $ " " ++ lcns ++ " \"" ++ show auth ++ "\"" 87 | where 88 | lcns = showLicense (pkgInfoLicense pkgi) 89 | auth = author pkgi 90 | 91 | pkgInfoLicense :: PkgInfo -> License 92 | #if MIN_VERSION_Cabal(2,2,0) 93 | pkgInfoLicense = either licenseFromSPDX id . license 94 | #else 95 | pkgInfoLicense = license 96 | #endif 97 | 98 | showLicense :: License -> String 99 | showLicense (GPL (Just v)) = "GPL" ++ versionToString v 100 | showLicense (GPL Nothing) = "GPL" 101 | showLicense (LGPL (Just v)) = "LGPL" ++ versionToString v 102 | showLicense (LGPL Nothing) = "LGPL" 103 | showLicense (UnknownLicense s) = s 104 | showLicense x = show x 105 | -------------------------------------------------------------------------------- /Distribution/Cab/Sandbox.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Distribution.Cab.Sandbox ( 4 | getSandbox, 5 | getSandboxOpts, 6 | getSandboxOpts2, 7 | ) where 8 | 9 | import Control.Exception as E (SomeException, catch, throwIO) 10 | import Data.Char (isSpace) 11 | import Data.List (isPrefixOf, tails) 12 | import System.Directory (doesFileExist, getCurrentDirectory) 13 | import System.FilePath (takeDirectory, takeFileName, ()) 14 | 15 | ---------------------------------------------------------------- 16 | 17 | configFile :: String 18 | configFile = "cabal.sandbox.config" 19 | 20 | pkgDbKey :: String 21 | pkgDbKey = "package-db:" 22 | 23 | pkgDbKeyLen :: Int 24 | pkgDbKeyLen = length pkgDbKey 25 | 26 | -- | Find a sandbox config file by tracing ancestor directories, 27 | -- parse it and return the package db path 28 | getSandbox :: IO (Maybe FilePath) 29 | getSandbox = (Just <$> getPkgDb) `E.catch` handler 30 | where 31 | getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir 32 | handler :: SomeException -> IO (Maybe String) 33 | handler _ = return Nothing 34 | 35 | -- | Find a sandbox config file by tracing ancestor directories. 36 | -- Exception is thrown if not found 37 | getSandboxConfigFile :: FilePath -> IO FilePath 38 | getSandboxConfigFile dir = do 39 | let cfile = dir configFile 40 | exist <- doesFileExist cfile 41 | if exist 42 | then 43 | return cfile 44 | else do 45 | let dir' = takeDirectory dir 46 | if dir == dir' 47 | then 48 | throwIO $ userError "sandbox config file not found" 49 | else 50 | getSandboxConfigFile dir' 51 | 52 | -- | Extract a package db directory from the sandbox config file. 53 | -- Exception is thrown if the sandbox config file is broken. 54 | getPackageDbDir :: FilePath -> IO FilePath 55 | getPackageDbDir sconf = do 56 | -- Be strict to ensure that an error can be caught. 57 | !path <- extractValue . parse <$> readFile sconf 58 | return path 59 | where 60 | parse = head . filter ("package-db:" `isPrefixOf`) . lines 61 | extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen 62 | 63 | ---------------------------------------------------------------- 64 | 65 | -- | Generate GHC options for package db according to GHC version. 66 | -- 67 | -- >>> getSandboxOpts Nothing 68 | -- "" 69 | -- >>> getSandboxOpts (Just "/path/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") 70 | -- "-package-db /path/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" 71 | -- >>> getSandboxOpts (Just "/path/.cabal-sandbox/i386-osx-ghc-7.4.1-packages.conf.d") 72 | -- "-package-conf /path/.cabal-sandbox/i386-osx-ghc-7.4.1-packages.conf.d" 73 | getSandboxOpts :: Maybe FilePath -> String 74 | getSandboxOpts Nothing = "" 75 | getSandboxOpts (Just path) = pkgOpt ++ path 76 | where 77 | ghcver = extractGhcVer path 78 | pkgOpt 79 | | ghcver >= 706 = "-package-db " 80 | | otherwise = "-package-conf " 81 | 82 | getSandboxOpts2 :: Maybe FilePath -> String 83 | getSandboxOpts2 Nothing = "" 84 | getSandboxOpts2 (Just path) = pkgOpt ++ "=" ++ path 85 | where 86 | ghcver = extractGhcVer path 87 | pkgOpt 88 | | ghcver >= 706 = "--package-db" 89 | | otherwise = "--package-conf" 90 | 91 | -- | Extracting GHC version from the path of package db. 92 | -- Exception is thrown if the string argument is incorrect. 93 | -- 94 | -- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d" 95 | -- 706 96 | extractGhcVer :: String -> Int 97 | extractGhcVer dir = ver 98 | where 99 | file = takeFileName dir 100 | findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails 101 | (verStr1, left) = break (== '.') $ findVer file 102 | (verStr2, _) = break (== '.') $ tail left 103 | ver = read verStr1 * 100 + read verStr2 104 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Exception (Handler (..)) 4 | import qualified Control.Exception as E (catches) 5 | import Control.Monad (when) 6 | import Data.List (intercalate, isPrefixOf) 7 | import Data.Maybe (isNothing) 8 | import Distribution.Cab 9 | import System.Console.GetOpt (ArgOrder (..), OptDescr (..), getOpt') 10 | import System.Environment (getArgs) 11 | import System.Exit (ExitCode, exitFailure) 12 | import System.IO 13 | 14 | import Commands 15 | import Doc 16 | import Help 17 | import Options 18 | import Run 19 | import Types 20 | 21 | ---------------------------------------------------------------- 22 | 23 | main :: IO () 24 | main = flip E.catches handlers $ do 25 | oargs <- getArgs 26 | let pargs = parseArgs getOptDB oargs 27 | checkOptions1 pargs illegalOptionsAndExit 28 | let Right (args, opts0) = pargs 29 | when (args == []) helpAndExit 30 | when (OptHelp `elem` opts0) $ helpCommandAndExit args [] [] 31 | let opts1 = filter (/= OptHelp) opts0 32 | act : params = args 33 | mcmdspec = commandSpecByName act (commandDB helpCommandAndExit) 34 | when (isNothing mcmdspec) (illegalCommandAndExit act) 35 | let Just cmdspec = mcmdspec 36 | checkOptions2 opts1 cmdspec oargs illegalOptionsAndExit 37 | run cmdspec params opts1 38 | where 39 | handlers = [Handler handleExit] 40 | handleExit :: ExitCode -> IO () 41 | handleExit _ = return () 42 | 43 | ---------------------------------------------------------------- 44 | 45 | illegalCommandAndExit :: String -> IO () 46 | illegalCommandAndExit x = do 47 | hPutStrLn stderr $ "Illegal command: " ++ x 48 | exitFailure 49 | 50 | ---------------------------------------------------------------- 51 | 52 | illegalOptionsAndExit :: UnknownOptPrinter 53 | illegalOptionsAndExit xs = do 54 | -- FixME 55 | hPutStrLn stderr $ "Illegal options: " ++ intercalate " " xs 56 | exitFailure 57 | 58 | ---------------------------------------------------------------- 59 | 60 | type ParsedArgs = Either [UnknownOpt] ([Arg], [Option]) 61 | 62 | parseArgs :: [GetOptSpec] -> [Arg] -> ParsedArgs 63 | parseArgs db args = case getOpt' Permute db args of 64 | (o, n, [], []) -> Right (n, o) 65 | (_, _, unknowns, _) -> Left unknowns 66 | 67 | ---------------------------------------------------------------- 68 | 69 | type UnknownOpt = String 70 | type UnknownOptPrinter = [UnknownOpt] -> IO () 71 | 72 | ---------------------------------------------------------------- 73 | 74 | checkOptions1 :: ParsedArgs -> UnknownOptPrinter -> IO () 75 | checkOptions1 (Left es) func = func es 76 | checkOptions1 _ _ = return () 77 | 78 | ---------------------------------------------------------------- 79 | 80 | checkOptions2 :: [Option] -> CommandSpec -> [Arg] -> UnknownOptPrinter -> IO () 81 | checkOptions2 opts cmdspec oargs func = 82 | when (unknowns /= []) $ 83 | func (concatMap (resolveOptionString oargs) unknowns) 84 | where 85 | unknowns = unknownOptions opts cmdspec 86 | 87 | unknownOptions :: [Option] -> CommandSpec -> [Switch] 88 | unknownOptions opts cmdspec = chk specified supported 89 | where 90 | chk [] _ = [] 91 | chk (x : xs) ys 92 | | x `elem` ys = chk xs ys 93 | | otherwise = x : chk xs ys 94 | specified = map toSwitch opts 95 | supported = map fst $ switches cmdspec 96 | 97 | resolveOptionString :: [Arg] -> Switch -> [UnknownOpt] 98 | resolveOptionString oargs sw = case lookup sw optionDB of 99 | Nothing -> error "resolveOptionString" 100 | Just gspec -> 101 | let (s, l) = getOptNames gspec 102 | in checkShort s ++ checkLong l 103 | where 104 | checkShort s = filter (== s) oargs 105 | checkLong l = filter (l `isPrefixOf`) oargs 106 | 107 | getOptNames :: GetOptSpec -> (String, String) 108 | getOptNames (Option (c : _) (s : _) _ _) = ('-' : [c], '-' : '-' : s) 109 | getOptNames _ = error "getOptNames" 110 | -------------------------------------------------------------------------------- /Distribution/Cab/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Distribution.Cab.Utils where 4 | 5 | import Data.List 6 | 7 | import Distribution.InstalledPackageInfo (InstalledPackageInfo) 8 | import Distribution.Package (PackageName) 9 | import Distribution.PackageDescription (GenericPackageDescription) 10 | import Distribution.Simple.PackageIndex (PackageIndex) 11 | import Distribution.Verbosity (Verbosity) 12 | 13 | #if MIN_VERSION_Cabal(1,21,0) && !(MIN_VERSION_Cabal(1,23,0)) 14 | import Distribution.Package (PackageInstalled) 15 | #endif 16 | 17 | #if MIN_VERSION_Cabal(1,23,0) 18 | import qualified Distribution.InstalledPackageInfo as Cabal 19 | (installedUnitId) 20 | import qualified Distribution.Package as Cabal (UnitId) 21 | import qualified Distribution.Simple.PackageIndex as Cabal 22 | (lookupUnitId) 23 | #else 24 | import qualified Distribution.InstalledPackageInfo as Cabal 25 | (installedPackageId) 26 | import qualified Distribution.Package as Cabal (InstalledPackageId) 27 | import qualified Distribution.Simple.PackageIndex as Cabal 28 | (lookupInstalledPackageId) 29 | #endif 30 | 31 | #if MIN_VERSION_Cabal(2,0,0) 32 | import qualified Distribution.Package as Cabal 33 | (mkPackageName, unPackageName) 34 | #else 35 | import qualified Distribution.Package as Cabal (PackageName(..)) 36 | #endif 37 | 38 | #if MIN_VERSION_Cabal(3,14,0) 39 | import qualified Distribution.Simple.PackageDescription as Cabal 40 | (readGenericPackageDescription) 41 | import Distribution.Utils.Path (makeSymbolicPath) 42 | #elif MIN_VERSION_Cabal(3,8,0) 43 | import qualified Distribution.Simple.PackageDescription as Cabal 44 | (readGenericPackageDescription) 45 | #elif MIN_VERSION_Cabal(2,2,0) 46 | import qualified Distribution.PackageDescription.Parsec as Cabal 47 | (readGenericPackageDescription) 48 | #elif MIN_VERSION_Cabal(2,0,0) 49 | import qualified Distribution.PackageDescription.Parse as Cabal 50 | (readGenericPackageDescription) 51 | #else 52 | import qualified Distribution.PackageDescription.Parse as Cabal 53 | (readPackageDescription) 54 | #endif 55 | 56 | -- | 57 | -- >>> fromDotted "1.2.3" 58 | -- [1,2,3] 59 | fromDotted :: String -> [Int] 60 | fromDotted [] = [] 61 | fromDotted xs = case break (== '.') xs of 62 | (x, "") -> [read x :: Int] 63 | (x, _ : ys) -> (read x :: Int) : fromDotted ys 64 | 65 | -- | 66 | -- >>> toDotted [1,2,3] 67 | -- "1.2.3" 68 | toDotted :: [Int] -> String 69 | toDotted = intercalate "." . map show 70 | 71 | -- UnitIds 72 | 73 | #if MIN_VERSION_Cabal(1,23,0) 74 | type UnitId = Cabal.UnitId 75 | #else 76 | type UnitId = Cabal.InstalledPackageId 77 | #endif 78 | 79 | installedUnitId :: InstalledPackageInfo -> UnitId 80 | #if MIN_VERSION_Cabal(1,23,0) 81 | installedUnitId = Cabal.installedUnitId 82 | #else 83 | installedUnitId = Cabal.installedPackageId 84 | #endif 85 | 86 | #if MIN_VERSION_Cabal(1,23,0) 87 | lookupUnitId :: PackageIndex a -> UnitId -> Maybe a 88 | lookupUnitId = Cabal.lookupUnitId 89 | #elif MIN_VERSION_Cabal(1,21,0) 90 | lookupUnitId :: PackageInstalled a => PackageIndex a -> UnitId -> Maybe a 91 | lookupUnitId = Cabal.lookupInstalledPackageId 92 | #else 93 | lookupUnitId :: PackageIndex -> UnitId -> Maybe InstalledPackageInfo 94 | lookupUnitId = Cabal.lookupInstalledPackageId 95 | #endif 96 | 97 | -- PackageNames 98 | 99 | mkPackageName :: String -> PackageName 100 | #if MIN_VERSION_Cabal(2,0,0) 101 | mkPackageName = Cabal.mkPackageName 102 | #else 103 | mkPackageName = Cabal.PackageName 104 | #endif 105 | 106 | unPackageName :: PackageName -> String 107 | #if MIN_VERSION_Cabal(2,0,0) 108 | unPackageName = Cabal.unPackageName 109 | #else 110 | unPackageName (Cabal.PackageName s) = s 111 | #endif 112 | 113 | -- GenericPackageDescription 114 | 115 | readGenericPackageDescription 116 | :: Verbosity -> FilePath -> IO GenericPackageDescription 117 | #if MIN_VERSION_Cabal(3,14,0) 118 | readGenericPackageDescription v fp = Cabal.readGenericPackageDescription v Nothing $ makeSymbolicPath fp 119 | #elif MIN_VERSION_Cabal(2,0,0) 120 | readGenericPackageDescription = Cabal.readGenericPackageDescription 121 | #else 122 | readGenericPackageDescription = Cabal.readPackageDescription 123 | #endif 124 | -------------------------------------------------------------------------------- /Distribution/Cab/PkgDB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Distribution.Cab.PkgDB ( 3 | -- * Types 4 | PkgDB 5 | , PkgInfo 6 | -- * Obtaining 'PkgDB' 7 | , getPkgDB 8 | , getGlobalPkgDB 9 | , getUserPkgDB 10 | -- * Looking up 11 | , lookupByName 12 | , lookupByVersion 13 | -- * Topological sorting 14 | , topSortedPkgs 15 | -- * To 'PkgInfo' 16 | , toPkgInfos 17 | -- * From 'PkgInfo' 18 | , nameOfPkgInfo 19 | , fullNameOfPkgInfo 20 | , pairNameOfPkgInfo 21 | , verOfPkgInfo 22 | -- * Find other libraries 23 | , findInternalLibs 24 | , findSourceLib 25 | ) where 26 | 27 | import Distribution.Cab.Utils 28 | (fromDotted, installedUnitId, mkPackageName, unPackageName) 29 | import Distribution.Cab.Version 30 | import Distribution.Cab.VerDB (PkgName) 31 | import Distribution.InstalledPackageInfo 32 | (InstalledPackageInfo(depends), sourcePackageId, sourceLibName) 33 | import Distribution.Package (PackageIdentifier(..)) 34 | #if MIN_VERSION_Cabal(3,14,0) 35 | import Distribution.Simple.Compiler (PackageDB, PackageDBX(..)) 36 | #else 37 | import Distribution.Simple.Compiler (PackageDB(..)) 38 | #endif 39 | import Distribution.Simple.GHC (configure, getInstalledPackages, getPackageDBContents) 40 | import Distribution.Simple.PackageIndex 41 | (lookupPackageName, lookupSourcePackageId, allPackages 42 | , fromList, reverseDependencyClosure, topologicalOrder) 43 | #if MIN_VERSION_Cabal(1,22,0) 44 | import Distribution.Simple.PackageIndex (InstalledPackageIndex) 45 | #else 46 | import Distribution.Simple.PackageIndex (PackageIndex) 47 | #endif 48 | import Distribution.Simple.Program.Db (defaultProgramDb) 49 | import Distribution.Types.LibraryName 50 | import Distribution.Types.UnitId (unUnitId) 51 | import Distribution.Types.UnqualComponentName (unUnqualComponentName) 52 | import Distribution.Verbosity (normal) 53 | 54 | #if MIN_VERSION_Cabal(3,14,0) 55 | import Distribution.Utils.Path (makeSymbolicPath) 56 | #endif 57 | 58 | import Data.Char 59 | import Data.Maybe 60 | 61 | ---------------------------------------------------------------- 62 | 63 | #if MIN_VERSION_Cabal(1,22,0) 64 | type PkgDB = InstalledPackageIndex 65 | #else 66 | type PkgDB = PackageIndex 67 | #endif 68 | type PkgInfo = InstalledPackageInfo 69 | 70 | ---------------------------------------------------------------- 71 | 72 | -- | Obtaining 'PkgDB' for global and user 73 | -- 74 | -- > getSandbox >>= getPkgDB 75 | getPkgDB :: Maybe FilePath -> IO PkgDB 76 | getPkgDB mpath = getDBs [GlobalPackageDB,userDB] 77 | where 78 | userDB = toUserSpec mpath 79 | 80 | -- | Obtaining 'PkgDB' for user 81 | getUserPkgDB :: Maybe FilePath -> IO PkgDB 82 | getUserPkgDB mpath = getDB userDB 83 | where 84 | userDB = toUserSpec mpath 85 | 86 | -- | Obtaining 'PkgDB' for global 87 | getGlobalPkgDB :: IO PkgDB 88 | getGlobalPkgDB = getDB GlobalPackageDB 89 | 90 | toUserSpec :: Maybe FilePath -> PackageDB 91 | toUserSpec Nothing = UserPackageDB 92 | #if MIN_VERSION_Cabal(3,14,0) 93 | toUserSpec (Just path) = SpecificPackageDB $ makeSymbolicPath path 94 | #else 95 | toUserSpec (Just path) = SpecificPackageDB path 96 | #endif 97 | 98 | getDBs :: [PackageDB] -> IO PkgDB 99 | getDBs specs = do 100 | (_comp,_,pro) <- configure normal Nothing Nothing defaultProgramDb 101 | getInstalledPackages normal 102 | #if MIN_VERSION_Cabal(1,23,0) 103 | _comp 104 | #endif 105 | #if MIN_VERSION_Cabal(3,14,0) 106 | Nothing 107 | #endif 108 | specs pro 109 | 110 | getDB :: PackageDB -> IO PkgDB 111 | getDB spec = do 112 | (_,_,pro) <- configure normal Nothing Nothing defaultProgramDb 113 | getPackageDBContents 114 | normal 115 | #if MIN_VERSION_Cabal(3,14,0) 116 | Nothing 117 | #endif 118 | spec pro 119 | 120 | ---------------------------------------------------------------- 121 | 122 | -- | 123 | -- 124 | -- > pkgdb <- getGlobalPkgDB 125 | -- > lookupByName "base" pkgdb 126 | lookupByName :: PkgName -> PkgDB -> [PkgInfo] 127 | lookupByName name db = concatMap snd $ lookupPackageName db (mkPackageName name) 128 | 129 | -- | 130 | -- 131 | -- > pkgdb <- getGlobalPkgDB 132 | -- > lookupByVersion "base" "4.6.0.1" pkgdb 133 | lookupByVersion :: PkgName -> String -> PkgDB -> [PkgInfo] 134 | lookupByVersion name ver db = lookupSourcePackageId db src 135 | where 136 | src = PackageIdentifier { 137 | pkgName = mkPackageName name 138 | , pkgVersion = toVersion $ fromDotted ver 139 | } 140 | 141 | ---------------------------------------------------------------- 142 | 143 | toPkgInfos :: PkgDB -> [PkgInfo] 144 | toPkgInfos db = allPackages db 145 | 146 | ---------------------------------------------------------------- 147 | 148 | nameOfPkgInfo :: PkgInfo -> PkgName 149 | nameOfPkgInfo pkgi = case sourceLibName pkgi of 150 | LMainLibName -> name 151 | LSubLibName sub -> libNameHack name $ unUnqualComponentName sub 152 | where 153 | name = unPackageName $ pkgName $ sourcePackageId pkgi 154 | 155 | fullNameOfPkgInfo :: PkgInfo -> String 156 | fullNameOfPkgInfo pkgi = nameOfPkgInfo pkgi ++ " " ++ verToString (verOfPkgInfo pkgi) 157 | 158 | pairNameOfPkgInfo :: PkgInfo -> (PkgName,String) 159 | pairNameOfPkgInfo pkgi = (nameOfPkgInfo pkgi, verToString (verOfPkgInfo pkgi)) 160 | 161 | verOfPkgInfo :: PkgInfo -> Ver 162 | verOfPkgInfo = version . pkgVersion . sourcePackageId 163 | 164 | ---------------------------------------------------------------- 165 | 166 | topSortedPkgs :: PkgInfo -> PkgDB -> [PkgInfo] 167 | topSortedPkgs pkgi db = topSort $ unitids [pkgi] 168 | where 169 | unitids = map installedUnitId 170 | topSort = topologicalOrder . fromList . reverseDependencyClosure db 171 | 172 | ---------------------------------------------------------------- 173 | 174 | findInternalLibs :: PkgInfo -> String -> [String] 175 | findInternalLibs pkgInfo name = map (libNameHack name) $ 176 | catMaybes $ map (getInternalLib . unUnitId) $ depends pkgInfo 177 | 178 | getInternalLib :: String -> Maybe String 179 | getInternalLib xs0 = case drop 22 $ skip xs0 of 180 | _:xs1 -> Just xs1 181 | _ -> Nothing 182 | where 183 | skip ys = case break (== '-') ys of 184 | (_,'-':b:bs) 185 | | isDigit b -> case break (== '-') bs of 186 | (_,'-':ds) -> ds 187 | _ -> "" -- error 188 | | otherwise -> skip bs 189 | _ -> "" -- error 190 | 191 | 192 | ---------------------------------------------------------------- 193 | 194 | -- A cabal package can exports multiple libraries. 195 | findSourceLib :: PkgDB -> PkgInfo -> [PkgInfo] 196 | findSourceLib db pkgi = case sourceLibName pkgi of 197 | -- Only one library is exported. 198 | LMainLibName -> [] 199 | -- This is a sub library. Need to find a main(source) library. 200 | LSubLibName _ -> lookupSourcePackageId db $ sourcePackageId pkgi 201 | 202 | ---------------------------------------------------------------- 203 | 204 | libNameHack :: String -> String -> String 205 | libNameHack name subname = "z-" ++ name ++ "-z-" ++ subname 206 | -------------------------------------------------------------------------------- /src/Commands.hs: -------------------------------------------------------------------------------- 1 | module Commands where 2 | 3 | import Distribution.Cab 4 | 5 | import Types 6 | 7 | ---------------------------------------------------------------- 8 | 9 | commandDB :: FunctionCommand -> [CommandSpec] 10 | commandDB help = 11 | [ CommandSpec 12 | { command = Sync 13 | , commandNames = ["sync", "update"] 14 | , document = "Fetch the latest package index" 15 | , routing = RouteCabal ["update"] 16 | , switches = [] 17 | , manual = Nothing 18 | } 19 | , CommandSpec 20 | { command = Install 21 | , commandNames = ["install"] 22 | , document = "Install packages" 23 | , routing = RouteCabal ["v1-install"] 24 | , switches = 25 | [ (SwNoharm, Solo "--dry-run -v") 26 | , (SwFlag, WithEqArg "--flags") 27 | , (SwTest, Solo "--enable-tests") 28 | , (SwBench, Solo "--enable-benchmarks") 29 | , (SwDepsOnly, Solo "--only-dependencies") 30 | , 31 | ( SwLibProfile 32 | , Solo "--enable-library-profiling --ghc-options=\"-fprof-auto -fprof-cafs\"" 33 | ) 34 | , 35 | ( SwExecProfile 36 | , Solo "--enable-profiling --ghc-options=\"-fprof-auto -fprof-cafs\"" 37 | ) 38 | , (SwDebug, Solo "--ghc-options=\"-g\"") 39 | , (SwJobs, WithEqArg "--jobs") 40 | , (SwStatic, Solo "--disable-shared") 41 | , (SwAllowNewer, Solo "--allow-newer") 42 | ] 43 | , manual = Just "[ []]" 44 | } 45 | , CommandSpec 46 | { command = Uninstall 47 | , commandNames = ["uninstall", "delete", "remove", "unregister"] 48 | , document = "Uninstall packages" 49 | , routing = RouteFunc uninstall 50 | , switches = 51 | [ (SwNoharm, None) 52 | , (SwRecursive, None) 53 | ] -- don't allow SwAll 54 | , manual = Just " []" 55 | } 56 | , CommandSpec 57 | { command = Installed 58 | , commandNames = ["installed", "list"] 59 | , document = "List installed packages" 60 | , routing = RouteFunc installed 61 | , switches = 62 | [ (SwAll, None) 63 | , (SwRecursive, None) 64 | , (SwInfo, None) 65 | ] 66 | , manual = Nothing 67 | } 68 | , CommandSpec 69 | { command = Configure 70 | , commandNames = ["configure", "conf"] 71 | , document = "Configure a cabal package" 72 | , routing = RouteCabal ["v1-configure"] 73 | , switches = 74 | [ (SwFlag, WithEqArg "--flags") 75 | , (SwTest, Solo "--enable-tests") 76 | , (SwBench, Solo "--enable-benchmarks") 77 | , 78 | ( SwLibProfile 79 | , Solo "--enable-library-profiling --ghc-options=\"-fprof-auto -fprof-cafs\"" 80 | ) 81 | , 82 | ( SwExecProfile 83 | , Solo "--enable-profiling --ghc-options=\"-fprof-auto -fprof-cafs\"" 84 | ) 85 | , (SwDebug, Solo "--ghc-options=\"-g\"") 86 | , (SwStatic, Solo "--disable-shared") 87 | , (SwAllowNewer, Solo "--allow-newer") 88 | ] 89 | , manual = Nothing 90 | } 91 | , CommandSpec 92 | { command = Build 93 | , commandNames = ["build"] 94 | , document = "Build a cabal package" 95 | , routing = RouteCabal ["v1-build"] 96 | , switches = [(SwJobs, WithEqArg "--jobs")] 97 | , manual = Nothing 98 | } 99 | , CommandSpec 100 | { command = Clean 101 | , commandNames = ["clean"] 102 | , document = "Clean up a build directory" 103 | , routing = RouteCabal ["v1-clean"] 104 | , switches = [] 105 | , manual = Nothing 106 | } 107 | , CommandSpec 108 | { command = Outdated 109 | , commandNames = ["outdated"] 110 | , document = "Display outdated packages" 111 | , routing = RouteFunc outdated 112 | , switches = 113 | [ (SwAll, None) 114 | , (SwFuture, Solo "--future") 115 | , (SwCleanUp, None) 116 | ] 117 | , manual = Nothing 118 | } 119 | , CommandSpec 120 | { command = Info 121 | , commandNames = ["info"] 122 | , document = "Display information of a package" 123 | , routing = RouteCabal ["v1-info"] 124 | , switches = [] 125 | , manual = Just " []" 126 | } 127 | , CommandSpec 128 | { command = Sdist 129 | , commandNames = ["sdist", "pack"] 130 | , document = "Make tar.gz for source distribution" 131 | , routing = RouteCabal ["sdist"] 132 | , switches = [] 133 | , manual = Nothing 134 | } 135 | , CommandSpec 136 | { command = Upload 137 | , commandNames = ["upload", "up"] 138 | , document = "Uploading tar.gz to HackageDB" 139 | , routing = RouteCabal ["upload", "--publish"] 140 | , switches = [(SwNoharm, Solo "-c")] 141 | , manual = Nothing 142 | } 143 | , CommandSpec 144 | { command = Unpack 145 | , commandNames = ["get", "unpack"] 146 | , document = "Untar a package in the current directory" 147 | , routing = RouteCabal ["get"] 148 | , switches = [] 149 | , manual = Just " []" 150 | } 151 | , CommandSpec 152 | { command = Deps 153 | , commandNames = ["deps"] 154 | , document = "Show dependencies of this package" 155 | , routing = RouteFunc deps 156 | , switches = 157 | [ (SwRecursive, None) 158 | , (SwAll, None) 159 | , (SwInfo, None) 160 | ] 161 | , manual = Just " []" 162 | } 163 | , CommandSpec 164 | { command = RevDeps 165 | , commandNames = ["revdeps", "dependents"] 166 | , document = "Show reverse dependencies of this package" 167 | , routing = RouteFunc revdeps 168 | , switches = 169 | [ (SwRecursive, None) 170 | , (SwAll, None) 171 | , (SwInfo, None) 172 | ] 173 | , manual = Just " []" 174 | } 175 | , CommandSpec 176 | { command = Check 177 | , commandNames = ["check"] 178 | , document = "Check consistency of packages" 179 | , routing = RouteFunc check 180 | , switches = [] 181 | , manual = Nothing 182 | } 183 | , CommandSpec 184 | { command = GenPaths 185 | , commandNames = ["genpaths", "genpath"] 186 | , document = "Generate Paths_.hs" 187 | , routing = RouteFunc genpaths 188 | , switches = [] 189 | , manual = Nothing 190 | } 191 | , CommandSpec 192 | { command = Search 193 | , commandNames = ["search"] 194 | , document = "Search available packages by package name" 195 | , routing = RouteFunc search 196 | , switches = [] 197 | , manual = Just "" 198 | } 199 | , CommandSpec 200 | { command = Add 201 | , commandNames = ["add", "add-source"] 202 | , document = "Add a source directory" 203 | , routing = RouteFunc add 204 | , switches = [] 205 | , manual = Just "" 206 | } 207 | , CommandSpec 208 | { command = Test 209 | , commandNames = ["test"] 210 | , document = "Run tests" 211 | , routing = RouteCabal ["v1-test"] 212 | , switches = [] 213 | , manual = Just "[testsuite]" 214 | } 215 | , CommandSpec 216 | { command = Bench 217 | , commandNames = ["bench"] 218 | , document = "Run benchmarks" 219 | , routing = RouteCabal ["v1-bench"] 220 | , switches = [] 221 | , manual = Nothing 222 | } 223 | , CommandSpec 224 | { command = Doc 225 | , commandNames = ["doc", "haddock", "man"] 226 | , document = "Generate manuals" 227 | , routing = RouteCabal ["v1-haddock", "--hyperlink-source"] 228 | , switches = [] 229 | , manual = Nothing 230 | } 231 | , CommandSpec 232 | { command = Ghci 233 | , commandNames = ["ghci", "repl"] 234 | , document = "Run GHCi (with a sandbox)" 235 | , routing = RouteFunc ghci 236 | , switches = [(SwImport, FollowArg "-i")] 237 | , manual = Nothing 238 | } 239 | , CommandSpec 240 | { command = Init 241 | , commandNames = ["init"] 242 | , document = "Initialize a sandbox" 243 | , routing = RouteFunc initSandbox 244 | , switches = [] 245 | , manual = Nothing 246 | } 247 | , CommandSpec 248 | { command = DocTest 249 | , commandNames = ["doctest"] 250 | , document = "Run doctest" 251 | , routing = RouteCabal ["v1-repl", "--with-ghc=doctest"] 252 | , switches = [] 253 | , manual = Nothing 254 | } 255 | , CommandSpec 256 | { command = Help 257 | , commandNames = ["help"] 258 | , document = "Display the help message of the command" 259 | , routing = RouteFunc help 260 | , switches = [] 261 | , manual = Just "[]" 262 | } 263 | ] 264 | -------------------------------------------------------------------------------- /Distribution/Cab/Commands.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Cab.Commands ( 2 | FunctionCommand, 3 | Option (..), 4 | deps, 5 | revdeps, 6 | installed, 7 | outdated, 8 | uninstall, 9 | search, 10 | genpaths, 11 | check, 12 | initSandbox, 13 | add, 14 | ghci, 15 | ) where 16 | 17 | import qualified Control.Exception as E 18 | import Control.Monad (forM_, unless, void, when) 19 | import Data.Char (toLower) 20 | import Data.List (intercalate, isPrefixOf) 21 | import qualified Data.Map.Strict as M 22 | import Distribution.Cab.GenPaths 23 | import Distribution.Cab.PkgDB 24 | import Distribution.Cab.Printer 25 | import Distribution.Cab.Sandbox 26 | import Distribution.Cab.VerDB 27 | import Distribution.Cab.Version 28 | import System.Directory (doesDirectoryExist, removeDirectoryRecursive) 29 | import System.Exit (exitFailure) 30 | import System.FilePath (takeDirectory, takeFileName) 31 | import System.IO (hPutStrLn, stderr) 32 | import System.Process (readProcess, system) 33 | 34 | ---------------------------------------------------------------- 35 | 36 | type FunctionCommand = [String] -> [Option] -> [String] -> IO () 37 | 38 | data Option 39 | = OptNoharm 40 | | OptRecursive 41 | | OptAll 42 | | OptInfo 43 | | OptFlag String 44 | | OptTest 45 | | OptHelp 46 | | OptBench 47 | | OptDepsOnly 48 | | OptLibProfile 49 | | OptExecProfile 50 | | OptJobs String 51 | | OptImport String 52 | | OptStatic 53 | | OptFuture 54 | | OptDebug 55 | | OptAllowNewer 56 | | OptCleanUp 57 | deriving (Eq, Show) 58 | 59 | ---------------------------------------------------------------- 60 | 61 | search :: FunctionCommand 62 | search [x] _ _ = do 63 | nvls <- toList <$> getVerDB AllRegistered 64 | forM_ (lok nvls) $ \(n, v) -> putStrLn $ n ++ " " ++ verToString v 65 | where 66 | key = map toLower x 67 | sat (n, _) = key `isPrefixOf` map toLower n 68 | lok = filter sat 69 | search _ _ _ = do 70 | hPutStrLn stderr "One search-key should be specified." 71 | exitFailure 72 | 73 | ---------------------------------------------------------------- 74 | 75 | installed :: FunctionCommand 76 | installed _ opts _ = do 77 | db <- getDB opts 78 | let pkgs = toPkgInfos db 79 | forM_ pkgs $ \pkgi -> do 80 | putStr $ fullNameOfPkgInfo pkgi 81 | extraInfo info pkgi 82 | putStrLn "" 83 | when optrec $ printDeps True info db 1 pkgi 84 | where 85 | info = OptInfo `elem` opts 86 | optrec = OptRecursive `elem` opts 87 | 88 | outdated :: FunctionCommand 89 | outdated _ opts _ = do 90 | pkgs <- toPkgInfos <$> getDB opts 91 | verDB <- toMap <$> getVerDB InstalledOnly 92 | let del = OptCleanUp `elem` opts 93 | forM_ pkgs $ \p -> case M.lookup (nameOfPkgInfo p) verDB of 94 | Nothing -> return () 95 | Just ver -> do 96 | let comp = verOfPkgInfo p `compare` ver 97 | when (dated comp) $ do 98 | if del 99 | then do 100 | let (nm, vr) = pairNameOfPkgInfo p 101 | uninstall [nm, vr] [OptRecursive] [] `E.catch` \(E.SomeException _) -> return () 102 | else 103 | putStrLn $ fullNameOfPkgInfo p ++ showIneq comp ++ verToString ver 104 | where 105 | dated LT = True 106 | dated GT = OptFuture `elem` opts 107 | dated EQ = False 108 | showIneq LT = " < " 109 | showIneq GT = " > " 110 | showIneq EQ = error "Packages have equal versions" 111 | 112 | getDB :: [Option] -> IO PkgDB 113 | getDB opts 114 | | optall = getSandbox >>= getPkgDB 115 | | otherwise = getSandbox >>= getUserPkgDB 116 | where 117 | optall = OptAll `elem` opts 118 | 119 | ---------------------------------------------------------------- 120 | 121 | uninstall :: FunctionCommand 122 | uninstall nmver opts _ = uninstall' opts $ Right nmver 123 | 124 | uninstall' :: [Option] -> Either PkgInfo [String] -> IO () 125 | uninstall' opts ex = do 126 | userDB <- getSandbox >>= getUserPkgDB 127 | pkgi <- case ex of 128 | Right nmver -> lookupPkg nmver userDB 129 | Left pkgi' -> return $ pkgi' 130 | let sortedPkgs = topSortedPkgs pkgi userDB 131 | if onlyOne && length sortedPkgs /= 1 132 | then do 133 | hPutStrLn stderr "The following packages depend on this. Use the \"-r\" option." 134 | mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) (init sortedPkgs) 135 | else do 136 | unless doit $ 137 | putStrLn "The following packages are deleted without the \"-n\" option." 138 | mapM_ (purge doit opts) sortedPkgs 139 | -- If "delete -r" removes a sub libraries of a package 140 | -- which exports multiple libraries, we need to delete the 141 | -- main library. Otherwise, DB gets inconsistency. 142 | when doit $ do 143 | -- DB is not updated. So, if doit is False, this may 144 | -- result in infinite loop, sigh. 145 | let sourceLibs = map Left $ concatMap (findSourceLib userDB) sortedPkgs 146 | mapM_ (uninstall' opts) sourceLibs 147 | where 148 | onlyOne = OptRecursive `notElem` opts 149 | doit = OptNoharm `notElem` opts 150 | 151 | purge :: Bool -> [Option] -> PkgInfo -> IO () 152 | purge doit opts pkgInfo = do 153 | sandboxOpts <- (makeOptList . getSandboxOpts2) <$> getSandbox 154 | dirs <- getDirs nameVer sandboxOpts 155 | unregister doit opts nameVer 156 | mapM_ unregisterInternal $ findInternalLibs pkgInfo name 157 | mapM_ (removeDir doit) dirs 158 | where 159 | unregisterInternal subname = unregister doit opts (subname, ver) 160 | nameVer@(name, ver) = pairNameOfPkgInfo pkgInfo 161 | makeOptList "" = [] 162 | makeOptList x = [x] 163 | 164 | getDirs :: (String, String) -> [String] -> IO [FilePath] 165 | getDirs (name, ver) sandboxOpts = do 166 | importDirs <- queryGhcPkg "import-dirs" 167 | haddock <- map docDir <$> queryGhcPkg "haddock-html" 168 | return $ topDir $ importDirs ++ haddock 169 | where 170 | nameVer = name ++ "-" ++ ver 171 | queryGhcPkg field = do 172 | let options = ["field"] ++ sandboxOpts ++ [nameVer, field] 173 | ws <- words <$> readProcess "ghc-pkg" options "" 174 | return $ case ws of 175 | [] -> [] 176 | (_ : xs) -> xs 177 | docDir dir 178 | | takeFileName dir == "html" = takeDirectory dir 179 | | otherwise = dir 180 | topDir [] = [] 181 | topDir ds@(dir : _) 182 | | takeFileName top == nameVer = top : ds 183 | | otherwise = ds 184 | where 185 | top = takeDirectory dir 186 | 187 | removeDir :: Bool -> FilePath -> IO () 188 | removeDir doit dir = do 189 | exist <- doesDirectoryExist dir 190 | when exist $ do 191 | putStrLn $ "Deleting " ++ dir 192 | when doit $ removeDirectoryRecursive dir 193 | 194 | unregister :: Bool -> [Option] -> (String, String) -> IO () 195 | unregister doit _ (name, ver) = 196 | if doit 197 | then do 198 | putStrLn $ "Deleting " ++ name ++ " " ++ ver 199 | sandboxOpts <- getSandboxOpts2 <$> getSandbox 200 | when doit $ void . system $ script sandboxOpts 201 | else 202 | putStrLn $ name ++ " " ++ ver 203 | where 204 | script sandboxOpts = "ghc-pkg unregister " ++ sandboxOpts ++ " " ++ name ++ "-" ++ ver 205 | 206 | ---------------------------------------------------------------- 207 | 208 | genpaths :: FunctionCommand 209 | genpaths _ _ _ = genPaths 210 | 211 | ---------------------------------------------------------------- 212 | 213 | check :: FunctionCommand 214 | check _ _ _ = do 215 | sandboxOpts <- getSandboxOpts2 <$> getSandbox 216 | void . system $ script sandboxOpts 217 | where 218 | script sandboxOpts = "ghc-pkg check -v " ++ sandboxOpts 219 | 220 | ---------------------------------------------------------------- 221 | 222 | deps :: FunctionCommand 223 | deps nmver opts _ = printDepends nmver opts printDeps 224 | 225 | revdeps :: FunctionCommand 226 | revdeps nmver opts _ = printDepends nmver opts printRevDeps 227 | 228 | printDepends 229 | :: [String] 230 | -> [Option] 231 | -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) 232 | -> IO () 233 | printDepends nmver opts func = do 234 | db' <- getSandbox >>= getPkgDB 235 | pkg <- lookupPkg nmver db' 236 | db <- getDB opts 237 | func rec info db 0 pkg 238 | where 239 | rec = OptRecursive `elem` opts 240 | info = OptInfo `elem` opts 241 | 242 | ---------------------------------------------------------------- 243 | 244 | lookupPkg :: [String] -> PkgDB -> IO PkgInfo 245 | lookupPkg [] _ = do 246 | hPutStrLn stderr "Package name must be specified." 247 | exitFailure 248 | lookupPkg [name] db = checkOne $ lookupByName name db 249 | lookupPkg [name, ver] db = checkOne $ lookupByVersion name ver db 250 | lookupPkg _ _ = do 251 | hPutStrLn stderr "Only one package name must be specified." 252 | exitFailure 253 | 254 | checkOne :: [PkgInfo] -> IO PkgInfo 255 | checkOne [] = do 256 | hPutStrLn stderr "No such package found." 257 | exitFailure 258 | checkOne [pkg] = return pkg 259 | checkOne pkgs = do 260 | hPutStrLn stderr "Package version must be specified." 261 | mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) pkgs 262 | exitFailure 263 | 264 | ---------------------------------------------------------------- 265 | 266 | initSandbox :: FunctionCommand 267 | initSandbox [] _ _ = void . system $ "cabal v1-sandbox init" 268 | initSandbox [path] _ _ = void . system $ "cabal v1-sandbox init --sandbox " ++ path 269 | initSandbox _ _ _ = do 270 | hPutStrLn stderr "Only one argument is allowed" 271 | exitFailure 272 | 273 | ---------------------------------------------------------------- 274 | 275 | add :: FunctionCommand 276 | add [src] _ _ = void . system $ "cabal v1-sandbox add-source " ++ src 277 | add _ _ _ = do 278 | hPutStrLn stderr "A source path be specified." 279 | exitFailure 280 | 281 | ---------------------------------------------------------------- 282 | 283 | ghci :: FunctionCommand 284 | ghci args _ options = do 285 | sbxOpts <- getSandboxOpts <$> getSandbox 286 | void $ 287 | system $ 288 | "ghci" ++ " " ++ sbxOpts ++ " " ++ intercalate " " (options ++ args) 289 | --------------------------------------------------------------------------------