-- | Functions and instances used by but not related to cabal-debian.
-- These could conceivably be moved into more general libraries.
{-# LANGUAGE FlexibleContexts, FlexibleInstances, Rank2Types, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
module Debian.Debianize.Prelude
    ( curry3
    , DebMap
    , buildDebVersionMap
    , (!)
    , strip
    , stripWith
    , strictReadF
    , replaceFile
    , modifyFile
    , diffFile
    , removeIfExists
    , dpkgFileMap
    , debOfFile
    , cond
    , readFile'
    , readFileMaybe
    , showDeps
    , showDeps'
    , withCurrentDirectory
    , getDirectoryContents'
    , setMapMaybe
    , zipMaps
    , foldEmpty
    , maybeL
    , indent
    , maybeRead
    , read'
    , modifyM
    , intToVerbosity'
    , listElemLens
    , maybeLens
    , fromEmpty
    , fromSingleton
    , (.?=)
    , escapeDebianWildcards
    , module Distribution.Version
    , module Distribution.Package
    ) where


import Control.Exception as E (bracket, catch, throw, try)
import Control.Lens
import Control.Monad (when)
import Control.Monad.Reader (ask, ReaderT)
import Control.Monad.State (get, MonadState, StateT, put)
import Data.Char (isSpace)
import Data.List as List (dropWhileEnd, intersperse, lines, map)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe)
import Data.Set as Set (Set, toList)
import qualified Data.Set as Set (findMin, fromList, null, size)
import Data.Text as Text (Text, unpack)
import Data.Text.IO (hGetContents)
import Debian.Control (stripWS)
import Debian.Orphans ()
import Debian.Pretty (PP(PP))
import qualified Debian.Relation as D (BinPkgName(..), Relations)
import Debian.Relation.Common ()
import Debian.Version (DebianVersion, parseDebianVersion', prettyDebianVersion)
import Distribution.Package (PackageIdentifier(..), PackageName, mkPackageName, unPackageName)
import Distribution.Version
import Distribution.Pretty (Pretty(pretty))
import Distribution.Verbosity (intToVerbosity, Verbosity)
import GHC.IO.Exception (ExitCode(ExitFailure, ExitSuccess), IOErrorType(InappropriateType, NoSuchThing), IOException(IOError, ioe_description, ioe_type))
import Prelude hiding (map)
import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, getDirectoryContents, removeDirectory, removeFile, renameFile, setCurrentDirectory)
import System.FilePath ((</>))
import System.IO (hSetBinaryMode, IOMode(ReadMode), openFile, withFile)
import System.IO.Error (catchIOError, isDoesNotExistError)
import System.Process (readProcess, readProcessWithExitCode, showCommandForUser)
import Text.PrettyPrint.HughesPJClass as PP (text)

curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d
curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d
curry3 (a, b, c) -> d
f a
a b
b c
c = (a, b, c) -> d
f (a
a, b
b, c
c)

type DebMap = Map D.BinPkgName (Maybe DebianVersion)

-- | Query versions of installed packages
buildDebVersionMap :: IO DebMap
buildDebVersionMap :: IO DebMap
buildDebVersionMap =
    [(BinPkgName, Maybe DebianVersion)] -> DebMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(BinPkgName, Maybe DebianVersion)] -> DebMap)
