packages feed

hackport 0.7.2.2 → 0.7.3.0

raw patch · 62 files changed

+2946/−2231 lines, 62 filesdep +lifted-basedep +monad-controldep +optparse-applicativedep ~mtldep ~parsec

Dependencies added: lifted-base, monad-control, optparse-applicative, parser-combinators

Dependency ranges changed: mtl, parsec

Files

.github/workflows/haskell.yml view
@@ -35,11 +35,14 @@           ${{ runner.os }}-build-           ${{ runner.os }}- -    - name: Install dependencies+    - name: Configure       run: |         cabal update-        cabal build --only-dependencies --enable-tests --enable-benchmarks+        cabal configure --enable-tests --enable-benchmarks --flag=pedantic+    - name: Install dependencies+      run: |+        cabal build --only-dependencies     - name: Build-      run: cabal v2-build --enable-tests all+      run: cabal build     - name: Run all enabled tests       run: cabal test --test-option=--color --test-show-details=streaming
.gitignore view
@@ -4,3 +4,4 @@ .ghc.environment* cabal.project.local report.html+hie.yaml
.gitmodules view
@@ -3,4 +3,4 @@ 	url = https://github.com/gentoo-haskell/cabal.git [submodule "hackage-security"] 	path = hackage-security-	url = https://github.com/well-typed/hackage-security.git+	url = https://github.com/gentoo-haskell/hackage-security.git
+ GlobalFlags.hs view
@@ -0,0 +1,51 @@+module HackPort.GlobalFlags+    ( GlobalFlags(..)+    , defaultGlobalFlags+    , withHackPortContext+    ) where++import qualified Distribution.Verbosity as DV+import qualified Distribution.Simple.Setup as DSS+import qualified Distribution.Client.Config as DCC+import qualified Distribution.Client.GlobalFlags as DCG+import qualified Distribution.Client.Types as DCT+import qualified Distribution.Utils.NubList as DUN++import qualified Network.URI as NU++import System.FilePath ((</>))++import qualified Overlays++-- | Type containing global flags.+data GlobalFlags =+    GlobalFlags { globalVersion :: DSS.Flag Bool+                , globalNumericVersion :: DSS.Flag Bool+                , globalPathToOverlay :: DSS.Flag (Maybe FilePath)+                , globalPathToPortage :: DSS.Flag (Maybe FilePath)+                }++-- | Default 'GlobalFlags'.+defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags =+    GlobalFlags { globalVersion = DSS.Flag False+                , globalNumericVersion = DSS.Flag False+                , globalPathToOverlay = DSS.Flag Nothing+                , globalPathToPortage = DSS.Flag Nothing+                }++-- | Default remote repository. Defaults to [hackage](hackage.haskell.org).+defaultRemoteRepo :: DCT.RemoteRepo+defaultRemoteRepo = DCC.addInfoForKnownRepos $ (DCT.emptyRemoteRepo (DCT.RepoName name)) { DCT.remoteRepoURI = uri }+   where+    Just uri = NU.parseURI "https://hackage.haskell.org/"+    name     = "hackage.haskell.org"++withHackPortContext :: DV.Verbosity -> GlobalFlags -> (DCG.RepoContext -> IO a) -> IO a+withHackPortContext verbosity global_flags callback = do+    overlayPath <- Overlays.getOverlayPath verbosity (DSS.fromFlag $ globalPathToOverlay global_flags)+    let flags = DCG.defaultGlobalFlags {+                    DCG.globalRemoteRepos = DUN.toNubList [defaultRemoteRepo]+                  , DCG.globalCacheDir    = DSS.Flag $ overlayPath </> ".hackport"+                }+    DCG.withRepoContext verbosity flags callback
exe/Main.hs view
@@ -1,491 +1,282 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE ApplicativeDo #-}  module Main (main) where +import Control.Applicative.Combinators+import qualified Control.Applicative.Combinators.NonEmpty as CNE import Control.Monad-import Data.Maybe-import Data.List-import qualified Data.Semigroup as S+import Data.Bitraversable+import Data.Monoid (Endo(..))+import qualified Options.Applicative as Opt+import qualified Options.Applicative.Help as Opt+import qualified Text.Parsec as P+import qualified Text.Parsec.String as P+import qualified Distribution.Verbosity as V --- cabal-import Distribution.Simple.Setup-        ( Flag(..), fromFlag-        , trueArg-        , optionVerbosity-        )+import Status.Types (StatusDirection(..)) -import Distribution.Simple.Command -- commandsRun-import Distribution.Simple.Utils ( dieNoVerbosity, cabalVersion, warn )-import qualified Distribution.PackageDescription.Parsec as Cabal-import qualified Distribution.Package as Cabal-import Distribution.Verbosity (Verbosity, normal)+import Hackport.Env+import Hackport.Command.List+import Hackport.Command.MakeEbuild+import Hackport.Command.Update+import Hackport.Command.Status+import Hackport.Command.Merge  import Data.Version (showVersion) import Distribution.Pretty (prettyShow)-import Distribution.Parsec (simpleParsec)--import qualified Distribution.Client.Setup as CabalInstall-import qualified Distribution.Client.Types as CabalInstall-import qualified Distribution.Client.Update as CabalInstall--import qualified Distribution.Client.IndexUtils as CabalInstall-import qualified Distribution.Solver.Types.SourcePackage as CabalInstall-import qualified Distribution.Solver.Types.PackageIndex as CabalInstall--import Portage.Overlay as Overlay ( loadLazy, inOverlay )-import Portage.Host as Host ( getInfo, portage_dir )-import Portage.PackageId ( normalizeCabalPackageId )--import System.Environment ( getArgs, getProgName )-import System.Directory ( doesDirectoryExist )-import System.Exit ( exitFailure )-{-# LANGUAGE CPP #-}--import System.FilePath ( (</>) )--import qualified HackPort.GlobalFlags as H--import Error-import Status-import Overlays-import Merge+import Distribution.Simple.Utils (cabalVersion)  import qualified Paths_cabal_install import qualified Paths_hackport --------------------------------------------------------------------------- List--------------------------------------------------------------------------data ListFlags = ListFlags {-    listVerbosity :: Flag Verbosity-  }--instance S.Semigroup ListFlags where-  a <> b = ListFlags {-    listVerbosity = combine listVerbosity-  }-    where combine field = field a S.<> field b--instance Monoid ListFlags where-  mempty = ListFlags {-    listVerbosity = mempty-  }-#if !(MIN_VERSION_base(4,11,0))-  mappend a b = ListFlags {-    listVerbosity = combine listVerbosity-  }-    where combine field = field a `mappend` field b-#endif--defaultListFlags :: ListFlags-defaultListFlags = ListFlags {-    listVerbosity = Flag normal-  }--listCommand :: CommandUI ListFlags-listCommand = CommandUI {-    commandName = "list",-    commandSynopsis = "List package versions matching pattern",-    commandUsage = usagePackages "list",-    commandDescription = Nothing,-    commandNotes = Nothing,--    commandDefaultFlags = defaultListFlags,-    commandOptions = \_showOrParseArgs ->-      [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })-      {--      , option [] ["overlay"]-         "Use cached packages list from specified overlay"-         listOverlayPath (\v flags -> flags { listOverlayPath = v })-         (reqArgFlag "PATH")-       -}-      ]-  }--listAction :: ListFlags -> [String] -> H.GlobalFlags -> IO ()-listAction flags extraArgs globalFlags = do- let verbosity = fromFlag (listVerbosity flags)- H.withHackPortContext verbosity globalFlags $ \repoContext -> do-  overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags)-  index <- fmap CabalInstall.packageIndex (CabalInstall.getSourcePackages verbosity repoContext)-  overlay <- Overlay.loadLazy overlayPath-  let pkgs | null extraArgs = CabalInstall.allPackages index-           | otherwise = concatMap (concatMap snd . CabalInstall.searchByNameSubstring index) extraArgs-      normalized = map (normalizeCabalPackageId . CabalInstall.srcpkgPackageId) pkgs-  let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized-  mapM_ (putStrLn . pretty) decorated+main :: IO ()+main = join $ Opt.customExecParser prefs globalParser   where-  pretty :: (Bool, Cabal.PackageIdentifier) -> String-  pretty (isInOverlay, pkgId) =-      let dec | isInOverlay = " * "-              | otherwise   = "   "-      in dec ++ prettyShow pkgId-+    prefs :: Opt.ParserPrefs+    prefs = Opt.prefs+      $  Opt.showHelpOnEmpty+      <> Opt.showHelpOnError+      <> Opt.noBacktrack+      <> Opt.helpLongEquals  -------------------------------------------------------------------------- Make Ebuild+-- Global ----------------------------------------------------------------------- -data MakeEbuildFlags = MakeEbuildFlags {-    makeEbuildVerbosity :: Flag Verbosity-  , makeEbuildCabalFlags :: Flag (Maybe String)-  }+globalParser :: Opt.ParserInfo (IO ())+globalParser = Opt.info (Opt.helper <*> parser) infoMod+  where+    infoMod :: Opt.InfoMod (IO ())+    infoMod = Opt.progDesc+      $  "HackPort is an .ebuild generator from .cabal files "+      ++ "with hackage index support" -instance S.Semigroup MakeEbuildFlags where-  a <> b = MakeEbuildFlags {-    makeEbuildVerbosity = combine makeEbuildVerbosity-  , makeEbuildCabalFlags = makeEbuildCabalFlags b-  }-    where combine field = field a S.<> field b+    parser :: Opt.Parser (IO ())+    parser =  versionParser+          <|> numericVersionParser+          <|> mainParser+      where+        versionParser :: Opt.Parser (IO ())+        versionParser = Opt.flag' printVersion+          $  Opt.short 'V'+          <> Opt.long "version"+          <> Opt.help "Print version information"+          where+            printVersion = putStrLn+              $  "hackport version "+              ++ showVersion Paths_hackport.version+              ++ "\nusing cabal-install "+              ++ showVersion Paths_cabal_install.version+              ++ " and the Cabal library version "+              ++ prettyShow cabalVersion -instance Monoid MakeEbuildFlags where-  mempty = MakeEbuildFlags {-    makeEbuildVerbosity = mempty-  , makeEbuildCabalFlags = mempty-  }-#if !MIN_VERSION_base(4,11,0)-  mappend a b = MakeEbuildFlags {-    makeEbuildVerbosity = combine makeEbuildVerbosity-  , makeEbuildCabalFlags = makeEbuildCabalFlags b-  }-    where combine field = field a `mappend` field b-#endif+        numericVersionParser :: Opt.Parser (IO ())+        numericVersionParser = Opt.flag' printNumericVersion+          $  Opt.long "numeric-version"+          <> Opt.help "Print just the version number"+          where+            printNumericVersion = putStrLn $ showVersion Paths_hackport.version -defaultMakeEbuildFlags :: MakeEbuildFlags-defaultMakeEbuildFlags = MakeEbuildFlags {-    makeEbuildVerbosity = Flag normal-  , makeEbuildCabalFlags = Flag Nothing-  }+        mainParser :: Opt.Parser (IO ())+        mainParser = do+          v <-  silentFlag+            <|> verbosityOption+            <|> (`appEndo` V.normal) . mconcat <$> many verbosityFlag -makeEbuildAction :: MakeEbuildFlags -> [String] -> H.GlobalFlags -> IO ()-makeEbuildAction flags args globalFlags = do-  (catstr,cabals) <- case args of-                      (category:cabal1:cabaln) -> return (category, cabal1:cabaln)-                      _ -> throwEx (ArgumentError "make-ebuild needs at least two arguments. <category> <cabal-1> <cabal-n>")-  cat <- case simpleParsec catstr of-            Just c -> return c-            Nothing -> throwEx (ArgumentError ("could not parse category: " ++ catstr))-  let verbosity = fromFlag (makeEbuildVerbosity flags)-  overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags)-  forM_ cabals $ \cabalFileName -> do-    pkg <- Cabal.readGenericPackageDescription normal cabalFileName-    mergeGenericPackageDescription verbosity overlayPath cat pkg False (fromFlag $ makeEbuildCabalFlags flags)+          op <- optional $ Opt.strOption+            $  Opt.short 'p'+            <> Opt.long "overlay-path"+            <> Opt.metavar "PATH"+            <> helpMulti+              [ "Override search path list where .hackport/ lives"+              , "(default list: ['.', paludis-ovls or emerge-ovls])"+              ] -makeEbuildCommand :: CommandUI MakeEbuildFlags-makeEbuildCommand = CommandUI {-    commandName = "make-ebuild",-    commandSynopsis = "Make an ebuild from a .cabal file",-    commandUsage = \_ -> [],-    commandDescription = Nothing,-    commandNotes = Nothing,+          pp <- optional $ Opt.strOption+            $  Opt.long "portage-path"+            <> Opt.metavar "PATH"+            <> Opt.help "Override path to your portage tree" -    commandDefaultFlags = defaultMakeEbuildFlags,-    commandOptions = \_showOrParseArgs ->-      [ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v })+          mode <- Opt.hsubparser+            $  subcmd "list"        listAction       listParser+            <> subcmd "make-ebuild" makeEbuildAction makeEbuildParser+            <> subcmd "update"      updateAction     updateParser+            <> subcmd "status"      statusAction     statusParser+            <> subcmd "merge"       mergeAction      mergeParser -      , option "f" ["flags"]-        (unlines [ "Set cabal flags to certain state."-                 , "Example: --flags=-all_extensions"-                 ])-        makeEbuildCabalFlags-        (\cabal_flags v -> v{ makeEbuildCabalFlags = cabal_flags })-        (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))-      ]-  }+          pure $ mode GlobalEnv+            { globalVerbosity = v+            , globalPathToOverlay = op+            , globalPathToPortage = pp+            } --------------------------------------------------------------------------- Update------------------------------------------------------------------------+          where+            subcmd+              :: String+              -> Env env ()+              -> Opt.ParserInfo env+              -> Opt.Mod Opt.CommandFields (GlobalEnv -> IO ())+            subcmd name env = Opt.command name . fmap (runEnv env) -data UpdateFlags = UpdateFlags {-    updateVerbosity :: Flag Verbosity-  }+            silentFlag :: Opt.Parser V.Verbosity+            silentFlag = Opt.flag' V.silent+                $  Opt.long "silent"+                <> Opt.help "Use the \"silent\" verbosity level" -instance S.Semigroup UpdateFlags where-  a <> b = UpdateFlags {-    updateVerbosity = combine updateVerbosity-  }-    where combine field = field a S.<> field b+            verbosityString :: P.Parser V.Verbosity+            verbosityString = choice+              [ V.silent <$ (P.try (P.string "0") <|> P.string "silent")+              , V.normal <$ (P.try (P.string "1") <|> P.string "normal")+              , V.verbose <$ (P.try (P.string "2") <|> P.string "verbose")+              , V.deafening <$ (P.try (P.string "3") <|> P.string "deafening")+              ] <* P.eof -instance Monoid UpdateFlags where-  mempty = UpdateFlags {-    updateVerbosity = mempty-  }-#if !(MIN_VERSION_base(4,11,0))-  mappend a b = UpdateFlags {-    updateVerbosity = combine updateVerbosity-  }-    where combine field = field a `mappend` field b-#endif+            verbosityFlag :: Opt.Parser (Endo V.Verbosity)+            verbosityFlag = Opt.flag' (Endo V.moreVerbose)+              $  Opt.short 'v'+              <> Opt.help "Increase verbosity level" -defaultUpdateFlags :: UpdateFlags-defaultUpdateFlags = UpdateFlags {-    updateVerbosity = Flag normal-  } -updateCommand :: CommandUI UpdateFlags-updateCommand = CommandUI {-    commandName = "update",-    commandSynopsis = "Update the local package database",-    commandUsage = usageFlags "update",-    commandDescription = Nothing,-    commandNotes = Nothing,+            verbosityOption :: Opt.Parser V.Verbosity+            verbosityOption = Opt.option readm+                $  Opt.long "verbosity"+                <> helpMulti+                  [ "Set verbosity level "+                  , "(0-3 or (silent,normal,verbose,deafening))"+                  ]+              where+                readm :: Opt.ReadM V.Verbosity+                readm = Opt.eitherReader+                  $ either (Left . err) Right+                  . P.runParser verbosityString () "command line option" -    commandDefaultFlags = defaultUpdateFlags,-    commandOptions = \_ ->-      [ optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v })+                err :: P.ParseError -> String+                err _ = ($ "") $ Opt.displayS $ Opt.renderCompact $ Opt.extractChunk $ Opt.vsepChunks+                  [ Opt.stringChunk "Takes a number (0-3) or one of the following values:"+                  , Opt.tabulate =<< traverse (bitraverse Opt.stringChunk Opt.stringChunk)+                      [ ("silent", "No output")+                      , ("normal", "Default verbosity")+                      , ("verbose", "Increased verbosity")+                      , ("deafening", "Maximum verbosity")+                      ]+                  ] -      {--      , option [] ["server"]-          "Set the server you'd like to update the cache from"-          updateServerURI (\v flags -> flags { updateServerURI = v} )-          (reqArgFlag "SERVER")-      -}-      ]-  } -updateAction :: UpdateFlags -> [String] -> H.GlobalFlags -> IO ()-updateAction flags extraArgs globalFlags = do-  unless (null extraArgs) $-    dieNoVerbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs-  let verbosity = fromFlag (updateVerbosity flags) -  H.withHackPortContext verbosity globalFlags $ \repoContext ->-    -- TODO: parse user's flags as cabal-iinstall does.-    -- Currently I'm lazy to adapt new flag and user:-    --    defaultUpdateFlags-    let updateFlags = commandDefaultFlags CabalInstall.updateCommand-    in CabalInstall.update verbosity updateFlags repoContext- -------------------------------------------------------------------------- Status+-- List ----------------------------------------------------------------------- -data StatusFlags = StatusFlags {-    statusVerbosity :: Flag Verbosity,-    statusDirection :: Flag StatusDirection-  }+listParser :: Opt.ParserInfo ListEnv+listParser = Opt.info parser infoMod+  where+    parser :: Opt.Parser ListEnv+    parser = do+      ps <- many $ Opt.strArgument $ Opt.metavar "PACKAGE"+      pure $ ListEnv ps -defaultStatusFlags :: StatusFlags-defaultStatusFlags = StatusFlags {-    statusVerbosity = Flag normal,-    statusDirection = Flag PortagePlusOverlay-  }+    infoMod :: Opt.InfoMod ListEnv+    infoMod = Opt.progDesc "List package versions matching pattern" -statusCommand :: CommandUI StatusFlags-statusCommand = CommandUI {-    commandName = "status",-    commandSynopsis = "Show up-to-date status against other repos (hackage, ::gentoo)",-    commandUsage = usagePackages "status",-    commandDescription = Nothing,-    commandNotes = Nothing,+-----------------------------------------------------------------------+-- Make Ebuild+----------------------------------------------------------------------- -    commandDefaultFlags = defaultStatusFlags,-    commandOptions = \_ ->-      [ optionVerbosity statusVerbosity (\v flags -> flags { statusVerbosity = v })-      , option [] ["to-portage"]-          "Print only packages likely to be interesting to move to the portage tree."-          statusDirection (\v flags -> flags { statusDirection = v })-          (noArg (Flag OverlayToPortage))-      , option [] ["from-hackage"]-          "Print only packages likely to be interesting to move from hackage tree."-          statusDirection (\v flags -> flags { statusDirection = v })-          (noArg (Flag HackageToOverlay))-      ]-  }+makeEbuildParser :: Opt.ParserInfo MakeEbuildEnv+makeEbuildParser = Opt.info parser infoMod+  where+    parser :: Opt.Parser MakeEbuildEnv+    parser = do+      cat <- Opt.strArgument $ Opt.metavar "<CATEGORY>"+      cabalFiles <- CNE.some $ Opt.strArgument $ Opt.metavar "[EBUILD FILE]"+      flags <- optional cabalFlagsParser+      notOnHackage <- Opt.switch+        $  Opt.long "not-on-hackage"+        <> Opt.help "Skip writing the hackage remote-id to metadata.xml" -statusAction :: StatusFlags -> [String] -> H.GlobalFlags -> IO ()-statusAction flags args globalFlags = do-  let verbosity = fromFlag (statusVerbosity flags)-      direction = fromFlag (statusDirection flags)-  portagePath <- getPortageDir verbosity globalFlags-  overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags)+      pure $ MakeEbuildEnv cat cabalFiles flags (not notOnHackage) -  H.withHackPortContext verbosity globalFlags $ \repoContext ->-      runStatus verbosity portagePath overlayPath direction args repoContext+    infoMod :: Opt.InfoMod MakeEbuildEnv+    infoMod = Opt.progDesc "Make an ebuild from a .cabal file"  -------------------------------------------------------------------------- Merge+-- Update ----------------------------------------------------------------------- -data MergeFlags = MergeFlags {-    mergeVerbosity :: Flag Verbosity-  , mergeCabalFlags :: Flag (Maybe String)-  }+updateParser :: Opt.ParserInfo ()+updateParser = Opt.info parser infoMod+  where+    parser :: Opt.Parser ()+    parser = pure () -instance S.Semigroup MergeFlags where-  a <> b = MergeFlags {-    mergeVerbosity = combine mergeVerbosity-  , mergeCabalFlags = mergeCabalFlags b-  }-    where combine field = field a S.<> field b+    infoMod :: Opt.InfoMod ()+    infoMod = Opt.progDesc "Update the local package database" -instance Monoid MergeFlags where-  mempty = MergeFlags {-    mergeVerbosity = mempty-  , mergeCabalFlags = mempty-  }-#if !(MIN_VERSION_base(4,11,0))-  mappend a b = MergeFlags {-    mergeVerbosity = combine mergeVerbosity-  , mergeCabalFlags = mergeCabalFlags b-  }-    where combine field = field a `mappend` field b-#endif+-----------------------------------------------------------------------+-- Status+----------------------------------------------------------------------- -defaultMergeFlags :: MergeFlags-defaultMergeFlags = MergeFlags {-    mergeVerbosity = Flag normal-  , mergeCabalFlags = Flag Nothing-  }+statusParser :: Opt.ParserInfo StatusEnv+statusParser = Opt.info parser infoMod+  where+    parser :: Opt.Parser StatusEnv+    parser = do+      dir <- choice+        [ Opt.flag' OverlayToPortage+            $  Opt.long "to-portage"+            <> Opt.help "Print only packages likely to be interesting to move to the portage tree."+        , Opt.flag' HackageToOverlay+            $  Opt.long "from-hackage"+            <> Opt.help "Print only packages likely to be interesting to move from hackage tree."+        , pure PortagePlusOverlay+        ] -mergeCommand :: CommandUI MergeFlags-mergeCommand = CommandUI {-    commandName = "merge",-    commandSynopsis = "Make an ebuild out of hackage package",-    commandUsage = usagePackages "merge",-    commandDescription = Nothing,-    commandNotes = Nothing,+      pkgs <- many $ Opt.strArgument $ Opt.metavar "PACKAGE" -    commandDefaultFlags = defaultMergeFlags,-    commandOptions = \_showOrParseArgs ->-      [ optionVerbosity mergeVerbosity (\v flags -> flags { mergeVerbosity = v })+      pure StatusEnv+        { statusDirection = dir+        , statusPackages = pkgs+        } -      , option "f" ["flags"]-        (unlines [ "Set cabal flags to certain state."-                 , "Example: --flags=-all_extensions"-                 ])-        mergeCabalFlags-        (\cabal_flags v -> v{ mergeCabalFlags = cabal_flags})-        (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))+    infoMod :: Opt.InfoMod StatusEnv+    infoMod = Opt.progDescDoc $ docMulti Opt.sep+      [ "Show up-to-date status against other repos"+      , "(hackage, ::gentoo)"       ]-  } -mergeAction :: MergeFlags -> [String] -> H.GlobalFlags -> IO ()-mergeAction flags extraArgs globalFlags = do-  let verbosity = fromFlag (mergeVerbosity flags)-  overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags)--  H.withHackPortContext verbosity globalFlags $ \repoContext ->-    merge verbosity repoContext extraArgs overlayPath (fromFlag $ mergeCabalFlags flags)- -------------------------------------------------------------------------- Utils+-- Merge ----------------------------------------------------------------------- -usagePackages :: String -> String -> String-usagePackages op_name pname =-  "Usage: " ++ pname ++ " " ++ op_name ++ " [FLAGS] [PACKAGE]\n\n"-  ++ "Flags for " ++ op_name ++ ":"+mergeParser :: Opt.ParserInfo MergeEnv+mergeParser = Opt.info parser infoMod+  where+    parser :: Opt.Parser MergeEnv+    parser = do+      flags <- optional $ cabalFlagsParser+      pkg <- Opt.strArgument $ Opt.metavar "PACKAGE" -usageFlags :: String -> String -> String-usageFlags flag_name pname =-      "Usage: " ++ pname ++ " " ++ flag_name ++ " [FLAGS]\n\n"-      ++ "Flags for " ++ flag_name ++ ":"+      pure $ MergeEnv flags pkg -getPortageDir :: Verbosity -> H.GlobalFlags -> IO FilePath-getPortageDir verbosity globalFlags = do-  let portagePathM =  fromFlag (H.globalPathToPortage globalFlags)-  portagePath <- case portagePathM of-                   Nothing -> Host.portage_dir <$> Host.getInfo-                   Just path -> return path-  exists <- doesDirectoryExist $ portagePath </> "dev-haskell"-  when (not exists) $-    warn verbosity $ "Looks like an invalid portage directory: " ++ portagePath-  return portagePath+    infoMod :: Opt.InfoMod MergeEnv+    infoMod = Opt.progDesc "Make an ebuild out of hackage package"  -------------------------------------------------------------------------- Main+-- Misc ----------------------------------------------------------------------- -globalCommand :: CommandUI H.GlobalFlags-globalCommand = CommandUI {-    commandName = "",-    commandSynopsis = "HackPort is an .ebuild generator from .cabal files with hackage index support",-    commandDescription = Just $ \pname ->-       let-         commands' = commands ++ [commandAddAction helpCommandUI undefined]-         cmdDescs = getNormalCommandDescriptions commands'-         maxlen    = maximum $ [length name | (name, _) <- cmdDescs]-         align str = str ++ replicate (maxlen - length str) ' '-       in-          "Commands:\n"-       ++ unlines [ "  " ++ align name ++ "    " ++ descr-                  | (name, descr) <- cmdDescs ]-       ++ "\n"-       ++ "For more information about a command use\n"-       ++ "  " ++ pname ++ " COMMAND --help\n\n"-       ++ "Typical steps for generating ebuilds from hackage packages:\n"-       ++ concat [ "  " ++ pname ++ " " ++ x ++ "\n"-                 | x <- ["update", "merge <package>"]]-       ++ "\n"-       ++ "Advanced usage:\n"-       ++ concat [ "  " ++ pname ++ " " ++ x ++ "\n"-                 | x <- ["update", "make-ebuild <CATEGORY> <ebuild.name>"]],--    commandNotes = Nothing,-    commandUsage = \pname -> "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",-    commandDefaultFlags = H.defaultGlobalFlags,-    commandOptions = \_showOrParseArgs ->-        [ option ['V'] ["version"]-            "Print version information"-            H.globalVersion (\v flags -> flags { H.globalVersion = v })-            trueArg-        , option [] ["numeric-version"]-            "Print just the version number"-            H.globalNumericVersion (\v flags -> flags { H.globalNumericVersion = v })-            trueArg-        , option ['p'] ["overlay-path"]-            "Override search path list where .hackport/ lives (default list: ['.', paludis-ovls or emerge-ovls])"-            H.globalPathToOverlay (\ovrl_path flags -> flags { H.globalPathToOverlay = ovrl_path })-            (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))-        , option [] ["portage-path"]-            "Override path to your portage tree"-            H.globalPathToPortage (\port_path flags -> flags { H.globalPathToPortage = port_path })-            (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))-        ]-    }--mainWorker :: [String] -> IO ()-mainWorker args =-  case commandsRun globalCommand commands args of-    CommandHelp help -> printHelp help-    CommandList opts -> printOptionsList opts-    CommandErrors errs -> printErrors errs-    CommandReadyToGo (globalflags, commandParse) -> do-      case commandParse of-        _ | fromFlag (H.globalVersion globalflags)        -> printVersion-          | fromFlag (H.globalNumericVersion globalflags) -> printNumericVersion-        CommandHelp help        -> printHelp help-        CommandList opts        -> printOptionsList opts-        CommandErrors errs      -> printErrors errs-        CommandReadyToGo action -> catchEx (action globalflags) errorHandler-    where-    printHelp help = getProgName >>= putStr . help-    printOptionsList = putStr . unlines-    printErrors errs = do-      putStr (concat (intersperse "\n" errs))-      exitFailure-    printNumericVersion = putStrLn $ showVersion Paths_hackport.version-    printVersion        = putStrLn $ "hackport version "-                                  ++ showVersion Paths_hackport.version-                                  ++ "\nusing cabal-install "-                                  ++ showVersion Paths_cabal_install.version-                                  ++ " and the Cabal library version "-                                  ++ prettyShow cabalVersion-    errorHandler :: HackPortError -> IO ()-    errorHandler e = do-      putStrLn (hackPortShowError e)+helpMulti :: [String] -> Opt.Mod f a+helpMulti = Opt.helpDoc . docMulti Opt.sep -commands :: [Command (H.GlobalFlags -> IO ())]-commands =-      [ listCommand `commandAddAction` listAction-      , makeEbuildCommand `commandAddAction` makeEbuildAction-      , statusCommand `commandAddAction` statusAction-      , updateCommand `commandAddAction` updateAction-      , mergeCommand `commandAddAction` mergeAction-      ]+docMulti :: ([Opt.Doc] -> Opt.Doc) -> [String] -> Maybe Opt.Doc+docMulti f = Opt.unChunk . fmap f . traverse Opt.paragraph -main :: IO ()-main = getArgs >>= mainWorker+cabalFlagsParser :: Opt.Parser String+cabalFlagsParser = Opt.strOption+        $  Opt.short 'f'+        <> Opt.long "flags"+        <> Opt.metavar "cabal_flags"+        <> helpMulti+          [ "Set cabal flags to certain state. Example:"+          , "--flags=-all_extensions"+          ]
hackport.cabal view
@@ -1,6 +1,6 @@-Cabal-Version:  2.2+Cabal-Version:  3.0 Name:           hackport-Version:        0.7.2.2+Version:        0.7.3.0 License:        GPL-3.0-or-later License-file:   LICENSE Author:         Henning Günther, Duncan Coutts, Lennart Kolmodin@@ -20,7 +20,27 @@   manual: True   default: False +flag gentoo-tests+  description: Build tests that require a running Gentoo system+  manual: True+  default: False++flag pedantic+    description: Enable -Werror+    default:     False+    manual:      True++-- Turn off all warnings (for external libs and doctests-v2)+common no-warnings+  ghc-options:        -Wno-default++common warnings+  ghc-options:        -Wall+  if flag(pedantic)+      ghc-options:    -Werror+ library hackport-external-libs-Cabal+  import: no-warnings   Default-Language: Haskell2010   Hs-Source-Dirs: cabal, cabal/Cabal @@ -299,6 +319,7 @@     Paths_Cabal  library hackport-external-libs-hackage-security+  import: no-warnings   Default-Language: Haskell2010   Hs-Source-Dirs: hackage-security/hackage-security/src @@ -399,6 +420,7 @@     Text.JSON.Canonical  library hackport-external-libs-cabal-install+  import: no-warnings   Default-Language: Haskell2010   Hs-Source-Dirs: cabal, cabal/cabal-install @@ -504,6 +526,7 @@     Distribution.Solver.Types.Settings  library hackport-internal+  import: warnings   Default-Language: Haskell2010   Hs-Source-Dirs: src   Build-Depends:@@ -517,8 +540,12 @@     directory,     extensible-exceptions,     filepath,+    lifted-base,+    monad-control,+    mtl,     network-uri,     parallel >= 3.2.1.0,+    parsec,     pretty,     process,     split,@@ -529,21 +556,35 @@     QuickCheck,     template-haskell +  default-extensions:+    FlexibleContexts+    MultiParamTypeClasses+   other-extensions:+    CPP+    ConstraintKinds     DeriveDataTypeable+    LambdaCase+    PatternGuards    exposed-modules:     Error     Merge     Overlays     Status-    HackPort.GlobalFlags+    Status.Types+    Hackport.Command.List+    Hackport.Command.MakeEbuild+    Hackport.Command.Update+    Hackport.Command.Status+    Hackport.Command.Merge+    Hackport.Env+    Hackport.Util     Portage.Host     Portage.Overlay     Portage.PackageId     Paths_hackport -  other-modules:     AnsiColor     Cabal2Ebuild     Merge.Dependencies@@ -560,6 +601,7 @@     Portage.EMeta     Portage.GHCCore     Portage.Metadata+    Portage.Metadata.RemoteId     Portage.Resolve     Portage.Tables     Portage.Use@@ -570,7 +612,8 @@     Paths_hackport  Executable hackport-  ghc-options: -Wall -threaded +RTS -N -RTS -with-rtsopts=-N+  import: warnings+  ghc-options: -threaded +RTS -N -RTS -with-rtsopts=-N   ghc-prof-options: -caf-all -auto-all -rtsopts   Main-Is:    Main.hs   Default-Language: Haskell2010@@ -581,18 +624,27 @@     hackport-internal,     base,     directory,-    filepath+    filepath,+    optparse-applicative <0.17,+    parsec,+    parser-combinators   other-modules: Paths_hackport +  other-extensions:+    ApplicativeDo+    CPP+ Test-Suite test-resolve-category+  import:               warnings   -- requires a local Portage overlay, thus fails in a sandboxed test.-  buildable: False-  ghc-options: -Wall+  if !flag(gentoo-tests)+    buildable: False   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell98-  Main-Is:              resolveCat.hs-  Hs-Source-Dirs:       src, tests-  Build-Depends:        hackport-external-libs,+  Main-Is:              Main.hs+  Hs-Source-Dirs:       tests/resolveCat+  Build-Depends:        hackport-external-libs-Cabal,+                        hackport-internal,                         array,                         base,                         binary,@@ -618,14 +670,14 @@     DoAndIfThenElse  Test-Suite test-print-deps+  import:               warnings   -- This test-suite has been incorporated into the 'spec' test-suite,   -- and may be removed in the future.   buildable: False-  ghc-options: -Wall   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell98-  Main-Is:              print_deps.hs-  Hs-Source-Dirs:       src, tests+  Main-Is:              Main.hs+  Hs-Source-Dirs:       tests/print_deps   Build-Depends:        hackport-external-libs,                         array,                         base,@@ -651,14 +703,14 @@     DoAndIfThenElse  Test-Suite test-normalize-deps+  import:               warnings   -- This test-suite has been incorporated into the 'spec' test-suite,   -- and may be removed in the future.   buildable: False-  ghc-options: -Wall   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell98-  Main-Is:              normalize_deps.hs-  Hs-Source-Dirs:       src, tests+  Main-Is:              Main.hs+  Hs-Source-Dirs:       tests/normalize_deps   Build-Depends:        hackport-external-libs,                         array,                         base,@@ -685,12 +737,13 @@     DoAndIfThenElse  test-suite doctests+  import:           warnings   x-doctest-components: lib:hackport-internal exe:hackport   type:             exitcode-stdio-1.0-  Hs-Source-Dirs:   tests+  Hs-Source-Dirs:   tests/doctests   ghc-options:      -threaded   default-language: Haskell98-  main-is:          doctests.hs+  main-is:          Main.hs   build-depends:    base,                     doctest >= 0.8,                     cabal-doctest,@@ -705,27 +758,32 @@     buildable: False  test-suite doctests-v2+  import:           warnings   type:             exitcode-stdio-1.0   default-language: Haskell98-  Hs-Source-Dirs:   tests-  main-is:          doctests-v2.hs-  build-depends:    base, process+  Hs-Source-Dirs:   tests/doctests-v2+  main-is:          Main.hs+  build-depends:    base,+                    process,+                    -- Force doctests-v2 to be built last.+                    -- This should reduce duplicated work: this test runs+                    -- `cabal repl` which will try to compile the whole project.+                    hackport-internal   build-tool-depends:-    cabal-install:cabal >= 3.2,-    doctest:doctest >= 0.8--  other-extensions:-    CPP+--    , cabal-install:cabal >= 3.4+    , doctest:doctest >= 0.8+    -- Force doctests-v2 to be built last+    , hackport:hackport    if flag(cabal-v1)     buildable: False  test-suite spec-  ghc-options: -Wall+  import:               warnings   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010-  Main-Is:              Spec.hs-  Hs-Source-Dirs:       src, tests+  Main-Is:              Main.hs+  Hs-Source-Dirs:       tests/spec   other-modules:     Merge.UtilsSpec     Portage.CabalSpec@@ -733,45 +791,14 @@     Portage.EBuildSpec     Portage.GHCCoreSpec     Portage.MetadataSpec+    Portage.Metadata.RemoteIdSpec     Portage.PackageIdSpec     Portage.VersionSpec     QuickCheck.Instances--    -- hackport-internal-    Error-    Merge-    Overlays-    Status-    HackPort.GlobalFlags-    Portage.Host-    Portage.Overlay-    Portage.PackageId-    Paths_hackport-    AnsiColor-    Cabal2Ebuild-    Merge.Dependencies-    Merge.Utils-    Portage.Cabal-    Portage.Dependency-    Portage.Dependency.Builder-    Portage.Dependency.Normalize-    Portage.Dependency.Print-    Portage.Dependency.Types-    Portage.EBuild-    Portage.EBuild.CabalFeature-    Portage.EBuild.Render-    Portage.EMeta-    Portage.GHCCore-    Portage.Metadata-    Portage.Resolve-    Portage.Tables-    Portage.Use-    Portage.Version-    Util-   Build-Depends:     hackport-external-libs-Cabal,     hackport-external-libs-cabal-install,+    hackport-internal,     async,     base,     bytestring,@@ -783,6 +810,7 @@     hspec >= 2.0,     network-uri,     parallel,+    parsec,     pretty,     process,     QuickCheck >= 2.0,
− hie.yaml 
@@ -1,55 +0,0 @@-cradle:-  cabal:-    - path: "cabal"-      component: "hackport:lib:hackport-external-libs-Cabal"--    - path: "cabal/Cabal"-      component: "hackport:lib:hackport-external-libs-Cabal"--    - path: "hackage-security/hackage-security/src"-      component: "hackport:lib:hackport-external-libs-hackage-security"--    - path: "cabal"-      component: "hackport:lib:hackport-external-libs-cabal-install"--    - path: "cabal/cabal-install"-      component: "hackport:lib:hackport-external-libs-cabal-install"--    - path: "src"-      component: "hackport:lib:hackport-internal"--    - path: "exe/Main.hs"-      component: "hackport:exe:hackport"--    - path: "exe/Paths_hackport.hs"-      component: "hackport:exe:hackport"--    - path: "src"-      component: "hackport:test:test-resolve-category"--    - path: "tests"-      component: "hackport:test:test-resolve-category"--    - path: "src"-      component: "hackport:test:test-print-deps"--    - path: "tests"-      component: "hackport:test:test-print-deps"--    - path: "src"-      component: "hackport:test:test-normalize-deps"--    - path: "tests"-      component: "hackport:test:test-normalize-deps"--    - path: "tests"-      component: "hackport:test:doctests"--    - path: "tests"-      component: "hackport:test:doctests-v2"--    - path: "src"-      component: "hackport:test:spec"--    - path: "tests"-      component: "hackport:test:spec"
src/Cabal2Ebuild.hs view
@@ -25,6 +25,7 @@                                                 ( PackageDescription(..), license) import qualified Distribution.Package as Cabal  ( PackageIdentifier(..)                                                 , Dependency(..))+import qualified Distribution.Types.SourceRepo as Cabal import qualified Distribution.Version as Cabal  ( VersionRange                                                 , cataVersionRange, normaliseVersionRange                                                 , majorUpperBound, mkVersion )@@ -55,6 +56,7 @@     E.hackage_name= cabalPkgName,     E.version     = prettyShow (Cabal.pkgVersion (Cabal.package pkg)),     E.revision    = getHackageRevision,+    E.sourceURIs  = getSourceURIs,     E.description = ST.fromShortText $ if ST.null (Cabal.synopsis pkg)                                           then Cabal.description pkg                                           else Cabal.synopsis pkg,@@ -83,6 +85,8 @@           case Map.lookup "x-revision" (Map.fromList (Cabal.customFieldsPD pkg)) of             Just rev -> rev             _ -> "0"+        getSourceURIs = catMaybes+          $ Cabal.repoLocation <$> Cabal.sourceRepos pkg         thisHomepage = if (ST.null $ Cabal.homepage pkg)                          then E.homepage E.ebuildTemplate                          else ST.fromShortText $ Cabal.homepage pkg
src/Error.hs view
@@ -1,9 +1,14 @@ {-# LANGUAGE DeriveDataTypeable #-} -module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where+module Error+    ( HackPortError(..)+    , hackPortShowError+    , throw+    , catch+    ) where  import Data.Typeable-import Control.Exception.Extensible as EE+import Control.Exception  -- | Type holding all of the 'HackPortError' constructors. data HackPortError@@ -34,13 +39,6 @@  instance Exception HackPortError where --- | Throw a 'HackPortError'.-throwEx :: HackPortError -> IO a-throwEx = EE.throw---- | Catch a 'HackPortError'.-catchEx :: IO a -> (HackPortError -> IO a) -> IO a-catchEx = EE.catch  -- | Show the error string for a given 'HackPortError'. hackPortShowError :: HackPortError -> String
− src/HackPort/GlobalFlags.hs 
@@ -1,51 +0,0 @@-module HackPort.GlobalFlags-    ( GlobalFlags(..)-    , defaultGlobalFlags-    , withHackPortContext-    ) where--import qualified Distribution.Verbosity as DV-import qualified Distribution.Simple.Setup as DSS-import qualified Distribution.Client.Config as DCC-import qualified Distribution.Client.GlobalFlags as DCG-import qualified Distribution.Client.Types as DCT-import qualified Distribution.Utils.NubList as DUN--import qualified Network.URI as NU--import System.FilePath ((</>))--import qualified Overlays---- | Type containing global flags.-data GlobalFlags =-    GlobalFlags { globalVersion :: DSS.Flag Bool-                , globalNumericVersion :: DSS.Flag Bool-                , globalPathToOverlay :: DSS.Flag (Maybe FilePath)-                , globalPathToPortage :: DSS.Flag (Maybe FilePath)-                }---- | Default 'GlobalFlags'.-defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags =-    GlobalFlags { globalVersion = DSS.Flag False-                , globalNumericVersion = DSS.Flag False-                , globalPathToOverlay = DSS.Flag Nothing-                , globalPathToPortage = DSS.Flag Nothing-                }---- | Default remote repository. Defaults to [hackage](hackage.haskell.org).-defaultRemoteRepo :: DCT.RemoteRepo-defaultRemoteRepo = DCC.addInfoForKnownRepos $ (DCT.emptyRemoteRepo (DCT.RepoName name)) { DCT.remoteRepoURI = uri }-   where-    Just uri = NU.parseURI "https://hackage.haskell.org/"-    name     = "hackage.haskell.org"--withHackPortContext :: DV.Verbosity -> GlobalFlags -> (DCG.RepoContext -> IO a) -> IO a-withHackPortContext verbosity global_flags callback = do-    overlayPath <- Overlays.getOverlayPath verbosity (DSS.fromFlag $ globalPathToOverlay global_flags)-    let flags = DCG.defaultGlobalFlags {-                    DCG.globalRemoteRepos = DUN.toNubList [defaultRemoteRepo]-                  , DCG.globalCacheDir    = DSS.Flag $ overlayPath </> ".hackport"-                }-    DCG.withRepoContext verbosity flags callback
+ src/Hackport/Command/List.hs view
@@ -0,0 +1,38 @@+module Hackport.Command.List+  ( listAction+  ) where++import qualified Distribution.Package as Cabal+import Distribution.Pretty (prettyShow)++import qualified Distribution.Client.Types as CabalInstall+import qualified Distribution.Client.IndexUtils as CabalInstall+import qualified Distribution.Solver.Types.SourcePackage as CabalInstall+import qualified Distribution.Solver.Types.PackageIndex as CabalInstall++import Portage.Overlay as Overlay (loadLazy, inOverlay)+import Portage.PackageId (normalizeCabalPackageId)+import Overlays++import Hackport.Util (withHackportContext)+import Hackport.Env++listAction :: Env ListEnv ()+listAction = do+  (GlobalEnv verbosity _ _, ListEnv pkgList) <- ask+  withHackportContext $ \repoContext -> do+    overlayPath <- getOverlayPath+    index <- fmap CabalInstall.packageIndex+      $ liftIO $ CabalInstall.getSourcePackages verbosity repoContext+    overlay <- Overlay.loadLazy overlayPath+    let pkgs | null pkgList = CabalInstall.allPackages index+             | otherwise = concatMap (concatMap snd . CabalInstall.searchByNameSubstring index) pkgList+        normalized = map (normalizeCabalPackageId . CabalInstall.srcpkgPackageId) pkgs+    let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized+    mapM_ (liftIO . putStrLn . pretty) decorated+  where+    pretty :: (Bool, Cabal.PackageIdentifier) -> String+    pretty (isInOverlay, pkgId) =+        let dec | isInOverlay = " * "+                | otherwise   = "   "+          in dec ++ prettyShow pkgId
+ src/Hackport/Command/MakeEbuild.hs view
@@ -0,0 +1,22 @@+module Hackport.Command.MakeEbuild+  ( makeEbuildAction+  ) where++import qualified Distribution.PackageDescription.Parsec as Cabal+import Distribution.Parsec (simpleParsec)+import qualified Distribution.Verbosity as V++import Error+import Merge++import Hackport.Env++makeEbuildAction :: Env MakeEbuildEnv ()+makeEbuildAction = do+  (_, MakeEbuildEnv catstr cabals flags _) <- ask+  cat <- case simpleParsec catstr of+            Just c -> return c+            Nothing -> throw (ArgumentError ("could not parse category: " ++ catstr))+  forM_ cabals $ \cabalFileName -> do+    pkg <- liftIO $ Cabal.readGenericPackageDescription V.normal cabalFileName+    mergeGenericPackageDescription cat pkg False flags
+ src/Hackport/Command/Merge.hs view
@@ -0,0 +1,13 @@+module Hackport.Command.Merge+  ( mergeAction+  ) where++import Merge (merge)++import Hackport.Util (withHackportContext)+import Hackport.Env++mergeAction :: Env MergeEnv ()+mergeAction = askEnv >>= \(MergeEnv flags pkg) -> do+  withHackportContext $ \repoContext ->+    merge repoContext pkg flags
+ src/Hackport/Command/Status.hs view
@@ -0,0 +1,11 @@+module Hackport.Command.Status+  ( statusAction+  ) where++import Status++import Hackport.Env+import Hackport.Util++statusAction :: Env StatusEnv ()+statusAction = withHackportContext runStatus
+ src/Hackport/Command/Update.hs view
@@ -0,0 +1,16 @@+module Hackport.Command.Update+  ( updateAction+  ) where++import Distribution.Simple.Command (CommandUI(..))+import qualified Distribution.Client.Setup as CabalInstall+import qualified Distribution.Client.Update as CabalInstall++import Hackport.Util (withHackportContext)+import Hackport.Env++updateAction :: Env env ()+updateAction  = askGlobalEnv >>= \(GlobalEnv verbosity _ _) ->+  withHackportContext $ \repoContext -> do+    let updateFlags = commandDefaultFlags CabalInstall.updateCommand+    liftIO $ CabalInstall.update verbosity updateFlags repoContext
+ src/Hackport/Env.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}++module Hackport.Env+  (+    -- * Env monad+    MonadEnv+  , HasEnv (..)+  , HasGlobalEnv (..)+  , Env+  , runEnv+    -- * Global env+  , GlobalEnv (..)+    -- * Subcommand env+    -- ** List+  , ListEnv (..)+    -- ** Make Ebuild+  , MakeEbuildEnv (..)+    -- ** Status+  , StatusEnv (..)+    -- ** Merge+  , MergeEnv (..)+    -- * Metadata+  , WritesMetadata (..)+  , UseHackageRemote+    -- * Re-exports+  , module Control.Monad.Reader+  ) where++import Control.Monad.Reader+import Data.List.NonEmpty (NonEmpty (..))+import Data.Semigroup (Last(..))+import qualified Distribution.Verbosity as V++import Status.Types (StatusDirection)++type MonadEnv env m = (HasGlobalEnv m, HasEnv env m, MonadIO m)+type Env env = ReaderT (GlobalEnv, env) IO++class HasGlobalEnv m where+  askGlobalEnv :: m GlobalEnv++instance Monad m => HasGlobalEnv (ReaderT (GlobalEnv,env) m) where+  askGlobalEnv = asks fst++class HasEnv env m where+  askEnv :: m env++instance Monad m => HasEnv env (ReaderT (a,env) m) where+  askEnv = asks snd++data GlobalEnv = GlobalEnv+  { globalVerbosity :: V.Verbosity+  , globalPathToOverlay :: Maybe FilePath+  , globalPathToPortage :: Maybe FilePath+  }+  deriving (Show, Eq, Ord)++instance Semigroup GlobalEnv where+  GlobalEnv v1 po1 pp1 <> GlobalEnv v2 po2 pp2 =+    GlobalEnv+      (getLast (Last v1 <> Last v2))+      (getLast <$> ((Last <$> po1) <> (Last <$> po2)))+      (getLast <$> ((Last <$> pp1) <> (Last <$> pp2)))++instance Monoid GlobalEnv where+  mempty = GlobalEnv V.normal Nothing Nothing++newtype ListEnv = ListEnv+  { listPackages :: [String]+  }+  deriving (Show, Eq, Ord)++class WritesMetadata a where+  useHackageRemote :: a -> UseHackageRemote++type UseHackageRemote = Bool++data MakeEbuildEnv = MakeEbuildEnv+  { makeEbuildCategory :: String+  , makeEbuildCabalFiles :: NonEmpty FilePath+  , makeEbuildCabalFlags :: Maybe String+  , makeEbuildUseHackageRemote :: UseHackageRemote+  }+  deriving (Show, Eq, Ord)++instance WritesMetadata MakeEbuildEnv where+  useHackageRemote = makeEbuildUseHackageRemote++data StatusEnv = StatusEnv+  { statusDirection :: StatusDirection+  , statusPackages :: [String]+  }+  deriving (Eq)++data MergeEnv = MergeEnv+  { mergeCabalFlags :: Maybe String+  , mergePackage :: String+  }++instance WritesMetadata MergeEnv where+  useHackageRemote _ = True++runEnv+  :: Env env a+  -> env+  -> GlobalEnv+  -> IO a+runEnv env e global = runReaderT env (global, e)
+ src/Hackport/Util.hs view
@@ -0,0 +1,54 @@+module Hackport.Util+  ( getPortageDir+  , withHackportContext+  , defaultRemoteRepo+  ) where++import Control.Monad.Trans.Control+import Data.Maybe (fromJust)+import qualified Network.URI as NU+import System.Directory ( doesDirectoryExist )+import System.FilePath ( (</>) )++import Distribution.Simple.Utils (warn)+import qualified Distribution.Simple.Setup as DSS+import qualified Distribution.Client.Config as DCC+import qualified Distribution.Client.GlobalFlags as DCG+import qualified Distribution.Client.Types as DCT+import qualified Distribution.Utils.NubList as DUN++import Portage.Host as Host ( getInfo, portage_dir )+import Overlays (getOverlayPath)++import Hackport.Env++getPortageDir :: Env env FilePath+getPortageDir = do+  (GlobalEnv verbosity _ portagePathM, _) <- ask+  portagePath <- case portagePathM of+                   Nothing -> liftIO $ Host.portage_dir <$> Host.getInfo+                   Just path -> return path+  exists <- liftIO $ doesDirectoryExist $ portagePath </> "dev-haskell"+  unless exists $ liftIO $+    warn verbosity $ "Looks like an invalid portage directory: " ++ portagePath+  return portagePath++withHackportContext :: (DCG.RepoContext -> Env env a) -> Env env a+withHackportContext callback = do+    (GlobalEnv verbosity _ _, _) <- ask+    overlayPath <- getOverlayPath+    let flags = DCG.defaultGlobalFlags {+                    DCG.globalRemoteRepos = DUN.toNubList [defaultRemoteRepo]+                  , DCG.globalCacheDir    = DSS.Flag $ overlayPath </> ".hackport"+                }+    control+      $ \runInIO -> DCG.withRepoContext verbosity flags+      $ runInIO . (callback <=< restoreM)++-- | Default remote repository. Defaults to [hackage](hackage.haskell.org).+defaultRemoteRepo :: DCT.RemoteRepo+defaultRemoteRepo = DCC.addInfoForKnownRepos+    (DCT.emptyRemoteRepo (DCT.RepoName name)) { DCT.remoteRepoURI = uri }+   where+    uri  = fromJust $ NU.parseURI "https://hackage.haskell.org/"+    name = "hackage.haskell.org"
src/Merge.hs view
@@ -5,13 +5,16 @@  Core functionality of the @merge@ command of @HackPort@. -}++{-# LANGUAGE ViewPatterns #-}+ module Merge   ( merge   , mergeGenericPackageDescription   ) where  import           Control.Monad-import           Control.Exception+import           Control.Exception.Lifted import qualified Data.Text as T import qualified Data.Text.IO as T import           Data.Function (on)@@ -25,14 +28,14 @@ import qualified Distribution.Package as Cabal import qualified Distribution.Version as Cabal import qualified Distribution.PackageDescription as Cabal+import qualified Distribution.Simple.Utils as Cabal import qualified Distribution.PackageDescription.PrettyPrint as Cabal (showPackageDescription) import qualified Distribution.Solver.Types.SourcePackage as CabalInstall import qualified Distribution.Solver.Types.PackageIndex as CabalInstall  import           Distribution.Pretty (prettyShow)-import           Distribution.Verbosity-import           Distribution.Simple.Utils + -- cabal-install import           Distribution.Client.IndexUtils ( getSourcePackages ) import qualified Distribution.Client.GlobalFlags as CabalInstall@@ -61,6 +64,7 @@ import qualified Portage.PackageId as Portage import qualified Portage.Version as Portage import qualified Portage.Metadata as Portage+import qualified Portage.Metadata.RemoteId as Portage import qualified Portage.Overlay as Overlay import qualified Portage.Resolve as Portage import qualified Portage.Dependency as Portage@@ -71,6 +75,11 @@ import qualified Merge.Dependencies as Merge import qualified Merge.Utils        as Merge +import Util+import Overlays (getOverlayPath)++import Hackport.Env+ {- Requested features:   * Add files to git?@@ -87,7 +96,7 @@ -- return the available package with that version. Latest version is chosen -- if no preference. resolveVersion :: [UnresolvedSourcePackage] -> Maybe Cabal.Version -> Maybe UnresolvedSourcePackage-resolveVersion avails Nothing = Just $ L.maximumBy (comparing (Cabal.pkgVersion . CabalInstall.srcpkgPackageId)) avails+resolveVersion avails Nothing = Just $ L.maximumBy (Cabal.comparing (Cabal.pkgVersion . CabalInstall.srcpkgPackageId)) avails resolveVersion avails (Just ver) = listToMaybe (filter match avails)   where     match avail = ver == Cabal.pkgVersion (CabalInstall.srcpkgPackageId avail)@@ -102,84 +111,106 @@ -- -- Various information is printed in between these steps depending on the -- 'Verbosity'.-merge :: Verbosity -> CabalInstall.RepoContext -> [String] -> FilePath -> Maybe String -> IO ()-merge verbosity repoContext args overlayPath users_cabal_flags = do+merge+  :: WritesMetadata env+  => CabalInstall.RepoContext+  -> String+  -> Maybe String+  -> Env env ()+merge repoContext packageString users_cabal_flags+  = askGlobalEnv >>= \(GlobalEnv verbosity _ _) -> do+  overlayPath <- getOverlayPath   (m_category, user_pName, m_version) <--    case Merge.readPackageString args of-      Left err -> throwEx err+    case Merge.readPackageString packageString of+      Left err -> throw err       Right (c,p,m_v) ->         case m_v of           Nothing -> return (c,p,Nothing)           Just v -> case Portage.toCabalVersion v of-                      Nothing -> throwEx (ArgumentError "illegal version")+                      Nothing -> throw (ArgumentError "illegal version")                       Just ver -> return (c,p,Just ver) -  debug verbosity $ "Category: " ++ show m_category-  debug verbosity $ "Package: " ++ show user_pName-  debug verbosity $ "Version: " ++ show m_version+  debug $ "Category: " ++ show m_category+  debug $ "Package: " ++ show user_pName+  debug $ "Version: " ++ show m_version    let user_pname_str = Cabal.unPackageName user_pName -  overlay <- Overlay.loadLazy overlayPath+  overlay <- liftIO $ Overlay.loadLazy overlayPath   -- portage_path <- Host.portage_dir `fmap` Host.getInfo   -- portage <- Overlay.loadLazy portage_path-  index <- fmap packageIndex $ getSourcePackages verbosity repoContext+  index <- fmap packageIndex $ liftIO $ getSourcePackages verbosity repoContext    -- find all packages that maches the user specified package name   availablePkgs <-     case map snd (CabalInstall.searchByName index user_pname_str) of-      [] -> throwEx (PackageNotFound user_pname_str)+      [] -> throw (PackageNotFound user_pname_str)       [pkg] -> return pkg       pkgs  -> do let cabal_pkg_to_pn pkg = Cabal.unPackageName $ Cabal.pkgName (CabalInstall.srcpkgPackageId pkg)                       names      = map (cabal_pkg_to_pn . L.head) pkgs-                  notice verbosity $ "Ambiguous names: " ++ L.intercalate ", " names+                  notice $ "Ambiguous names: " ++ L.intercalate ", " names                   forM_ pkgs $ \ps ->                       do let p_name = (cabal_pkg_to_pn . L.head) ps-                         notice verbosity $ p_name ++ ": " ++ (L.intercalate ", " $ map (prettyShow . Cabal.pkgVersion . CabalInstall.srcpkgPackageId) ps)+                         notice $ p_name ++ ": " ++ (L.intercalate ", " $ map (prettyShow . Cabal.pkgVersion . CabalInstall.srcpkgPackageId) ps)                   return $ concat pkgs +   -- select a single package taking into account the user specified version-  selectedPkg <-+  selectedPkg <- liftIO $     case resolveVersion availablePkgs m_version of       Nothing -> do         putStrLn "No such version for that package, available versions:"         forM_ availablePkgs $ \ avail ->           putStrLn (prettyShow . CabalInstall.srcpkgPackageId $ avail)-        throwEx (ArgumentError "no such version for that package")+        throw (ArgumentError "no such version for that package")       Just avail -> return avail ++   -- print some info-  info verbosity "Selecting package:"+  info "Selecting package:"   forM_ availablePkgs $ \ avail -> do     let match_text | CabalInstall.srcpkgPackageId avail == CabalInstall.srcpkgPackageId selectedPkg = "* "-                   | otherwise = "- "-    info verbosity $ match_text ++ (prettyShow . CabalInstall.srcpkgPackageId $ avail)+                  | otherwise = "- "+    info $ match_text ++ (prettyShow . CabalInstall.srcpkgPackageId $ avail)    let cabal_pkgId = CabalInstall.srcpkgPackageId selectedPkg       norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)-  cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category-  mergeGenericPackageDescription verbosity overlayPath cat (CabalInstall.srcpkgDescription selectedPkg) True users_cabal_flags+  cat <- liftIO $ maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category+  mergeGenericPackageDescription+    cat+    (CabalInstall.srcpkgDescription selectedPkg)+    True+    users_cabal_flags +   -- Maybe generate a diff   let pkgPath = overlayPath </> (Portage.unCategory cat) </> (Cabal.unPackageName norm_pkgName)       newPkgId = Portage.fromCabalPackageId cat cabal_pkgId-  pkgDir <- listDirectory pkgPath+  pkgDir <- liftIO $ listDirectory pkgPath   case Merge.getPreviousPackageId pkgDir newPkgId of-    Just validPkg -> do info verbosity "Generating a diff..."-                        diffEbuilds overlayPath validPkg newPkgId-    _ -> info verbosity "Nothing to diff!"+    Just validPkg -> do info "Generating a diff..."+                        liftIO $ diffEbuilds overlayPath validPkg newPkgId+    _ -> info "Nothing to diff!"  -- used to be FlagAssignment in Cabal but now it's an opaque type type CabalFlags = [(Cabal.FlagName, Bool)]  -- | Generate an ebuild from a 'Cabal.GenericPackageDescription'.-mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> Maybe String -> IO ()-mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch users_cabal_flags = do-  overlay <- Overlay.loadLazy overlayPath+mergeGenericPackageDescription+  :: WritesMetadata env+  => Portage.Category+  -> Cabal.GenericPackageDescription+  -> Bool+  -> Maybe String+  -> Env env ()+mergeGenericPackageDescription cat pkgGenericDesc fetch users_cabal_flags = do+  overlayPath <- getOverlayPath+  overlay <- liftIO $ Overlay.loadLazy overlayPath   let merged_cabal_pkg_name = Cabal.pkgName (Cabal.package (Cabal.packageDescription pkgGenericDesc))       merged_PN = Portage.cabal_pn_to_PN merged_cabal_pkg_name       pkgdir    = overlayPath </> Portage.unCategory cat </> merged_PN-  existing_meta <- EM.findExistingMeta pkgdir+  existing_meta <- liftIO $ EM.findExistingMeta pkgdir   let requested_cabal_flags = Merge.first_just_of [users_cabal_flags, EM.cabal_flags existing_meta]        -- accepts things, like: "cabal_flag:iuse_name", "+cabal_flag", "-cabal_flag"@@ -210,7 +241,7 @@        (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags -  debug verbosity "searching for minimal suitable ghc version"+  debug "searching for minimal suitable ghc version"   (compiler_info, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc (Cabal.mkFlagAssignment user_specified_fas) of               Just v  -> return v               Nothing -> let pn = prettyShow merged_cabal_pkg_name@@ -222,7 +253,7 @@                                             , "  # fix " ++ pn ++ ".cabal"                                             , "  $ hackport make-ebuild " ++ cn ++ " " ++ pn ++ ".cabal"                                             ]-+--   let (accepted_deps, skipped_deps) = Portage.partition_depends ghc_packages merged_cabal_pkg_name                                       (Merge.exeAndLibDeps pkgDesc0) @@ -351,25 +382,25 @@   -- but using it instead of 'active_flag_descs' avoids forcing the very computation we   -- are trying to warn the user about.   when (length cabal_flag_descs >= 12) $-    notice verbosity $ "There are up to " +++    notice $ "There are up to " ++     A.bold (show (2^(length cabal_flag_descs) :: Int)) ++     " possible flag combinations.\n" ++     A.inColor A.Yellow True A.Default "This may take a while." -  debug verbosity $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0-  debug verbosity $ "buildDepends pkgDesc0: " ++ show (map prettyShow (Merge.exeAndLibDeps pkgDesc0))-  debug verbosity $ "buildDepends pkgDesc:  " ++ show (map prettyShow (Merge.buildDepends pkgDesc))+  debug $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0+  debug $ "buildDepends pkgDesc0: " ++ show (map prettyShow (Merge.exeAndLibDeps pkgDesc0))+  debug $ "buildDepends pkgDesc:  " ++ show (map prettyShow (Merge.buildDepends pkgDesc)) -  notice verbosity $ "Accepted depends: " ++ show (map prettyShow accepted_deps)-  notice verbosity $ "Skipped  depends: " ++ show (map prettyShow skipped_deps)-  notice verbosity $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments)-  notice verbosity $ "Dropped  flags: " ++ show (map (Cabal.unFlagName.fst) common_fa)-  notice verbosity $ "Active flags: " ++ show (map Cabal.unFlagName active_flags)-  notice verbosity $ "Irrelevant flags: " ++ show (map Cabal.unFlagName irrelevant_flags)+  notice $ "Accepted depends: " ++ show (map prettyShow accepted_deps)+  notice $ "Skipped  depends: " ++ show (map prettyShow skipped_deps)+  notice $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments)+  notice $ "Dropped  flags: " ++ show (map (Cabal.unFlagName.fst) common_fa)+  notice $ "Active flags: " ++ show (map Cabal.unFlagName active_flags)+  notice $ "Irrelevant flags: " ++ show (map Cabal.unFlagName irrelevant_flags)   -- mapM_ print tdeps    forM_ ghc_packages $-      \name -> info verbosity $ "Excluded packages (comes with ghc): " ++ Cabal.unPackageName name+      \name -> info $ "Excluded packages (comes with ghc): " ++ Cabal.unPackageName name    let pp_fn (cabal_fn, yesno) = b yesno ++ Cabal.unFlagName cabal_fn           where b True  = ""@@ -414,13 +445,13 @@   let active_flag_descs_renamed =         (\f -> f { Cabal.flagName = Cabal.mkFlagName . cfn_to_iuse . Cabal.unFlagName                    . Cabal.flagName $ f }) <$> active_flag_descs-  iuse_flag_descs <- Merge.dropIfUseExpands active_flag_descs_renamed-  mergeEbuild verbosity existing_meta pkgdir ebuild iuse_flag_descs+  iuse_flag_descs <- liftIO $ Merge.dropIfUseExpands active_flag_descs_renamed+  mergeEbuild existing_meta pkgdir ebuild iuse_flag_descs    when fetch $ do     let cabal_pkgId = Cabal.packageId (Merge.packageDescription pkgDesc)         norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)-    fetchDigestAndCheck verbosity (overlayPath </> prettyShow cat </> prettyShow norm_pkgName)+    fetchDigestAndCheck (overlayPath </> prettyShow cat </> prettyShow norm_pkgName)       $ Portage.fromCabalPackageId cat cabal_pkgId  -- | Run @ebuild@ and @pkgcheck@ commands in the directory of the@@ -428,63 +459,76 @@ -- -- This will ensure well-formed ebuilds and @metadata.xml@, and will update (if possible) -- the @Manifest@ file.-fetchDigestAndCheck :: Verbosity-                    -> FilePath -- ^ directory of ebuild-                    -> Portage.PackageId -- ^ newest ebuild-                    -> IO ()-fetchDigestAndCheck verbosity ebuildDir pkgId =+fetchDigestAndCheck+  :: FilePath -- ^ directory of ebuild+  -> Portage.PackageId -- ^ newest ebuild+  -> Env env ()+fetchDigestAndCheck ebuildDir pkgId = do   let ebuild = prettyShow (Portage.cabalPkgName . Portage.packageId $ pkgId)                ++ "-" ++ prettyShow (Portage.pkgVersion pkgId) <.> "ebuild"-  in withWorkingDirectory ebuildDir $ do-    notice verbosity "Recalculating digests..."-    emEx <- system $ "ebuild " ++ ebuild ++ " manifest > /dev/null 2>&1"+  withWorkingDirectory ebuildDir $ do+    notice "Recalculating digests..."+    emEx <- liftIO $ system $ "ebuild " ++ ebuild ++ " manifest > /dev/null 2>&1"     when (emEx /= ExitSuccess) $-      notice verbosity "ebuild manifest failed horribly. Do something about it!"+      notice "ebuild manifest failed horribly. Do something about it!" -    notice verbosity $ "Running " ++ A.bold "pkgcheck scan..."+    notice $ "Running " ++ A.bold "pkgcheck scan..." -    (psEx,psOut,_) <- readCreateProcessWithExitCode (shell "pkgcheck scan --color True") ""-    -    when (psEx /= ExitSuccess) $ -- this should never be true, even with QA issues.-      notice verbosity $ A.inColor A.Red True A.Default "pkgcheck scan failed."-    notice verbosity psOut+    (psEx,psOut,_) <- liftIO $ readCreateProcessWithExitCode (shell "pkgcheck scan --color True") "" -    return ()+    when (psEx /= ExitSuccess) $ -- this should never be true, even with QA issues.+      notice $ A.inColor A.Red True A.Default "pkgcheck scan failed."+    notice psOut -withWorkingDirectory :: FilePath -> IO a -> IO a+withWorkingDirectory :: FilePath -> Env env a -> Env env a withWorkingDirectory newDir action = do-  oldDir <- getCurrentDirectory+  oldDir <- liftIO $ getCurrentDirectory   bracket-    (setCurrentDirectory newDir)-    (\_ -> setCurrentDirectory oldDir)+    (liftIO $ setCurrentDirectory newDir)+    (\_ -> liftIO $ setCurrentDirectory oldDir)     (\_ -> action)  -- | Write the ebuild (and sometimes a new @metadata.xml@) to its directory.-mergeEbuild :: Verbosity -> EM.EMeta -> FilePath -> E.EBuild -> [Cabal.PackageFlag] -> IO ()-mergeEbuild verbosity existing_meta pkgdir ebuild flags = do+mergeEbuild+  :: WritesMetadata env+  => EM.EMeta+  -> FilePath+  -> E.EBuild+  -> [Cabal.PackageFlag]+  -> Env env ()+mergeEbuild existing_meta pkgdir ebuild flags+  = ask >>= \(_, useHackageRemote -> useHackageRemoteId) -> do+   let edir = pkgdir       elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild"       epath = edir </> elocal       emeta = "metadata.xml"       mpath = edir </> emeta-  yet_meta <- doesFileExist mpath+  yet_meta <- liftIO $ doesFileExist mpath   -- If there is an existing @metadata.xml@, read it in as a 'T.Text'.   -- Otherwise return 'T.empty'. We only use this once more to directly   -- compare to @default_meta@ before writing it.   current_meta <- if yet_meta-                  then T.readFile mpath+                  then liftIO $ T.readFile mpath                   else return T.empty   -- Either create an object of the 'Portage.Metadata' type from a valid @current_meta@,   -- or supply a default minimal metadata object. Note the difference to @current_meta@:   -- @current_meta@ is of type 'T.Text', @current_meta'@ is of type 'Portage.Metadata'.-  let current_meta' = fromMaybe Portage.makeMinimalMetadata-                      (Portage.pureMetadataFromFile current_meta)+  let current_meta' = fromMaybe (Portage.minimalMetadata useHackageRemoteId ebuild)+                      (Portage.parseMetadataXML current_meta)+      hackageRemoteId =+        if useHackageRemoteId+          then S.singleton $ Portage.RemoteIdHackage $ E.hackage_name ebuild+          else S.empty       -- Create the @metadata.xml@ string, adding new USE flags (if any) to those of       -- the existing @metadata.xml@. If an existing flag has a new and old description,       -- the new one takes precedence.-      default_meta = Portage.makeDefaultMetadata-                     $ Merge.metaFlags flags `Map.union`-                     Portage.metadataUseFlags current_meta'+      default_meta = Portage.printMetadata $+                      current_meta' <> mempty+                        { Portage.metadataUseFlags = Merge.metaFlags flags+                        , Portage.metadataRemoteIds =+                            Portage.matchURIs (E.sourceURIs ebuild) <> hackageRemoteId+                        }       -- Create a 'Map.Map' of USE flags with updated descriptions.       new_flags = Map.differenceWith (\new old -> if (new /= old)                                                   then Just $ old ++ A.bold (" -> " ++ new)@@ -492,8 +536,8 @@                   (Merge.metaFlags flags)                   $ Portage.metadataUseFlags current_meta' -  createDirectoryIfMissing True edir-  now <- TC.getCurrentTime+  liftIO $ createDirectoryIfMissing True edir+  now <- liftIO $ TC.getCurrentTime    let (existing_keywords, existing_license) = (EM.keywords existing_meta, EM.license existing_meta)       new_keywords = maybe (E.keywords ebuild) (map Merge.to_unstable) existing_keywords@@ -507,19 +551,19 @@                             }       s_ebuild'    = E.showEBuild now ebuild' -  notice verbosity $ "Current keywords: " ++ show existing_keywords ++ " -> " ++ show new_keywords-  notice verbosity $ "Current license:  " ++ show existing_license ++ " -> " ++ show new_license+  notice $ "Current keywords: " ++ show existing_keywords ++ " -> " ++ show new_keywords+  notice $ "Current license:  " ++ show existing_license ++ " -> " ++ show new_license -  notice verbosity $ "Writing " ++ elocal-  length s_ebuild' `seq` T.writeFile epath (T.pack s_ebuild')+  notice $ "Writing " ++ elocal+  length s_ebuild' `seq` liftIO (T.writeFile epath (T.pack s_ebuild'))    when (current_meta /= default_meta) $ do     when (current_meta /= T.empty) $ do-      notice verbosity $ A.bold $ "Default and current " ++ emeta ++ " differ."+      notice $ A.bold $ "Default and current " ++ emeta ++ " differ."       if (new_flags /= Map.empty)-        then notice verbosity $ "New or updated USE flags:\n" +++        then notice $ "New or updated USE flags:\n" ++              (unlines $ Portage.prettyPrintFlagsHuman new_flags)-        else notice verbosity "No new USE flags."+        else notice "No new USE flags." -    notice verbosity $ "Writing " ++ emeta-    T.writeFile mpath default_meta+    notice $ "Writing " ++ emeta+    liftIO $ T.writeFile mpath default_meta
src/Merge/Dependencies.hs view
@@ -15,7 +15,6 @@   ) where  import           Control.DeepSeq (NFData(..))-import           Control.Parallel.Strategies import           Data.Maybe ( isJust, isNothing ) import qualified Data.List as L #if !MIN_VERSION_base(4,11,0)@@ -580,4 +579,5 @@   ,("SDL2_image",                  ("media-libs", "sdl2-image", Portage.AnySlot))   ,("SDL2_mixer",                  ("media-libs", "sdl2-mixer", Portage.AnySlot))   ,("zlib",                        ("sys-libs", "zlib", Portage.AnySlot))+  ,("libpcre",                     ("dev-libs", "libpcre", Portage.AnySlot))   ]
src/Merge/Utils.hs view
@@ -36,29 +36,19 @@ import qualified Distribution.Package            as Cabal import qualified Distribution.PackageDescription as Cabal --- | Parse a ['String'] as a valid package string. E.g. @category\/name-1.0.0@.+-- | Parse a 'String' as a valid package string. E.g. @category\/name-1.0.0@. -- Return 'HackPortError' if the string to parse is invalid. ----- When the ['String'] is valid:+-- When the 'String' is valid: ----- >>> readPackageString ["dev-haskell/packagename1-1.0.0"]+-- >>> readPackageString "dev-haskell/packagename1-1.0.0" -- Right (Just (Category {unCategory = "dev-haskell"}),PackageName "packagename1",Just (Version {versionNumber = [1,0,0], versionChar = Nothing, versionSuffix = [], versionRevision = 0}))------ When the ['String'] is empty:------ >>> readPackageString []--- Left ...-readPackageString :: [String]+readPackageString :: String                   -> Either HackPortError ( Maybe Portage.Category                                           , Cabal.PackageName                                           , Maybe Portage.Version                                           )-readPackageString args = do-  packageString <--    case args of-      [] -> Left (ArgumentError "Need an argument, [category/]package[-version]")-      [pkg] -> return pkg-      _ -> Left (ArgumentError ("Too many arguments: " ++ unwords args))+readPackageString packageString = do   case Portage.parseFriendlyPackage packageString of     Right v@(_,_,Nothing) -> return v     -- we only allow versions we can convert into cabal versions
src/Overlays.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+ module Overlays     ( getOverlayPath     ) where@@ -10,47 +12,46 @@  import Error import Portage.Host---- cabal-import Distribution.Verbosity-import Distribution.Simple.Utils ( info )+import Util (info)+import Hackport.Env hiding (local) -getOverlayPath :: Verbosity -> Maybe FilePath -> IO String-getOverlayPath verbosity override_overlay = do+-- getOverlayPath :: forall m. (HasGlobalEnv m, MonadIO m) => m String+getOverlayPath :: Env env String+getOverlayPath = askGlobalEnv >>= \(GlobalEnv _ override_overlay _) -> do   overlays <- if isJust override_overlay-                  then do info verbosity $ "Forced " ++ fromJust override_overlay+                  then do info $ "Forced " ++ fromJust override_overlay                           return [fromJust override_overlay]                   else getOverlays   case overlays of-    [] -> throwEx NoOverlay+    [] -> throw NoOverlay     [x] -> return x     mul -> search mul   where-  search :: [String] -> IO String+  search :: [String] -> Env env String   search mul = do-    let loop [] = throwEx (MultipleOverlays mul)+    let loop [] = throw (MultipleOverlays mul)         loop (x:xs) = do-          info verbosity $ "Checking '" ++ x ++ "'..."-          found <- SD.doesDirectoryExist (x </> ".hackport")+          info $ "Checking '" ++ x ++ "'..."+          found <- liftIO $ SD.doesDirectoryExist (x </> ".hackport")           if found             then do-              info verbosity "OK!"+              info "OK!"               return x             else do-              info verbosity "Not ok."+              info "Not ok."               loop xs-    info verbosity "There are several overlays in your configuration."-    mapM_ (info verbosity . (" * " ++)) mul-    info verbosity "Looking for one with a HackPort cache..."+    info "There are several overlays in your configuration."+    mapM_ (info . (" * " ++)) mul+    info "Looking for one with a HackPort cache..."     overlay <- loop mul-    info verbosity $ "I choose " ++ overlay-    info verbosity "Override my decision with hackport --overlay /my/overlay"+    info $ "I choose " ++ overlay+    info "Override my decision with hackport --overlay /my/overlay"     return overlay -getOverlays :: IO [String]+getOverlays :: MonadIO m => m [String] getOverlays = do   local    <- getLocalOverlay-  overlays <- overlay_list `fmap` getInfo+  overlays <- liftIO $ overlay_list `fmap` getInfo   return $ nub $ map clean $                  maybeToList local               ++ overlays@@ -59,11 +60,11 @@                 '/':p -> reverse p                 _ -> path -getLocalOverlay :: IO (Maybe FilePath)+getLocalOverlay :: MonadIO m => m (Maybe FilePath) getLocalOverlay = do-  curDir <- SD.getCurrentDirectory+  curDir <- liftIO $ SD.getCurrentDirectory   let lookIn = map joinPath . reverse . inits . splitPath $ curDir   fmap listToMaybe (filterM probe lookIn)    where-    probe dir = SD.doesDirectoryExist (dir </> "dev-haskell")+    probe dir = liftIO $ SD.doesDirectoryExist (dir </> "dev-haskell")
src/Portage/EBuild.hs view
@@ -38,30 +38,31 @@ #endif  -- | Type representing the information contained in an @.ebuild@.-data EBuild = EBuild {-    name :: String,-    category :: String,-    hackage_name :: String, -- might differ a bit (we mangle case)-    version :: String,-    revision :: String,-    hackportVersion :: String,-    description :: String,-    homepage :: String,-    license :: Either String String,-    slot :: String,-    keywords :: [String],-    iuse :: [String],-    depend :: Dependency,-    depend_extra :: [String],-    rdepend :: Dependency,-    rdepend_extra :: [String]+data EBuild = EBuild+    { name :: String+    , category :: String+    , hackage_name :: String -- might differ a bit (we mangle case)+    , version :: String+    , revision :: String+    , hackportVersion :: String+    , sourceURIs :: [String]+    , description :: String+    , homepage :: String+    , license :: Either String String+    , slot :: String+    , keywords :: [String]+    , iuse :: [String]+    , depend :: Dependency+    , depend_extra :: [String]+    , rdepend :: Dependency+    , rdepend_extra :: [String]     , features :: [CabalFeature]     , cabal_pn :: Maybe String -- ^ Just 'myOldName' if the package name contains upper characters     , src_prepare :: [String] -- ^ raw block for src_prepare() contents     , src_configure :: [String] -- ^ raw block for src_configure() contents     , used_options :: [(String, String)] -- ^ hints to ebuild writers/readers                                          --   on what hackport options were used to produce an ebuild-  }+    }  getHackportVersion :: Version -> String getHackportVersion Version {versionBranch=(x:s)} = foldl (\y z -> y ++ "." ++ (show z)) (show x) s@@ -75,6 +76,7 @@     hackage_name = "FooBar",     version = "0.1",     revision = "0",+    sourceURIs = [],     hackportVersion = getHackportVersion Paths_hackport.version,     description = "",     homepage = "https://hackage.haskell.org/package/${HACKAGE_N}",
src/Portage/Metadata.hs view
@@ -7,62 +7,66 @@ -} module Portage.Metadata         ( Metadata(..)-        , metadataFromFile-        , pureMetadataFromFile+        , UseFlags+        , readMetadataFile+        , parseMetadataXML         , stripGlobalUseFlags -- exported for hspec         , prettyPrintFlags -- exported for hspec         , prettyPrintFlagsHuman-        , makeDefaultMetadata-        , makeMinimalMetadata+        , printMetadata+        , minimalMetadata         ) where  import qualified AnsiColor as A -import qualified Data.List       as L+import Control.Monad import qualified Data.Map.Strict as Map+import qualified Data.Set        as S import qualified Data.Text       as T import qualified Data.Text.IO    as T  import Text.XML.Light +import Portage.EBuild as EBuild+import Portage.Metadata.RemoteId++import Hackport.Env++type UseFlags = Map.Map String String+ -- | A data type for the Gentoo-specific @metadata.xml@ file. -- Currently defines functions for the maintainer email and -- USE flags and their descriptions. data Metadata = Metadata       { metadataEmails :: [String] -- ^ This should /always/ be [\"haskell@gentoo.org\"].-      , metadataUseFlags :: Map.Map String String -- ^ Only /active/ USE flags, if any.-      } deriving (Eq, Show)+      , metadataUseFlags :: UseFlags -- ^ Only /active/ USE flags, if any.+      , metadataRemoteIds :: S.Set RemoteId+      } deriving (Eq, Show, Ord) +instance Semigroup Metadata where+  Metadata e1 u1 r1 <> Metadata e2 u2 r2 = Metadata (e1<>e2) (u1<>u2) (r1<>r2)++instance Monoid Metadata where+  mempty = Metadata mempty mempty mempty+ -- | Maybe return a 'Metadata' from a 'T.Text'. -- -- Trying to parse an empty 'T.Text' should return 'Nothing': ----- >>> pureMetadataFromFile T.empty+-- >>> parseMetadataXML T.empty -- Nothing------ Parsing a @metadata.xml@ /without/ USE flags should /always/ be equivalent--- to 'makeMinimalMetadata':------ >>> pureMetadataFromFile (makeDefaultMetadata Map.empty) == Just makeMinimalMetadata--- True------ Parsing a @metadata.xml@ /with/ USE flags should /always/ be equivalent--- to 'makeMinimalMetadata' /plus/ the supplied USE flags:------ >>> pureMetadataFromFile (makeDefaultMetadata (Map.fromList [("name","description")])) == Just (makeMinimalMetadata {metadataUseFlags = Map.fromList [("name","description")] } )--- True-pureMetadataFromFile :: T.Text -> Maybe Metadata-pureMetadataFromFile file = parseXMLDoc file >>= \doc -> parseMetadata doc+parseMetadataXML :: T.Text -> Maybe Metadata+parseMetadataXML = parseMetadata <=< parseXMLDoc --- | Apply 'pureMetadataFromFile' to a 'FilePath'.-metadataFromFile :: FilePath -> IO (Maybe Metadata)-metadataFromFile fp = pureMetadataFromFile <$> T.readFile fp+-- | Apply 'parseMetadataXML' to a 'FilePath'.+readMetadataFile :: FilePath -> IO (Maybe Metadata)+readMetadataFile fp = parseMetadataXML <$> T.readFile fp  -- | Extract the maintainer email and USE flags from a supplied XML 'Element'. --  -- If we're parsing a blank 'Element' or otherwise empty @metadata.xml@: -- >>> parseMetadata blank_element--- Just (Metadata {metadataEmails = [], metadataUseFlags = fromList []})+-- Just (Metadata {metadataEmails = [], metadataUseFlags = fromList [], metadataRemoteIds = fromList []}) parseMetadata :: Element -> Maybe Metadata parseMetadata xml =   return Metadata { metadataEmails = strContent <$> findElements (unqual "email") xml@@ -75,13 +79,15 @@                           a = concatMap elContent y                           b = cdData <$> onlyText a                       in Map.fromList $ zip z b+                  -- TODO: Read remote-ids from existing metadata.xml+                  , metadataRemoteIds = S.empty                   }  -- | Remove global @USE@ flags from the flags 'Map.Map', as these should not be -- within the local @metadata.xml@. For now, this is manually specified rather than -- parsing @use.desc@.-stripGlobalUseFlags :: Map.Map String String -> Map.Map String String-stripGlobalUseFlags m = foldr1 Map.intersection (Map.delete <$> globals <*> [m])+stripGlobalUseFlags :: UseFlags -> UseFlags+stripGlobalUseFlags m = foldr Map.delete m globals   where     globals = [ "debug"               , "examples"@@ -89,41 +95,56 @@               ]  -- | Pretty print as valid XML a list of flags and their descriptions--- from a given 'Map.Map'.-prettyPrintFlags :: Map.Map String String -> [String]-prettyPrintFlags m = (\(name,description) ->-                        "\t\t" ++-                        (showElement-                         . add_attr (Attr (blank_name { qName = "name" }) name)-                         . unode "flag" $ description))-                     <$> (Map.toAscList . stripGlobalUseFlags $ m)+-- from a given 'Map.Map'. This wraps the flags in "<use>...</use>" and is+-- meant to be passed to 'unlines'. If the Map is empty, it will return no+-- output.+prettyPrintFlags :: UseFlags -> [String]+prettyPrintFlags m+  | Map.null m = []+  | otherwise = ["\t<use>"] ++ go ++ ["\t</use>"]+  where+    go = printFlag <$> Map.toAscList (stripGlobalUseFlags m)+    printFlag (n, d) =+      "\t\t" +++      showElement+        (add_attr+          (Attr (blank_name { qName = "name" }) n)+          (unode "flag" d)+        )  -- | Pretty print a human-readable list of flags and their descriptions -- from a given 'Map.Map'.-prettyPrintFlagsHuman :: Map.Map String String -> [String]-prettyPrintFlagsHuman m = (\(name,description) -> A.bold (name ++ ": ") ++-                            (L.intercalate " " . lines $ description))+prettyPrintFlagsHuman :: UseFlags -> [String]+prettyPrintFlagsHuman m = (\(n,d) -> A.bold (n ++ ": ") +++                            (unwords . lines $ d))                           <$> (Map.toAscList . stripGlobalUseFlags $ m)-                          + -- | A minimal metadata for use as a fallback value.-makeMinimalMetadata :: Metadata-makeMinimalMetadata = Metadata { metadataEmails = ["haskell@gentoo.org"]-                               , metadataUseFlags = Map.empty-                               }+minimalMetadata :: UseHackageRemote -> EBuild.EBuild -> Metadata+minimalMetadata useHackage ebuild =+  mempty+  { metadataEmails = ["haskell@gentoo.org"]+  , metadataRemoteIds =+      if useHackage+        then S.singleton $ RemoteIdHackage $ EBuild.hackage_name ebuild+        else S.empty+  }  -- don't use Text.XML.Light as we like our own pretty printer -- | Pretty print the @metadata.xml@ string.-makeDefaultMetadata :: Map.Map String String -> T.Text-makeDefaultMetadata flags = T.pack $-  unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"-          , "<!DOCTYPE pkgmetadata SYSTEM \"https://www.gentoo.org/dtd/metadata.dtd\">"-          , "<pkgmetadata>"-          , "\t<maintainer type=\"project\">"-          , "\t\t<email>haskell@gentoo.org</email>"-          , "\t\t<name>Gentoo Haskell</name>"-          , "\t</maintainer>"-            ++ if flags == Map.empty-               then ""-               else "\n\t<use>\n" ++ (unlines $ prettyPrintFlags flags) ++ "\t</use>"-          , "</pkgmetadata>"-          ]+printMetadata :: Metadata -> T.Text+printMetadata (Metadata _ flags rids) = T.pack $+  unlines $+    [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+    , "<!DOCTYPE pkgmetadata SYSTEM \"https://www.gentoo.org/dtd/metadata.dtd\">"+    , "<pkgmetadata>"+    , "\t<maintainer type=\"project\">"+    , "\t\t<email>haskell@gentoo.org</email>"+    , "\t\t<name>Gentoo Haskell</name>"+    , "\t</maintainer>"+    ]+    ++ prettyPrintFlags flags+    ++ prettyPrintRemoteIds rids+    +++    [ "</pkgmetadata>"+    ]
+ src/Portage/Metadata/RemoteId.hs view
@@ -0,0 +1,490 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++module Portage.Metadata.RemoteId+    (+      -- * Remote id+      RemoteId (..)+      -- * Pretty printing+    , prettyPrintRemoteIds+    , prettyPrintRemoteId+      -- * Parsing+    , URIParser (..)+    , matchURIs+    , matchURI+    , runUriParser+    , definedParsers+      -- ** Individual parsers+    , hackageParser+    , cranParser+    , ctanParser+    , gentooParser+    , githubParser+    , gitlabParser+    , launchpadParser+    , osdnParser+    , peclParser+    , pypiParser+    , rubygemsParser+    , sourceforgeParser+    , vimParser+      -- ** Utility+      -- *** URI scheme+    , httpScheme+      -- *** URI domain+    , Domain+    , domainOrWWW+    , subdomain+      -- *** URI path+    , Path+    , stripPrefix+    , stripPrefixP+    , gitPath+      -- *** Misc+    , ignore+    , allChars+    ) where++import Control.Monad+import Data.Foldable (asum)+import qualified Data.List as L+import Data.Maybe (catMaybes, mapMaybe)+import qualified Data.Set as S+import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI)+import System.FilePath.Posix+import Text.Parsec+import Text.Parsec.String++data RemoteId+    = RemoteIdHackage String       -- ^ Hackage package+    | RemoteIdCRAN String          -- ^ CRAN package+    | RemoteIdCTAN String          -- ^ CTAN package+    | RemoteIdGentoo String        -- ^ Gentoo project+    | RemoteIdGithub String String -- ^ Github user and repo+    | RemoteIdGitlab String String -- ^ Gitlab user and repo+    | RemoteIdLaunchpad String     -- ^ Launchpad project+    | RemoteIdOSDN String          -- ^ OSDN project+    | RemoteIdPECL String          -- ^ PECL package+    | RemoteIdPyPI String          -- ^ PyPI project+    | RemoteIdRubygems String      -- ^ Rubygems gem+    | RemoteIdSourceforge String   -- ^ Sourceforge project+    | RemoteIdVim String           -- ^ Vim script+    deriving (Show, Eq, Ord)++-- | A set of parsers to use on a 'URI'. Each parser can produce an arbitrary+--   type. These intermediate types are coalesced in 'mkRemoteId' and+--   are hidden from the top-level using the @ExistentialQuantification@+--   language extension.+data URIParser = forall scheme user regname port path query fragment. URIParser+    { schemeParser :: Parser scheme     -- | ^ scheme+    , userParser :: Parser user         -- | ^ user+    , regnameParser :: Parser regname   -- | ^ domain+    , portParser :: Parser port         -- | ^ port+    , pathParser :: Parser path         -- | ^ path+    , queryParser :: Parser query       -- | ^ query+    , fragmentParser :: Parser fragment -- | ^ fragment+      -- | coalescing function+    , mkRemoteId :: scheme -> user -> regname -> port -> path -> query -> fragment -> RemoteId+    }++type Domain = String+type Path = String++-- | Pretty print a 'S.Set' of 'RemoteId's as XML. Wraps the block in @"<upstream>"@.+prettyPrintRemoteIds :: S.Set RemoteId -> [String]+prettyPrintRemoteIds set+    | S.null set = []+    | otherwise =+        ["\t<upstream>"]+        ++ (prettyPrintRemoteId <$> S.toAscList set)+        ++ ["\t</upstream>"]++-- | Pretty print a single 'RemoteId'.+prettyPrintRemoteId :: RemoteId -> String+prettyPrintRemoteId = \case+    RemoteIdHackage p     -> pp "hackage"     p+    RemoteIdCRAN p        -> pp "cran"        p+    RemoteIdCTAN p        -> pp "ctan"        p+    RemoteIdGentoo p      -> pp "gentoo"      p+    RemoteIdGithub u r    -> pp "github"      $ u ++ "/" ++ r+    RemoteIdGitlab u r    -> pp "gitlab"      $ u ++ "/" ++ r+    RemoteIdLaunchpad p   -> pp "launchpad"   p+    RemoteIdOSDN p        -> pp "osdn"        p+    RemoteIdPECL p        -> pp "pecl"        p+    RemoteIdPyPI p        -> pp "pypi"        p+    RemoteIdRubygems g    -> pp "rubygems"    g+    RemoteIdSourceforge p -> pp "sourceforge" p+    RemoteIdVim s         -> pp "vim"         s+  where+    pp t v = "\t\t<remote-id type=\"" ++ t ++ "\">" ++ v ++ "</remote-id>"++-- | Run 'matchURI' on all given strings, collecting the result in a 'S.Set'.+matchURIs :: [String] -> S.Set RemoteId+matchURIs = S.fromList . mapMaybe matchURI++-- | Try to parse the given string using any of the defined URI parsers+matchURI :: String -> Maybe RemoteId+matchURI str = asum $ map runUriP definedParsers+  where+    runUriP :: URIParser -> Maybe RemoteId+    runUriP p = eitherToMaybe $ runUriParser p str++    -- @Maybe@ is an Alternative, whereas @Either e@ is not. This is needed+    -- to make 'asum' work.+    eitherToMaybe :: Either e a -> Maybe a+    eitherToMaybe (Left  _) = Nothing+    eitherToMaybe (Right x) = Just x++-- | All parsers defined in this module+definedParsers :: [URIParser]+definedParsers =+    [ hackageParser+    , cranParser+    , ctanParser+    , gentooParser+    , githubParser+    , gitlabParser+    , launchpadParser+    , osdnParser+    , peclParser+    , pypiParser+    , rubygemsParser+    , sourceforgeParser+    , vimParser+    ]++-- | @'hackage': 'https://hackage.haskell.org/package/{project}'@+hackageParser :: URIParser+hackageParser = URIParser+    httpScheme+    ignore+    (string "hackage.haskell.org")+    ignore+    (do+        (p:_) <- stripPrefixP "/package"+        pure p+    )+    ignore+    ignore+    (\_ _ _ _ p _ _ -> RemoteIdHackage p)++-- | @'cran': 'https://cran.r-project.org/web/packages/{project}/'@+cranParser :: URIParser+cranParser = URIParser+    httpScheme+    ignore+    (string "cran.r-project.org")+    ignore+    (do+        (p:_) <- stripPrefixP "/web/packages"+        pure p+    )+    ignore+    ignore+    (\_ _ _ _ p _ _ -> RemoteIdCRAN p)++-- | @'ctan': 'https://ctan.org/pkg/{project}'@+ctanParser :: URIParser+ctanParser = URIParser+    httpScheme+    ignore+    (domainOrWWW "ctan.org")+    ignore+    (do+        (p:_) <- stripPrefixP "/pkg"+        pure p+    )+    ignore+    ignore+    (\_ _ _ _ p _ _ -> RemoteIdCTAN p)++-- | @'gentoo': 'https://gitweb.gentoo.org/{project}.git/'@+gentooParser :: URIParser+gentooParser = URIParser+    httpScheme+    ignore+    (string "gitweb.gentoo.org")+    ignore+    (do+        (s:_) <- stripPrefixP "/"+        gitPath s+    )+    ignore+    ignore+    (\_ _ _ _ p _ _ -> RemoteIdGentoo p)++-- | @'github': 'https://github.com/{project}'@+githubParser :: URIParser+githubParser = URIParser+    (choice [httpScheme, string "git:"])+    ignore+    (domainOrWWW "github.com")+    ignore+    (do+        (u:r:_) <- stripPrefixP "/"+        (u,) <$> gitPath r+    )+    ignore+    ignore+    (\_ _ _ _ (u,r) _ _ -> RemoteIdGithub u r)++-- | @'gitlab': 'https://gitlab.com/{project}'@+gitlabParser :: URIParser+gitlabParser = URIParser+    (choice [httpScheme, string "git:"])+    ignore+    (domainOrWWW "gitlab.com")+    ignore+    (do+        (u:r:_) <- stripPrefixP "/"+        (u,) <$> gitPath r+    )+    ignore+    ignore+    (\_ _ _ _ (u,r) _ _ -> RemoteIdGitlab u r)++-- | @'launchpad': 'https://launchpad.net/{project}'@+launchpadParser :: URIParser+launchpadParser = URIParser+    httpScheme+    ignore+    (domainOrWWW "launchpad.net")+    ignore+    (do+        (p:_) <- stripPrefixP "/"+        pure p+    )+    ignore+    ignore+    (\_ _ _ _ p _ _ -> RemoteIdLaunchpad p)++-- | @'osdn': 'https://osdn.net/projects/{project}/'@+osdnParser :: URIParser+osdnParser = URIParser+    httpScheme+    ignore+    (domainOrWWW "osdn.net")+    ignore+    (do+        (p:_) <- stripPrefixP "/projects"+        pure p+    )+    ignore+    ignore+    (\_ _ _ _ p _ _ -> RemoteIdOSDN p)++-- | @'pecl': 'https://pecl.php.net/package/{project}'@+peclParser :: URIParser+peclParser = URIParser+    httpScheme+    ignore+    (string "pecl.php.net")+    ignore+    (do+        (p:_) <- stripPrefixP "/package"+        pure p+    )+    ignore+    ignore+    (\_ _ _ _ p _ _ -> RemoteIdPECL p)++-- | @'pypi': 'https://pypi.org/project/{project}/'@+pypiParser :: URIParser+pypiParser = URIParser+    httpScheme+    ignore+    (domainOrWWW "pypi.org")+    ignore+    (do+        (p:_) <- stripPrefixP "/project"+        pure p+    )+    ignore+    ignore+    (\_ _ _ _ p _ _ -> RemoteIdPyPI p)++-- | @'rubygems': 'https://rubygems.org/gems/{project}'@+rubygemsParser :: URIParser+rubygemsParser = URIParser+    httpScheme+    ignore+    (domainOrWWW "rubygems.org")+    ignore+    (do+        (g:_) <- stripPrefixP "/gems"+        pure g+    )+    ignore+    ignore+    (\_ _ _ _ g _ _ -> RemoteIdRubygems g)++-- | @'sourceforge': 'https://sourceforge.net/projects/{project}/'@+sourceforgeParser :: URIParser+sourceforgeParser = URIParser+    httpScheme+    ignore+    (domainOrWWW "sourceforge.net")+    ignore+    (do+        (p:_) <- stripPrefixP "/projects"+        pure p+    )+    ignore+    ignore+    (\_ _ _ _ p _ _ -> RemoteIdSourceforge p)++-- | @'vim': 'https://vim.org/scripts/script.php?script_id={project}'@+vimParser :: URIParser+vimParser = URIParser+    httpScheme+    ignore+    (domainOrWWW "vim.org")+    ignore+    (string "/scripts/script.php")+    (do+        _ <- char '?'+        ss <- sepBy1 (optionMaybe scriptParser) (char '&')+        (s:_) <- pure $ catMaybes ss -- The first successful 'scriptParser'+        pure s+    )+    ignore+    (\_ _ _ _ _ s _ -> RemoteIdVim s)+  where+    scriptParser :: Parser String+    scriptParser = string "script_id=" *> many1 (noneOf ['=','&','#'])++-- | Run a specified 'URIParser' with a string+--+--   Internally, uses 'parseAbsoluteURI' to create a 'URI', and then uses each+--   parser specified in 'URIParser' on a specific part of the uri. These+--   intermediate results are coalesced with the supplied 'mkRemoteId'.+runUriParser+  :: URIParser+  -> String+  -> Either ParseError RemoteId+runUriParser (URIParser {..}) = join . parseIt go+  where+    go :: Parser (Either ParseError RemoteId)+    go = do+        cs <- allChars+        case parseAbsoluteURI cs of+            Just (URI scheme (Just (URIAuth user regname port)) path query fragment) ->+                pure $ mkRemoteId+                    <$> parseIt schemeParser scheme+                    <*> parseIt userParser user+                    <*> parseIt regnameParser regname+                    <*> parseIt portParser port+                    <*> parseIt pathParser path+                    <*> parseIt queryParser query+                    <*> parseIt fragmentParser fragment+            _ -> fail $ "Could not parse as an absolute URI: " ++ show cs++    parseIt :: Parser a -> String -> Either ParseError a+    parseIt p = parse p ""++-- | Convenience function for 'stripPrefix', which uses 'allChars' as the+--   target path. Throws a parse error if 'stripPrefix' fails.+stripPrefixP+    :: Path -- ^ The prefix path to strip+    -> Parser [String]+stripPrefixP pre = do+    targ <- allChars+    case stripPrefix pre targ of+        Just ps -> pure ps+        Nothing -> fail $ "Path prefix does not match: \n"+            ++ "pre = " ++ show pre ++ "\n"+            ++ "targ = " ++ show targ ++ "\n"+            ++ "L.stripPrefix " ++ show (splitDirectories pre)+                ++ " " ++ show (splitDirectories targ) ++ " = Nothing"++-- | Strips a path of a prefix, then returns the result split along path+--   seperators. Returns 'Nothing' if the prefix path does not match the+--   beginning of the target path.+--+--   Examples:+--+--   >>> stripPrefix "/web/packages" "/web/packages/foo/"+--   Just ["foo"]+--+--   >>> stripPrefix "/" "/foo/bar"+--   Just ["foo","bar"]+--+--   >>> stripPrefix "" "/foo/bar"+--   Just ["/","foo","bar"]+--+--   >>> stripPrefix "/some/thing" "/something/else"+--   Nothing+stripPrefix+    :: Path -- ^ The prefix path to strip+    -> Path -- ^ The target path to strip from+    -> Maybe [String]+stripPrefix pre targ =+    L.stripPrefix+        (splitDirectories pre)+        (splitDirectories targ)++-- | Compares the input stream to the given domain. Parser succeeds if+--   either of the following is true:+--+--   * The input stream matches the target domain exactly+--   * The input stream matches the target domain prepended by @"www."@+--+--   e.g.+--+--   > domainOrWWW "github.com"+--+--   will match on @"github.com"@ or @"www.github.com"@+domainOrWWW+    :: Domain+    -> Parser ()+domainOrWWW targ = do+    sub <- allChars+    if sub == ("www." ++ targ) || sub == targ+        then pure ()+        else fail $ "domainOrWWW did not match:"+            ++ "\nsub: " ++ show sub+            ++ "\ntarg: " ++ show targ++-- | Remove any ".git" suffix from the specified string+gitPath+    :: String+    -> Parser String+gitPath p = case parse go "" p of+    Left e  -> fail $ show e -- Not ideal, but it works+    Right r -> pure r+  where+    go :: Parser String+    go = choice+        [ try $ manyTill anyChar (string ".git") <* eof+        , allChars+        ]++-- | Compares the input stream to the given domain. Parser succeeds if the+--   input stream is a subdomain of the target.+subdomain+    :: Domain -- ^ Target domain to match against+    -> Parser ()+subdomain targ = do+    sub <- allChars+    if targ `L.isSuffixOf` sub+        then pure ()+        else fail $ show sub ++ " is not a subdomain of " ++ show targ++ignore :: Parser ()+ignore = pure ()++-- | Matches either of the strings @"http:"@ or @"https:"@+httpScheme :: Parser String+httpScheme = choice+    [ try $ string "https:"+    , string "http:"+    ]++-- | Match on every character from the input stream+allChars :: Parser String+allChars = many anyChar
src/Portage/Overlay.hs view
@@ -19,6 +19,7 @@ import Distribution.Parsec (simpleParsec) import Distribution.Simple.Utils ( comparing, equating ) +import Control.Monad.IO.Class import Data.List as List import qualified Data.Map as Map import Data.Map (Map)@@ -60,10 +61,10 @@                     in cabal_pn == overlay_pn && (not (null ebs))) om     om = overlayMap overlay -loadLazy :: FilePath -> IO Overlay+loadLazy :: MonadIO m => FilePath -> m Overlay loadLazy path = do   dir <- getDirectoryTree path-  metadata <- unsafeInterleaveIO $ mkMetadataMap path dir+  metadata <- liftIO $ unsafeInterleaveIO $ mkMetadataMap path dir   return $ mkOverlay metadata $ readOverlayByPackage dir   where     allowed v = case v of@@ -92,7 +93,7 @@ mkMetadataMap :: FilePath -> DirectoryTree -> IO (Map Portage.PackageName Portage.Metadata) mkMetadataMap root dir =   fmap (Map.mapMaybe id) $-    traverse Portage.metadataFromFile $+    traverse Portage.readMetadataFile $       Map.fromList         [ (Portage.mkPackageName category package, root </> category </> package </> "metadata.xml")         | Directory category packages <- dir@@ -162,8 +163,8 @@ type DirectoryTree  = [DirectoryEntry] data DirectoryEntry = File FilePath | Directory FilePath [DirectoryEntry] -getDirectoryTree :: FilePath -> IO DirectoryTree-getDirectoryTree = dirEntries+getDirectoryTree :: MonadIO m => FilePath -> m DirectoryTree+getDirectoryTree = liftIO . dirEntries    where     dirEntries :: FilePath -> IO [DirectoryEntry]
src/Portage/Resolve.hs view
@@ -40,7 +40,7 @@                 return devhaskell         else do warn verbosity "Multiple matches and no known default. Override by specifying "                 warn verbosity "package category like so  'hackport merge categoryname/package[-version]."-                throwEx (ArgumentError "Specify package category and try again.")+                throw (ArgumentError "Specify package category and try again.")   where   devhaskell = Portage.Category "dev-haskell"
src/Status.hs view
@@ -1,8 +1,5 @@ module Status-    ( FileStatus(..)-    , StatusDirection(..)-    , fromStatus-    , status+    ( status     , runStatus     ) where @@ -27,9 +24,8 @@ import Control.Monad  -- cabal-import qualified Distribution.Verbosity as Cabal import qualified Distribution.Package as Cabal (pkgName)-import qualified Distribution.Simple.Utils as Cabal (comparing, die', equating)+import qualified Distribution.Simple.Utils as Cabal (die', equating) import Distribution.Pretty (prettyShow) import Distribution.Parsec (simpleParsec) @@ -39,46 +35,20 @@ import qualified Distribution.Solver.Types.PackageIndex as CabalInstall import qualified Distribution.Solver.Types.SourcePackage as CabalInstall ( SourcePackage(..) ) -data StatusDirection-    = PortagePlusOverlay-    | OverlayToPortage-    | HackageToOverlay-    deriving Eq--data FileStatus a-        = Same a-        | Differs a a-        | OverlayOnly a-        | PortageOnly a-        | HackageOnly a-        deriving (Show,Eq)--instance Ord a => Ord (FileStatus a) where-    compare = Cabal.comparing fromStatus--instance Functor FileStatus where-    fmap f st =-        case st of-            Same a -> Same (f a)-            Differs a b -> Differs (f a) (f b)-            OverlayOnly a -> OverlayOnly (f a)-            PortageOnly a -> PortageOnly (f a)-            HackageOnly a -> HackageOnly (f a)--fromStatus :: FileStatus a -> a-fromStatus fs =-    case fs of-        Same a -> a-        Differs a _ -> a -- second status is lost-        OverlayOnly a -> a-        PortageOnly a -> a-        HackageOnly a -> a+import Overlays+import Status.Types+import Hackport.Env+import Hackport.Util   -loadHackage :: Cabal.Verbosity -> CabalInstall.RepoContext -> Overlay -> IO [[PackageId]]-loadHackage verbosity repoContext overlay = do-    CabalInstall.SourcePackageDb { CabalInstall.packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity repoContext+loadHackage+  :: CabalInstall.RepoContext+  -> Overlay+  -> Env env [[PackageId]]+loadHackage repoContext overlay = askGlobalEnv >>= \(GlobalEnv verbosity _ _) -> do+    CabalInstall.SourcePackageDb { CabalInstall.packageIndex = pindex } <-+      liftIO $ CabalInstall.getSourcePackages verbosity repoContext     let get_cat cabal_pkg = case resolveCategories overlay (Cabal.pkgName cabal_pkg) of                                 []    -> Category "dev-haskell"                                 [cat] -> cat@@ -89,10 +59,12 @@                         (CabalInstall.allPackagesByName pindex)     return pkg_infos -status :: Cabal.Verbosity -> FilePath -> FilePath -> CabalInstall.RepoContext -> IO (Map PackageName [FileStatus ExistingEbuild])-status verbosity portdir overlaydir repoContext = do+status :: CabalInstall.RepoContext -> Env StatusEnv (Map PackageName [FileStatus ExistingEbuild])+status repoContext = do+    portdir <- getPortageDir+    overlaydir <- getOverlayPath     overlay <- loadLazy overlaydir-    hackage <- loadHackage verbosity repoContext overlay+    hackage <- loadHackage repoContext overlay     portage <- filterByEmail ("haskell@gentoo.org" `elem`) <$> loadLazy portdir     let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage) @@ -138,17 +110,18 @@   ebuilds <- Map.lookup (packageId pkgid) overlay   List.find (\e -> ebuildId e == pkgid) ebuilds -runStatus :: Cabal.Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> CabalInstall.RepoContext -> IO ()-runStatus verbosity portdir overlaydir direction pkgs repoContext = do+runStatus :: CabalInstall.RepoContext -> Env StatusEnv ()+runStatus repoContext =+  ask >>= \(GlobalEnv verbosity _ _, StatusEnv direction pkgs) -> do   let pkgFilter = case direction of                       OverlayToPortage   -> toPortageFilter                       PortagePlusOverlay -> id                       HackageToOverlay   -> fromHackageFilter   pkgs' <- forM pkgs $ \p ->             case simpleParsec p of-              Nothing -> Cabal.die' verbosity ("Could not parse package name: " ++ p ++ ". Format cat/pkg")+              Nothing -> liftIO $ Cabal.die' verbosity ("Could not parse package name: " ++ p ++ ". Format cat/pkg")               Just pn -> return pn-  tree0 <- status verbosity portdir overlaydir repoContext+  tree0 <- status repoContext   let tree = pkgFilter tree0   if (null pkgs')     then statusPrinter tree@@ -193,8 +166,8 @@             HackageOnly _ | not (null inEbuilds) -> Just sts             _                                    -> Nothing -statusPrinter :: Map PackageName [FileStatus ExistingEbuild] -> IO ()-statusPrinter packages = do+statusPrinter :: MonadIO m => Map PackageName [FileStatus ExistingEbuild] -> m ()+statusPrinter packages = liftIO $ do     putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same"     putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs"     putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay"@@ -236,8 +209,8 @@  -- | Compares two ebuilds, returns True if they are equal. --   Disregards comments.-equals :: FilePath -> FilePath -> IO Bool-equals fp1 fp2 = do+equals :: MonadIO m => FilePath -> FilePath -> m Bool+equals fp1 fp2 = liftIO $ do     -- don't leave halfopenfiles     f1 <- BS.readFile fp1     f2 <- BS.readFile fp2
+ src/Status/Types.hs view
@@ -0,0 +1,42 @@+module Status.Types+    ( FileStatus(..)+    , StatusDirection(..)+    , fromStatus+    ) where++import qualified Distribution.Simple.Utils as Cabal (comparing)++data StatusDirection+    = PortagePlusOverlay+    | OverlayToPortage+    | HackageToOverlay+    deriving Eq++data FileStatus a+        = Same a+        | Differs a a+        | OverlayOnly a+        | PortageOnly a+        | HackageOnly a+        deriving (Show,Eq)++instance Ord a => Ord (FileStatus a) where+    compare = Cabal.comparing fromStatus++instance Functor FileStatus where+    fmap f st =+        case st of+            Same a -> Same (f a)+            Differs a b -> Differs (f a) (f b)+            OverlayOnly a -> OverlayOnly (f a)+            PortageOnly a -> PortageOnly (f a)+            HackageOnly a -> HackageOnly (f a)++fromStatus :: FileStatus a -> a+fromStatus fs =+    case fs of+        Same a -> a+        Differs a _ -> a -- second status is lost+        OverlayOnly a -> a+        PortageOnly a -> a+        HackageOnly a -> a
src/Util.hs view
@@ -8,11 +8,16 @@  module Util     ( run_cmd -- :: String -> IO (Maybe String)+    , debug+    , notice+    , info     ) where  import System.IO import System.Process import System.Exit (ExitCode(..))+import qualified Distribution.Simple.Utils as Cabal+import Hackport.Env  -- 'run_cmd' executes command and returns it's standard output -- as 'String'.@@ -29,3 +34,12 @@                  return $ if (output == "" || exitCode /= ExitSuccess)                           then Nothing                           else Just output++debug :: (HasGlobalEnv m, MonadIO m) => String -> m ()+debug s = askGlobalEnv >>= \(GlobalEnv v _ _) -> liftIO $ Cabal.debug v s++notice :: (HasGlobalEnv m, MonadIO m) => String -> m ()+notice s = askGlobalEnv >>= \(GlobalEnv v _ _) -> liftIO $ Cabal.notice v s++info :: (HasGlobalEnv m, MonadIO m) => String -> m ()+info s = askGlobalEnv >>= \(GlobalEnv v _ _) -> liftIO $ Cabal.info v s
− tests/Merge/UtilsSpec.hs 
@@ -1,153 +0,0 @@-module Merge.UtilsSpec (spec) where--import           Test.Hspec-import           Test.Hspec.QuickCheck-import           Test.QuickCheck-import           QuickCheck.Instances--import           Control.Applicative (liftA2)-import qualified Data.Map.Strict as Map-import           Data.Maybe (catMaybes)-import qualified Data.List as L--import           Error-import           Merge.Utils-import           Portage.PackageId--import qualified Distribution.Package            as Cabal-import qualified Distribution.PackageDescription as Cabal-import           Distribution.Pretty (prettyShow)--spec :: Spec-spec = do-  describe "readPackageString" $ do-    prop "returns a Right tuple containing the parsed information or a Left ArgumentError" $ do-      let cat = Category "dev-haskell"-          name = Cabal.mkPackageName "package-name1"-        in \(ComplexVersion version) ->-             readPackageString [prettyShow cat ++ "/" ++ prettyShow name ++-                                 if (versionNumber version) == []-                                 then ""-                                 else "-" ++ prettyShow version]-             `shouldBe`-             if (versionChar     version) /= Nothing ||-                (versionSuffix   version) /= []      ||-                (versionRevision version) /= 0-             then Left (ArgumentError ("Could not parse [category/]package[-version]: "-                                        ++ prettyShow cat ++ "/" ++-                                        prettyShow name ++-                                        if (versionNumber version) == []-                                        then ""-                                        else "-" ++ prettyShow version))-             else Right ( Just cat-                        , name-                        , if (versionNumber version) == []-                          then Nothing-                          else Just version-                        )-    it "returns a Left HackPortError if the package string is empty" $ do-      readPackageString []-        `shouldBe`-        Left (ArgumentError "Need an argument, [category/]package[-version]")-    prop "returns a Left HackPortError if fed too many arguments" $ do-      \(NonEmpty args) ->-        if length args > 1-        then readPackageString args `shouldBe`-             Left (ArgumentError ("Too many arguments: " ++ unwords args))-        else readPackageString args `shouldNotBe`-             Left (ArgumentError ("Too many arguments: " ++ unwords args))-          -  describe "getPreviousPackageId" $ do-    context "when there is a previous version available" $ do-      it "returns the PackageId of the previous version" $ do-        let ebuildDir = [ "foo-bar2-3.0.0b_rc2-r1.ebuild"-                        , "foo-bar2-3.0.0b_rc2-r2.ebuild"-                        , "foo-bar2-3.0.1.ebuild"-                        , "metadata.xml"-                        , "Manifest"-                        , "files"-                        ]-            newPkgId = PackageId (PackageName (Category "dev-haskell")-                                  (Cabal.mkPackageName "foo-bar2"))-                       (Version [3,0,2] Nothing [] 0 )-          in getPreviousPackageId ebuildDir newPkgId `shouldBe`-             Just (PackageId (PackageName (Category "dev-haskell")-                              (Cabal.mkPackageName "foo-bar2"))-                   (Version [3,0,1] Nothing [] 0))-    context "if there is no previous version available" $ do-      it "returns Nothing" $ do-        let ebuildDir = [ "foo-bar2-3.0.0b_rc2-r1.ebuild"-                        , "foo-bar2-3.0.0b_rc2-r2.ebuild"-                        , "foo-bar2-3.0.1.ebuild"-                        , "metadata.xml"-                        , "Manifest"-                        , "files"-                        ]-            newPkgId = PackageId (PackageName (Category "dev-haskell")-                                   (Cabal.mkPackageName "foo-bar2"))-                       (Version [3,0,0] (Just 'a') [] 0 )-          in getPreviousPackageId ebuildDir newPkgId `shouldBe` Nothing--  describe "drop_prefix" $ do-    context "when an IUSE has a with/use prefix" $ do-      prop "drops the prefix" $ do-        let prefix   = ["with","use"]-            sep      = ["-","_"]-            prefixes = liftA2 (++) prefix sep-        \flag -> L.nub (drop_prefix <$> (liftA2 (++) prefixes [flag])) == [flag]-    context "when an IUSE has neither a with nor a use prefix" $ do-      prop "preserves the existing string" $ do-        \prefix flag -> L.nub (drop_prefix <$> (liftA2 (++) [prefix] ['-':flag])) ==-          if prefix == "with" || prefix == "use"-          then [flag]-          else [prefix ++ '-':flag]--  describe "squash_debug" $ do-    it "squashes debug-related flags under the debug global USE flag" $ do-      squash_debug "use-debug-foo" `shouldBe` "debug"-      squash_debug "debug-foo" `shouldBe` "debug"-      squash_debug "foo-debugger" `shouldBe` "debug"-    it "ignores debug-unrelated flags" $ do-      squash_debug "foo-bar" `shouldBe` "foo-bar"--  describe "convert_underscores" $ do-    it "converts underscores (_) into hyphens (-)" $ do-      convert_underscores "foo_bar" `shouldBe` "foo-bar"-    it "ignores mangling of separators other than underscores" $ do-      convert_underscores "foo-bar" `shouldBe` "foo-bar"-    it "ignores mangling of characters which are not separators" $ do-      convert_underscores "foobar" `shouldBe` "foobar"--  describe "mangle_iuse" $ do-    it "performs all IUSE mangling" $ do-      mangle_iuse "use_foo_bar" `shouldBe` "foo-bar"-      mangle_iuse "with-baz-quux" `shouldBe` "baz-quux"-      mangle_iuse "use_debugging-symbols" `shouldBe` "debug"-      mangle_iuse "foo-bar-baz_quux" `shouldBe` "foo-bar-baz-quux"--  describe "to_unstable" $ do-    prop "creates an unstable keyword from a stable keyword, or preserves a mask" $ do-      \a -> to_unstable a ==-        case a of-          '~':_ -> a-          '-':_ -> a-          _ -> '~':a--  describe "metaFlags" $ do-    prop "converts a [Cabal.PackageFlag] into a Map.Map String String" $ do-      \name desc -> metaFlags [(Cabal.emptyFlag (Cabal.mkFlagName name))-                                { Cabal.flagDescription = desc }] ==-                    Map.fromList [(mangle_iuse name,desc)]--  describe "dropIfUseExpand" $ do-    it "drops a USE flag if it is a USE_EXPAND, otherwise preserves it" $ do-      let use_expands = ["cpu_flags_x86","cpu_flags_arm"]-          flags       = Cabal.emptyFlag . Cabal.mkFlagName <$>-                        [ "cpu_flags_x86_sse4_2"-                        , "foo"-                        , "bar"-                        , "baz"-                        , "cpu_flags_arm_v8"-                        ]-      Cabal.unFlagName . Cabal.flagName <$> catMaybes (dropIfUseExpand use_expands <$> flags)-        `shouldBe` ["foo","bar","baz"]
− tests/Portage/CabalSpec.hs 
@@ -1,69 +0,0 @@-module Portage.CabalSpec (spec) where--import Test.Hspec--import qualified Distribution.SPDX as SPDX--import Portage.Cabal--spec :: Spec-spec = do-  describe "convertLicense" $ do-    it "converts AGPL_3_0_or_later into AGPL-3+" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.AGPL_3_0_or_later)-        `shouldBe`-        Right "AGPL-3+"-    it "converts AGPL_3_0_only into AGPL-3" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.AGPL_3_0_only)-        `shouldBe`-        Right "AGPL-3"-    it "converts GPL_2_0_or_later into GPL-2+" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_2_0_or_later)-        `shouldBe`-        Right "GPL-2+"-    it "converts GPL_2_0_only into GPL-2" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_2_0_only)-        `shouldBe`-        Right "GPL-2"-    it "converts GPL_3_0_or_later into GPL-3+" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_3_0_or_later)-        `shouldBe`-        Right "GPL-3+"-    it "converts GPL_3_0_only into GPL-3" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_3_0_only)-        `shouldBe`-        Right "GPL-3"-    -- Unfortunately, Cabal treats LGPL_2_0_only and LGPL_2_0_or_later as identical,-    -- just as it does with LGPL_2_1_only and LGPL_2_1_or_later. This means-    -- we cannot handle LGPL-2.0+ or LGPL-2,1+ without directly dealing with-    -- the SPDX licence, before it is converted into a Cabal-style licence.-    it "converts LGPL_2_0_or_later into LGPL-2, without a trailing plus (+)" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_2_0_or_later)-        `shouldBe`-        Right "LGPL-2"-    it "converts LGPL_2_0_only into LGPL-2" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_2_0_only)-        `shouldBe`-        Right "LGPL-2"-    it "converts LGPL_2_1_or_later into LGPL-2.1, without a trailing plus (+)" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_2_1_or_later)-        `shouldBe`-        Right "LGPL-2.1"-    it "converts LGPL_2_1_only into LGPL-2.1" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_2_1_only)-        `shouldBe`-        Right "LGPL-2.1"-      -- But these next two cases are correctly handled:-    it "converts LGPL_3_0_or_later into LGPL-3+" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_3_0_or_later)-        `shouldBe`-        Right "LGPL-3+"-    it "converts LGPL_3_0_only into LGPL-3" $ do-      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_3_0_only)-        `shouldBe`-        Right "LGPL-3"-    context "when a licence string is invalid" $ do-      it "converts the unknown licence into an error string" $ do-        convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1)-          `shouldBe`-          Left "license unknown to cabal. Please pick it manually."
− tests/Portage/Dependency/PrintSpec.hs 
@@ -1,327 +0,0 @@-module Portage.Dependency.PrintSpec (spec) where--import Test.Hspec--import Control.Monad (forM_)-import Data.List (intercalate)--import qualified Portage.PackageId            as P--import qualified Portage.Dependency.Builder   as P-import qualified Portage.Dependency.Print     as P-import qualified Portage.Dependency.Types     as P-import qualified Portage.Dependency.Normalize as P--import qualified Portage.Use                  as P--spec :: Spec-spec = do-  describe "dep2str" $ do-    it "converts an empty Dependency into an empty string" $ do-      let d_all = P.DependAllOf-          d_any = P.DependAnyOf-          d_use u dep = P.mkUseDependency (True, P.Use u) dep-          deps     = [ d_all []-                     , d_any []-                     , d_use "f" (d_all [])-                     , P.DependAllOf [d_any []]-                     , P.DependAnyOf [d_all []]-                     -- Deep Useless Use Tree :]-                     , d_use "f" $-                       d_use "g" $-                       d_all [d_any []-                             , d_use "h" $-                               d_all [ d_all []-                                     , d_any []-                                     ]-                             , d_use "i" $-                               d_all [ d_all []-                                     , d_any []-                                     ]-                             ]-                     ]-      forM_ deps $ \d ->-        P.dep2str 0 (P.normalize_depend d) `shouldBe` ""--    it "converts a Dependency into a normalized string" $ do-      let def_attr = P.DAttr P.AnySlot []-          p_v v = P.Version { P.versionNumber   = v-                            , P.versionChar     = Nothing-                            , P.versionSuffix   = []-                            , P.versionRevision = 0-                            }-          d_all = P.DependAllOf-          d_any = P.DependAnyOf-          d_ge pn v = P.DependAtom $ P.Atom pn-                   (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)-                   def_attr-          d_lt pn v = P.DependAtom $ P.Atom pn-                   (P.DRange P.ZeroB (P.StrictUB $ p_v v))-                   def_attr-          -- for the deps_norm test, formerly normalize_deps-          pnm = P.mkPackageName "dev-haskell" "mtl"-          pnp = P.mkPackageName "dev-haskell" "parsec"-          pnq = P.mkPackageName "dev-haskell" "quickcheck"-          d_p pn = P.DependAtom $ P.Atom (P.mkPackageName "c" pn)-                   (P.DRange P.ZeroB P.InfinityB)-                   def_attr-          d_use u d = P.mkUseDependency (True, P.Use u) d-          d_nuse u d = P.mkUseDependency (False, P.Use u) d--          deps  = [ -- from agda: "mtl ==2.0.* || >=2.1.1 && <2.2"-            ( d_all [ d_any [ d_all [ d_ge pnm [2, 0]-                                    , d_lt pnm [2, 1]-                                    ]-                            , d_all [ d_ge pnm [2, 1, 1]-                                    , d_lt pnm [2, 2]-                                    ]-                            ]-                    ]-            , [ "|| ( ( >=dev-haskell/mtl-2.0 <dev-haskell/mtl-2.1 )"-              , "     ( >=dev-haskell/mtl-2.1.1 <dev-haskell/mtl-2.2 ) )"-              ]-            )-              -- remove duplicate entries-            , ( let d = d_all [d_ge pnm [2, 0], d_lt pnm [2, 2]]-                in d_all [d, d]-              , [ ">=dev-haskell/mtl-2.0 <dev-haskell/mtl-2.2" ]-              )-            ]-      forM_ deps $ \(d,expected) ->-        P.dep2str 0 (P.normalize_depend d) `shouldBe` (intercalate "\n" expected)--      -- from normalize_deps.hs-      let deps_norm  = [ ( d_all [ d_ge pnm [1,0]-                                 , d_use "foo" (d_all [ d_ge pnm [1,0] -- duplicate-                                                      , d_ge pnp [2,1]-                                                      ])-                                 ]-                         , [ ">=dev-haskell/mtl-1.0"-                           , "foo? ( >=dev-haskell/parsec-2.1 )"-                           ]-                         )-                       , ( d_all [ d_ge pnm [1,0]-                                 , d_use "foo" (d_any [ d_ge pnm [1,0] -- already satisfied-                                                      , d_ge pnp [2,1]-                                                      ])-                                 ]-                         , [ ">=dev-haskell/mtl-1.0" ]-                         )-                       , ( d_any [ d_all [ d_ge pnm [1,0] -- common subdep-                                         , d_ge pnq [1,2]-                                         ]-                                 , d_all [ d_ge pnm [1,0]-                                         , d_ge pnp [3,1]-                                         ]-                                 ]-                         , [ ">=dev-haskell/mtl-1.0"-                           , "|| ( >=dev-haskell/parsec-3.1"-                           , "     >=dev-haskell/quickcheck-1.2 )"-                           ]-                         )-                       , ( d_all [ d_use "foo" $ d_use "bar" $ d_ge pnm [1,0]-                                 , d_use "bar" $ d_use "foo" $ d_ge pnm [1,0]-                                 ]-                         , [ "bar? ( foo? ( >=dev-haskell/mtl-1.0 ) )" ]-                         )-                       , ( d_all [ d_use "foo" $ d_ge pnm [1,0]-                                 , d_use "foo" $ d_ge pnp [3,1]-                                 ]-                         , [ "foo? ( >=dev-haskell/mtl-1.0"-                           , "       >=dev-haskell/parsec-3.1 )"-                           ]-                         )-                       , ( d_all [ d_use  "a" $ d_use "b" $ d_ge pnm [1,0]-                                 , d_nuse "a" $ d_use "b" $ d_ge pnm [1,0]-                                 ]-                         , [ "b? ( >=dev-haskell/mtl-1.0 )"-                           ]-                         )-                       -- 'test?' is special-                       , ( d_use "a" $ d_use "test" $ d_ge pnm [1,0]-                         , [ "test? ( a? ( >=dev-haskell/mtl-1.0 ) )"-                           ]-                         )-                       , -- pop context for complementary depends, like-                         --   a? ( x y a ) !a? ( x y na )-                         -- leads to-                         --   x y a? ( a ) !a? ( na )-                         ( d_all [ d_use  "a" $ d_all $ map d_p [ "x", "y", "a" ]-                                 , d_nuse "a" $ d_all $ map d_p [ "x", "y", "na" ]-                                 ]-                         , [ "c/x"-                           , "c/y"-                           , "a? ( c/a )"-                           , "!a? ( c/na )"-                           ]-                         )-                       , -- push stricter context into less strict-                         ( d_all [ d_ge pnm [2,0]-                                 , d_use "a" $ d_ge pnm [1,0]-                                 ]-                         ,-                           [ ">=dev-haskell/mtl-2.0" ]-                         )-                       , -- propagate use guarded depend into deeply nested one-                         ( d_all [ d_use  "a"    $             d_all $ map d_p [ "x" ]-                                 , d_use  "test" $ d_use "a" $ d_all $ map d_p [ "x", "t" ]-                                 ]-                         , [ "test? ( a? ( c/t ) )"-                           , "a? ( c/x )"-                           ]-                         )-                       , -- lift nested use context for complementary depends-                         --   a? ( b? ( y ) ) b? ( x )-                         ( d_all [ d_use  "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]-                                 , d_nuse "a" $ d_use "b" $ d_p "x"-                                 ]-                         , [ "a? ( b? ( c/y ) )"-                           , "b? ( c/x )"-                           ]-                         )-                       , -- more advanced lift of complementary deps-                         -- a? ( b? ( x y ) )-                         -- !a? ( b? ( y z ) )-                         ( d_all [ d_use   "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]-                                 , d_nuse  "a" $ d_use "b" $ d_all $ map d_p [ "y", "z" ]-                                 ]-                         , [ "a? ( b? ( c/x ) )"-                           , "!a? ( b? ( c/z ) )"-                           , "b? ( c/y )"-                           ]-                         )-                       , -- completely expanded set of USEs-                         -- a? ( b? ( c? ( x y z ) )-                         -- a? ( b? ( !c? ( x y ) )-                         -- a? ( !b? ( c? ( x z ) )-                         -- a? ( !b? ( !c? ( x ) )-                         ---                         -- !a? ( b? ( c? ( y z ) )-                         -- !a? ( b? ( !c? ( y ) )-                         -- !a? ( !b? ( c? ( z ) )-                         -- !a? ( !b? ( !c? ( ) )-                         ( d_all [ d_use   "a" $ d_use  "b" $ d_use  "c" $ d_all $ map d_p [ "x", "y", "z" ]-                                 , d_use   "a" $ d_use  "b" $ d_nuse "c" $ d_all $ map d_p [ "x", "y" ]-                                 , d_use   "a" $ d_nuse "b" $ d_use  "c" $ d_all $ map d_p [ "x", "z" ]-                                 , d_use   "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ "x" ]-                                 , d_nuse  "a" $ d_use  "b" $ d_use  "c" $ d_all $ map d_p [ "y", "z" ]-                                 , d_nuse  "a" $ d_use  "b" $ d_nuse "c" $ d_all $ map d_p [ "y" ]-                                 , d_nuse  "a" $ d_nuse "b" $ d_use  "c" $ d_all $ map d_p [ "z" ]-                                 , d_nuse  "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ ]-                                 ]-                         , [ "a? ( c/x )"-                           , "b? ( c/y )"-                           , "c? ( c/z )"-                           ]-                         )-                       , -- pop simple common subdepend-                         -- a?  ( b? ( d ) )-                         -- !a? ( b? ( d ) )-                         ( d_all [ d_use   "a" $ d_use  "b" $ d_p "d"-                                 , d_nuse  "a" $ d_use  "b" $ d_p "d"-                                 ]-                         , [ "b? ( c/d )"-                           ]-                         )-                       , -- pop '|| ( some thing )' depend-                         ( let any_part = d_any $ map d_p ["a", "b"] in-                             d_all [ d_use  "u" $ d_all [ any_part , d_p "z"]-                                   , d_nuse "u" $         any_part-                                   ]-                         , [ "|| ( c/a"-                           , "     c/b )"-                           , "u? ( c/z )"-                           ]-                         )-                       , -- simplify slightly more complex counterguard-                         --   v? ( c/d )-                         --   u? ( !v? ( c/d ) )-                         -- to-                         --   v? ( c/d )-                         --   u? ( c/d )-                         ( d_all [               d_use  "v" $ d_p "d"-                                 , d_use   "u" $ d_nuse "v" $ d_p "d"-                                 ]-                         , [ "u? ( c/d )"-                           , "v? ( c/d )"-                           ]-                         )-                       -                       , --   ffi? ( c/d c/e )-                         --   !ffi ( !gmp ( c/d c/e ) )-                         --   gmp? ( c/d c/e )-                         -- to-                         --   ( c/d c/e )-                         ( let de = d_all [ d_p "d" , d_p "e" ]-                           in d_all [ d_use "ffi" de-                                    , d_nuse "ffi" $ d_nuse "gmp" $ de-                                    , d_use  "gmp" $ de-                                    ]-                         , [ "c/d"-                           , "c/e"-                           ]-                         )-                       -                       {- TODO: another popular case-                       , -- simplify even more complex counterguard-                         --   u? ( c/d )-                         --   !u? ( v? ( c/d ) )-                         -- to-                         --   u? ( c/d )-                         --   v? ( c/d )-                       ( d_all [               d_use "u" $ d_p "d"-                               , d_nuse  "u" $ d_use "v" $ d_p "d"-                               ]-                       , [ "u? ( c/d )"-                       , "v? ( c/d )"-                       ]-                       )-                       -}-                       ]-      forM_ deps_norm $ \(d, expected) ->-        (P.dep2str 0 $ P.normalize_depend d) `shouldBe` (intercalate "\n" expected)--  describe "dep2str_noindent" $ do-    it "converts a Dependency into a string" $ do-      let pn = P.mkPackageName "dev-haskell" "mtl"-          def_attr = P.DAttr P.AnySlot []-          p_v v = P.Version { P.versionNumber   = v-                            , P.versionChar     = Nothing-                            , P.versionSuffix   = []-                            , P.versionRevision = 0-                            }-          d_all = P.DependAllOf-          d_any = P.DependAnyOf-          d_ge v = P.DependAtom $ P.Atom pn-                   (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)-                   def_attr-          d_lt v = P.DependAtom $ P.Atom pn-                   (P.DRange P.ZeroB (P.StrictUB $ p_v v))-                   def_attr-          deps  = [ -- from agda: "mtl ==2.0.* || >=2.1.1 && <2.2"-            ( d_all [ d_any [ d_all [ d_ge [2, 0]-                                    , d_lt [2, 1]-                                    ]-                            , d_all [ d_ge [2, 1, 1]-                                    , d_lt [2, 2]-                                    ]-                            ]-                    ]-            , [ "|| ( ( >=dev-haskell/mtl-2.0"-              , "       <dev-haskell/mtl-2.1 )"-              , "     ( >=dev-haskell/mtl-2.1.1"-              , "       <dev-haskell/mtl-2.2 ) )"-              ]-            )-              -- remove duplicate entries-            , ( let d = d_all [d_ge [2, 0], d_lt [2, 2]]-                in d_all [d, d]-              , [ ">=dev-haskell/mtl-2.0"-                , "<dev-haskell/mtl-2.2"-                , ">=dev-haskell/mtl-2.0"-                , "<dev-haskell/mtl-2.2"-                ]-              )-            ]-      forM_ deps $ \(d, expected) ->-        P.dep2str_noindent d `shouldBe` intercalate "\n" expected
− tests/Portage/EBuildSpec.hs 
@@ -1,34 +0,0 @@-module Portage.EBuildSpec (spec) where--import Test.Hspec--import Portage.EBuild--spec :: Spec-spec = do-  describe "sort_iuse" $ do-    it "sorts IUSE alphabetically despite pluses (+)" $ do-      sort_iuse ["+a","c","+b","d"] `shouldBe` ["+a","+b","c","d"]-  describe "drop_tdot" $ do-    it "drops trailing dots (.)" $ do-      drop_tdot "foo." `shouldBe` "foo"-      drop_tdot "foo..." `shouldBe` "foo"-      drop_tdot "foo" `shouldBe` "foo"-  describe "quote" $ do-    it "should correctly surround a string with special characters in quotes" $ do-      quote "Reading, writing and manipulating '.tar' archives." ""-        `shouldBe`-        "\"Reading, writing and manipulating \'.tar\' archives.\""-      quote "Extras for the \"contravariant\" package" ""-        `shouldBe`-        "\"Extras for the \\\"contravariant\\\" package\""-  describe "toHttps" $ do-    it "should not convert whitelisted http-only homepages into https homepages" $ do-      toHttps "http://leksah.org" `shouldBe` "http://leksah.org"-      toHttps "http://darcs.net/" `shouldBe` "http://darcs.net/"-      toHttps "http://khumba.net/" `shouldBe` "http://khumba.net/"-    it "should otherwise convert all homepages into https-aware homepages" $ do-      toHttps "http://pandoc.org" `shouldBe` "https://pandoc.org"-      toHttps "http://www.yesodweb.com/" `shouldBe` "https://www.yesodweb.com/"-    it "should ignore any conversions of homepages already marked as https-aware" $ do-      toHttps "https://github.com" `shouldBe` "https://github.com"
− tests/Portage/GHCCoreSpec.hs 
@@ -1,23 +0,0 @@-module Portage.GHCCoreSpec (spec) where--import Test.Hspec--import qualified Distribution.Version             as Cabal-import qualified Distribution.Package             as Cabal--import Portage.GHCCore--spec :: Spec-spec = do-  describe "cabalFromGHC" $ do-    it "returns the corresponding Cabal version for a valid GHC version" $ do-      cabalFromGHC [8,8,3] `shouldBe` Just (Cabal.mkVersion [3,0,1,0])-    it "returns Nothing for an invalid GHC version" $ do-      cabalFromGHC [9,9,9,9] `shouldBe` Nothing-  describe "packageIsCoreInAnyGHC" $ do-    it "returns True for the binary package" $ do-      packageIsCoreInAnyGHC (Cabal.mkPackageName "binary") `shouldBe` True-    it "returns False for the haskeline package (because it is upgradeable)" $ do-      packageIsCoreInAnyGHC (Cabal.mkPackageName "haskeline") `shouldBe` False-    it "returns False for the yesod package" $ do-      packageIsCoreInAnyGHC (Cabal.mkPackageName "yesod") `shouldBe` False
− tests/Portage/MetadataSpec.hs 
@@ -1,104 +0,0 @@-module Portage.MetadataSpec (spec) where--import Test.Hspec-import Test.Hspec.QuickCheck--import qualified Data.List       as L-import qualified Data.Text       as T-import qualified Data.Map.Strict as Map--import Portage.Metadata--spec :: Spec-spec = do-  describe "pureMetadataFromFile" $ do-    it "returns Nothing from an empty Text" $ do-      pureMetadataFromFile T.empty `shouldBe` Nothing-    it "equals makeMinimalMetadata with no USE flags" $ do-      pureMetadataFromFile (makeDefaultMetadata Map.empty) `shouldBe` Just makeMinimalMetadata-    it "equals makeMinimalMetadata plus the supplied USE flags" $ do-      let flags = Map.singleton "name" "description"-      pureMetadataFromFile (makeDefaultMetadata flags) `shouldBe` Just (makeMinimalMetadata { metadataUseFlags = flags })--  describe "stripGlobalUseFlags" $ do-    it "should remove specified global USE flags from the metadata.xml" $ do-      stripGlobalUseFlags (Map.singleton "debug" "description") `shouldBe` Map.empty-      stripGlobalUseFlags (Map.singleton "examples" "description") `shouldBe` Map.empty-      stripGlobalUseFlags (Map.singleton "static" "description") `shouldBe` Map.empty-    prop "should ignore USE flags that are not specified as global" $ do-      \name description -> stripGlobalUseFlags (Map.singleton name description) ==-                           if name `elem` ["debug","examples","static"]-                           then Map.empty-                           else Map.singleton name description--  describe "prettyPrintFlags" $ do-    it "correctly handles special XML characters contained in strings" $ do-      let name = "foo"-          desc = "bar < 1.1.0"-        in prettyPrintFlags (Map.singleton name desc) `shouldBe`-        ["\t\t<flag name=\"" ++ name ++ "\">"-         ++ "bar &lt; 1.1.0" ++ "</flag>"]-    it "correctly formats a single USE flag name with its description" $ do-      let name = "foo"-          description = "bar"-        in prettyPrintFlags (Map.singleton name description) `shouldBe`-                           ["\t\t<flag name=\"" ++ name ++-                           "\">" ++ (L.intercalate " " . lines $ description)-                           ++ "</flag>"]-    it "correctly formats multiple USE flag names with their descriptions" $ do-      let f1 = "flag1"-          f2 = "flag2"-          d1 = "foo_desc"-          d2 = "bar_desc"-        in prettyPrintFlags (Map.fromList [(f1,d1),(f2,d2)]) `shouldBe`-           ["\t\t<flag name=\"" ++ f1-           ++ "\">" ++ (L.intercalate " " . lines $ d1)-           ++ "</flag>"-           ,-           "\t\t<flag name=\"" ++ f2-           ++ "\">" ++ (L.intercalate " " . lines $ d2)-           ++ "</flag>"]--    prop "should have a length equal to the number of USE flags" $ do-      \flags -> length (prettyPrintFlags flags) == Map.size flags-      -  describe "makeDefaultMetadata" $ do-    context "when writing a minimal metadata.xml with no USE flags" $ do-      it "should have a certain number of lines" $ do-        -- This is the number of lines in a skeleton metadata.xml.-        -- If it does not equal this number, the formatting may be wrong.-        length (T.lines (makeDefaultMetadata Map.empty)) `shouldBe` 8-      it "should have a certain format" $ do-        let correctMetadata = T.pack $ unlines-              [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"-              , "<!DOCTYPE pkgmetadata SYSTEM \"https://www.gentoo.org/dtd/metadata.dtd\">"-              , "<pkgmetadata>"-              , "\t<maintainer type=\"project\">"-              , "\t\t<email>haskell@gentoo.org</email>"-              , "\t\t<name>Gentoo Haskell</name>"-              , "\t</maintainer>"-              , "</pkgmetadata>"-              ]-          in makeDefaultMetadata Map.empty `shouldBe` correctMetadata-    context "when writing a metadata.xml with USE flags" $ do-      it "should have a certain number of lines" $ do-        let flags = Map.singleton "name" "description"-          in length (T.lines (makeDefaultMetadata flags))-             `shouldBe` 10 + (Map.size flags)-      it "should have a certain format, including the <use> element" $ do-        let flags = Map.fromList [("flag1","desc1"),("flag2","desc2")]-            correctMetadata = T.pack $ unlines-              [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"-              , "<!DOCTYPE pkgmetadata SYSTEM \"https://www.gentoo.org/dtd/metadata.dtd\">"-              , "<pkgmetadata>"-              , "\t<maintainer type=\"project\">"-              , "\t\t<email>haskell@gentoo.org</email>"-              , "\t\t<name>Gentoo Haskell</name>"-              , "\t</maintainer>"-              , "\t<use>"-              , "\t\t<flag name=\"flag1\">desc1</flag>"-              , "\t\t<flag name=\"flag2\">desc2</flag>"-              , "\t</use>"-              , "</pkgmetadata>"-              ]-          in makeDefaultMetadata flags `shouldBe` correctMetadata
− tests/Portage/PackageIdSpec.hs 
@@ -1,69 +0,0 @@-module Portage.PackageIdSpec (spec) where--import           Test.Hspec-import           Test.Hspec.QuickCheck-import           Test.QuickCheck-import           QuickCheck.Instances--import qualified Data.Char as Char-import qualified Distribution.Package as Cabal-import           Distribution.Pretty (prettyShow)--import           Portage.PackageId--spec :: Spec-spec = do-  describe "packageIdToFilePath" $ do-    prop "transforms a PackageId into a FilePath" $ do-      let cat = Category "dev-haskell"-          name = Cabal.mkPackageName "foo-bar2+"-        in \(ComplexVersion version) ->-             packageIdToFilePath (PackageId (PackageName cat name) version)-             `shouldBe`-             "dev-haskell/" ++ prettyShow name ++ "/" ++ prettyShow name ++ "-" ++-             prettyShow version ++ ".ebuild"--  describe "filePathToPackageId" $ do-    prop "returns a Just PackageId from a valid FilePath" $ do-      let cat = Category "dev-haskell"-          name = Cabal.mkPackageName "foo-bar2+"-        in \(ComplexVersion version) ->-             filePathToPackageId cat-             (prettyShow name ++ "-" ++ prettyShow version)-             `shouldBe`-             Just (PackageId (PackageName cat name) version)-    prop "returns Nothing on a malformed FilePath" $ do-      let cat = Category "dev-haskell"-          name = Cabal.mkPackageName "foo-bar-2+"-        in \(ComplexVersion version) ->-             filePathToPackageId cat (prettyShow name ++ "-" ++ prettyShow version)-             `shouldBe`-             Nothing--  describe "normalizeCabalPackageName" $ do-    prop "converts a Cabal.PackageName into lowercase" $ do-      \(PrintableString s) -> normalizeCabalPackageName (Cabal.mkPackageName s)-                            `shouldBe` Cabal.mkPackageName (Char.toLower <$> s)--  describe "parseFriendlyPackage" $ do-    prop "parses a package string as [category/]name[-version]" $ do-      let cat = Category "dev-haskell"-          name = Cabal.mkPackageName "package-name1+"-        in \(ComplexVersion version) ->-             parseFriendlyPackage (prettyShow cat ++ "/" ++ prettyShow name-                                    ++ "-" ++ prettyShow version)-             `shouldBe`-             Right (Just cat, name, Just version)-    prop "returns an error string if parsing a malformed package string" $ do-      let cat = Category "dev-haskell"-          name = Cabal.mkPackageName "package-name-1+"-        in \(ComplexVersion version) ->-             parseFriendlyPackage (prettyShow cat ++ "/" ++ prettyShow name-                                   ++ "-" ++ prettyShow version)-             `shouldNotBe`-             Right (Just cat, name, Just version)--  describe "cabal_pn_to_PN" $ do-    prop "pretty-prints a Cabal PackageName as a lowercase String" $ do-      \(PrintableString s) -> cabal_pn_to_PN (Cabal.mkPackageName s)-                            `shouldBe` Char.toLower <$> s
− tests/Portage/VersionSpec.hs 
@@ -1,27 +0,0 @@-module Portage.VersionSpec (spec) where--import           Test.Hspec-import           Test.Hspec.QuickCheck-import           QuickCheck.Instances--import qualified Distribution.Version as Cabal--import           Portage.Version--spec :: Spec-spec = do-  describe "is_live" $ do-    prop "determines if a Portage version is live" $ do-      \(ComplexVersion v) -> is_live v `shouldBe`-        if last (versionNumber v) >= 9999-        then True else False-        -  describe "fromCabalVersion" $ do-    prop "converts from a Cabal version to a Portage version" $ do-      \verNum -> fromCabalVersion (Cabal.mkVersion verNum) == Version verNum Nothing [] 0-      -  describe "toCabalVersion" $ do-    prop "converts from a Portage version to a Cabal version" $ do-      \(ComplexVersion v) -> toCabalVersion v `shouldBe`-        if versionChar v == Nothing && versionSuffix v == []-        then Just (Cabal.mkVersion (versionNumber v)) else Nothing
− tests/QuickCheck/Instances.hs 
@@ -1,44 +0,0 @@-module QuickCheck.Instances (ComplexVersion(..)) where--import Test.QuickCheck--import Portage.Version (Suffix(..), Version(..))------------------------------------------------------------------------------------- Types------------------------------------------------------------------------------------ | Wrapper for 'Suffix', intended for use in an 'Arbitrary' instance--- to return a single, valid 'Suffix'.-newtype ValidSuffix = ValidSuffix { getSuffix :: Suffix }-  deriving (Eq,Ord,Show)---- | Wrapper For 'Version', intended for use in an 'Arbitrary' instance--- where we want to generate the most complex 'Version' possible.-newtype ComplexVersion = ComplexVersion { getVersion :: Version }-  deriving (Eq,Ord,Show)------------------------------------------------------------------------------------- Instances------------------------------------------------------------------------------------ | Return a single, valid 'ValidSuffix'.-instance Arbitrary ValidSuffix where-  arbitrary = oneof [ ValidSuffix . Alpha . getNonNegative <$> arbitrary-                    , ValidSuffix . Beta  . getNonNegative <$> arbitrary-                    , ValidSuffix . Pre   . getNonNegative <$> arbitrary-                    , ValidSuffix . RC    . getNonNegative <$> arbitrary-                    , ValidSuffix . P     . getNonNegative <$> arbitrary-                    ]-  --- | Return a valid 'ComplexVersion' with a non-empty 'versionNumber',--- an optional 'versionChar' if valid, a ['Suffix'] which may be empty,--- and a 'NonNegative' 'versionRevision' which may be zero.------ This is used to generate a 'Version' of high complexity to--- stress-test our parsers for a range of valid inputs.-instance Arbitrary ComplexVersion where-  arbitrary = do-    v <- listOf1 $ getNonNegative <$> arbitrary-    c <- oneof $ [Just <$> choose ('a','z'), elements [Nothing]]-    s <- listOf $ getSuffix <$> arbitrary-    (NonNegative r) <- arbitrary-    return $ ComplexVersion $ Version v (if length v == 1 then Nothing else c) s r
− tests/RunTests.hs 
@@ -1,15 +0,0 @@-module RunTests-    (run_tests) where--import Control.Monad (when)--import System.Exit (exitFailure)-import Test.HUnit--something_broke :: Counts -> Bool-something_broke stats = errors stats + failures stats > 0--run_tests :: Test -> IO ()-run_tests tests =-    do stats <- runTestTT tests-       when (something_broke stats) exitFailure
− tests/Spec.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− tests/doctests-v2.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE CPP #-}--module Main (main) where--import Control.Monad.Fail (fail)-import Data.Foldable (for_)-import System.Exit (ExitCode (..), exitWith)-import System.Process (readProcess, createProcess, proc, waitForProcess, getProcessExitCode)--#if !MIN_VERSION_base(4,13,0)-import Prelude hiding (fail)-#endif---main :: IO ()-main = do-    doctestPath <- head . lines <$> readProcess "cabal" ["list-bin", "doctest"] []--    let components =-            [ "hackport:lib:hackport-internal"-            , "hackport:exe:hackport"-            ]--    for_ components $ \component -> do-        let cabalArgs =-                [ "repl"-                , "--with-compiler=" ++ doctestPath-                , component-                ]-        putStrLn $ "Running: cabal " ++ unwords cabalArgs-        (_, _, _, processHandle) <- createProcess (proc "cabal" cabalArgs)-        waitForProcess processHandle-        exitCode <- getProcessExitCode processHandle-        case exitCode of-            Nothing -> fail "No exit code from cabal process..."-            Just ExitSuccess -> pure ()-            Just c@(ExitFailure i) -> do-                putStrLn $ "\nFailure: cabal process returned exit code " ++ show i-                exitWith c
+ tests/doctests-v2/Main.hs view
@@ -0,0 +1,35 @@+module Main (main) where++import Data.Foldable (for_)+import System.Exit (ExitCode (..), exitWith)+import System.Process (readProcess, createProcess, proc, waitForProcess, getProcessExitCode)+++main :: IO ()+main = do++    doctestPath:_ <- lines <$> readProcess "cabal" ["list-bin", "doctest"] []++    let components =+            [ "hackport:lib:hackport-internal"+            , "hackport:exe:hackport"+            ]++    for_ components $ \component -> do+        let cabalArgs =+                [ "repl"+                  -- -Wtype-defaults screws up some doctests when run with -Werror+                , "--ghc-option=-Wno-type-defaults"+                , "--with-compiler=" ++ doctestPath+                , component+                ]+        putStrLn $ "Running: cabal " ++ unwords cabalArgs+        (_, _, _, processHandle) <- createProcess (proc "cabal" cabalArgs)+        _ <- waitForProcess processHandle+        exitCode <- getProcessExitCode processHandle+        case exitCode of+            Nothing -> fail "No exit code from cabal process..."+            Just ExitSuccess -> pure ()+            Just c@(ExitFailure i) -> do+                putStrLn $ "\nFailure: cabal process returned exit code " ++ show i+                exitWith c
− tests/doctests.hs 
@@ -1,36 +0,0 @@-module Main where--import Build_doctests (Component (..), Name (..), components)-import Test.DocTest (doctest)-import Data.Foldable (for_)-import qualified Data.List as L-import GHC.IO.Encoding (setLocaleEncoding)-import System.Directory (getCurrentDirectory, makeAbsolute)-import System.Environment.Compat (unsetEnv)-import System.FilePath.Glob (glob)-import System.FilePath.Posix ((</>))-import System.IO (utf8)--main :: IO ()-main = do-    setLocaleEncoding utf8-    unsetEnv "GHC_ENVIRONMENT"-    pwd    <- getCurrentDirectory-    prefix <- makeAbsolute pwd--    for_ components $ \(Component name pkgs flags _) -> do-        putStrLn "----------"-        print name--        maybeSources <- case name of-            NameLib (Just "hackport-internal") -> Just <$> glob (prefix </> "src" </> "**/*.hs")-            NameExe "hackport"                 -> Just <$> glob (prefix </> "exe" </> "**/*.hs")-            _                                  -> fail $-                "Unexpected component: " ++ show name ++ "\n" ++-                "Please edit tests/doctests.hs to add sources for this component."--        for_ maybeSources $ \sources -> do-            let args = flags ++ pkgs ++ sources-            putStrLn "Flags passed:"-            for_ args $ \a -> putStr "    " *> print a-            doctest args
+ tests/doctests/Main.hs view
@@ -0,0 +1,36 @@+module Main where++import Build_doctests (Component (..), Name (..), components)+import Test.DocTest (doctest)+import Data.Foldable (for_)+import GHC.IO.Encoding (setLocaleEncoding)+import System.Directory (getCurrentDirectory, makeAbsolute)+import System.Environment.Compat (unsetEnv)+import System.FilePath.Glob (glob)+import System.FilePath.Posix ((</>))+import System.IO (utf8)++main :: IO ()+main = do+    setLocaleEncoding utf8+    unsetEnv "GHC_ENVIRONMENT"+    pwd    <- getCurrentDirectory+    prefix <- makeAbsolute pwd++    for_ components $ \(Component name pkgs flags _) -> do+        putStrLn "----------"+        print name++        maybeSources <- case name of+            NameLib (Just "hackport-internal") -> Just <$> glob (prefix </> "src" </> "**/*.hs")+            NameExe "hackport"                 -> Just <$> glob (prefix </> "exe" </> "**/*.hs")+            _                                  -> fail $+                "Unexpected component: " ++ show name ++ "\n" +++                "Please edit tests/doctests.hs to add sources for this component."++        for_ maybeSources $ \sources -> do+            let noWarnFlags = ["-Wwarn", "-Wno-default"]+            let args = flags ++ noWarnFlags ++ pkgs ++ sources+            putStrLn "Flags passed:"+            for_ args $ \a -> putStr "    " *> print a+            doctest args
− tests/normalize_deps.hs 
@@ -1,250 +0,0 @@-import Control.Monad (forM_)-import Data.List--import Test.HUnit--import qualified Portage.Dependency as P-import qualified Portage.Dependency.Normalize as PN-import qualified Portage.PackageId  as P-import qualified Portage.Use        as P-import qualified RunTests as RT--tests :: Test-tests = TestList [ TestLabel "normalize_in_use_and_top" test_normalize_in_use_and_top-                 ]--pnm :: P.PackageName-pnm = P.mkPackageName "dev-haskell" "mtl"-pnp :: P.PackageName-pnp = P.mkPackageName "dev-haskell" "parsec"-pnq :: P.PackageName-pnq = P.mkPackageName "dev-haskell" "quickcheck"--def_attr :: P.DAttr-def_attr = P.DAttr P.AnySlot []--p_v :: [Int] -> P.Version-p_v v = P.Version { P.versionNumber   = v-                  , P.versionChar     = Nothing-                  , P.versionSuffix   = []-                  , P.versionRevision = 0-                  }--d_all :: [P.Dependency] -> P.Dependency-d_all = P.DependAllOf-d_any :: [P.Dependency] -> P.Dependency-d_any = P.DependAnyOf--d_ge :: P.PackageName -> [Int] -> P.Dependency-d_ge pn v = P.DependAtom $ P.Atom pn-                   (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)-                   def_attr--d_p :: String -> P.Dependency-d_p pn = P.DependAtom $ P.Atom (P.mkPackageName "c" pn)-                (P.DRange P.ZeroB P.InfinityB)-                def_attr--d_use :: String -> P.Dependency -> P.Dependency-d_use u d = P.mkUseDependency (True, P.Use u) d--d_nuse :: String -> P.Dependency -> P.Dependency-d_nuse u d = P.mkUseDependency (False, P.Use u) d--test_normalize_in_use_and_top :: Test-test_normalize_in_use_and_top = TestCase $ do-    let deps  = [ ( d_all [ d_ge pnm [1,0]-                          , d_use "foo" (d_all [ d_ge pnm [1,0] -- duplicate-                                               , d_ge pnp [2,1]-                                               ])-                          ]-                  , [ ">=dev-haskell/mtl-1.0"-                    , "foo? ( >=dev-haskell/parsec-2.1 )"-                    ]-                  )-                , ( d_all [ d_ge pnm [1,0]-                          , d_use "foo" (d_any [ d_ge pnm [1,0] -- already satisfied-                                               , d_ge pnp [2,1]-                                               ])-                          ]-                  , [ ">=dev-haskell/mtl-1.0" ]-                  )-                , ( d_any [ d_all [ d_ge pnm [1,0] -- common subdep-                                  , d_ge pnq [1,2]-                                  ]-                          , d_all [ d_ge pnm [1,0]-                                  , d_ge pnp [3,1]-                                  ]-                          ]-                  , [ ">=dev-haskell/mtl-1.0"-                    , "|| ( >=dev-haskell/parsec-3.1"-                    , "     >=dev-haskell/quickcheck-1.2 )"-                    ]-                  )-                , ( d_all [ d_use "foo" $ d_use "bar" $ d_ge pnm [1,0]-                          , d_use "bar" $ d_use "foo" $ d_ge pnm [1,0]-                          ]-                  , [ "bar? ( foo? ( >=dev-haskell/mtl-1.0 ) )" ]-                  )-                , ( d_all [ d_use "foo" $ d_ge pnm [1,0]-                          , d_use "foo" $ d_ge pnp [3,1]-                          ]-                  , [ "foo? ( >=dev-haskell/mtl-1.0"-                    , "       >=dev-haskell/parsec-3.1 )"-                    ]-                  )-                , ( d_all [ d_use  "a" $ d_use "b" $ d_ge pnm [1,0]-                          , d_nuse "a" $ d_use "b" $ d_ge pnm [1,0]-                          ]-                  , [ "b? ( >=dev-haskell/mtl-1.0 )"-                    ]-                  )-                -- 'test?' is special-                , ( d_use "a" $ d_use "test" $ d_ge pnm [1,0]-                  , [ "test? ( a? ( >=dev-haskell/mtl-1.0 ) )"-                    ]-                  )-                , -- pop context for complementary depends, like-                  --   a? ( x y a ) !a? ( x y na )-                  -- leads to-                  --   x y a? ( a ) !a? ( na )-                  ( d_all [ d_use  "a" $ d_all $ map d_p [ "x", "y", "a" ]-                          , d_nuse "a" $ d_all $ map d_p [ "x", "y", "na" ]-                          ]-                  , [ "c/x"-                    , "c/y"-                    , "a? ( c/a )"-                    , "!a? ( c/na )"-                    ]-                  )-                , -- push stricter context into less strict-                  ( d_all [ d_ge pnm [2,0]-                          , d_use "a" $ d_ge pnm [1,0]-                          ]-                  ,-                    [ ">=dev-haskell/mtl-2.0" ]-                  )-                , -- propagate use guarded depend into deeply nested one-                  ( d_all [ d_use  "a"    $             d_all $ map d_p [ "x" ]-                          , d_use  "test" $ d_use "a" $ d_all $ map d_p [ "x", "t" ]-                          ]-                  , [ "test? ( a? ( c/t ) )"-                    , "a? ( c/x )"-                    ]-                  )-                , -- lift nested use context for complementary depends-                  --   a? ( b? ( y ) ) b? ( x )-                  ( d_all [ d_use  "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]-                          , d_nuse "a" $ d_use "b" $ d_p "x"-                          ]-                  , [ "a? ( b? ( c/y ) )"-                    , "b? ( c/x )"-                    ]-                  )-                , -- more advanced lift of complementary deps-                  -- a? ( b? ( x y ) )-                  -- !a? ( b? ( y z ) )-                  ( d_all [ d_use   "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]-                          , d_nuse  "a" $ d_use "b" $ d_all $ map d_p [ "y", "z" ]-                          ]-                  , [ "a? ( b? ( c/x ) )"-                    , "!a? ( b? ( c/z ) )"-                    , "b? ( c/y )"-                    ]-                  )-                , -- completely expanded set of USEs-                  -- a? ( b? ( c? ( x y z ) )-                  -- a? ( b? ( !c? ( x y ) )-                  -- a? ( !b? ( c? ( x z ) )-                  -- a? ( !b? ( !c? ( x ) )-                  ---                  -- !a? ( b? ( c? ( y z ) )-                  -- !a? ( b? ( !c? ( y ) )-                  -- !a? ( !b? ( c? ( z ) )-                  -- !a? ( !b? ( !c? ( ) )-                  ( d_all [ d_use   "a" $ d_use  "b" $ d_use  "c" $ d_all $ map d_p [ "x", "y", "z" ]-                          , d_use   "a" $ d_use  "b" $ d_nuse "c" $ d_all $ map d_p [ "x", "y" ]-                          , d_use   "a" $ d_nuse "b" $ d_use  "c" $ d_all $ map d_p [ "x", "z" ]-                          , d_use   "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ "x" ]-                          , d_nuse  "a" $ d_use  "b" $ d_use  "c" $ d_all $ map d_p [ "y", "z" ]-                          , d_nuse  "a" $ d_use  "b" $ d_nuse "c" $ d_all $ map d_p [ "y" ]-                          , d_nuse  "a" $ d_nuse "b" $ d_use  "c" $ d_all $ map d_p [ "z" ]-                          , d_nuse  "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ ]-                          ]-                  , [ "a? ( c/x )"-                    , "b? ( c/y )"-                    , "c? ( c/z )"-                    ]-                  )-                , -- pop simple common subdepend-                  -- a?  ( b? ( d ) )-                  -- !a? ( b? ( d ) )-                  ( d_all [ d_use   "a" $ d_use  "b" $ d_p "d"-                          , d_nuse  "a" $ d_use  "b" $ d_p "d"-                          ]-                  , [ "b? ( c/d )"-                    ]-                  )-                , -- pop '|| ( some thing )' depend-                  ( let any_part = d_any $ map d_p ["a", "b"] in-                    d_all [ d_use  "u" $ d_all [ any_part , d_p "z"]-                          , d_nuse "u" $         any_part-                          ]-                  , [ "|| ( c/a"-                    , "     c/b )"-                    , "u? ( c/z )"-                    ]-                  )-                , -- simplify slightly more complex counterguard-                  --   v? ( c/d )-                  --   u? ( !v? ( c/d ) )-                  -- to-                  --   v? ( c/d )-                  --   u? ( c/d )-                  ( d_all [               d_use  "v" $ d_p "d"-                          , d_use   "u" $ d_nuse "v" $ d_p "d"-                          ]-                  , [ "u? ( c/d )"-                    , "v? ( c/d )"-                    ]-                  )--                , --   ffi? ( c/d c/e )-                  --   !ffi ( !gmp ( c/d c/e ) )-                  --   gmp? ( c/d c/e )-                  -- to-                  --   ( c/d c/e )-                  ( let de = d_all [ d_p "d" , d_p "e" ]-                    in d_all [ d_use "ffi" de-                             , d_nuse "ffi" $ d_nuse "gmp" $ de-                             , d_use  "gmp" $ de-                             ]-                  , [ "c/d"-                    , "c/e"-                    ]-                  )--                {- TODO: another popular case-                , -- simplify even more complex counterguard-                  --   u? ( c/d )-                  --   !u? ( v? ( c/d ) )-                  -- to-                  --   u? ( c/d )-                  --   v? ( c/d )-                  ( d_all [               d_use "u" $ d_p "d"-                          , d_nuse  "u" $ d_use "v" $ d_p "d"-                          ]-                  , [ "u? ( c/d )"-                    , "v? ( c/d )"-                    ]-                  )-                 -}-                ]-    forM_ deps $ \(d, expected) ->-        let actual = P.dep2str 0 $ PN.normalize_depend d-        in assertEqual ("expecting matching result for " ++ show d)-                       (intercalate "\n" expected)-                       actual--main :: IO ()-main = RT.run_tests tests
+ tests/normalize_deps/Main.hs view
@@ -0,0 +1,250 @@+import Control.Monad (forM_)+import Data.List++import Test.HUnit++import qualified Portage.Dependency as P+import qualified Portage.Dependency.Normalize as PN+import qualified Portage.PackageId  as P+import qualified Portage.Use        as P+import qualified RunTests as RT++tests :: Test+tests = TestList [ TestLabel "normalize_in_use_and_top" test_normalize_in_use_and_top+                 ]++pnm :: P.PackageName+pnm = P.mkPackageName "dev-haskell" "mtl"+pnp :: P.PackageName+pnp = P.mkPackageName "dev-haskell" "parsec"+pnq :: P.PackageName+pnq = P.mkPackageName "dev-haskell" "quickcheck"++def_attr :: P.DAttr+def_attr = P.DAttr P.AnySlot []++p_v :: [Int] -> P.Version+p_v v = P.Version { P.versionNumber   = v+                  , P.versionChar     = Nothing+                  , P.versionSuffix   = []+                  , P.versionRevision = 0+                  }++d_all :: [P.Dependency] -> P.Dependency+d_all = P.DependAllOf+d_any :: [P.Dependency] -> P.Dependency+d_any = P.DependAnyOf++d_ge :: P.PackageName -> [Int] -> P.Dependency+d_ge pn v = P.DependAtom $ P.Atom pn+                   (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)+                   def_attr++d_p :: String -> P.Dependency+d_p pn = P.DependAtom $ P.Atom (P.mkPackageName "c" pn)+                (P.DRange P.ZeroB P.InfinityB)+                def_attr++d_use :: String -> P.Dependency -> P.Dependency+d_use u d = P.mkUseDependency (True, P.Use u) d++d_nuse :: String -> P.Dependency -> P.Dependency+d_nuse u d = P.mkUseDependency (False, P.Use u) d++test_normalize_in_use_and_top :: Test+test_normalize_in_use_and_top = TestCase $ do+    let deps  = [ ( d_all [ d_ge pnm [1,0]+                          , d_use "foo" (d_all [ d_ge pnm [1,0] -- duplicate+                                               , d_ge pnp [2,1]+                                               ])+                          ]+                  , [ ">=dev-haskell/mtl-1.0"+                    , "foo? ( >=dev-haskell/parsec-2.1 )"+                    ]+                  )+                , ( d_all [ d_ge pnm [1,0]+                          , d_use "foo" (d_any [ d_ge pnm [1,0] -- already satisfied+                                               , d_ge pnp [2,1]+                                               ])+                          ]+                  , [ ">=dev-haskell/mtl-1.0" ]+                  )+                , ( d_any [ d_all [ d_ge pnm [1,0] -- common subdep+                                  , d_ge pnq [1,2]+                                  ]+                          , d_all [ d_ge pnm [1,0]+                                  , d_ge pnp [3,1]+                                  ]+                          ]+                  , [ ">=dev-haskell/mtl-1.0"+                    , "|| ( >=dev-haskell/parsec-3.1"+                    , "     >=dev-haskell/quickcheck-1.2 )"+                    ]+                  )+                , ( d_all [ d_use "foo" $ d_use "bar" $ d_ge pnm [1,0]+                          , d_use "bar" $ d_use "foo" $ d_ge pnm [1,0]+                          ]+                  , [ "bar? ( foo? ( >=dev-haskell/mtl-1.0 ) )" ]+                  )+                , ( d_all [ d_use "foo" $ d_ge pnm [1,0]+                          , d_use "foo" $ d_ge pnp [3,1]+                          ]+                  , [ "foo? ( >=dev-haskell/mtl-1.0"+                    , "       >=dev-haskell/parsec-3.1 )"+                    ]+                  )+                , ( d_all [ d_use  "a" $ d_use "b" $ d_ge pnm [1,0]+                          , d_nuse "a" $ d_use "b" $ d_ge pnm [1,0]+                          ]+                  , [ "b? ( >=dev-haskell/mtl-1.0 )"+                    ]+                  )+                -- 'test?' is special+                , ( d_use "a" $ d_use "test" $ d_ge pnm [1,0]+                  , [ "test? ( a? ( >=dev-haskell/mtl-1.0 ) )"+                    ]+                  )+                , -- pop context for complementary depends, like+                  --   a? ( x y a ) !a? ( x y na )+                  -- leads to+                  --   x y a? ( a ) !a? ( na )+                  ( d_all [ d_use  "a" $ d_all $ map d_p [ "x", "y", "a" ]+                          , d_nuse "a" $ d_all $ map d_p [ "x", "y", "na" ]+                          ]+                  , [ "c/x"+                    , "c/y"+                    , "a? ( c/a )"+                    , "!a? ( c/na )"+                    ]+                  )+                , -- push stricter context into less strict+                  ( d_all [ d_ge pnm [2,0]+                          , d_use "a" $ d_ge pnm [1,0]+                          ]+                  ,+                    [ ">=dev-haskell/mtl-2.0" ]+                  )+                , -- propagate use guarded depend into deeply nested one+                  ( d_all [ d_use  "a"    $             d_all $ map d_p [ "x" ]+                          , d_use  "test" $ d_use "a" $ d_all $ map d_p [ "x", "t" ]+                          ]+                  , [ "test? ( a? ( c/t ) )"+                    , "a? ( c/x )"+                    ]+                  )+                , -- lift nested use context for complementary depends+                  --   a? ( b? ( y ) ) b? ( x )+                  ( d_all [ d_use  "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]+                          , d_nuse "a" $ d_use "b" $ d_p "x"+                          ]+                  , [ "a? ( b? ( c/y ) )"+                    , "b? ( c/x )"+                    ]+                  )+                , -- more advanced lift of complementary deps+                  -- a? ( b? ( x y ) )+                  -- !a? ( b? ( y z ) )+                  ( d_all [ d_use   "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]+                          , d_nuse  "a" $ d_use "b" $ d_all $ map d_p [ "y", "z" ]+                          ]+                  , [ "a? ( b? ( c/x ) )"+                    , "!a? ( b? ( c/z ) )"+                    , "b? ( c/y )"+                    ]+                  )+                , -- completely expanded set of USEs+                  -- a? ( b? ( c? ( x y z ) )+                  -- a? ( b? ( !c? ( x y ) )+                  -- a? ( !b? ( c? ( x z ) )+                  -- a? ( !b? ( !c? ( x ) )+                  --+                  -- !a? ( b? ( c? ( y z ) )+                  -- !a? ( b? ( !c? ( y ) )+                  -- !a? ( !b? ( c? ( z ) )+                  -- !a? ( !b? ( !c? ( ) )+                  ( d_all [ d_use   "a" $ d_use  "b" $ d_use  "c" $ d_all $ map d_p [ "x", "y", "z" ]+                          , d_use   "a" $ d_use  "b" $ d_nuse "c" $ d_all $ map d_p [ "x", "y" ]+                          , d_use   "a" $ d_nuse "b" $ d_use  "c" $ d_all $ map d_p [ "x", "z" ]+                          , d_use   "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ "x" ]+                          , d_nuse  "a" $ d_use  "b" $ d_use  "c" $ d_all $ map d_p [ "y", "z" ]+                          , d_nuse  "a" $ d_use  "b" $ d_nuse "c" $ d_all $ map d_p [ "y" ]+                          , d_nuse  "a" $ d_nuse "b" $ d_use  "c" $ d_all $ map d_p [ "z" ]+                          , d_nuse  "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ ]+                          ]+                  , [ "a? ( c/x )"+                    , "b? ( c/y )"+                    , "c? ( c/z )"+                    ]+                  )+                , -- pop simple common subdepend+                  -- a?  ( b? ( d ) )+                  -- !a? ( b? ( d ) )+                  ( d_all [ d_use   "a" $ d_use  "b" $ d_p "d"+                          , d_nuse  "a" $ d_use  "b" $ d_p "d"+                          ]+                  , [ "b? ( c/d )"+                    ]+                  )+                , -- pop '|| ( some thing )' depend+                  ( let any_part = d_any $ map d_p ["a", "b"] in+                    d_all [ d_use  "u" $ d_all [ any_part , d_p "z"]+                          , d_nuse "u" $         any_part+                          ]+                  , [ "|| ( c/a"+                    , "     c/b )"+                    , "u? ( c/z )"+                    ]+                  )+                , -- simplify slightly more complex counterguard+                  --   v? ( c/d )+                  --   u? ( !v? ( c/d ) )+                  -- to+                  --   v? ( c/d )+                  --   u? ( c/d )+                  ( d_all [               d_use  "v" $ d_p "d"+                          , d_use   "u" $ d_nuse "v" $ d_p "d"+                          ]+                  , [ "u? ( c/d )"+                    , "v? ( c/d )"+                    ]+                  )++                , --   ffi? ( c/d c/e )+                  --   !ffi ( !gmp ( c/d c/e ) )+                  --   gmp? ( c/d c/e )+                  -- to+                  --   ( c/d c/e )+                  ( let de = d_all [ d_p "d" , d_p "e" ]+                    in d_all [ d_use "ffi" de+                             , d_nuse "ffi" $ d_nuse "gmp" $ de+                             , d_use  "gmp" $ de+                             ]+                  , [ "c/d"+                    , "c/e"+                    ]+                  )++                {- TODO: another popular case+                , -- simplify even more complex counterguard+                  --   u? ( c/d )+                  --   !u? ( v? ( c/d ) )+                  -- to+                  --   u? ( c/d )+                  --   v? ( c/d )+                  ( d_all [               d_use "u" $ d_p "d"+                          , d_nuse  "u" $ d_use "v" $ d_p "d"+                          ]+                  , [ "u? ( c/d )"+                    , "v? ( c/d )"+                    ]+                  )+                 -}+                ]+    forM_ deps $ \(d, expected) ->+        let actual = P.dep2str 0 $ PN.normalize_depend d+        in assertEqual ("expecting matching result for " ++ show d)+                       (intercalate "\n" expected)+                       actual++main :: IO ()+main = RT.run_tests tests
− tests/print_deps.hs 
@@ -1,140 +0,0 @@-import Control.Monad (forM_)-import Data.List--import Test.HUnit--import qualified Portage.Dependency as P-import qualified Portage.Dependency.Normalize as PN-import qualified Portage.PackageId  as P-import qualified Portage.Use  as P-import qualified RunTests as RT--tests :: Test-tests = TestList [ TestLabel "print_empty" test_print_empty-                 , TestLabel "print_mixed" test_print_mixed-                 , TestLabel "print_denorm" test_print_denorm-                 ]--test_print_empty :: Test-test_print_empty = TestCase $ do-    let expect_empty = ""-        d_all = P.DependAllOf-        d_any = P.DependAnyOf-        d_use u dep = P.mkUseDependency (True, P.Use u) dep-        deps     = [ d_all []-                   , d_any []-                   , d_use "f" (d_all [])-                   , P.DependAllOf [d_any []]-                   , P.DependAnyOf [d_all []]-                   -- Deep Useless Use Tree :]-                   , d_use "f" $-                       d_use "g" $-                           d_all [d_any []-                                 , d_use "h" $-                                     d_all [ d_all []-                                           , d_any []-                                           ]-                                 , d_use "i" $-                                     d_all [ d_all []-                                           , d_any []-                                           ]-                                 ]-                   ]-    forM_ deps $ \d ->-        let actual_result = P.dep2str 0 $ PN.normalize_depend d-        in assertEqual ("expecting empty result for " ++ show d)-                       expect_empty-                       actual_result--test_print_mixed :: Test-test_print_mixed = TestCase $ do-    let pn = P.mkPackageName "dev-haskell" "mtl"-        def_attr = P.DAttr P.AnySlot []-        p_v v = P.Version { P.versionNumber   = v-                          , P.versionChar     = Nothing-                          , P.versionSuffix   = []-                          , P.versionRevision = 0-                          }-        d_all = P.DependAllOf-        d_any = P.DependAnyOf-        d_ge v = P.DependAtom $ P.Atom pn-                        (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)-                        def_attr-        d_lt v = P.DependAtom $ P.Atom pn-                        (P.DRange P.ZeroB (P.StrictUB $ p_v v))-                        def_attr-        deps  = [ -- from agda: "mtl ==2.0.* || >=2.1.1 && <2.2"-                  ( d_all [ d_any [ d_all [ d_ge [2, 0]-                                          , d_lt [2, 1]-                                          ]-                                  , d_all [ d_ge [2, 1, 1]-                                          , d_lt [2, 2]-                                          ]-                                  ]-                          ]-                  , [ "|| ( ( >=dev-haskell/mtl-2.0 <dev-haskell/mtl-2.1 )"-                    , "     ( >=dev-haskell/mtl-2.1.1 <dev-haskell/mtl-2.2 ) )"-                    ]-                  )-                -- remove duplicate entries-                , ( let d = d_all [d_ge [2, 0], d_lt [2, 2]]-                    in d_all [d, d]-                  , [ ">=dev-haskell/mtl-2.0 <dev-haskell/mtl-2.2" ]-                  )-                ]-    forM_ deps $ \(d, expected) ->-        let actual = P.dep2str 0 $ PN.normalize_depend d-        in assertEqual ("expecting empty result for " ++ show d)-                       (intercalate "\n" expected)-                       actual--test_print_denorm :: Test-test_print_denorm = TestCase $ do-    let pn = P.mkPackageName "dev-haskell" "mtl"-        def_attr = P.DAttr P.AnySlot []-        p_v v = P.Version { P.versionNumber   = v-                          , P.versionChar     = Nothing-                          , P.versionSuffix   = []-                          , P.versionRevision = 0-                          }-        d_all = P.DependAllOf-        d_any = P.DependAnyOf-        d_ge v = P.DependAtom $ P.Atom pn-                        (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)-                        def_attr-        d_lt v = P.DependAtom $ P.Atom pn-                        (P.DRange P.ZeroB (P.StrictUB $ p_v v))-                        def_attr-        deps  = [ -- from agda: "mtl ==2.0.* || >=2.1.1 && <2.2"-                  ( d_all [ d_any [ d_all [ d_ge [2, 0]-                                          , d_lt [2, 1]-                                          ]-                                  , d_all [ d_ge [2, 1, 1]-                                          , d_lt [2, 2]-                                          ]-                                  ]-                          ]-                  , [ "|| ( ( >=dev-haskell/mtl-2.0"-                    , "       <dev-haskell/mtl-2.1 )"-                    , "     ( >=dev-haskell/mtl-2.1.1"-                    , "       <dev-haskell/mtl-2.2 ) )"-                    ]-                  )-                -- remove duplicate entries-                , ( let d = d_all [d_ge [2, 0], d_lt [2, 2]]-                    in d_all [d, d]-                  , [ ">=dev-haskell/mtl-2.0"-                    , "<dev-haskell/mtl-2.2"-                    , ">=dev-haskell/mtl-2.0"-                    , "<dev-haskell/mtl-2.2"-                    ]-                  )-                ]-    forM_ deps $ \(d, expected) ->-        let actual = P.dep2str_noindent d-        in assertEqual ("expecting empty result for " ++ show d)-                       (intercalate "\n" expected)-                       actual--main :: IO ()-main = RT.run_tests tests
+ tests/print_deps/Main.hs view
@@ -0,0 +1,140 @@+import Control.Monad (forM_)+import Data.List++import Test.HUnit++import qualified Portage.Dependency as P+import qualified Portage.Dependency.Normalize as PN+import qualified Portage.PackageId  as P+import qualified Portage.Use  as P+import qualified RunTests as RT++tests :: Test+tests = TestList [ TestLabel "print_empty" test_print_empty+                 , TestLabel "print_mixed" test_print_mixed+                 , TestLabel "print_denorm" test_print_denorm+                 ]++test_print_empty :: Test+test_print_empty = TestCase $ do+    let expect_empty = ""+        d_all = P.DependAllOf+        d_any = P.DependAnyOf+        d_use u dep = P.mkUseDependency (True, P.Use u) dep+        deps     = [ d_all []+                   , d_any []+                   , d_use "f" (d_all [])+                   , P.DependAllOf [d_any []]+                   , P.DependAnyOf [d_all []]+                   -- Deep Useless Use Tree :]+                   , d_use "f" $+                       d_use "g" $+                           d_all [d_any []+                                 , d_use "h" $+                                     d_all [ d_all []+                                           , d_any []+                                           ]+                                 , d_use "i" $+                                     d_all [ d_all []+                                           , d_any []+                                           ]+                                 ]+                   ]+    forM_ deps $ \d ->+        let actual_result = P.dep2str 0 $ PN.normalize_depend d+        in assertEqual ("expecting empty result for " ++ show d)+                       expect_empty+                       actual_result++test_print_mixed :: Test+test_print_mixed = TestCase $ do+    let pn = P.mkPackageName "dev-haskell" "mtl"+        def_attr = P.DAttr P.AnySlot []+        p_v v = P.Version { P.versionNumber   = v+                          , P.versionChar     = Nothing+                          , P.versionSuffix   = []+                          , P.versionRevision = 0+                          }+        d_all = P.DependAllOf+        d_any = P.DependAnyOf+        d_ge v = P.DependAtom $ P.Atom pn+                        (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)+                        def_attr+        d_lt v = P.DependAtom $ P.Atom pn+                        (P.DRange P.ZeroB (P.StrictUB $ p_v v))+                        def_attr+        deps  = [ -- from agda: "mtl ==2.0.* || >=2.1.1 && <2.2"+                  ( d_all [ d_any [ d_all [ d_ge [2, 0]+                                          , d_lt [2, 1]+                                          ]+                                  , d_all [ d_ge [2, 1, 1]+                                          , d_lt [2, 2]+                                          ]+                                  ]+                          ]+                  , [ "|| ( ( >=dev-haskell/mtl-2.0 <dev-haskell/mtl-2.1 )"+                    , "     ( >=dev-haskell/mtl-2.1.1 <dev-haskell/mtl-2.2 ) )"+                    ]+                  )+                -- remove duplicate entries+                , ( let d = d_all [d_ge [2, 0], d_lt [2, 2]]+                    in d_all [d, d]+                  , [ ">=dev-haskell/mtl-2.0 <dev-haskell/mtl-2.2" ]+                  )+                ]+    forM_ deps $ \(d, expected) ->+        let actual = P.dep2str 0 $ PN.normalize_depend d+        in assertEqual ("expecting empty result for " ++ show d)+                       (intercalate "\n" expected)+                       actual++test_print_denorm :: Test+test_print_denorm = TestCase $ do+    let pn = P.mkPackageName "dev-haskell" "mtl"+        def_attr = P.DAttr P.AnySlot []+        p_v v = P.Version { P.versionNumber   = v+                          , P.versionChar     = Nothing+                          , P.versionSuffix   = []+                          , P.versionRevision = 0+                          }+        d_all = P.DependAllOf+        d_any = P.DependAnyOf+        d_ge v = P.DependAtom $ P.Atom pn+                        (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)+                        def_attr+        d_lt v = P.DependAtom $ P.Atom pn+                        (P.DRange P.ZeroB (P.StrictUB $ p_v v))+                        def_attr+        deps  = [ -- from agda: "mtl ==2.0.* || >=2.1.1 && <2.2"+                  ( d_all [ d_any [ d_all [ d_ge [2, 0]+                                          , d_lt [2, 1]+                                          ]+                                  , d_all [ d_ge [2, 1, 1]+                                          , d_lt [2, 2]+                                          ]+                                  ]+                          ]+                  , [ "|| ( ( >=dev-haskell/mtl-2.0"+                    , "       <dev-haskell/mtl-2.1 )"+                    , "     ( >=dev-haskell/mtl-2.1.1"+                    , "       <dev-haskell/mtl-2.2 ) )"+                    ]+                  )+                -- remove duplicate entries+                , ( let d = d_all [d_ge [2, 0], d_lt [2, 2]]+                    in d_all [d, d]+                  , [ ">=dev-haskell/mtl-2.0"+                    , "<dev-haskell/mtl-2.2"+                    , ">=dev-haskell/mtl-2.0"+                    , "<dev-haskell/mtl-2.2"+                    ]+                  )+                ]+    forM_ deps $ \(d, expected) ->+        let actual = P.dep2str_noindent d+        in assertEqual ("expecting empty result for " ++ show d)+                       (intercalate "\n" expected)+                       actual++main :: IO ()+main = RT.run_tests tests
− tests/resolveCat.hs 
@@ -1,29 +0,0 @@-import qualified Distribution.Package as Cabal--import qualified Portage.Overlay as Portage-import qualified Portage.Resolve as Portage-import qualified Portage.PackageId as Portage-import qualified Portage.Host as Portage--import Test.HUnit--import qualified RunTests as RT--tests :: Test-tests = TestList [ TestLabel "resolve cabal" (test_resolveCategory "dev-haskell" "cabal")-                 , TestLabel "resolve ghc" (test_resolveCategory "dev-lang" "ghc")-                 , TestLabel "resolve Cabal" (test_resolveCategory "dev-haskell" "Cabal")-                 , TestLabel "resolve DaRcS" (test_resolveCategory "dev-vcs" "DaRcS")-                 ]--test_resolveCategory :: String -> String -> Test-test_resolveCategory cat pkg = TestCase $ do-  portage_dir <- Portage.portage_dir `fmap` Portage.getInfo-  portage <- Portage.loadLazy portage_dir-  let cabal = Cabal.mkPackageName pkg-      hits = Portage.resolveFullPortageName portage cabal-      expected = Just (Portage.PackageName (Portage.Category cat) (Portage.normalizeCabalPackageName cabal))-  assertEqual ("expecting to find package " ++ pkg) expected hits--main :: IO ()-main = RT.run_tests tests
+ tests/resolveCat/Main.hs view
@@ -0,0 +1,27 @@+import qualified Distribution.Package as Cabal++import qualified Portage.Overlay as Portage+import qualified Portage.Resolve as Portage+import qualified Portage.PackageId as Portage+import qualified Portage.Host as Portage++import Test.HUnit++tests :: Test+tests = TestList [ TestLabel "resolve cabal" (test_resolveCategory "dev-haskell" "cabal")+                 , TestLabel "resolve ghc" (test_resolveCategory "dev-lang" "ghc")+                 , TestLabel "resolve Cabal" (test_resolveCategory "dev-haskell" "Cabal")+                 , TestLabel "resolve DaRcS" (test_resolveCategory "dev-vcs" "DaRcS")+                 ]++test_resolveCategory :: String -> String -> Test+test_resolveCategory cat pkg = TestCase $ do+  portage_dir <- Portage.portage_dir `fmap` Portage.getInfo+  portage <- Portage.loadLazy portage_dir+  let cabal = Cabal.mkPackageName pkg+      hits = Portage.resolveFullPortageName portage cabal+      expected = Just (Portage.PackageName (Portage.Category cat) (Portage.normalizeCabalPackageName cabal))+  assertEqual ("expecting to find package " ++ pkg) expected hits++main :: IO ()+main = runTestTTAndExit tests
+ tests/spec/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/spec/Merge/UtilsSpec.hs view
@@ -0,0 +1,141 @@+module Merge.UtilsSpec (spec) where++import           Test.Hspec+import           Test.Hspec.QuickCheck+import           QuickCheck.Instances++import           Control.Applicative (liftA2)+import qualified Data.Map.Strict as Map+import           Data.Maybe (catMaybes)+import qualified Data.List as L++import           Error+import           Merge.Utils+import           Portage.PackageId++import qualified Distribution.Package            as Cabal+import qualified Distribution.PackageDescription as Cabal+import           Distribution.Pretty (prettyShow)++spec :: Spec+spec = do+  describe "readPackageString" $ do+    prop "returns a Right tuple containing the parsed information or a Left ArgumentError" $ do+      let cat = Category "dev-haskell"+          name = Cabal.mkPackageName "package-name1"+        in \(ComplexVersion version) ->+             readPackageString (prettyShow cat ++ "/" ++ prettyShow name +++                                 if (versionNumber version) == []+                                 then ""+                                 else "-" ++ prettyShow version)+             `shouldBe`+             if (versionChar     version) /= Nothing ||+                (versionSuffix   version) /= []      ||+                (versionRevision version) /= 0+             then Left (ArgumentError ("Could not parse [category/]package[-version]: "+                                        ++ prettyShow cat ++ "/" +++                                        prettyShow name +++                                        if (versionNumber version) == []+                                        then ""+                                        else "-" ++ prettyShow version))+             else Right ( Just cat+                        , name+                        , if (versionNumber version) == []+                          then Nothing+                          else Just version+                        )++  describe "getPreviousPackageId" $ do+    context "when there is a previous version available" $ do+      it "returns the PackageId of the previous version" $ do+        let ebuildDir = [ "foo-bar2-3.0.0b_rc2-r1.ebuild"+                        , "foo-bar2-3.0.0b_rc2-r2.ebuild"+                        , "foo-bar2-3.0.1.ebuild"+                        , "metadata.xml"+                        , "Manifest"+                        , "files"+                        ]+            newPkgId = PackageId (PackageName (Category "dev-haskell")+                                  (Cabal.mkPackageName "foo-bar2"))+                       (Version [3,0,2] Nothing [] 0 )+          in getPreviousPackageId ebuildDir newPkgId `shouldBe`+             Just (PackageId (PackageName (Category "dev-haskell")+                              (Cabal.mkPackageName "foo-bar2"))+                   (Version [3,0,1] Nothing [] 0))+    context "if there is no previous version available" $ do+      it "returns Nothing" $ do+        let ebuildDir = [ "foo-bar2-3.0.0b_rc2-r1.ebuild"+                        , "foo-bar2-3.0.0b_rc2-r2.ebuild"+                        , "foo-bar2-3.0.1.ebuild"+                        , "metadata.xml"+                        , "Manifest"+                        , "files"+                        ]+            newPkgId = PackageId (PackageName (Category "dev-haskell")+                                   (Cabal.mkPackageName "foo-bar2"))+                       (Version [3,0,0] (Just 'a') [] 0 )+          in getPreviousPackageId ebuildDir newPkgId `shouldBe` Nothing++  describe "drop_prefix" $ do+    context "when an IUSE has a with/use prefix" $ do+      prop "drops the prefix" $ do+        let prefix   = ["with","use"]+            sep      = ["-","_"]+            prefixes = liftA2 (++) prefix sep+        \flag -> L.nub (drop_prefix <$> (liftA2 (++) prefixes [flag])) == [flag]+    context "when an IUSE has neither a with nor a use prefix" $ do+      prop "preserves the existing string" $ do+        \prefix flag -> L.nub (drop_prefix <$> (liftA2 (++) [prefix] ['-':flag])) ==+          if prefix == "with" || prefix == "use"+          then [flag]+          else [prefix ++ '-':flag]++  describe "squash_debug" $ do+    it "squashes debug-related flags under the debug global USE flag" $ do+      squash_debug "use-debug-foo" `shouldBe` "debug"+      squash_debug "debug-foo" `shouldBe` "debug"+      squash_debug "foo-debugger" `shouldBe` "debug"+    it "ignores debug-unrelated flags" $ do+      squash_debug "foo-bar" `shouldBe` "foo-bar"++  describe "convert_underscores" $ do+    it "converts underscores (_) into hyphens (-)" $ do+      convert_underscores "foo_bar" `shouldBe` "foo-bar"+    it "ignores mangling of separators other than underscores" $ do+      convert_underscores "foo-bar" `shouldBe` "foo-bar"+    it "ignores mangling of characters which are not separators" $ do+      convert_underscores "foobar" `shouldBe` "foobar"++  describe "mangle_iuse" $ do+    it "performs all IUSE mangling" $ do+      mangle_iuse "use_foo_bar" `shouldBe` "foo-bar"+      mangle_iuse "with-baz-quux" `shouldBe` "baz-quux"+      mangle_iuse "use_debugging-symbols" `shouldBe` "debug"+      mangle_iuse "foo-bar-baz_quux" `shouldBe` "foo-bar-baz-quux"++  describe "to_unstable" $ do+    prop "creates an unstable keyword from a stable keyword, or preserves a mask" $ do+      \a -> to_unstable a ==+        case a of+          '~':_ -> a+          '-':_ -> a+          _ -> '~':a++  describe "metaFlags" $ do+    prop "converts a [Cabal.PackageFlag] into a Map.Map String String" $ do+      \name desc -> metaFlags [(Cabal.emptyFlag (Cabal.mkFlagName name))+                                { Cabal.flagDescription = desc }] ==+                    Map.fromList [(mangle_iuse name,desc)]++  describe "dropIfUseExpand" $ do+    it "drops a USE flag if it is a USE_EXPAND, otherwise preserves it" $ do+      let use_expands = ["cpu_flags_x86","cpu_flags_arm"]+          flags       = Cabal.emptyFlag . Cabal.mkFlagName <$>+                        [ "cpu_flags_x86_sse4_2"+                        , "foo"+                        , "bar"+                        , "baz"+                        , "cpu_flags_arm_v8"+                        ]+      Cabal.unFlagName . Cabal.flagName <$> catMaybes (dropIfUseExpand use_expands <$> flags)+        `shouldBe` ["foo","bar","baz"]
+ tests/spec/Portage/CabalSpec.hs view
@@ -0,0 +1,69 @@+module Portage.CabalSpec (spec) where++import Test.Hspec++import qualified Distribution.SPDX as SPDX++import Portage.Cabal++spec :: Spec+spec = do+  describe "convertLicense" $ do+    it "converts AGPL_3_0_or_later into AGPL-3+" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.AGPL_3_0_or_later)+        `shouldBe`+        Right "AGPL-3+"+    it "converts AGPL_3_0_only into AGPL-3" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.AGPL_3_0_only)+        `shouldBe`+        Right "AGPL-3"+    it "converts GPL_2_0_or_later into GPL-2+" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_2_0_or_later)+        `shouldBe`+        Right "GPL-2+"+    it "converts GPL_2_0_only into GPL-2" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_2_0_only)+        `shouldBe`+        Right "GPL-2"+    it "converts GPL_3_0_or_later into GPL-3+" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_3_0_or_later)+        `shouldBe`+        Right "GPL-3+"+    it "converts GPL_3_0_only into GPL-3" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_3_0_only)+        `shouldBe`+        Right "GPL-3"+    -- Unfortunately, Cabal treats LGPL_2_0_only and LGPL_2_0_or_later as identical,+    -- just as it does with LGPL_2_1_only and LGPL_2_1_or_later. This means+    -- we cannot handle LGPL-2.0+ or LGPL-2,1+ without directly dealing with+    -- the SPDX licence, before it is converted into a Cabal-style licence.+    it "converts LGPL_2_0_or_later into LGPL-2, without a trailing plus (+)" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_2_0_or_later)+        `shouldBe`+        Right "LGPL-2"+    it "converts LGPL_2_0_only into LGPL-2" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_2_0_only)+        `shouldBe`+        Right "LGPL-2"+    it "converts LGPL_2_1_or_later into LGPL-2.1, without a trailing plus (+)" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_2_1_or_later)+        `shouldBe`+        Right "LGPL-2.1"+    it "converts LGPL_2_1_only into LGPL-2.1" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_2_1_only)+        `shouldBe`+        Right "LGPL-2.1"+      -- But these next two cases are correctly handled:+    it "converts LGPL_3_0_or_later into LGPL-3+" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_3_0_or_later)+        `shouldBe`+        Right "LGPL-3+"+    it "converts LGPL_3_0_only into LGPL-3" $ do+      convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.LGPL_3_0_only)+        `shouldBe`+        Right "LGPL-3"+    context "when a licence string is invalid" $ do+      it "converts the unknown licence into an error string" $ do+        convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1)+          `shouldBe`+          Left "license unknown to cabal. Please pick it manually."
+ tests/spec/Portage/Dependency/PrintSpec.hs view
@@ -0,0 +1,327 @@+module Portage.Dependency.PrintSpec (spec) where++import Test.Hspec++import Control.Monad (forM_)+import Data.List (intercalate)++import qualified Portage.PackageId            as P++import qualified Portage.Dependency.Builder   as P+import qualified Portage.Dependency.Print     as P+import qualified Portage.Dependency.Types     as P+import qualified Portage.Dependency.Normalize as P++import qualified Portage.Use                  as P++spec :: Spec+spec = do+  describe "dep2str" $ do+    it "converts an empty Dependency into an empty string" $ do+      let d_all = P.DependAllOf+          d_any = P.DependAnyOf+          d_use u dep = P.mkUseDependency (True, P.Use u) dep+          deps     = [ d_all []+                     , d_any []+                     , d_use "f" (d_all [])+                     , P.DependAllOf [d_any []]+                     , P.DependAnyOf [d_all []]+                     -- Deep Useless Use Tree :]+                     , d_use "f" $+                       d_use "g" $+                       d_all [d_any []+                             , d_use "h" $+                               d_all [ d_all []+                                     , d_any []+                                     ]+                             , d_use "i" $+                               d_all [ d_all []+                                     , d_any []+                                     ]+                             ]+                     ]+      forM_ deps $ \d ->+        P.dep2str 0 (P.normalize_depend d) `shouldBe` ""++    it "converts a Dependency into a normalized string" $ do+      let def_attr = P.DAttr P.AnySlot []+          p_v v = P.Version { P.versionNumber   = v+                            , P.versionChar     = Nothing+                            , P.versionSuffix   = []+                            , P.versionRevision = 0+                            }+          d_all = P.DependAllOf+          d_any = P.DependAnyOf+          d_ge pn v = P.DependAtom $ P.Atom pn+                   (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)+                   def_attr+          d_lt pn v = P.DependAtom $ P.Atom pn+                   (P.DRange P.ZeroB (P.StrictUB $ p_v v))+                   def_attr+          -- for the deps_norm test, formerly normalize_deps+          pnm = P.mkPackageName "dev-haskell" "mtl"+          pnp = P.mkPackageName "dev-haskell" "parsec"+          pnq = P.mkPackageName "dev-haskell" "quickcheck"+          d_p pn = P.DependAtom $ P.Atom (P.mkPackageName "c" pn)+                   (P.DRange P.ZeroB P.InfinityB)+                   def_attr+          d_use u d = P.mkUseDependency (True, P.Use u) d+          d_nuse u d = P.mkUseDependency (False, P.Use u) d++          deps  = [ -- from agda: "mtl ==2.0.* || >=2.1.1 && <2.2"+            ( d_all [ d_any [ d_all [ d_ge pnm [2, 0]+                                    , d_lt pnm [2, 1]+                                    ]+                            , d_all [ d_ge pnm [2, 1, 1]+                                    , d_lt pnm [2, 2]+                                    ]+                            ]+                    ]+            , [ "|| ( ( >=dev-haskell/mtl-2.0 <dev-haskell/mtl-2.1 )"+              , "     ( >=dev-haskell/mtl-2.1.1 <dev-haskell/mtl-2.2 ) )"+              ]+            )+              -- remove duplicate entries+            , ( let d = d_all [d_ge pnm [2, 0], d_lt pnm [2, 2]]+                in d_all [d, d]+              , [ ">=dev-haskell/mtl-2.0 <dev-haskell/mtl-2.2" ]+              )+            ]+      forM_ deps $ \(d,expected) ->+        P.dep2str 0 (P.normalize_depend d) `shouldBe` (intercalate "\n" expected)++      -- from normalize_deps.hs+      let deps_norm  = [ ( d_all [ d_ge pnm [1,0]+                                 , d_use "foo" (d_all [ d_ge pnm [1,0] -- duplicate+                                                      , d_ge pnp [2,1]+                                                      ])+                                 ]+                         , [ ">=dev-haskell/mtl-1.0"+                           , "foo? ( >=dev-haskell/parsec-2.1 )"+                           ]+                         )+                       , ( d_all [ d_ge pnm [1,0]+                                 , d_use "foo" (d_any [ d_ge pnm [1,0] -- already satisfied+                                                      , d_ge pnp [2,1]+                                                      ])+                                 ]+                         , [ ">=dev-haskell/mtl-1.0" ]+                         )+                       , ( d_any [ d_all [ d_ge pnm [1,0] -- common subdep+                                         , d_ge pnq [1,2]+                                         ]+                                 , d_all [ d_ge pnm [1,0]+                                         , d_ge pnp [3,1]+                                         ]+                                 ]+                         , [ ">=dev-haskell/mtl-1.0"+                           , "|| ( >=dev-haskell/parsec-3.1"+                           , "     >=dev-haskell/quickcheck-1.2 )"+                           ]+                         )+                       , ( d_all [ d_use "foo" $ d_use "bar" $ d_ge pnm [1,0]+                                 , d_use "bar" $ d_use "foo" $ d_ge pnm [1,0]+                                 ]+                         , [ "bar? ( foo? ( >=dev-haskell/mtl-1.0 ) )" ]+                         )+                       , ( d_all [ d_use "foo" $ d_ge pnm [1,0]+                                 , d_use "foo" $ d_ge pnp [3,1]+                                 ]+                         , [ "foo? ( >=dev-haskell/mtl-1.0"+                           , "       >=dev-haskell/parsec-3.1 )"+                           ]+                         )+                       , ( d_all [ d_use  "a" $ d_use "b" $ d_ge pnm [1,0]+                                 , d_nuse "a" $ d_use "b" $ d_ge pnm [1,0]+                                 ]+                         , [ "b? ( >=dev-haskell/mtl-1.0 )"+                           ]+                         )+                       -- 'test?' is special+                       , ( d_use "a" $ d_use "test" $ d_ge pnm [1,0]+                         , [ "test? ( a? ( >=dev-haskell/mtl-1.0 ) )"+                           ]+                         )+                       , -- pop context for complementary depends, like+                         --   a? ( x y a ) !a? ( x y na )+                         -- leads to+                         --   x y a? ( a ) !a? ( na )+                         ( d_all [ d_use  "a" $ d_all $ map d_p [ "x", "y", "a" ]+                                 , d_nuse "a" $ d_all $ map d_p [ "x", "y", "na" ]+                                 ]+                         , [ "c/x"+                           , "c/y"+                           , "a? ( c/a )"+                           , "!a? ( c/na )"+                           ]+                         )+                       , -- push stricter context into less strict+                         ( d_all [ d_ge pnm [2,0]+                                 , d_use "a" $ d_ge pnm [1,0]+                                 ]+                         ,+                           [ ">=dev-haskell/mtl-2.0" ]+                         )+                       , -- propagate use guarded depend into deeply nested one+                         ( d_all [ d_use  "a"    $             d_all $ map d_p [ "x" ]+                                 , d_use  "test" $ d_use "a" $ d_all $ map d_p [ "x", "t" ]+                                 ]+                         , [ "test? ( a? ( c/t ) )"+                           , "a? ( c/x )"+                           ]+                         )+                       , -- lift nested use context for complementary depends+                         --   a? ( b? ( y ) ) b? ( x )+                         ( d_all [ d_use  "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]+                                 , d_nuse "a" $ d_use "b" $ d_p "x"+                                 ]+                         , [ "a? ( b? ( c/y ) )"+                           , "b? ( c/x )"+                           ]+                         )+                       , -- more advanced lift of complementary deps+                         -- a? ( b? ( x y ) )+                         -- !a? ( b? ( y z ) )+                         ( d_all [ d_use   "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]+                                 , d_nuse  "a" $ d_use "b" $ d_all $ map d_p [ "y", "z" ]+                                 ]+                         , [ "a? ( b? ( c/x ) )"+                           , "!a? ( b? ( c/z ) )"+                           , "b? ( c/y )"+                           ]+                         )+                       , -- completely expanded set of USEs+                         -- a? ( b? ( c? ( x y z ) )+                         -- a? ( b? ( !c? ( x y ) )+                         -- a? ( !b? ( c? ( x z ) )+                         -- a? ( !b? ( !c? ( x ) )+                         --+                         -- !a? ( b? ( c? ( y z ) )+                         -- !a? ( b? ( !c? ( y ) )+                         -- !a? ( !b? ( c? ( z ) )+                         -- !a? ( !b? ( !c? ( ) )+                         ( d_all [ d_use   "a" $ d_use  "b" $ d_use  "c" $ d_all $ map d_p [ "x", "y", "z" ]+                                 , d_use   "a" $ d_use  "b" $ d_nuse "c" $ d_all $ map d_p [ "x", "y" ]+                                 , d_use   "a" $ d_nuse "b" $ d_use  "c" $ d_all $ map d_p [ "x", "z" ]+                                 , d_use   "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ "x" ]+                                 , d_nuse  "a" $ d_use  "b" $ d_use  "c" $ d_all $ map d_p [ "y", "z" ]+                                 , d_nuse  "a" $ d_use  "b" $ d_nuse "c" $ d_all $ map d_p [ "y" ]+                                 , d_nuse  "a" $ d_nuse "b" $ d_use  "c" $ d_all $ map d_p [ "z" ]+                                 , d_nuse  "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ ]+                                 ]+                         , [ "a? ( c/x )"+                           , "b? ( c/y )"+                           , "c? ( c/z )"+                           ]+                         )+                       , -- pop simple common subdepend+                         -- a?  ( b? ( d ) )+                         -- !a? ( b? ( d ) )+                         ( d_all [ d_use   "a" $ d_use  "b" $ d_p "d"+                                 , d_nuse  "a" $ d_use  "b" $ d_p "d"+                                 ]+                         , [ "b? ( c/d )"+                           ]+                         )+                       , -- pop '|| ( some thing )' depend+                         ( let any_part = d_any $ map d_p ["a", "b"] in+                             d_all [ d_use  "u" $ d_all [ any_part , d_p "z"]+                                   , d_nuse "u" $         any_part+                                   ]+                         , [ "|| ( c/a"+                           , "     c/b )"+                           , "u? ( c/z )"+                           ]+                         )+                       , -- simplify slightly more complex counterguard+                         --   v? ( c/d )+                         --   u? ( !v? ( c/d ) )+                         -- to+                         --   v? ( c/d )+                         --   u? ( c/d )+                         ( d_all [               d_use  "v" $ d_p "d"+                                 , d_use   "u" $ d_nuse "v" $ d_p "d"+                                 ]+                         , [ "u? ( c/d )"+                           , "v? ( c/d )"+                           ]+                         )+                       +                       , --   ffi? ( c/d c/e )+                         --   !ffi ( !gmp ( c/d c/e ) )+                         --   gmp? ( c/d c/e )+                         -- to+                         --   ( c/d c/e )+                         ( let de = d_all [ d_p "d" , d_p "e" ]+                           in d_all [ d_use "ffi" de+                                    , d_nuse "ffi" $ d_nuse "gmp" $ de+                                    , d_use  "gmp" $ de+                                    ]+                         , [ "c/d"+                           , "c/e"+                           ]+                         )+                       +                       {- TODO: another popular case+                       , -- simplify even more complex counterguard+                         --   u? ( c/d )+                         --   !u? ( v? ( c/d ) )+                         -- to+                         --   u? ( c/d )+                         --   v? ( c/d )+                       ( d_all [               d_use "u" $ d_p "d"+                               , d_nuse  "u" $ d_use "v" $ d_p "d"+                               ]+                       , [ "u? ( c/d )"+                       , "v? ( c/d )"+                       ]+                       )+                       -}+                       ]+      forM_ deps_norm $ \(d, expected) ->+        (P.dep2str 0 $ P.normalize_depend d) `shouldBe` (intercalate "\n" expected)++  describe "dep2str_noindent" $ do+    it "converts a Dependency into a string" $ do+      let pn = P.mkPackageName "dev-haskell" "mtl"+          def_attr = P.DAttr P.AnySlot []+          p_v v = P.Version { P.versionNumber   = v+                            , P.versionChar     = Nothing+                            , P.versionSuffix   = []+                            , P.versionRevision = 0+                            }+          d_all = P.DependAllOf+          d_any = P.DependAnyOf+          d_ge v = P.DependAtom $ P.Atom pn+                   (P.DRange (P.NonstrictLB $ p_v v) P.InfinityB)+                   def_attr+          d_lt v = P.DependAtom $ P.Atom pn+                   (P.DRange P.ZeroB (P.StrictUB $ p_v v))+                   def_attr+          deps  = [ -- from agda: "mtl ==2.0.* || >=2.1.1 && <2.2"+            ( d_all [ d_any [ d_all [ d_ge [2, 0]+                                    , d_lt [2, 1]+                                    ]+                            , d_all [ d_ge [2, 1, 1]+                                    , d_lt [2, 2]+                                    ]+                            ]+                    ]+            , [ "|| ( ( >=dev-haskell/mtl-2.0"+              , "       <dev-haskell/mtl-2.1 )"+              , "     ( >=dev-haskell/mtl-2.1.1"+              , "       <dev-haskell/mtl-2.2 ) )"+              ]+            )+              -- remove duplicate entries+            , ( let d = d_all [d_ge [2, 0], d_lt [2, 2]]+                in d_all [d, d]+              , [ ">=dev-haskell/mtl-2.0"+                , "<dev-haskell/mtl-2.2"+                , ">=dev-haskell/mtl-2.0"+                , "<dev-haskell/mtl-2.2"+                ]+              )+            ]+      forM_ deps $ \(d, expected) ->+        P.dep2str_noindent d `shouldBe` intercalate "\n" expected
+ tests/spec/Portage/EBuildSpec.hs view
@@ -0,0 +1,34 @@+module Portage.EBuildSpec (spec) where++import Test.Hspec++import Portage.EBuild++spec :: Spec+spec = do+  describe "sort_iuse" $ do+    it "sorts IUSE alphabetically despite pluses (+)" $ do+      sort_iuse ["+a","c","+b","d"] `shouldBe` ["+a","+b","c","d"]+  describe "drop_tdot" $ do+    it "drops trailing dots (.)" $ do+      drop_tdot "foo." `shouldBe` "foo"+      drop_tdot "foo..." `shouldBe` "foo"+      drop_tdot "foo" `shouldBe` "foo"+  describe "quote" $ do+    it "should correctly surround a string with special characters in quotes" $ do+      quote "Reading, writing and manipulating '.tar' archives." ""+        `shouldBe`+        "\"Reading, writing and manipulating \'.tar\' archives.\""+      quote "Extras for the \"contravariant\" package" ""+        `shouldBe`+        "\"Extras for the \\\"contravariant\\\" package\""+  describe "toHttps" $ do+    it "should not convert whitelisted http-only homepages into https homepages" $ do+      toHttps "http://leksah.org" `shouldBe` "http://leksah.org"+      toHttps "http://darcs.net/" `shouldBe` "http://darcs.net/"+      toHttps "http://khumba.net/" `shouldBe` "http://khumba.net/"+    it "should otherwise convert all homepages into https-aware homepages" $ do+      toHttps "http://pandoc.org" `shouldBe` "https://pandoc.org"+      toHttps "http://www.yesodweb.com/" `shouldBe` "https://www.yesodweb.com/"+    it "should ignore any conversions of homepages already marked as https-aware" $ do+      toHttps "https://github.com" `shouldBe` "https://github.com"
+ tests/spec/Portage/GHCCoreSpec.hs view
@@ -0,0 +1,23 @@+module Portage.GHCCoreSpec (spec) where++import Test.Hspec++import qualified Distribution.Version             as Cabal+import qualified Distribution.Package             as Cabal++import Portage.GHCCore++spec :: Spec+spec = do+  describe "cabalFromGHC" $ do+    it "returns the corresponding Cabal version for a valid GHC version" $ do+      cabalFromGHC [8,8,3] `shouldBe` Just (Cabal.mkVersion [3,0,1,0])+    it "returns Nothing for an invalid GHC version" $ do+      cabalFromGHC [9,9,9,9] `shouldBe` Nothing+  describe "packageIsCoreInAnyGHC" $ do+    it "returns True for the binary package" $ do+      packageIsCoreInAnyGHC (Cabal.mkPackageName "binary") `shouldBe` True+    it "returns False for the haskeline package (because it is upgradeable)" $ do+      packageIsCoreInAnyGHC (Cabal.mkPackageName "haskeline") `shouldBe` False+    it "returns False for the yesod package" $ do+      packageIsCoreInAnyGHC (Cabal.mkPackageName "yesod") `shouldBe` False
+ tests/spec/Portage/Metadata/RemoteIdSpec.hs view
@@ -0,0 +1,98 @@++module Portage.Metadata.RemoteIdSpec where++import Control.Monad+import Test.Hspec hiding (Example(..))++import Portage.Metadata.RemoteId++spec :: Spec+spec = do+    describe "runUriParser" $ do+        it "parses URI as RemoteId correctly" $ do+            forM_ contrivedExamples $ \(Example u p r) ->+                runUriParser p u `shouldBe` Right r+        it "parses real-world examples correctly" $ do+            forM_ realWorldExamples $ \(Example u p r) ->+                runUriParser p u `shouldBe` Right r+    describe "matchURI" $ do+        it "matches URI correctly" $ do+            forM_ contrivedExamples $ \(Example u _ r) ->+                matchURI u `shouldBe` Just r+        it "matches real-world examples correctly" $ do+            forM_ realWorldExamples $ \(Example u _ r) ->+                matchURI u `shouldBe` Just r++data Example = Example+    { exampleURI :: String+    , exampleParser :: URIParser+    , exampleRemoteId :: RemoteId+    }++contrivedExamples :: [Example]+contrivedExamples =+    [ Example+        "https://cran.r-project.org/web/packages/foo/"+        cranParser+        (RemoteIdCRAN "foo")+    , Example+        "https://ctan.org/pkg/foo"+        ctanParser+        (RemoteIdCTAN "foo")+    , Example+        "https://gitweb.gentoo.org/foo.git/"+        gentooParser+        (RemoteIdGentoo "foo")+    , Example+        "https://github.com/foo/bar"+        githubParser+        (RemoteIdGithub "foo" "bar")+    , Example+        "https://gitlab.com/foo/bar"+        gitlabParser+        (RemoteIdGitlab "foo" "bar")+    , Example+        "https://launchpad.net/foo"+        launchpadParser+        (RemoteIdLaunchpad "foo")+    , Example+        "https://osdn.net/projects/foo/"+        osdnParser+        (RemoteIdOSDN "foo")+    , Example+        "https://pecl.php.net/package/foo"+        peclParser+        (RemoteIdPECL "foo")+    , Example+        "https://pypi.org/project/foo/"+        pypiParser+        (RemoteIdPyPI "foo")+    , Example+        "https://rubygems.org/gems/foo"+        rubygemsParser+        (RemoteIdRubygems "foo")+    , Example+        "https://sourceforge.net/projects/foo/"+        sourceforgeParser+        (RemoteIdSourceforge "foo")+    , Example+        "https://vim.org/scripts/script.php?script_id=foo"+        vimParser+        (RemoteIdVim "foo")+    ]++realWorldExamples :: [Example]+realWorldExamples =+    [ Example+        "git://github.com/gentoo-haskell/hackport.git"+        githubParser+        (RemoteIdGithub "gentoo-haskell" "hackport")+    , Example+        "https://github.com/haskell/parsec"+        githubParser+        (RemoteIdGithub "haskell" "parsec")+    , Example+        "https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-toml"+        githubParser+        (RemoteIdGithub "dhall-lang" "dhall-haskell")+    ]
+ tests/spec/Portage/MetadataSpec.hs view
@@ -0,0 +1,127 @@+module Portage.MetadataSpec (spec) where++import Test.Hspec+import Test.Hspec.QuickCheck++import qualified Data.Text       as T+import qualified Data.Map.Strict as Map+import qualified Data.Set        as S++import qualified Portage.EBuild as E+import Portage.Metadata+import Portage.Metadata.RemoteId++spec :: Spec+spec = do+-- TODO: These tests are based off old behavior and should be remade at some point+--   describe "parseMetadataXML" $ do+--     it "returns Nothing from an empty Text" $ do+--       parseMetadataXML T.empty `shouldBe` Nothing+--     it "equals makeMinimalMetadata with no USE flags" $ do+--       parseMetadataXML (printMetadata Map.empty) `shouldBe` Just minimalMetadata+--     it "equals makeMinimalMetadata plus the supplied USE flags" $ do+--       let flags = Map.singleton "name" "description"+--       parseMetadataXML (makeDefaultMetadata flags) `shouldBe` Just (makeMinimalMetadata { metadataUseFlags = flags })++  describe "stripGlobalUseFlags" $ do+    it "should remove specified global USE flags from the metadata.xml" $ do+      stripGlobalUseFlags (Map.singleton "debug" "description") `shouldBe` Map.empty+      stripGlobalUseFlags (Map.singleton "examples" "description") `shouldBe` Map.empty+      stripGlobalUseFlags (Map.singleton "static" "description") `shouldBe` Map.empty+    prop "should ignore USE flags that are not specified as global" $ do+      \name description -> stripGlobalUseFlags (Map.singleton name description) ==+                           if name `elem` ["debug","examples","static"]+                           then Map.empty+                           else Map.singleton name description++  describe "prettyPrintFlags" $ do+    it "correctly handles special XML characters contained in strings" $ do+      let name = "foo"+          desc = "bar < 1.1.0"+        in prettyPrintFlags (Map.singleton name desc) `shouldBe`+        [ "\t<use>"+        , "\t\t<flag name=\"" ++ name ++ "\">"+            ++ "bar &lt; 1.1.0" ++ "</flag>"+        , "\t</use>"+        ]+    it "correctly formats a single USE flag name with its description" $ do+      let name = "foo"+          description = "bar"+        in prettyPrintFlags (Map.singleton name description) `shouldBe`+                          [ "\t<use>"+                          , "\t\t<flag name=\"" ++ name+                              ++ "\">" ++ (unwords . lines $ description)+                              ++ "</flag>"+                          , "\t</use>"+                          ]+    it "correctly formats multiple USE flag names with their descriptions" $ do+      let f1 = "flag1"+          f2 = "flag2"+          d1 = "foo_desc"+          d2 = "bar_desc"+        in prettyPrintFlags (Map.fromList [(f1,d1),(f2,d2)]) `shouldBe`+          [ "\t<use>"+          , "\t\t<flag name=\"" ++ f1+              ++ "\">" ++ (unwords . lines $ d1)+              ++ "</flag>"+          , "\t\t<flag name=\"" ++ f2+              ++ "\">" ++ (unwords . lines $ d2)+              ++ "</flag>"+          , "\t</use>"+          ]++  describe "printMetadata" $ do+    context "when writing a minimal metadata.xml with no USE flags" $ do+      it "should have a certain format" $+        let correctMetadata = T.pack $ unlines+              [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+              , "<!DOCTYPE pkgmetadata SYSTEM \"https://www.gentoo.org/dtd/metadata.dtd\">"+              , "<pkgmetadata>"+              , "\t<maintainer type=\"project\">"+              , "\t\t<email>haskell@gentoo.org</email>"+              , "\t\t<name>Gentoo Haskell</name>"+              , "\t</maintainer>"+              , "\t<upstream>"+              , "\t\t<remote-id type=\"hackage\">FooBar</remote-id>"+              , "\t</upstream>"+              , "</pkgmetadata>"+              ]+        in printMetadata (minimalMetadata True E.ebuildTemplate) `shouldBe` correctMetadata+    context "when writing a minimal metadata.xml with no USE flags and --no-hackage-remote-id" $ do+      it "should have a certain format" $+        let correctMetadata = T.pack $ unlines+              [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+              , "<!DOCTYPE pkgmetadata SYSTEM \"https://www.gentoo.org/dtd/metadata.dtd\">"+              , "<pkgmetadata>"+              , "\t<maintainer type=\"project\">"+              , "\t\t<email>haskell@gentoo.org</email>"+              , "\t\t<name>Gentoo Haskell</name>"+              , "\t</maintainer>"+              , "</pkgmetadata>"+              ]+        in printMetadata (minimalMetadata False E.ebuildTemplate) `shouldBe` correctMetadata+    context "when writing a metadata.xml with USE flags and a GitHub remote-id" $ do+      it "should have a certain format, including the <use> element" $ do+        let meta = minimalMetadata True E.ebuildTemplate <> mempty+              { metadataUseFlags = Map.fromList [("flag1","desc1"),("flag2","desc2")]+              , metadataRemoteIds = S.singleton $ RemoteIdGithub "foo" "bar"+              }+            correctMetadata = T.pack $ unlines+              [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+              , "<!DOCTYPE pkgmetadata SYSTEM \"https://www.gentoo.org/dtd/metadata.dtd\">"+              , "<pkgmetadata>"+              , "\t<maintainer type=\"project\">"+              , "\t\t<email>haskell@gentoo.org</email>"+              , "\t\t<name>Gentoo Haskell</name>"+              , "\t</maintainer>"+              , "\t<use>"+              , "\t\t<flag name=\"flag1\">desc1</flag>"+              , "\t\t<flag name=\"flag2\">desc2</flag>"+              , "\t</use>"+              , "\t<upstream>"+              , "\t\t<remote-id type=\"hackage\">FooBar</remote-id>"+              , "\t\t<remote-id type=\"github\">foo/bar</remote-id>"+              , "\t</upstream>"+              , "</pkgmetadata>"+              ]+          in printMetadata meta `shouldBe` correctMetadata
+ tests/spec/Portage/PackageIdSpec.hs view
@@ -0,0 +1,69 @@+module Portage.PackageIdSpec (spec) where++import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck+import           QuickCheck.Instances++import qualified Data.Char as Char+import qualified Distribution.Package as Cabal+import           Distribution.Pretty (prettyShow)++import           Portage.PackageId++spec :: Spec+spec = do+  describe "packageIdToFilePath" $ do+    prop "transforms a PackageId into a FilePath" $ do+      let cat = Category "dev-haskell"+          name = Cabal.mkPackageName "foo-bar2+"+        in \(ComplexVersion version) ->+             packageIdToFilePath (PackageId (PackageName cat name) version)+             `shouldBe`+             "dev-haskell/" ++ prettyShow name ++ "/" ++ prettyShow name ++ "-" +++             prettyShow version ++ ".ebuild"++  describe "filePathToPackageId" $ do+    prop "returns a Just PackageId from a valid FilePath" $ do+      let cat = Category "dev-haskell"+          name = Cabal.mkPackageName "foo-bar2+"+        in \(ComplexVersion version) ->+             filePathToPackageId cat+             (prettyShow name ++ "-" ++ prettyShow version)+             `shouldBe`+             Just (PackageId (PackageName cat name) version)+    prop "returns Nothing on a malformed FilePath" $ do+      let cat = Category "dev-haskell"+          name = Cabal.mkPackageName "foo-bar-2+"+        in \(ComplexVersion version) ->+             filePathToPackageId cat (prettyShow name ++ "-" ++ prettyShow version)+             `shouldBe`+             Nothing++  describe "normalizeCabalPackageName" $ do+    prop "converts a Cabal.PackageName into lowercase" $ do+      \(PrintableString s) -> normalizeCabalPackageName (Cabal.mkPackageName s)+                            `shouldBe` Cabal.mkPackageName (Char.toLower <$> s)++  describe "parseFriendlyPackage" $ do+    prop "parses a package string as [category/]name[-version]" $ do+      let cat = Category "dev-haskell"+          name = Cabal.mkPackageName "package-name1+"+        in \(ComplexVersion version) ->+             parseFriendlyPackage (prettyShow cat ++ "/" ++ prettyShow name+                                    ++ "-" ++ prettyShow version)+             `shouldBe`+             Right (Just cat, name, Just version)+    prop "returns an error string if parsing a malformed package string" $ do+      let cat = Category "dev-haskell"+          name = Cabal.mkPackageName "package-name-1+"+        in \(ComplexVersion version) ->+             parseFriendlyPackage (prettyShow cat ++ "/" ++ prettyShow name+                                   ++ "-" ++ prettyShow version)+             `shouldNotBe`+             Right (Just cat, name, Just version)++  describe "cabal_pn_to_PN" $ do+    prop "pretty-prints a Cabal PackageName as a lowercase String" $ do+      \(PrintableString s) -> cabal_pn_to_PN (Cabal.mkPackageName s)+                            `shouldBe` Char.toLower <$> s
+ tests/spec/Portage/VersionSpec.hs view
@@ -0,0 +1,27 @@+module Portage.VersionSpec (spec) where++import           Test.Hspec+import           Test.Hspec.QuickCheck+import           QuickCheck.Instances++import qualified Distribution.Version as Cabal++import           Portage.Version++spec :: Spec+spec = do+  describe "is_live" $ do+    prop "determines if a Portage version is live" $ do+      \(ComplexVersion v) -> is_live v `shouldBe`+        if last (versionNumber v) >= 9999+        then True else False+        +  describe "fromCabalVersion" $ do+    prop "converts from a Cabal version to a Portage version" $ do+      \verNum -> fromCabalVersion (Cabal.mkVersion verNum) == Version verNum Nothing [] 0+      +  describe "toCabalVersion" $ do+    prop "converts from a Portage version to a Cabal version" $ do+      \(ComplexVersion v) -> toCabalVersion v `shouldBe`+        if versionChar v == Nothing && versionSuffix v == []+        then Just (Cabal.mkVersion (versionNumber v)) else Nothing
+ tests/spec/QuickCheck/Instances.hs view
@@ -0,0 +1,44 @@+module QuickCheck.Instances (ComplexVersion(..)) where++import Test.QuickCheck++import Portage.Version (Suffix(..), Version(..))++--------------------------------------------------------------------------------+-- Types+--------------------------------------------------------------------------------+-- | Wrapper for 'Suffix', intended for use in an 'Arbitrary' instance+-- to return a single, valid 'Suffix'.+newtype ValidSuffix = ValidSuffix { getSuffix :: Suffix }+  deriving (Eq,Ord,Show)++-- | Wrapper For 'Version', intended for use in an 'Arbitrary' instance+-- where we want to generate the most complex 'Version' possible.+newtype ComplexVersion = ComplexVersion { getVersion :: Version }+  deriving (Eq,Ord,Show)++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------+-- | Return a single, valid 'ValidSuffix'.+instance Arbitrary ValidSuffix where+  arbitrary = oneof [ ValidSuffix . Alpha . getNonNegative <$> arbitrary+                    , ValidSuffix . Beta  . getNonNegative <$> arbitrary+                    , ValidSuffix . Pre   . getNonNegative <$> arbitrary+                    , ValidSuffix . RC    . getNonNegative <$> arbitrary+                    , ValidSuffix . P     . getNonNegative <$> arbitrary+                    ]+  +-- | Return a valid 'ComplexVersion' with a non-empty 'versionNumber',+-- an optional 'versionChar' if valid, a ['Suffix'] which may be empty,+-- and a 'NonNegative' 'versionRevision' which may be zero.+--+-- This is used to generate a 'Version' of high complexity to+-- stress-test our parsers for a range of valid inputs.+instance Arbitrary ComplexVersion where+  arbitrary = do+    v <- listOf1 $ getNonNegative <$> arbitrary+    c <- oneof $ [Just <$> choose ('a','z'), elements [Nothing]]+    s <- listOf $ getSuffix <$> arbitrary+    (NonNegative r) <- arbitrary+    return $ ComplexVersion $ Version v (if length v == 1 then Nothing else c) s r
+ tests/spec/RunTests.hs view
@@ -0,0 +1,15 @@+module RunTests+    (run_tests) where++import Control.Monad (when)++import System.Exit (exitFailure)+import Test.HUnit++something_broke :: Counts -> Bool+something_broke stats = errors stats + failures stats > 0++run_tests :: Test -> IO ()+run_tests tests =+    do stats <- runTestTT tests+       when (something_broke stats) exitFailure