{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Targets
-- Copyright   :  (c) Duncan Coutts 2011
-- License     :  BSD-like
--
-- Maintainer  :  duncan@community.haskell.org
--
-- Handling for user-specified targets
-----------------------------------------------------------------------------
module Distribution.Client.Targets (
  -- * User targets
  UserTarget(..),
  readUserTargets,

  -- * Package specifiers
  PackageSpecifier(..),
  pkgSpecifierTarget,
  pkgSpecifierConstraints,

  -- * Resolving user targets to package specifiers
  resolveUserTargets,

  -- ** Detailed interface
  UserTargetProblem(..),
  readUserTarget,
  reportUserTargetProblems,
  expandUserTarget,

  PackageTarget(..),
  fetchPackageTarget,
  readPackageTarget,

  PackageTargetProblem(..),
  reportPackageTargetProblems,

  disambiguatePackageTargets,
  disambiguatePackageName,

  -- * User constraints
  UserConstraint(..),
  userConstraintPackageName,
  readUserConstraint,
  userToPackageConstraint

  ) where

import Distribution.Package
         ( Package(..), PackageName(..)
         , PackageIdentifier(..), packageName, packageVersion
         , Dependency(Dependency) )
import Distribution.Client.Types
         ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) )
import Distribution.Client.Dependency.Types
         ( PackageConstraint(..), ConstraintSource(..)
         , LabeledPackageConstraint(..) )

import qualified Distribution.Client.World as World
import Distribution.Client.PackageIndex (PackageIndex)
import qualified Distribution.Client.PackageIndex as PackageIndex
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils ( HttpTransport(..) )
import Distribution.Client.Utils ( tryFindPackageDesc )

import Distribution.PackageDescription
         ( GenericPackageDescription, FlagName(..), FlagAssignment )
import Distribution.PackageDescription.Parse
         ( readPackageDescription, parsePackageDescription, ParseResult(..) )
import Distribution.Version
         ( Version(Version), thisVersion, anyVersion, isAnyVersion
         , VersionRange )
import Distribution.Text
         ( Text(..), display )
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.Utils
         ( die, warn, intercalate, fromUTF8, lowercase, ignoreBOM )

import Data.List
         ( find, nub )
import Data.Maybe
         ( listToMaybe )
import Data.Either
         ( partitionEithers )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
         ( Monoid(..) )
#endif
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import qualified Distribution.Client.GZipUtils as GZipUtils
import Control.Monad (liftM)
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP
         ( (+++), (<++) )
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint
         ( (<>), (<+>) )
import Data.Char
         ( isSpace, isAlphaNum )
import System.FilePath
         ( takeExtension, dropExtension, takeDirectory, splitPath )
import System.Directory
         ( doesFileExist, doesDirectoryExist )
import Network.URI
         ( URI(..), URIAuth(..), parseAbsoluteURI )

-- ------------------------------------------------------------
-- * User targets
-- ------------------------------------------------------------

-- | Various ways that a user may specify a package or package collection.
--
data UserTarget =

     -- | A partially specified package, identified by name and possibly with
     -- an exact version or a version constraint.
     --
     -- > cabal install foo
     -- > cabal install foo-1.0
     -- > cabal install 'foo < 2'
     --
     UserTargetNamed Dependency

     -- | A special virtual package that refers to the collection of packages
     -- recorded in the world file that the user specifically installed.
     --
     -- > cabal install world
     --
   | UserTargetWorld

     -- | A specific package that is unpacked in a local directory, often the
     -- current directory.
     --
     -- > cabal install .
     -- > cabal install ../lib/other
     --
     -- * Note: in future, if multiple @.cabal@ files are allowed in a single
     -- directory then this will refer to the collection of packages.
     --
   | UserTargetLocalDir FilePath

     -- | A specific local unpacked package, identified by its @.cabal@ file.
     --
     -- > cabal install foo.cabal
     -- > cabal install ../lib/other/bar.cabal
     --
   | UserTargetLocalCabalFile FilePath

     -- | A specific package that is available as a local tarball file
     --
     -- > cabal install dist/foo-1.0.tar.gz
     -- > cabal install ../build/baz-1.0.tar.gz
     --
   | UserTargetLocalTarball FilePath

     -- | A specific package that is available as a remote tarball file
     --
     -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz
     --
   | UserTargetRemoteTarball URI
  deriving (Show,Eq)