-> (String -> [(BinPkgName, Maybe DebianVersion)])
-> String
-> DebMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (BinPkgName, Maybe DebianVersion))
-> [String] -> [(BinPkgName, Maybe DebianVersion)]
forall a b. (a -> b) -> [a] -> [b]
List.map String -> (BinPkgName, Maybe DebianVersion)
lineToKV ([String] -> [(BinPkgName, Maybe DebianVersion)])
-> (String -> [String])
-> String
-> [(BinPkgName, Maybe DebianVersion)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
Prelude.lines (String -> DebMap) -> IO String -> IO DebMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"dpkg-query" [String
"--showformat", String
"${Package}\\t${Version}\\n"] String
""
    where
        lineToKV :: String -> (BinPkgName, Maybe DebianVersion)
lineToKV = (String -> BinPkgName)
-> (String -> Maybe DebianVersion)
-> (String, String)
-> (BinPkgName, Maybe DebianVersion)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (String -> BinPkgName
D.BinPkgName (String -> BinPkgName)
-> (String -> String) -> String -> BinPkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. ControlFunctions a => a -> a
stripWS) (DebianVersion -> Maybe DebianVersion
forall a. a -> Maybe a
Just (DebianVersion -> Maybe DebianVersion)
-> (String -> DebianVersion) -> String -> Maybe DebianVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DebianVersion
forall string. ParseDebianVersion string => string -> DebianVersion
parseDebianVersion' (String -> DebianVersion)
-> (String -> String) -> String -> DebianVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. ControlFunctions a => a -> a
stripWS) ((String, String) -> (BinPkgName, Maybe DebianVersion))
-> (String -> (String, String))
-> String
-> (BinPkgName, Maybe DebianVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t')

(!) :: DebMap -> D.BinPkgName -> DebianVersion
DebMap
m ! :: DebMap -> BinPkgName -> DebianVersion
! BinPkgName
k = DebianVersion
-> (DebianVersion -> DebianVersion)
-> Maybe DebianVersion
-> DebianVersion
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> DebianVersion
forall a. HasCallStack => String -> a
error (String
"No version number for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (BinPkgName -> Doc) -> BinPkgName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PP BinPkgName -> Doc
forall a. Pretty a => a -> Doc
pretty (PP BinPkgName -> Doc)
-> (BinPkgName -> PP BinPkgName) -> BinPkgName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinPkgName -> PP BinPkgName
forall a. a -> PP a
PP (BinPkgName -> String) -> BinPkgName -> String
forall a b. (a -> b) -> a -> b
$ BinPkgName
k) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Map BinPkgName (Maybe Doc) -> String
forall a. Show a => a -> String
show ((Maybe DebianVersion -> Maybe Doc)
-> DebMap -> Map BinPkgName (Maybe Doc)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Maybe Doc
-> (DebianVersion -> Maybe Doc) -> Maybe DebianVersion -> Maybe Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Doc
forall a. Maybe a
Nothing (Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc)
-> (DebianVersion -> Doc) -> DebianVersion -> Maybe Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebianVersion -> Doc
prettyDebianVersion)) DebMap
m))) DebianVersion -> DebianVersion
forall a. a -> a
id (Maybe DebianVersion -> BinPkgName -> DebMap -> Maybe DebianVersion
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Maybe DebianVersion
forall a. Maybe a
Nothing BinPkgName
k DebMap
m)

strip :: String -> String
strip :: String -> String
strip = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
stripWith Char -> Bool
isSpace

stripWith :: (a -> Bool) -> [a] -> [a]
stripWith :: (a -> Bool) -> [a] -> [a]
stripWith a -> Bool
f = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile a -> Bool
f ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd a -> Bool
f

strictReadF :: (Text -> r) -> FilePath -> IO r
strictReadF :: (Text -> r) -> String -> IO r
strictReadF Text -> r
f String
path = String -> IOMode -> (Handle -> IO r) -> IO r
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
ReadMode (\Handle
h -> Handle -> IO Text
hGetContents Handle
h IO Text -> (Text -> IO r) -> IO r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Text
x -> r -> IO r
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> IO r) -> r -> IO r
forall a b. (a -> b) -> a -> b
$! Text -> r
f Text
x))
-- strictRead = strictReadF id

-- | Write a file which we might still be reading from in
-- order to compute the text argument.
replaceFile :: FilePath -> String -> IO ()
replaceFile :: String -> String -> IO ()
replaceFile String
path String
s =
    do String -> IO ()
removeFile String
back IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\ (IOException
e :: IOException) -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (IOException -> Bool
isDoesNotExistError IOException
e)) (IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e))
       String -> String -> IO ()
renameFile String
path String
back IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\ (IOException
e :: IOException) -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (IOException -> Bool
isDoesNotExistError IOException
e)) (IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e))
       String -> String -> IO ()
writeFile String
path String
s
    where
      back :: String
back = String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"~"

-- | Compute the new file contents from the old.  If f returns Nothing
-- do not write.
modifyFile :: FilePath -> (String -> IO (Maybe String)) -> IO ()
modifyFile :: String -> (String -> IO (Maybe String)) -> IO ()
modifyFile String
path String -> IO (Maybe String)
f =
    do String -> IO ()
