Merge pull request #6806 from phadej/regex-list

Regex list

Cabal/Distribution/Simple/PackageIndex.hs

@@ -77,7 +77,7 @@ module Distribution.Simple.PackageIndex (
   searchByName,
   SearchResult(..),
   searchByNameSubstring,
-  searchByNameExact,
+  searchWithPredicate,
 
   -- ** Bulk queries
   allPackages,
@@ -527,24 +527,19 @@ data SearchResult a = None | Unambiguous a | Ambiguous [a]
 -- That is, all packages that contain the given string in their name.
 --
 searchByNameSubstring :: PackageIndex a -> String -> [a]
-searchByNameSubstring =
-  searchByNameInternal False
-
-searchByNameExact :: PackageIndex a -> String -> [a]
-searchByNameExact =
-  searchByNameInternal True
+searchByNameSubstring index searchterm =
+  searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n)
+  where lsearchterm = lowercase searchterm
 
-searchByNameInternal :: Bool -> PackageIndex a -> String -> [a]
-searchByNameInternal exactMatch index searchterm =
+-- | @since 3.4.0.0
+searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a]
+searchWithPredicate index predicate =
   [ pkg
   -- Don't match internal packages
   | ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index)
-  , if exactMatch
-      then searchterm == unPackageName pname
-      else lsearchterm `isInfixOf` lowercase (unPackageName pname)
+  , predicate (unPackageName pname)
   , pkgs <- Map.elems pvers
   , pkg <- pkgs ]
-  where lsearchterm = lowercase searchterm
 
 --
 -- * Special queries

cabal-install/Distribution/Client/List.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Distribution.Client.List
@@ -13,6 +14,9 @@ module Distribution.Client.List (
   list, info
   ) where
 
+import Prelude ()
+import Distribution.Client.Compat.Prelude
+
 import Distribution.Package
          ( PackageName, Package(..), packageName
          , packageVersion, UnitId )
@@ -33,7 +37,7 @@ import Distribution.Simple.Compiler
 import Distribution.Simple.Program (ProgramDb)
 import Distribution.Simple.Utils
         ( equating, comparing, die', notice )
-import Distribution.Simple.Setup (fromFlag)
+import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault)
 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
 import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
 import Distribution.Version
@@ -61,64 +65,73 @@ import Distribution.Client.IndexUtils as IndexUtils
 import Distribution.Client.FetchUtils
          ( isFetched )
 
+import Data.Bits ((.|.))
 import Data.List
-         ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )
+         ( maximumBy, partition )
+import Data.List.NonEmpty (groupBy, nonEmpty)
+import qualified Data.List as L
 import Data.Maybe
-         ( listToMaybe, fromJust, fromMaybe, isJust, maybeToList )
+         ( fromJust )
 import qualified Data.Map as Map
 import Data.Tree as Tree
 import Control.Monad
-         ( MonadPlus(mplus), join )
+         ( join )
 import Control.Exception
          ( assert )
-import Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint
+         ( lineLength, ribbonsPerLine, Doc, renderStyle, char
+         , (<+>), nest, ($+$), text, vcat, style, parens, fsep)
 import System.Directory
          ( doesDirectoryExist )
 
 import Distribution.Utils.ShortText (ShortText)
 import qualified Distribution.Utils.ShortText as ShortText
+import qualified Text.Regex.Base as Regex
+import qualified Text.Regex.Posix.String as Regex
 
 
 -- | Return a list of packages matching given search strings.
 getPkgList :: Verbosity
            -> PackageDBStack
            -> RepoContext
-           -> Compiler
-           -> ProgramDb
+           -> Maybe (Compiler, ProgramDb)
            -> ListFlags
            -> [String]
            -> IO [PackageDisplayInfo]
-getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do
-    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
+getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do
+    installedPkgIndex <- for mcompprogdb $ \(comp, progdb) ->
+        getInstalledPackages verbosity comp packageDBs progdb
     sourcePkgDb       <- getSourcePackages verbosity repoCtxt
+
+    regexps <- for pats $ \pat -> do
+        e <- Regex.compile compOption Regex.execBlank pat
+        case e of
+            Right r  -> return r
+            Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err
+
     let sourcePkgIndex = packageIndex sourcePkgDb
         prefs name = fromMaybe anyVersion
                        (Map.lookup name (packagePreferences sourcePkgDb))
 
+        pkgsInfoMatching ::
+          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
+        pkgsInfoMatching =
+          let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex
+              matchingSource    = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex
+          in mergePackages matchingInstalled matchingSource
+
         pkgsInfo ::
           [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
         pkgsInfo
             -- gather info for all packages
-          | null pats = mergePackages
-                        (InstalledPackageIndex.allPackages installedPkgIndex)
-                        (         PackageIndex.allPackages sourcePkgIndex)
+          | null regexps = mergePackages
+                           (maybe [] InstalledPackageIndex.allPackages installedPkgIndex)
+                           (         PackageIndex.allPackages          sourcePkgIndex)
 
             -- gather info for packages matching search term
           | otherwise = pkgsInfoMatching
 
-        pkgsInfoMatching ::
-          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
-        pkgsInfoMatching =
-          let matchingInstalled = matchingPackages
-                                  ipiSearch
-                                  installedPkgIndex
-              matchingSource   = matchingPackages
-                                 (\ idx n ->
-                                   concatMap snd
-                                   (piSearch idx n))
-                                 sourcePkgIndex
-          in mergePackages matchingInstalled matchingSource
-
         matches :: [PackageDisplayInfo]
         matches = [ mergePackageInfo pref
                       installedPkgs sourcePkgs selectedPkg False
@@ -128,29 +141,28 @@ getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do
                         selectedPkg = latestWithPref pref sourcePkgs ]
     return matches
   where
-    onlyInstalled = fromFlag (listInstalled listFlags)
-    exactMatch = fromFlag (listExactMatch listFlags)
-    ipiSearch | exactMatch = InstalledPackageIndex.searchByNameExact
-              | otherwise  = InstalledPackageIndex.searchByNameSubstring
-    piSearch  | exactMatch = PackageIndex.searchByNameExact
-              | otherwise  = PackageIndex.searchByNameSubstring
-    matchingPackages search index =
+    onlyInstalled   = fromFlagOrDefault False (listInstalled listFlags)
+    caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags)
+
+    compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase
+               | otherwise       = Regex.compExtended
+
+    matchingPackages search regexps index =
       [ pkg
-      | pat <- pats
-      , pkg <- search index pat ]
+      | re <- regexps
+      , pkg <- search index (Regex.matchTest re) ]
 
 
 -- | Show information about packages.
 list :: Verbosity
      -> PackageDBStack
      -> RepoContext