-- ------------------------------------------------------------
-- * Package specifier
-- ------------------------------------------------------------

-- | A fully or partially resolved reference to a package.
--
data PackageSpecifier pkg =

     -- | A partially specified reference to a package (either source or
     -- installed). It is specified by package name and optionally some
     -- additional constraints. Use a dependency resolver to pick a specific
     -- package satisfying these constraints.
     --
     NamedPackage PackageName [PackageConstraint]

     -- | A fully specified source package.
     --
   | SpecificSourcePackage pkg
  deriving Show

pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget (NamedPackage name _)       = name
pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg

pkgSpecifierConstraints :: Package pkg
                        => PackageSpecifier pkg -> [LabeledPackageConstraint]
pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints
  where
    toLpc pc = LabeledPackageConstraint pc ConstraintSourceUserTarget
pkgSpecifierConstraints (SpecificSourcePackage pkg)  =
    [LabeledPackageConstraint pc ConstraintSourceUserTarget]
  where
    pc = PackageConstraintVersion (packageName pkg)
         (thisVersion (packageVersion pkg))

-- ------------------------------------------------------------
-- * Parsing and checking user targets
-- ------------------------------------------------------------

readUserTargets :: Verbosity -> [String] -> IO [UserTarget]
readUserTargets _verbosity targetStrs = do
    (problems, targets) <- liftM partitionEithers
                                 (mapM readUserTarget targetStrs)
    reportUserTargetProblems problems
    return targets


data UserTargetProblem
   = UserTargetUnexpectedFile      String
   | UserTargetNonexistantFile     String
   | UserTargetUnexpectedUriScheme String
   | UserTargetUnrecognisedUri     String
   | UserTargetUnrecognised        String
   | UserTargetBadWorldPkg
  deriving Show

readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)
readUserTarget targetstr =
    case testNamedTargets targetstr of
      Just (Dependency (PackageName "world") verrange)
        | verrange == anyVersion -> return (Right UserTargetWorld)
        | otherwise              -> return (Left  UserTargetBadWorldPkg)
      Just dep                   -> return (Right (UserTargetNamed dep))
      Nothing -> do
        fileTarget <- testFileTargets targetstr
        case fileTarget of
          Just target -> return target
          Nothing     ->
            case testUriTargets targetstr of
              Just target -> return target
              Nothing     -> return (Left (UserTargetUnrecognised targetstr))
  where
    testNamedTargets = readPToMaybe parseDependencyOrPackageId

    testFileTargets filename = do
      isDir  <- doesDirectoryExist filename
      isFile <- doesFileExist filename
      parentDirExists <- case takeDirectory filename of
                           []  -> return False
                           dir -> doesDirectoryExist dir
      let result
            | isDir
            = Just (Right (UserTargetLocalDir filename))

            | isFile && extensionIsTarGz filename
            = Just (Right (UserTargetLocalTarball filename))

            | isFile && takeExtension filename == ".cabal"
            = Just (Right (UserTargetLocalCabalFile filename))

            | isFile
            = Just (Left (UserTargetUnexpectedFile filename))

            | parentDirExists
            = Just (Left (UserTargetNonexistantFile filename))

            | otherwise
            = Nothing
      return result

    testUriTargets str =
      case parseAbsoluteURI str of
        Just uri@URI {
            uriScheme    = scheme,
            uriAuthority = Just URIAuth { uriRegName = host }
          }
          | scheme /= "http:" && scheme /= "https:" ->
            Just (Left (UserTargetUnexpectedUriScheme targetstr))

          | null host ->
            Just (Left (UserTargetUnrecognisedUri targetstr))

          | otherwise ->
            Just (Right (UserTargetRemoteTarball uri))
        _ -> Nothing

    extensionIsTarGz f = takeExtension f                 == ".gz"
                      && takeExtension (dropExtension f) == ".tar"

    parseDependencyOrPackageId :: Parse.ReadP r Dependency
    parseDependencyOrPackageId = parse
                             +++ liftM pkgidToDependency parse
      where
        pkgidToDependency :: PackageIdentifier -> Dependency
        pkgidToDependency p = case packageVersion p of
          Version [] _ -> Dependency (packageName p) anyVersion
          version      -> Dependency (packageName p) (thisVersion version)

readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
                                     , all isSpace s ]