removeFile String
back IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\ (IOException
e :: IOException) -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (IOException -> Bool
isDoesNotExistError IOException
e)) (IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e))
       IO () -> IO (Either IOException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> String -> IO ()
renameFile String
path String
back) IO (Either IOException ())
-> (Either IOException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
           (IOException -> IO ())
-> (() -> IO ()) -> Either IOException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ (IOException
e :: IOException) -> if Bool -> Bool
not (IOException -> Bool
isDoesNotExistError IOException
e)
                                           then IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e
                                           else String -> IO (Maybe String)
f String
"" IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> String -> IO ()
writeFile String
path))
                  (\ () -> String -> IO String
readFile String
back IO String -> (String -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO (Maybe String)
f IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> String -> IO ()
writeFile String
path))
    where
      back :: String
back = String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"~"

diffFile :: FilePath -> Text -> IO (Maybe String)
diffFile :: String -> Text -> IO (Maybe String)
diffFile String
path Text
s =
    String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
cmd [String]
args (Text -> String
unpack Text
s) IO (ExitCode, String, String)
-> ((ExitCode, String, String) -> IO (Maybe String))
-> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (ExitCode
code, String
out, String
_err) ->
    case ExitCode
code of
      ExitCode
ExitSuccess -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
      ExitFailure Int
1 -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
out)
      ExitCode
_ -> String -> IO (Maybe String)
forall a. HasCallStack => String -> a
error (String -> [String] -> String
showCommandForUser String
cmd [String]
args {- ++ " < " ++ show s -} String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
code)
    where
      cmd :: String
cmd = String
"diff"
      args :: [String]
args = [String
"-ruw", String
path, String
"-"]

removeFileIfExists :: FilePath -> IO ()
removeFileIfExists :: String -> IO ()
removeFileIfExists String
x = String -> IO Bool
doesFileExist String
x IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` (String -> IO ()
removeFile String
x))

removeDirectoryIfExists :: FilePath -> IO ()
removeDirectoryIfExists :: String -> IO ()
removeDirectoryIfExists String
x = String -> IO Bool
doesDirectoryExist String
x IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` (String -> IO ()
removeDirectory String
x))

removeIfExists :: FilePath -> IO ()
removeIfExists :: String -> IO ()
removeIfExists String
x = String -> IO ()
removeFileIfExists String
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
removeDirectoryIfExists String
x

-- |Create a map from pathname to the names of the packages that contains that pathname using the
-- contents of the debian package info directory @/var/lib/dpkg/info@.
dpkgFileMap :: IO (Map FilePath (Set D.BinPkgName))
dpkgFileMap :: IO (Map String (Set BinPkgName))
dpkgFileMap =
    do
      [BinPkgName]
