Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 203 lines (174 sloc) 6.667 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
module Commands (
    deps, revdeps, installed, outdated, uninstall, search, env
  , genpaths, check, add, ghci
  ) where

import Control.Applicative hiding (many)
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import GenPaths
import PkgDB
import System.Exit
import System.IO
import System.Process hiding (env)
import Types
import Utils
import VerDB

----------------------------------------------------------------

search :: FunctionCommand
search _ [x] _ = do
    nvls <- getVerAlist False
    forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ toDotted v
  where
    key = map toLower x
    sat (n,_) = key `isPrefixOf` map toLower n
    lok [] = []
    lok (e:es)
      | sat e = e : lok es
      | otherwise = lok es
search _ _ _ = do
    hPutStrLn stderr "One search-key should be specified."
    exitFailure

----------------------------------------------------------------

installed :: FunctionCommand
installed _ _ opts = do
    let optall = OptAll `elem` opts
        optrec = OptRecursive `elem` opts
    db' <- getPkgDB (getSandbox opts)
    flt <- if optall then allPkgs else userPkgs
    -- FIXME: the optall case does unnecessary conversion
    let pkgs = toPkgList flt db'
        db = toPkgDB pkgs
    forM_ pkgs $ \pkgi -> do
        putStr $ fullNameOfPkgInfo pkgi
        extraInfo info pkgi
        putStrLn ""
        when optrec $ printDeps True info db 1 pkgi
  where
    info = OptInfo `elem` opts

outdated :: FunctionCommand
outdated _ _ opts = do
    flt <- if OptAll `elem` opts then allPkgs else userPkgs
    pkgs <- toPkgList flt <$> getPkgDB (getSandbox opts)
    verDB <- getVerDB
    forM_ pkgs $ \p -> case lookupLatestVersion (nameOfPkgInfo p) verDB of
        Nothing -> return ()
        Just ver -> when (numVersionOfPkgInfo p /= ver) $
                        putStrLn $ fullNameOfPkgInfo p ++ " < " ++ toDotted ver

----------------------------------------------------------------

uninstall :: FunctionCommand
uninstall _ nmver opts = do
    db' <- getPkgDB (getSandbox opts)
    db <- toPkgDB . flip toPkgList db' <$> userPkgs
    pkg <- lookupPkg nmver db
    let sortedPkgs = topSortedPkgs pkg db
    if onlyOne && length sortedPkgs /= 1 then do
        hPutStrLn stderr "The following packages depend on this. Use the \"-r\" option."
        mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) (init sortedPkgs)
      else do
        unless doit $ putStrLn "The following packages are deleted without the \"-n\" option."
        mapM_ (unregister doit opts . pairNameOfPkgInfo) sortedPkgs
  where
    onlyOne = OptRecursive `notElem` opts
    doit = OptNoharm `notElem` opts

unregister :: Bool -> [Option] -> (String,String) -> IO ()
unregister doit opts (name,ver) =
    if doit then do
        putStrLn $ "Deleting " ++ name ++ " " ++ ver
        pkgconf <- pkgConfOpt opts
        when doit $ void . system $ script pkgconf
      else
        putStrLn $ name ++ " " ++ ver
  where
    script pkgconf = "ghc-pkg unregister " ++ pkgconf ++ name ++ "-" ++ ver

pkgConfOpt :: [Option] -> IO String
pkgConfOpt opts = case getSandbox opts of
    Nothing -> return ""
    Just path -> do
        pkgConf <- getPackageConf path
        return $ "--package-conf=" ++ pkgConf ++ " "

----------------------------------------------------------------

genpaths :: FunctionCommand
genpaths _ _ _ = genPaths

----------------------------------------------------------------

check :: FunctionCommand
check _ _ opts = do
    pkgconf <- pkgConfOpt opts
    void . system $ script pkgconf
  where
   script pkgconf = "ghc-pkg check -v " ++ pkgconf

----------------------------------------------------------------

deps :: FunctionCommand
deps _ nmver opts = printDepends nmver opts printDeps

revdeps :: FunctionCommand
revdeps _ nmver opts = printDepends nmver opts printRevDeps

printDepends :: [String] -> [Option]
             -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO ()
printDepends nmver opts func = do
    db' <- getPkgDB (getSandbox opts)
    pkg <- lookupPkg nmver db'
    db <- if OptAll `elem` opts
          then return db'
          else toPkgDB . flip toPkgList db' <$> userPkgs
    func rec info db 0 pkg
  where
    rec = OptRecursive `elem` opts
    info = OptInfo `elem` opts

----------------------------------------------------------------

lookupPkg :: [String] -> PkgDB -> IO PkgInfo
lookupPkg [] _ = do
  hPutStrLn stderr "Package name must be specified."
  exitFailure
lookupPkg [name] db = checkOne $ lookupByName name db
lookupPkg [name,ver] db = checkOne $ lookupByVersion name ver db
lookupPkg _ _ = do
  hPutStrLn stderr "Only one package name must be specified."
  exitFailure

checkOne :: [PkgInfo] -> IO PkgInfo
checkOne [] = do
    hPutStrLn stderr "No such package found."
    exitFailure
checkOne [pkg] = return pkg
checkOne pkgs = do
    hPutStrLn stderr "Package version must be specified."
    mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) pkgs
    exitFailure

----------------------------------------------------------------

env :: FunctionCommand
env _ _ opts = case getSandbox opts of
    Nothing -> do
        putStrLn "unset CAB_SANDBOX_PATH"
        putStrLn "unsetenv CAB_SANDBOX_PATH"
        putStrLn ""
        putStrLn "unset GHC_PACKAGE_PATH"
        putStrLn "unsetenv GHC_PACKAGE_PATH"
    Just path -> do
        pkgConf <- getPackageConf path
        gPkgConf <- globalPackageDB
        putStrLn $ "export CAB_SANDBOX_PATH=" ++ path
        putStrLn $ "setenv CAB_SANDBOX_PATH " ++ path
        putStrLn ""
        putStrLn "The following commands are not necessary in normal case."
        let confs = gPkgConf ++ ":" ++ pkgConf
        putStrLn $ "export GHC_PACKAGE_PATH=" ++ confs
        putStrLn $ "setenv GHC_PACKAGE_PATH " ++ confs

globalPackageDB :: IO String
globalPackageDB = do
    res <- readProcess "ghc" ["--info"] []
    let alist = read res :: [(String,String)]
    return . fromJust $ lookup "Global Package DB" alist

----------------------------------------------------------------

add :: FunctionCommand
add _ params opts = case getSandbox opts of
    Nothing -> hPutStrLn stderr "A sandbox must be specified with \"-s\" option."
    Just sbox -> case params of
        [src] -> void . system $ "cabal-dev add-source " ++ src ++ " -s " ++ sbox
        _ -> hPutStrLn stderr "A source path be specified."

----------------------------------------------------------------

ghci :: FunctionCommand
ghci _ _ opts = case getSandbox opts of
    Nothing -> hPutStrLn stderr "A sandbox must be specified with \"-s\" option."
    Just sbox -> do
      _ <- system $ "cabal-dev -s " ++ sbox ++ " ghci"
      return ()
Something went wrong with that request. Please try again.