reportUserTargetProblems :: [UserTargetProblem] -> IO ()
reportUserTargetProblems problems = do
    case [ target | UserTargetUnrecognised target <- problems ] of
      []     -> return ()
      target -> die
              $ unlines
                  [ "Unrecognised target '" ++ name ++ "'."
                  | name <- target ]
             ++ "Targets can be:\n"
             ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"
             ++ " - the special 'world' target\n"
             ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"
             ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"

    case [ () | UserTargetBadWorldPkg <- problems ] of
      [] -> return ()
      _  -> die "The special 'world' target does not take any version."

    case [ target | UserTargetNonexistantFile target <- problems ] of
      []     -> return ()
      target -> die
              $ unlines
                  [ "The file does not exist '" ++ name ++ "'."
                  | name <- target ]

    case [ target | UserTargetUnexpectedFile target <- problems ] of
      []     -> return ()
      target -> die
              $ unlines
                  [ "Unrecognised file target '" ++ name ++ "'."
                  | name <- target ]
             ++ "File targets can be either package tarballs 'pkgname.tar.gz' "
             ++ "or cabal files 'pkgname.cabal'."

    case [ target | UserTargetUnexpectedUriScheme target <- problems ] of
      []     -> return ()
      target -> die
              $ unlines
                  [ "URL target not supported '" ++ name ++ "'."
                  | name <- target ]
             ++ "Only 'http://' and 'https://' URLs are supported."

    case [ target | UserTargetUnrecognisedUri target <- problems ] of
      []     -> return ()
      target -> die
              $ unlines
                  [ "Unrecognise URL target '" ++ name ++ "'."
                  | name <- target ]


-- ------------------------------------------------------------
-- * Resolving user targets to package specifiers
-- ------------------------------------------------------------

-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to. They can either be specific packages (local dirs, tarballs etc)
-- or they can be named packages (with or without version info).
--
resolveUserTargets :: Package pkg
                   => Verbosity
                   -> HttpTransport
                   -> FilePath
                   -> PackageIndex pkg
                   -> [UserTarget]
                   -> IO [PackageSpecifier SourcePackage]
resolveUserTargets verbosity transport worldFile available userTargets = do

    -- given the user targets, get a list of fully or partially resolved
    -- package references
    packageTargets <- mapM (readPackageTarget verbosity)
                  =<< mapM (fetchPackageTarget transport verbosity) . concat
                  =<< mapM (expandUserTarget worldFile) userTargets

    -- users are allowed to give package names case-insensitively, so we must
    -- disambiguate named package references
    let (problems, packageSpecifiers) =
           disambiguatePackageTargets available availableExtra packageTargets

        -- use any extra specific available packages to help us disambiguate
        availableExtra = [ packageName pkg
                         | PackageTargetLocation pkg <- packageTargets ]

    reportPackageTargetProblems verbosity problems

    return packageSpecifiers


-- ------------------------------------------------------------
-- * Package targets
-- ------------------------------------------------------------

-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.
-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.
--
data PackageTarget pkg =
     PackageTargetNamed      PackageName [PackageConstraint] UserTarget

     -- | A package identified by name, but case insensitively, so it needs
     -- to be resolved to the right case-sensitive name.
   | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget
   | PackageTargetLocation pkg
  deriving Show


-- ------------------------------------------------------------
-- * Converting user targets to package targets
-- ------------------------------------------------------------

-- | Given a user-specified target, expand it to a bunch of package targets
-- (each of which refers to only one package).
--
expandUserTarget :: FilePath
                 -> UserTarget
                 -> IO [PackageTarget (PackageLocation ())]
expandUserTarget worldFile userTarget = case userTarget of

    UserTargetNamed (Dependency name vrange) ->
      let constraints = [ PackageConstraintVersion name vrange
                        | not (isAnyVersion vrange) ]
      in  return [PackageTargetNamedFuzzy name constraints userTarget]

    UserTargetWorld -> do
      worldPkgs <- World.getContents worldFile
      --TODO: should we warn if there are no world targets?
      return [ PackageTargetNamed name constraints userTarget
             | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs
             , let constraints = [ PackageConstraintVersion name vrange
                                 | not (isAnyVersion vrange) ]
                              ++ [ PackageConstraintFlags name flags
                                 | not (null flags) ] ]

    UserTargetLocalDir dir ->
      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]

    UserTargetLocalCabalFile file -> do
      let dir = takeDirectory file
      _   <- tryFindPackageDesc dir (localPackageError dir) -- just as a check
      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]

    UserTargetLocalTarball tarballFile ->
      return [ PackageTargetLocation (LocalTarballPackage tarballFile) ]

    UserTargetRemoteTarball tarballURL ->
      return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]