installedPackages <- DebMap -> [BinPkgName]
forall k a. Map k a -> [k]
Map.keys (DebMap -> [BinPkgName]) -> IO DebMap -> IO [BinPkgName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO DebMap
buildDebVersionMap

      [[String]]
files <- (BinPkgName -> IO [String]) -> [BinPkgName] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO [String]
listFiles (String -> IO [String])
-> (BinPkgName -> String) -> BinPkgName -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinPkgName -> String
D.unBinPkgName) [BinPkgName]
installedPackages
      Map String (Set BinPkgName) -> IO (Map String (Set BinPkgName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map String (Set BinPkgName) -> IO (Map String (Set BinPkgName)))
-> Map String (Set BinPkgName) -> IO (Map String (Set BinPkgName))
forall a b. (a -> b) -> a -> b
$ [(String, Set BinPkgName)] -> Map String (Set BinPkgName)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, Set BinPkgName)] -> Map String (Set BinPkgName))
-> [(String, Set BinPkgName)] -> Map String (Set BinPkgName)
forall a b. (a -> b) -> a -> b
$ [String] -> [Set BinPkgName] -> [(String, Set BinPkgName)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((BinPkgName -> String) -> [BinPkgName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
List.map BinPkgName -> String
D.unBinPkgName [BinPkgName]
installedPackages) (([String] -> Set BinPkgName) -> [[String]] -> [Set BinPkgName]
forall a b. (a -> b) -> [a] -> [b]
List.map ([BinPkgName] -> Set BinPkgName
forall a. Ord a => [a] -> Set a
Set.fromList ([BinPkgName] -> Set BinPkgName)
-> ([String] -> [BinPkgName]) -> [String] -> Set BinPkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> BinPkgName) -> [String] -> [BinPkgName]
forall a b. (a -> b) -> [a] -> [b]
List.map String -> BinPkgName
D.BinPkgName) ([[String]] -> [Set BinPkgName]) -> [[String]] -> [Set BinPkgName]
forall a b. (a -> b) -> a -> b
$ [[String]]
files)
    where
        listFiles :: String -> IO [String]
listFiles String
pkg = String -> [String]
Prelude.lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"dpkg-query" [String
"--listfiles", String
pkg] String
""

-- |Given a path, return the name of the package that owns it.
debOfFile :: FilePath -> ReaderT (Map FilePath (Set D.BinPkgName)) IO (Maybe D.BinPkgName)
debOfFile :: String
-> ReaderT (Map String (Set BinPkgName)) IO (Maybe BinPkgName)
debOfFile String
path =
    do Map String (Set BinPkgName)
mp <- ReaderT
  (Map String (Set BinPkgName)) IO (Map String (Set BinPkgName))
forall r (m :: * -> *). MonadReader r m => m r
ask
       Maybe BinPkgName
-> ReaderT (Map String (Set BinPkgName)) IO (Maybe BinPkgName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe BinPkgName
 -> ReaderT (Map String (Set BinPkgName)) IO (Maybe BinPkgName))
-> Maybe BinPkgName
-> ReaderT (Map String (Set BinPkgName)) IO (Maybe BinPkgName)
forall a b. (a -> b) -> a -> b
$ Maybe (Set BinPkgName) -> Maybe BinPkgName
forall a. Maybe (Set a) -> Maybe a
testPath (String -> Map String (Set BinPkgName) -> Maybe (Set BinPkgName)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
path Map String (Set BinPkgName)
mp)
    where
      -- testPath :: Maybe (Set FilePath) -> Maybe FilePath
      testPath :: Maybe (Set a) -> Maybe a
testPath Maybe (Set a)
Nothing = Maybe a
forall a. Maybe a
Nothing
      testPath (Just Set a
s) =
          case Set a -> Int
forall a. Set a -> Int
Set.size Set a
s of
            Int
1 -> a -> Maybe a
forall a. a -> Maybe a
Just (Set a -> a
forall a. Set a -> a
Set.findMin Set a
s)
            Int
_ -> Maybe a
forall a. Maybe a
Nothing

cond :: t -> t -> Bool -> t
cond :: t -> t -> Bool -> t
cond t
ifF t
_ifT Bool
False = t
ifF
cond t
_ifF t
ifT Bool
True = t
ifT

readFile' :: FilePath -> IO Text
readFile' :: String -> IO Text
readFile' String
path =
    do Handle
file <- String -> IOMode -> IO Handle
openFile String
path IOMode
ReadMode
       Handle -> Bool -> IO ()
hSetBinaryMode Handle
file Bool
True
       Handle -> IO Text
hGetContents Handle
file

readFileMaybe :: FilePath -> IO (Maybe Text)
readFileMaybe :: String -> IO (Maybe Text)
readFileMaybe String
path = (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
readFile' String
path) IO (Maybe Text)
-> (IOException -> IO (Maybe Text)) -> IO (Maybe Text)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIOError` (\ IOException
_ -> Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing)

showDeps :: D.Relations -> String
showDeps :: Relations -> String
showDeps = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (Relations -> Doc) -> Relations -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PP Relations -> Doc
forall a. Pretty a => a -> Doc
pretty (PP Relations -> Doc)
-> (Relations -> PP Relations) -> Relations -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relations -> PP Relations
forall a. a -> PP a
PP

showDeps' :: D.Relations -> String
showDeps' :: Relations -> String
showDeps' Relations
xss = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
"\n ") ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$
    [PP OrRelation -> Doc
forall a. Pretty a => a -> Doc
pretty (OrRelation -> PP OrRelation
forall a. a -> PP a
PP OrRelation
xs) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"," | OrRelation
xs <- Relations
xss ]

-- | From Darcs.Utils - set the working directory and run an IO operation.
withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory :: String -> IO a -> IO a
withCurrentDirectory String
path IO a
m =
    IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket
        (do String
oldwd <- IO String
getCurrentDirectory
            let newwd :: String
newwd = String
oldwd String -> String -> String
</> String
path
            String -> IO ()
setCurrentDirectory' String
newwd
            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
oldwd)
        (\String
oldwd -> String -> IO ()
setCurrentDirectory' String
oldwd {- `catchall` return () -})
        (\String
_oldwd -> IO a
m)

setCurrentDirectory' :: FilePath -> IO ()
setCurrentDirectory' :: String -> IO ()
setCurrentDirectory' String
dir =
    IO () -> IO (Either IOException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO ()
setCurrentDirectory String
dir) IO (Either IOException ())
-> (Either IOException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IOException -> IO ())
-> (() -> IO ()) -> Either IOException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOException -> IO ()
forall p. IOException -> p
handle () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return
    where
      handle :: IOException -> p
handle e :: IOException
e@(IOError {ioe_type :: IOException -> IOErrorType
ioe_type = IOErrorType
NoSuchThing}) = IOException -> p
forall a e. Exception e => e -> a
throw (IOException -> p) -> IOException -> p
forall a b. (a -> b) -> a -> b
$ IOException
e {ioe_description :: String
ioe_description = IOException -> String
ioe_description IOException
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
dir}
      handle e :: IOException
e@(IOError {ioe_type :: IOException -> IOErrorType
ioe_type = IOErrorType
InappropriateType}) = IOException -> p
forall a e. Exception e => e -> a
throw (IOException -> p) -> IOException -> p
forall a b. (a -> b) -> a -> b
$ IOException
e {ioe_description :: String
ioe_description = IOException -> String
ioe_description IOException
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
dir}
      handle e :: IOException
e@(IOError {ioe_type :: IOException -> IOErrorType
ioe_type = IOErrorType
typ}) = IOException -> p
forall a e. Exception e => e -> a
throw (IOException -> p) -> IOException -> p
forall a b. (a -> b) -> a -> b
$ IOException
e {ioe_description :: String
ioe_description = IOException -> String
ioe_description IOException
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" unexpected ioe_type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOErrorType -> String
forall a. Show a => a -> String
show IOErrorType
typ}

{-
catchall :: IO a -> IO a -> IO a
a `catchall` b = a `catchNonSignal` (\_ -> b)

-- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows
-- us to catch anything but a signal.  Useful for situations where we want
-- don't want to inhibit ctrl-C.

catchNonSignal :: IO a -> (E.SomeException -> IO a) -> IO a
catchNonSignal comp handler = catch comp handler'
    where handler' se =
           case fromException se :: Maybe SignalException of
             Nothing -> handler se
             Just _ -> E.throw se

newtype SignalException = SignalException Signal deriving (Show, Typeable)

instance Exception SignalException where
   toException e = SomeException e
   fromException (SomeException e) = cast e
-}

-- | Get directory contents minus dot files.
getDirectoryContents' :: FilePath -> IO [FilePath]
getDirectoryContents' :: String -> IO [String]
getDirectoryContents' String
dir =
    String -> IO [String]
getDirectoryContents String
dir IO [String] -> ([String] -> IO [String]) -> IO [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String])
-> ([String] -> [String]) -> [String] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
dotFile)
    where
      dotFile :: String -> Bool
dotFile String
"." = Bool
True
      dotFile String
".." = Bool
True
      dotFile String
_ = Bool
False

setMapMaybe :: ({-Ord a,-} Ord b) => (a -> Maybe b) -> Set a -> Set b
setMapMaybe :: (a -> Maybe b) -> Set a -> Set b
setMapMaybe a -> Maybe b
p = [b] -> Set b
forall a. Ord a => [a] -> Set a
Set.fromList ([b] -> Set b) -> (Set a -> [b]) -> Set a -> Set b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> [a] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe b
p ([a] -> [b]) -> (Set a -> [a]) -> Set a -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
toList

zipMaps :: Ord k => (k -> Maybe a -> Maybe b -> Maybe c) -> Map k a -> Map k b -> Map k c
zipMaps :: (k -> Maybe a -> Maybe b -> Maybe c)
-> Map k a -> Map k b -> Map k c
zipMaps k -> Maybe a -> Maybe b -> Maybe c
f Map k a
m Map k b
n =
    (k -> b -> Map k c -> Map k c) -> Map k c -> Map k b -> Map k c
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey k -> b -> Map k c -> Map k c
h ((k -> a -> Map k c -> Map k c) -> Map k c -> Map k a -> Map k c
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey k -> a -> Map k c -> Map k c
g Map k c
forall k a. Map k a
Map.empty Map k a
m) Map k b
n
    where
      g :: k -> a -> Map k c -> Map k c
g k
k a
a Map k c
r = case k -> Maybe a -> Maybe b -> Maybe c
f k
k (a -> Maybe a
forall a. a -> Maybe a
Just a
a) (k -> Map k b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k b
n) of
                  Just c
c -> k -> c -> Map k c -> Map k c
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k c
c Map k c
r              -- Both m and n have entries for k
                  Maybe c
Nothing -> Map k c
r                            -- Only m has an entry for k
      h :: k -> b -> Map k c -> Map k c
h k
k b
b Map k c
r = case k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k a
m of
                  Maybe a
Nothing -> case k -> Maybe a -> Maybe b -> Maybe c
f k
k Maybe a
forall a. Maybe a
Nothing (b -> Maybe b
forall a. a -> Maybe a
Just b
b) of
                               Just c
c -> k -> c -> Map k c -> Map k c
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k c
c Map k c
r -- Only n has an entry for k
                               Maybe c
Nothing -> Map k c
r
                  Just a
_ -> Map k c
r

foldEmpty :: r -> ([a] -> r) -> [a] -> r
foldEmpty :: r -> ([a] -> r) -> [a] -> r
foldEmpty r
r [a] -> r
_ [] = r
r
foldEmpty r
_ [a] -> r
f [a]
l = [a] -> r
f [a]
l

-- | If the current value of view x is Nothing, replace it with f.
maybeL :: Lens' a (Maybe b) -> Maybe b -> a -> a
maybeL :: Lens' a (Maybe b) -> Maybe b -> a -> a
maybeL Lens' a (Maybe b)
l Maybe b
mb a
x = ASetter a a (Maybe b) (Maybe b) -> (Maybe b -> Maybe b) -> a -> a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter a a (Maybe b) (Maybe b)
Lens' a (Maybe b)
l (Maybe b -> (b -> Maybe b) -> Maybe b -> Maybe b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe b
mb b -> Maybe b
forall a. a -> Maybe a
Just) a
x

indent :: [Char] -> String -> String
indent :: String -> String -> String
indent String
prefix String
s = [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
List.map (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> [String]
List.lines String
s))

maybeRead :: Read a => String -> Maybe a
maybeRead :: String -> Maybe a
maybeRead = ((a, String) -> a) -> Maybe (a, String) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, String) -> a
forall a b. (a, b) -> a
fst (Maybe (a, String) -> Maybe a)
-> (String -> Maybe (a, String)) -> String -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, String)] -> Maybe (a, String)
forall a. [a] -> Maybe a
listToMaybe ([(a, String)] -> Maybe (a, String))
-> (String -> [(a, String)]) -> String -> Maybe (a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(a, String)]
forall a. Read a => ReadS a
reads

read' :: Read a => (String -> a) -> String -> a
read' :: (String -> a) -> String -> a
read' String -> a
f String
s = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
f String
s) (String -> Maybe a
forall a. Read a => String -> Maybe a
maybeRead String
s)

-- modifyM :: (Monad m, MonadTrans t, MonadState a (t m)) => (a -> m a) -> t m ()
-- modifyM f = get >>= lift . f >>= put

-- modifyM :: (Monad m, MonadTrans t, MonadState a (t m)) => (a -> m a) -> t m ()
modifyM :: MonadState a m => (a -> m a) -> m ()
modifyM :: (a -> m a) -> m ()
modifyM a -> m a
f = m a
forall s (m :: * -> *). MonadState s m => m s
get m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m a
f m a -> (a -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

-- read' :: Read a => String -> a
-- read' s = trace ("read " ++ show s) (read s)

-- | Version of 'Distribution.Verbosity.intToVerbosity' that first
-- clamps its argument to the acceptable range (0-3).
intToVerbosity' :: Int -> Verbosity
intToVerbosity' :: Int -> Verbosity
intToVerbosity' Int
n = Maybe Verbosity -> Verbosity
forall a. HasCallStack => Maybe a -> a
fromJust (Int -> Maybe Verbosity
intToVerbosity (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
3 Int
n)))

listElemLens :: (a -> Bool) -> Lens' [a] (Maybe a)
listElemLens :: (a -> Bool) -> Lens' [a] (Maybe a)
listElemLens a -> Bool
p =
    ([a] -> Maybe a) -> ([a] -> Maybe a -> [a]) -> Lens' [a] (Maybe a)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens [a] -> Maybe a
lensGet [a] -> Maybe a -> [a]
lensPut
    where
      lensGet :: [a] -> Maybe a
lensGet [a]
xs =
          case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) [a]
xs of
            ([a]
_, a
x : [a]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
            ([a], [a])
_ -> Maybe a
forall a. Maybe a
Nothing
      lensPut :: [a] -> Maybe a -> [a]
lensPut [a]
xs Maybe a
Nothing  =
          case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) [a]
xs of
            ([a]
before, a
_ : [a]
after) -> [a]
before [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
after
            ([a], [a])
_ -> [a]
xs
      lensPut [a]
xs (Just a
x) =
          case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) [a]
xs of
            ([a]
before, a
_ : [a]
after) -> [a]
before [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
after)
            ([a], [a])
_ -> [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]

maybeLens :: a -> Lens' a b -> Lens' (Maybe a) b
maybeLens :: a -> Lens' a b -> Lens' (Maybe a) b
maybeLens a
def Lens' a b
l =
    (Maybe a -> b) -> (Maybe a -> b -> Maybe a) -> Lens' (Maybe a) b
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\ Maybe a
x -> (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def Maybe a
x) a -> Getting b a b -> b
forall s a. s -> Getting a s a -> a
^. Getting b a b
Lens' a b
l)
         (\ Maybe a
b b
a -> case (b
a, Maybe a
b) of
                     (b
_, Maybe a
Nothing) -> a -> Maybe a
forall a. a -> Maybe a
Just ((b -> Identity b) -> a -> Identity a
Lens' a b
l ((b -> Identity b) -> a -> Identity a) -> b -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ b
a (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
def)
                     (b
_, Just a
b') -> a -> Maybe a
forall a. a -> Maybe a
Just ((b -> Identity b) -> a -> Identity a
Lens' a b
l ((b -> Identity b) -> a -> Identity a) -> b -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ b
a (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
b'))

fromEmpty :: Set a -> Set a -> Set a
fromEmpty :: Set a -> Set a -> Set a
fromEmpty Set a
d Set a
s | Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
s = Set a
d
fromEmpty Set a
_ Set a
s = Set a
s

fromSingleton :: a -> ([a] -> a) -> Set a -> a
fromSingleton :: a -> ([a] -> a) -> Set a -> a
fromSingleton a
e [a] -> a
multiple Set a
s =
    case Set a -> [a]
forall a. Set a -> [a]
toList Set a
s of
      [a
x] -> a
x
      [] -> a
e
      [a]
xs -> [a] -> a
multiple [a]
xs

instance Pretty (PP PackageIdentifier) where
    pretty :: PP PackageIdentifier -> Doc
pretty (PP PackageIdentifier
p) = PP PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty (PackageName -> PP PackageName
forall a. a -> PP a
PP (PackageIdentifier -> PackageName
pkgName PackageIdentifier
p)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"-" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PP Version -> Doc
forall a. Pretty a => a -> Doc
pretty (Version -> PP Version
forall a. a -> PP a
PP (PackageIdentifier -> Version
pkgVersion PackageIdentifier
p))

instance Pretty (PP PackageName) where
    pretty :: PP PackageName -> Doc
pretty (PP PackageName
p) = String -> Doc
text (PackageName -> String
unPackageName PackageName
p)

-- | Set @b@ if it currently isNothing and the argument isJust, that is
--  1. Nothing happens if the argument isNothing
--  2. Nothing happens if the current value isJust
(.?=) :: Monad m => Lens' a (Maybe b) -> Maybe b -> StateT a m ()
Lens' a (Maybe b)
l .?= :: Lens' a (Maybe b) -> Maybe b -> StateT a m ()
.?= Maybe b
mx = Getting (Maybe b) a (Maybe b) -> StateT a m (Maybe b)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe b) a (Maybe b)
Lens' a (Maybe b)
l StateT a m (Maybe b) -> (Maybe b -> StateT a m ()) -> StateT a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASetter a a (Maybe b) (Maybe b) -> Maybe b -> StateT a m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter a a (Maybe b) (Maybe b)
Lens' a (Maybe b)
l (Maybe b -> StateT a m ())
-> (Maybe b -> Maybe b) -> Maybe b -> StateT a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe b -> (b -> Maybe b) -> Maybe b -> Maybe b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe b
mx b -> Maybe b
forall a. a -> Maybe a
Just

-- | This should probably be used in a lot of places.
escapeDebianWildcards :: String -> String
escapeDebianWildcards :: String -> String
escapeDebianWildcards (Char
c : String
more) | Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c String
"[]" = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escapeDebianWildcards String
more
escapeDebianWildcards (Char
c : String
more) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escapeDebianWildcards String
more
escapeDebianWildcards String
"" = String
""