{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}

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

-- |
-- Module      :  Distribution.Simple.Setup.Register
-- Copyright   :  Isaac Jones 2003-2004
--                Duncan Coutts 2007
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Definition of the register command-line options.
-- See: @Distribution.Simple.Setup@
module Distribution.Simple.Setup.Register
  ( RegisterFlags
      ( RegisterCommonFlags
      , registerVerbosity
      , registerDistPref
      , registerCabalFilePath
      , registerWorkingDir
      , registerTargets
      , ..
      )
  , emptyRegisterFlags
  , defaultRegisterFlags
  , registerCommand
  , unregisterCommand
  ) where

import Distribution.Compat.Prelude hiding (get)
import Prelude ()

import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Compiler
import Distribution.Simple.Flag
import Distribution.Simple.Setup.Common
import Distribution.Utils.Path
import Distribution.Verbosity

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

-- * Register flags

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

-- | Flags to @register@ and @unregister@: (user package, gen-script,
-- in-place, verbosity)
data RegisterFlags = RegisterFlags
  { RegisterFlags -> CommonSetupFlags
registerCommonFlags :: !CommonSetupFlags
  , RegisterFlags -> Flag PackageDB
regPackageDB :: Flag PackageDB
  , RegisterFlags -> Flag Bool
regGenScript :: Flag Bool
  , RegisterFlags -> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
regGenPkgConf :: Flag (Maybe (SymbolicPath Pkg (Dir PkgConf)))
  , RegisterFlags -> Flag Bool
regInPlace :: Flag Bool
  , RegisterFlags -> Flag Bool
regPrintId :: Flag Bool
  }
  deriving (Int -> RegisterFlags -> ShowS
[RegisterFlags] -> ShowS
RegisterFlags -> String
(Int -> RegisterFlags -> ShowS)
-> (RegisterFlags -> String)
-> ([RegisterFlags] -> ShowS)
-> Show RegisterFlags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RegisterFlags -> ShowS
showsPrec :: Int -> RegisterFlags -> ShowS
$cshow :: RegisterFlags -> String
show :: RegisterFlags -> String
$cshowList :: [RegisterFlags] -> ShowS
showList :: [RegisterFlags] -> ShowS
Show, (forall x. RegisterFlags -> Rep RegisterFlags x)
-> (forall x. Rep RegisterFlags x -> RegisterFlags)
-> Generic RegisterFlags
forall x. Rep RegisterFlags x -> RegisterFlags
forall x. RegisterFlags -> Rep RegisterFlags x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RegisterFlags -> Rep RegisterFlags x
from :: forall x. RegisterFlags -> Rep RegisterFlags x
$cto :: forall x. Rep RegisterFlags x -> RegisterFlags
to :: forall x. Rep RegisterFlags x -> RegisterFlags
Generic, Typeable)

pattern RegisterCommonFlags
  :: Flag Verbosity
  -> Flag (SymbolicPath Pkg (Dir Dist))
  -> Flag (SymbolicPath CWD (Dir Pkg))
  -> Flag (SymbolicPath Pkg File)
  -> [String]
  -> RegisterFlags