localPackageError :: FilePath -> String
localPackageError dir =
    "Error reading local package.\nCouldn't find .cabal file in: " ++ dir

-- ------------------------------------------------------------
-- * Fetching and reading package targets
-- ------------------------------------------------------------


-- | Fetch any remote targets so that they can be read.
--
fetchPackageTarget :: HttpTransport
                   -> Verbosity
                   -> PackageTarget (PackageLocation ())
                   -> IO (PackageTarget (PackageLocation FilePath))
fetchPackageTarget transport verbosity target = case target of
    PackageTargetNamed      n cs ut -> return (PackageTargetNamed      n cs ut)
    PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut)
    PackageTargetLocation location  -> do
      location' <- fetchPackage transport verbosity (fmap (const Nothing) location)
      return (PackageTargetLocation location')


-- | Given a package target that has been fetched, read the .cabal file.
--
-- This only affects targets given by location, named targets are unaffected.
--
readPackageTarget :: Verbosity
                  -> PackageTarget (PackageLocation FilePath)
                  -> IO (PackageTarget SourcePackage)
readPackageTarget verbosity target = case target of

    PackageTargetNamed pkgname constraints userTarget ->
      return (PackageTargetNamed pkgname constraints userTarget)

    PackageTargetNamedFuzzy pkgname constraints userTarget ->
      return (PackageTargetNamedFuzzy pkgname constraints userTarget)

    PackageTargetLocation location -> case location of

      LocalUnpackedPackage dir -> do
        pkg <- tryFindPackageDesc dir (localPackageError dir) >>=
                 readPackageDescription verbosity
        return $ PackageTargetLocation $
                   SourcePackage {
                     packageInfoId        = packageId pkg,
                     packageDescription   = pkg,
                     packageSource        = fmap Just location,
                     packageDescrOverride = Nothing
                   }

      LocalTarballPackage tarballFile ->
        readTarballPackageTarget location tarballFile tarballFile

      RemoteTarballPackage tarballURL tarballFile ->
        readTarballPackageTarget location tarballFile (show tarballURL)

      RepoTarballPackage _repo _pkgid _ ->
        error "TODO: readPackageTarget RepoTarballPackage"
        -- For repo tarballs this info should be obtained from the index.

  where
    readTarballPackageTarget location tarballFile tarballOriginalLoc = do
      (filename, content) <- extractTarballPackageCabalFile
                               tarballFile tarballOriginalLoc
      case parsePackageDescription' content of
        Nothing  -> die $ "Could not parse the cabal file "
                       ++ filename ++ " in " ++ tarballFile
        Just pkg ->
          return $ PackageTargetLocation $
                     SourcePackage {
                       packageInfoId        = packageId pkg,
                       packageDescription   = pkg,
                       packageSource        = fmap Just location,
                       packageDescrOverride = Nothing
                     }

    extractTarballPackageCabalFile :: FilePath -> String
                                   -> IO (FilePath, BS.ByteString)
    extractTarballPackageCabalFile tarballFile tarballOriginalLoc =
          either (die . formatErr) return
        . check
        . Tar.entriesIndex
        . Tar.filterEntries isCabalFile
        . Tar.read
        . GZipUtils.maybeDecompress
      =<< BS.readFile tarballFile
      where
        formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg

        check (Left e)  = Left e
        check (Right m) = case Map.elems m of
            []     -> Left noCabalFile
            [file] -> case Tar.entryContent file of
              Tar.NormalFile content _ -> Right (Tar.entryPath file, content)
              _                        -> Left noCabalFile
            _files -> Left multipleCabalFiles
          where
            noCabalFile        = "No cabal file found"
            multipleCabalFiles = "Multiple cabal files found"

        isCabalFile e = case splitPath (Tar.entryPath e) of
          [     _dir, file] -> takeExtension file == ".cabal"
          [".", _dir, file] -> takeExtension file == ".cabal"
          _                 -> False

    parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription
    parsePackageDescription' content =
      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of
        ParseOk _ pkg -> Just pkg
        _             -> Nothing


-- ------------------------------------------------------------
-- * Checking package targets
-- ------------------------------------------------------------

data PackageTargetProblem
   = PackageNameUnknown   PackageName               UserTarget
   | PackageNameAmbiguous PackageName [PackageName] UserTarget
  deriving Show


-- | Users are allowed to give package names case-insensitively, so we must
-- disambiguate named package references.
--
disambiguatePackageTargets :: Package pkg'
                           => PackageIndex pkg'
                           -> [PackageName]
                           -> [PackageTarget pkg]
                           -> ( [PackageTargetProblem]
                              , [PackageSpecifier pkg] )
disambiguatePackageTargets availablePkgIndex availableExtra targets =
    partitionEithers (map disambiguatePackageTarget targets)
  where
    disambiguatePackageTarget packageTarget = case packageTarget of
      PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)

      PackageTargetNamed pkgname constraints userTarget
        | null (PackageIndex.lookupPackageName availablePkgIndex pkgname)
                    -> Left (PackageNameUnknown pkgname userTarget)
        | otherwise -> Right (NamedPackage pkgname constraints)

      PackageTargetNamedFuzzy pkgname constraints userTarget ->
        case disambiguatePackageName packageNameEnv pkgname of
          None                 -> Left  (PackageNameUnknown
                                          pkgname userTarget)
          Ambiguous   pkgnames -> Left  (PackageNameAmbiguous
                                          pkgname pkgnames userTarget)
          Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints')
            where
              constraints' = map (renamePackageConstraint pkgname') constraints

    -- use any extra specific available packages to help us disambiguate
    packageNameEnv :: PackageNameEnv
    packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex)
                             (extraPackageNameEnv availableExtra)


-- | Report problems to the user. That is, if there are any problems
-- then raise an exception.
reportPackageTargetProblems :: Verbosity
                            -> [PackageTargetProblem] -> IO ()
reportPackageTargetProblems verbosity problems = do
    case [ pkg | PackageNameUnknown pkg originalTarget <- problems
               , not (isUserTagetWorld originalTarget) ] of
      []    -> return ()
      pkgs  -> die $ unlines
                       [ "There is no package named '" ++ display name ++ "'. "
                       | name <- pkgs ]
                  ++ "You may need to run 'cabal update' to get the latest "
                  ++ "list of available packages."

    case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of
      []          -> return ()
      ambiguities -> die $ unlines
                             [    "The package name '" ++ display name
                               ++ "' is ambiguous. It could be: "
                               ++ intercalate ", " (map display matches)
                             | (name, matches) <- ambiguities ]

    case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of
      []   -> return ()
      pkgs -> warn verbosity $
                 "The following 'world' packages will be ignored because "
              ++ "they refer to packages that cannot be found: "
              ++ intercalate ", " (map display pkgs) ++ "\n"
              ++ "You can suppress this warning by correcting the world file."
  where
    isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False


-- ------------------------------------------------------------
-- * Disambiguating package names
-- ------------------------------------------------------------

data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]

-- | Given a package name and a list of matching names, figure out which one it
-- might be referring to. If there is an exact case-sensitive match then that's
-- ok. If it matches just one package case-insensitively then that's also ok.
-- The only problem is if it matches multiple packages case-insensitively, in
-- that case it is ambiguous.
--
disambiguatePackageName :: PackageNameEnv
                        -> PackageName
                        -> MaybeAmbiguous PackageName
disambiguatePackageName (PackageNameEnv pkgNameLookup) name =
    case nub (pkgNameLookup name) of
      []      -> None
      [name'] -> Unambiguous name'
      names   -> case find (name==) names of
                   Just name' -> Unambiguous name'
                   Nothing    -> Ambiguous names


newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])

instance Monoid PackageNameEnv where
  mempty = PackageNameEnv (const [])
  mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) =
    PackageNameEnv (\name -> lookupA name ++ lookupB name)

indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv
indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup
  where
    pkgNameLookup (PackageName name) =
      map fst (PackageIndex.searchByName pkgIndex name)