-     -> Compiler
-     -> ProgramDb
+     -> Maybe (Compiler, ProgramDb)
      -> ListFlags
      -> [String]
      -> IO ()
-list verbosity packageDBs repos comp progdb listFlags pats = do
-    matches <- getPkgList verbosity packageDBs repos comp progdb listFlags pats
+list verbosity packageDBs repos mcompProgdb listFlags pats = do
+    matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats
 
     if simpleOutput
       then putStr $ unlines
@@ -204,7 +216,7 @@ info verbosity packageDBs repoCtxt comp progdb
                        (fromFlag $ globalWorldFile globalFlags)
                        sourcePkgs' userTargets
 
-    pkgsinfo      <- sequence
+    pkgsinfo      <- sequenceA
                        [ do pkginfo <- either (die' verbosity) return $
                                          gatherPkgInfo prefs
                                            installedPkgIndex sourcePkgIndex
@@ -330,16 +342,16 @@ showPackageSummaryInfo pkginfo =
      $+$ text ""
   where
     maybeShowST l s f
-        | ShortText.null l = empty
+        | ShortText.null l = Disp.empty
         | otherwise        = text s <+> f (ShortText.fromShortText l)
 
 showPackageDetailedInfo :: PackageDisplayInfo -> String
 showPackageDetailedInfo pkginfo =
   renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
    char '*' <+> pretty (pkgName pkginfo)
-            Disp.<> maybe empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)
+            <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)
             <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ')
-            Disp.<> parens pkgkind
+            <<>> parens pkgkind
    $+$
    (nest 4 $ vcat [
      entryST "Synopsis"      synopsis     hideIfNull  reflowParagraphs
@@ -363,14 +375,14 @@ showPackageDetailedInfo pkginfo =
    , entry "Dependencies"  dependencies hideIfNull     (commaSep dispExtDep)
    , entry "Documentation" haddockHtml  showIfInstalled text
    , entry "Cached"        haveTarball  alwaysShow     dispYesNo
-   , if not (hasLib pkginfo) then empty else
+   , if not (hasLib pkginfo) then mempty else
      text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo))
    ])
    $+$ text ""
   where
     entry fname field cond format = case cond (field pkginfo) of
       Nothing           -> label <+> format (field pkginfo)
-      Just Nothing      -> empty
+      Just Nothing      -> mempty
       Just (Just other) -> label <+> text other
       where
         label   = text fname Disp.<> char ':' Disp.<> padding
@@ -407,7 +419,7 @@ showPackageDetailedInfo pkginfo =
             | hasLib pkginfo                   = text "library"
             | hasExes                          = text "programs"
             | hasExe pkginfo                   = text "program"
-            | otherwise                        = empty
+            | otherwise                        = mempty
 
 
 reflowParagraphs :: String -> Doc
@@ -416,7 +428,7 @@ reflowParagraphs =
   . intersperse (text "")                    -- re-insert blank lines
   . map (fsep . map text . concatMap words)  -- reflow paragraphs
   . filter (/= [""])
-  . groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines
+  . L.groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines
   . lines
 
 reflowLines :: String -> Doc
@@ -548,7 +560,7 @@ mergePackages installedPkgs sourcePkgs =
     collect (OnlyInRight          (name,as)) = (name, [], as)
 
 groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]
-groupOn key = map (\xs -> (key (head xs), xs))
+groupOn key = map (\xs -> (key (head xs), toList xs))
             . groupBy (equating key)
             . sortBy (comparing key)
 
@@ -586,9 +598,12 @@ interestingVersions pref =
     . reorderTree (\(Node (v,_) _) -> pref (mkVersion v))
     . reverseTree
     . mkTree
-    . map versionNumbers
+    . map (or0 . versionNumbers)
 
   where
+    or0 []     = 0 :| []
+    or0 (x:xs) = x :| xs
+
     swizzleTree = unfoldTree (spine [])
       where
         spine ts' (Node x [])     = (x, ts')
@@ -601,12 +616,17 @@ interestingVersions pref =
 
     reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))
 
+    mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool)
     mkTree xs = unfoldTree step (False, [], xs)
       where
+        step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])])
         step (node,ns,vs) =
           ( (reverse ns, node)
-          , [ (any null vs', n:ns, filter (not . null) vs')
-            | (n, vs') <- groups vs ]
+          , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs'))
+            | (n, vs') <- groups vs
+            ]
           )
-        groups = map (\g -> (head (head g), map tail g))
+
+        groups :: [NonEmpty a] -> [(a, NonEmpty [a])]
+        groups = map (\g -> (head (head g), fmap tail g))
                . groupBy (equating head)