pattern $mRegisterCommonFlags :: forall {r}.
RegisterFlags
-> (Flag Verbosity
    -> Flag (SymbolicPath Pkg ('Dir Dist))
    -> Flag (SymbolicPath CWD ('Dir Pkg))
    -> Flag (SymbolicPath Pkg 'File)
    -> [String]
    -> r)
-> ((# #) -> r)
-> r
RegisterCommonFlags
  { RegisterFlags -> Flag Verbosity
registerVerbosity
  , RegisterFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
registerDistPref
  , RegisterFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
registerWorkingDir
  , RegisterFlags -> Flag (SymbolicPath Pkg 'File)
registerCabalFilePath
  , RegisterFlags -> [String]
registerTargets
  } <-
  ( registerCommonFlags ->
      CommonSetupFlags
        { setupVerbosity = registerVerbosity
        , setupDistPref = registerDistPref
        , setupWorkingDir = registerWorkingDir
        , setupCabalFilePath = registerCabalFilePath
        , setupTargets = registerTargets
        }
    )

defaultRegisterFlags :: RegisterFlags
defaultRegisterFlags :: RegisterFlags
defaultRegisterFlags =
  RegisterFlags
    { registerCommonFlags :: CommonSetupFlags
registerCommonFlags = CommonSetupFlags
defaultCommonSetupFlags
    , regPackageDB :: Flag PackageDB
regPackageDB = Flag PackageDB
forall a. Flag a
NoFlag
    , regGenScript :: Flag Bool
regGenScript = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False
    , regGenPkgConf :: Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
regGenPkgConf = Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
forall a. Flag a
NoFlag
    , regInPlace :: Flag Bool
regInPlace = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False
    , regPrintId :: Flag Bool
regPrintId = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False
    }

registerCommand :: CommandUI RegisterFlags
registerCommand :: CommandUI RegisterFlags
registerCommand =
  CommandUI
    { commandName :: String
commandName = String
"register"
    , commandSynopsis :: String
commandSynopsis =
        String
"Register this package with the compiler."
    , commandDescription :: Maybe ShowS
commandDescription = Maybe ShowS
forall a. Maybe a
Nothing
    , commandNotes :: Maybe ShowS
commandNotes = Maybe ShowS
forall a. Maybe a
Nothing
    , commandUsage :: ShowS
commandUsage = \String
pname ->
        String
"Usage: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" register [FLAGS]\n"
    , commandDefaultFlags :: RegisterFlags
commandDefaultFlags = RegisterFlags
defaultRegisterFlags
    , commandOptions :: ShowOrParseArgs -> [OptionField RegisterFlags]
commandOptions = \ShowOrParseArgs
showOrParseArgs ->
        (RegisterFlags -> CommonSetupFlags)
-> (CommonSetupFlags -> RegisterFlags -> RegisterFlags)
-> ShowOrParseArgs
-> [OptionField RegisterFlags]
-> [OptionField RegisterFlags]
forall flags.
(flags -> CommonSetupFlags)
-> (CommonSetupFlags -> flags -> flags)
-> ShowOrParseArgs
-> [OptionField flags]
-> [OptionField flags]
withCommonSetupOptions
          RegisterFlags -> CommonSetupFlags
registerCommonFlags
          (\CommonSetupFlags
c RegisterFlags
f -> RegisterFlags
f{registerCommonFlags = c})
          ShowOrParseArgs
showOrParseArgs
          ([OptionField RegisterFlags] -> [OptionField RegisterFlags])
-> [OptionField RegisterFlags] -> [OptionField RegisterFlags]
forall a b. (a -> b) -> a -> b
$ [ String
-> [String]
-> String
-> (RegisterFlags -> Flag PackageDB)
-> (Flag PackageDB -> RegisterFlags -> RegisterFlags)
-> MkOptDescr
     (RegisterFlags -> Flag PackageDB)
     (Flag PackageDB -> RegisterFlags -> RegisterFlags)
     RegisterFlags
-> OptionField RegisterFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
                String
""
                [String
"packageDB"]
                String
""
                RegisterFlags -> Flag PackageDB
regPackageDB
                (\Flag PackageDB
v RegisterFlags
flags -> RegisterFlags
flags{regPackageDB = v})
                ( [(Flag PackageDB, OptFlags, String)]
-> MkOptDescr
     (RegisterFlags -> Flag PackageDB)
     (Flag PackageDB -> RegisterFlags -> RegisterFlags)
     RegisterFlags
forall b a.
Eq b =>
[(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt
                    [
                      ( PackageDB -> Flag PackageDB
forall a. a -> Flag a
Flag PackageDB
forall fp. PackageDBX fp
UserPackageDB
                      , ([], [String
"user"])
                      , String
"upon registration, register this package in the user's local package database"
                      )
                    ,
                      ( PackageDB -> Flag PackageDB
forall a. a -> Flag a
Flag PackageDB
forall fp. PackageDBX fp
GlobalPackageDB
                      , ([], [String
"global"])
                      , String
"(default)upon registration, register this package in the system-wide package database"
                      )
                    ]
                )
            , String
-> [String]
-> String
-> (RegisterFlags -> Flag Bool)
-> (Flag Bool -> RegisterFlags -> RegisterFlags)
-> MkOptDescr
     (RegisterFlags -> Flag Bool)
     (Flag Bool -> RegisterFlags -> RegisterFlags)
     RegisterFlags
-> OptionField RegisterFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
                String
""
                [String
"inplace"]
                String
"register the package in the build location, so it can be used without being installed"
                RegisterFlags -> Flag Bool
regInPlace
                (\Flag Bool
v RegisterFlags
flags -> RegisterFlags
flags{regInPlace = v})
                MkOptDescr
  (RegisterFlags -> Flag Bool)
  (Flag Bool -> RegisterFlags -> RegisterFlags)
  RegisterFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
            , String
-> [String]
-> String
-> (RegisterFlags -> Flag Bool)
-> (Flag Bool -> RegisterFlags -> RegisterFlags)
-> MkOptDescr
     (RegisterFlags -> Flag Bool)
     (Flag Bool -> RegisterFlags -> RegisterFlags)
     RegisterFlags
-> OptionField RegisterFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
                String
""
                [String
"gen-script"]
                String
"instead of registering, generate a script to register later"
                RegisterFlags -> Flag Bool
regGenScript
                (\Flag Bool
v RegisterFlags
flags -> RegisterFlags
flags{regGenScript = v})
                MkOptDescr
  (RegisterFlags -> Flag Bool)
  (Flag Bool -> RegisterFlags -> RegisterFlags)
  RegisterFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
            , String
-> [String]
-> String
-> (RegisterFlags
    -> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf))))
-> (Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
    -> RegisterFlags -> RegisterFlags)
-> MkOptDescr
     (RegisterFlags -> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf))))
     (Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
      -> RegisterFlags -> RegisterFlags)
     RegisterFlags
-> OptionField RegisterFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
                String
""
                [String
"gen-pkg-config"]
                String
"instead of registering, generate a package registration file/directory"
                RegisterFlags -> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
regGenPkgConf
                (\Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
v RegisterFlags
flags -> RegisterFlags
flags{regGenPkgConf = v})
                (String
-> (Maybe String -> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf))))
-> (Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
    -> [Maybe String])
-> MkOptDescr
     (RegisterFlags -> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf))))
     (Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
      -> RegisterFlags -> RegisterFlags)
     RegisterFlags
forall b a.
Monoid b =>
String
-> (Maybe String -> b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg' String
"PKG" (Maybe (SymbolicPath Pkg ('Dir PkgConf))
-> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
forall a. a -> Flag a
Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf))
 -> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf))))