extraPackageNameEnv :: [PackageName] -> PackageNameEnv
extraPackageNameEnv names = PackageNameEnv pkgNameLookup
  where
    pkgNameLookup (PackageName name) =
      [ PackageName name'
      | let lname = lowercase name
      , PackageName name' <- names
      , lowercase name' == lname ]


-- ------------------------------------------------------------
-- * Package constraints
-- ------------------------------------------------------------

data UserConstraint =
     UserConstraintVersion   PackageName VersionRange
   | UserConstraintInstalled PackageName
   | UserConstraintSource    PackageName
   | UserConstraintFlags     PackageName FlagAssignment
   | UserConstraintStanzas   PackageName [OptionalStanza]
  deriving (Show,Eq)

userConstraintPackageName :: UserConstraint -> PackageName
userConstraintPackageName uc = case uc of
  UserConstraintVersion   name _ -> name
  UserConstraintInstalled name   -> name
  UserConstraintSource    name   -> name
  UserConstraintFlags     name _ -> name
  UserConstraintStanzas   name _ -> name

userToPackageConstraint :: UserConstraint -> PackageConstraint
-- At the moment, the types happen to be directly equivalent
userToPackageConstraint uc = case uc of
  UserConstraintVersion   name ver   -> PackageConstraintVersion    name ver
  UserConstraintInstalled name       -> PackageConstraintInstalled  name
  UserConstraintSource    name       -> PackageConstraintSource     name
  UserConstraintFlags     name flags -> PackageConstraintFlags      name flags
  UserConstraintStanzas   name stanzas -> PackageConstraintStanzas  name stanzas

renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint
renamePackageConstraint name pc = case pc of
  PackageConstraintVersion   _ ver   -> PackageConstraintVersion    name ver
  PackageConstraintInstalled _       -> PackageConstraintInstalled  name
  PackageConstraintSource    _       -> PackageConstraintSource     name
  PackageConstraintFlags     _ flags -> PackageConstraintFlags      name flags
  PackageConstraintStanzas   _ stanzas -> PackageConstraintStanzas   name stanzas

readUserConstraint :: String -> Either String UserConstraint
readUserConstraint str =
    case readPToMaybe parse str of
      Nothing -> Left msgCannotParse
      Just c  -> Right c
  where
    msgCannotParse =
         "expected a package name followed by a constraint, which is "
      ++ "either a version range, 'installed', 'source' or flags"

instance Text UserConstraint where
  disp (UserConstraintVersion   pkgname verrange) = disp pkgname
                                                    <+> disp verrange
  disp (UserConstraintInstalled pkgname)          = disp pkgname
                                                    <+> Disp.text "installed"
  disp (UserConstraintSource    pkgname)          = disp pkgname
                                                    <+> Disp.text "source"
  disp (UserConstraintFlags     pkgname flags)    = disp pkgname
                                                    <+> dispFlagAssignment flags
    where
      dispFlagAssignment = Disp.hsep . map dispFlagValue
      dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f
      dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f
      dispFlagName (FlagName f) = Disp.text f

  disp (UserConstraintStanzas   pkgname stanzas)  = disp pkgname
                                                    <+> dispStanzas stanzas
    where
      dispStanzas = Disp.hsep . map dispStanza
      dispStanza TestStanzas  = Disp.text "test"
      dispStanza BenchStanzas = Disp.text "bench"

  parse = parse >>= parseConstraint
    where
      spaces = Parse.satisfy isSpace >> Parse.skipSpaces

      parseConstraint pkgname =
            ((parse >>= return . UserConstraintVersion pkgname)
        +++ (do spaces
                _ <- Parse.string "installed"
                return (UserConstraintInstalled pkgname))
        +++ (do spaces
                _ <- Parse.string "source"
                return (UserConstraintSource pkgname))
        +++ (do spaces
                _ <- Parse.string "test"
                return (UserConstraintStanzas pkgname [TestStanzas]))
        +++ (do spaces
                _ <- Parse.string "bench"
                return (UserConstraintStanzas pkgname [BenchStanzas])))
        <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))

      parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue)
      parseFlagValue =
            (do Parse.optional (Parse.char '+')
                f <- parseFlagName
                return (f, True))
        +++ (do _ <- Parse.char '-'
                f <- parseFlagName
                return (f, False))
      parseFlagName = liftM FlagName ident

      ident :: Parse.ReadP r String
      ident = Parse.munch1 identChar >>= \s -> check s >> return s
        where
          identChar c   = isAlphaNum c || c == '_' || c == '-'
          check ('-':_) = Parse.pfail
          check _       = return ()
