Types.hs

{- |
   Module      : Distribution.Gentoo.CmdLine.Types

   Types representing command-line options
 -}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

module Distribution.Gentoo.CmdLine.Types
    (
      -- * main type
      CmdLineArgs(..)
    , defCmdLineArgs
      -- * sub types
    , BuildTarget(..)
    , CustomTarget
    , RunMode(..)
      -- * Multiple-choice arguments
    , CmdlineOpt(..)
      -- ** getter functions
    , argString
    , argDescription
      -- ** utility functions
    , argHelp
    , fromCmdline
    ) where

import           Data.Char             (toLower)
import qualified Data.List             as L
import qualified Data.List.NonEmpty    as NE
import           Data.Proxy

import Distribution.Gentoo.PkgManager.Types
import Distribution.Gentoo.Types
import Output

-- | Represents possible options given on the command line
data CmdLineArgs = CmdLineArgs
    { cmdLinePkgManager :: PkgManager -- ^ @--package-manager@ or @--custom-pm@
    , cmdLinePretend :: Bool -- ^ @--pretend@
    , cmdLineNoDeep :: Bool -- ^ @--no-deep@
    , cmdLineVersion :: Bool -- ^ @--version@
    , cmdLineAction :: WithCmd -- ^ @--action@
    , cmdLineTargets :: Maybe (NE.NonEmpty (Either CustomTarget BuildTarget)) -- ^ @--target@
    , cmdLineMode :: RunMode -- ^ @--mode@
    , cmdLineVerbosity :: Verbosity -- ^ @--verbose@ or @--quiet@
    , cmdLineHelp :: Bool -- ^ @--help@

      -- This would be better off as another BuildTarget option, but then we
      -- would lose the cool CmdlineOpt automagic
    , cmdLineWorldFull :: Bool -- ^ @--world-full@
    } deriving (Show, Eq, Ord)

defCmdLineArgs :: PkgManager -> CmdLineArgs
defCmdLineArgs defPM = CmdLineArgs
    { cmdLinePkgManager = defPM
    , cmdLinePretend = False
    , cmdLineNoDeep = False
    , cmdLineVersion = False
    , cmdLineAction = PrintAndRun
    , cmdLineTargets = Nothing
    , cmdLineMode = BasicMode
    , cmdLineVerbosity = Normal
    , cmdLineHelp = False
    , cmdLineWorldFull = False
    }

data BuildTarget
    = OnlyInvalid -- ^ Default
    | AllInstalled -- ^ Rebuild every Haskell package
    | WorldTarget -- ^ Target @@world@ portage set
    | PreservedRebuild -- ^ Append @@preserved-rebuild@ set
    deriving (Eq, Ord, Show, Read, Enum, Bounded)

type CustomTarget = String

data RunMode
    = BasicMode -- ^ @--mode=basic@
    | ListMode -- ^ @--mode=list@
    | ReinstallAtomsMode -- ^ @--mode=reinstall-atoms@ (portage only)
    deriving (Show, Eq, Ord, Enum, Bounded)

-- | A class for multiple-choice options selected by an argument on the command
--   line
class (Eq a, Enum a, Bounded a) => CmdlineOpt a where
    -- | Define the short name and an optional description for a constructor
    argInfo :: a -> (String, Maybe String)
    -- | Define the short name for the multiple-choice argument as a whole
    --
    --   e.g. @"action"@
    optName :: Proxy a -> String
    -- | Define the description for the multiple-choice argument as a whole
    --
    --   e.g. @"Specify whether to run the PM command or just print it"@
    optDescription :: Proxy a -> String
    -- | Define the default constructor for the multiple-choice argument
    --
    --   e.g. 'PrintAndRun'
    optDefault :: Proxy a -> a

instance CmdlineOpt WithCmd where
    argInfo PrintAndRun = ("print-and-run", Nothing)
    argInfo PrintOnly = ("print", Nothing)
    argInfo RunOnly = ("run", Nothing)

    optName _ = "action"
    optDescription _ =
        "Specify whether to run the PM command or just print it"
    optDefault _ = PrintAndRun

instance CmdlineOpt BuildTarget where
    argInfo OnlyInvalid = ("invalid", Just "broken Haskell packages")
    argInfo AllInstalled = ("all", Just "all installed Haskell packages")
    argInfo WorldTarget =
        ( "world"
        , Just $ "@world set (only valid with portage package\n"
              ++ "manager and reinstall-atoms mode)"
        )
    argInfo PreservedRebuild =
        ( "preserved-rebuild"
        , Just $ "Append @preserved-rebuild set (only valid with\n"
              ++ "portage package manager and basic mode)"
        )

    optName _ = "target"
    optDescription _ =
        "Choose the type of packages for the PM to target.\n\
        \May be given multiple times in reinstall-atoms mode."
    optDefault _ = OnlyInvalid

instance CmdlineOpt RunMode where
    argInfo BasicMode = ("basic", Just "classic haskell-updater behavior")
    argInfo ListMode =
        ( "list"
        , Just $ "just print a list of packages for rebuild,\n"
              ++ "one package per line"
        )
    argInfo ReinstallAtomsMode =
        ( "reinstall-atoms"
        , Just $ "experimental portage invocation using\n"
              ++ "--reinstall-atoms (may be more useful in\n"
              ++ "some situations)" )

    optName _ = "mode"
    optDescription _ =
        "Mode of operation for haskell-updater"
    optDefault _ = BasicMode

argString :: CmdlineOpt a => a -> String
argString = fst . argInfo

argDescription :: CmdlineOpt a => a -> Maybe String
argDescription = snd . argInfo

argHelp :: forall a. CmdlineOpt a => Proxy a -> String
argHelp _ = unlines $ [mainDesc] ++ (args >>= argLine)
  where
    mainDesc = optDescription (Proxy @a)
    argLine a = case (L.lookup a argFields, argDescription a) of
        (Nothing, _) -> []
        (Just s, Nothing) ->  [s]
        (Just s, Just d) -> case lines d of
            (l:ls) -> [paddedFst s l] ++ (paddedRest <$> ls)
            _ -> []
    paddedFst s d =
        s ++ replicate (padMax - length s) ' ' ++ " : " ++ d
    paddedRest d = replicate (padMax + 3) ' ' ++ d
    padMax = maximum $ length . snd <$> argFields
    argFields = (\a -> (a, showArg a)) <$> args
    showArg a = " * " ++ argString a ++ showDef a
    showDef a
        | optDefault (Proxy @a) == a = " (default)"
        | otherwise = ""
    args = [minBound :: a .. maxBound]

fromCmdline
    :: forall a. CmdlineOpt a
    => (a -> CmdLineArgs -> CmdLineArgs)
    -> String
    -> CmdLineArgs
    -> Either String CmdLineArgs
fromCmdline update s rm =
    case L.find (\a -> argString a == lowerS) args of
        Nothing -> Left $ "Unknown " ++ name ++ ": " ++ lowerS
        Just a -> Right $ update a rm
  where
    lowerS = map toLower s
    name = optName $ Proxy @a
    args = [minBound :: a .. maxBound]