-> (Maybe String -> Maybe (SymbolicPath Pkg ('Dir PkgConf)))
-> Maybe String
-> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SymbolicPath Pkg ('Dir PkgConf))
-> Maybe String -> Maybe (SymbolicPath Pkg ('Dir PkgConf))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> SymbolicPath Pkg ('Dir PkgConf)
forall from (to :: FileOrDir). String -> SymbolicPath from to
makeSymbolicPath) (Flag (Maybe String) -> [Maybe String]
forall a. Flag a -> [a]
flagToList (Flag (Maybe String) -> [Maybe String])
-> (Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
    -> Flag (Maybe String))
-> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
-> [Maybe String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (SymbolicPath Pkg ('Dir PkgConf)) -> Maybe String)
-> Flag (Maybe (SymbolicPath Pkg ('Dir PkgConf)))
-> Flag (Maybe String)
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SymbolicPath Pkg ('Dir PkgConf) -> String)
-> Maybe (SymbolicPath Pkg ('Dir PkgConf)) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolicPath Pkg ('Dir PkgConf) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath)))
            , String
-> [String]
-> String
-> (RegisterFlags -> Flag Bool)
-> (Flag Bool -> RegisterFlags -> RegisterFlags)
-> MkOptDescr
     (RegisterFlags -> Flag Bool)
     (Flag Bool -> RegisterFlags -> RegisterFlags)
     RegisterFlags
-> OptionField RegisterFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
                String
""
                [String
"print-ipid"]
                String
"print the installed package ID calculated for this package"
                RegisterFlags -> Flag Bool
regPrintId
                (\Flag Bool
v RegisterFlags
flags -> RegisterFlags
flags{regPrintId = v})
                MkOptDescr
  (RegisterFlags -> Flag Bool)
  (Flag Bool -> RegisterFlags -> RegisterFlags)
  RegisterFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
            ]
    }

unregisterCommand :: CommandUI RegisterFlags
unregisterCommand :: CommandUI RegisterFlags
unregisterCommand =
  CommandUI
    { commandName :: String
commandName = String
"unregister"
    , commandSynopsis :: String
commandSynopsis =
        String
"Unregister this package with the compiler."
    , commandDescription :: Maybe ShowS
commandDescription = Maybe ShowS
forall a. Maybe a
Nothing
    , commandNotes :: Maybe ShowS
commandNotes = Maybe ShowS
forall a. Maybe a
Nothing
    , commandUsage :: ShowS
commandUsage = \String
pname ->
        String
"Usage: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" unregister [FLAGS]\n"
    , commandDefaultFlags :: RegisterFlags
commandDefaultFlags = RegisterFlags
defaultRegisterFlags
    , commandOptions :: ShowOrParseArgs -> [OptionField RegisterFlags]
commandOptions = \ShowOrParseArgs
showOrParseArgs ->
        (RegisterFlags -> CommonSetupFlags)
-> (CommonSetupFlags -> RegisterFlags -> RegisterFlags)
-> ShowOrParseArgs
-> [OptionField RegisterFlags]
-> [OptionField RegisterFlags]
forall flags.
(flags -> CommonSetupFlags)
-> (CommonSetupFlags -> flags -> flags)
-> ShowOrParseArgs
-> [OptionField flags]
-> [OptionField flags]
withCommonSetupOptions
          RegisterFlags -> CommonSetupFlags
registerCommonFlags
          (\CommonSetupFlags
c RegisterFlags
f -> RegisterFlags
f{registerCommonFlags = c})
          ShowOrParseArgs
showOrParseArgs
          ([OptionField RegisterFlags] -> [OptionField RegisterFlags])
-> [OptionField RegisterFlags] -> [OptionField RegisterFlags]
forall a b. (a -> b) -> a -> b
$ [ String
-> [String]
-> String
-> (RegisterFlags -> Flag PackageDB)
-> (Flag PackageDB -> RegisterFlags -> RegisterFlags)
-> MkOptDescr
     (RegisterFlags -> Flag PackageDB)
     (Flag PackageDB -> RegisterFlags -> RegisterFlags)
     RegisterFlags
-> OptionField RegisterFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
                String
""
                [String
"user"]
                String
""
                RegisterFlags -> Flag PackageDB
regPackageDB
                (\Flag PackageDB
v RegisterFlags
flags -> RegisterFlags
flags{regPackageDB = v})
                ( [(Flag PackageDB, OptFlags, String)]
-> MkOptDescr
     (RegisterFlags -> Flag PackageDB)
     (Flag PackageDB -> RegisterFlags -> RegisterFlags)
     RegisterFlags
forall b a.
Eq b =>
[(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt
                    [
                      ( PackageDB -> Flag PackageDB
forall a. a -> Flag a
Flag PackageDB
forall fp. PackageDBX fp
UserPackageDB
                      , ([], [String
"user"])
                      , String
"unregister this package in the user's local package database"
                      )
                    ,
                      ( PackageDB -> Flag PackageDB
forall a. a -> Flag a
Flag PackageDB
forall fp. PackageDBX fp
GlobalPackageDB
                      , ([], [String
"global"])
                      , String
"(default) unregister this package in the  system-wide package database"
                      )
                    ]
                )
            , String
-> [String]
-> String
-> (RegisterFlags -> Flag Bool)
-> (Flag Bool -> RegisterFlags -> RegisterFlags)
-> MkOptDescr
     (RegisterFlags -> Flag Bool)
     (Flag Bool -> RegisterFlags -> RegisterFlags)
     RegisterFlags
-> OptionField RegisterFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
                String
""
                [String
"gen-script"]
                String
"Instead of performing the unregister command, generate a script to unregister later"
                RegisterFlags -> Flag Bool
regGenScript
                (\Flag Bool
v RegisterFlags
flags -> RegisterFlags
flags{regGenScript = v})
                MkOptDescr
  (RegisterFlags -> Flag Bool)
  (Flag Bool -> RegisterFlags -> RegisterFlags)
  RegisterFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
            ]
    }

emptyRegisterFlags :: RegisterFlags
emptyRegisterFlags :: RegisterFlags
emptyRegisterFlags = RegisterFlags
forall a. Monoid a => a
mempty

instance Monoid RegisterFlags where
  mempty :: RegisterFlags
mempty = RegisterFlags
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
  mappend :: RegisterFlags -> RegisterFlags -> RegisterFlags
mappend = RegisterFlags -> RegisterFlags -> RegisterFlags
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup RegisterFlags where
  <> :: RegisterFlags -> RegisterFlags -> RegisterFlags
(<>) = RegisterFlags -> RegisterFlags -> RegisterFlags
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend