Flags.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-

Copyright 2012, 2013, 2014 Colin Woodbury <[email protected]>

This file is part of Aura.

Aura is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Aura is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Aura.  If not, see <http://www.gnu.org/licenses/>.

-}

--module Aura.Flags where
    --( parseLanguageFlag
    --, parseFlags
    --, settingsFlags
    --, reconvertFlags
    --, dualFlagMap
    --, hijackedFlagMap
    --, pacmanFlagMap
    --, buildABSDepsStatus
    --, confirmationStatus
    --, customizepkgStatus
    --, delMakeDepsStatus
    --, hotEditStatus
    --, keepSourceStatus
    --, neededStatus
    --, noPowerPillStatus
    --, pbDiffStatus
    --, quietStatus
    --, rebuildDevelStatus
    --, sortSchemeStatus
    --, suppressionStatus
    --, truncationStatus
    --, dryRunStatus
    --, notSettingsFlag
    --, ignoredAuraPkgs
    --, makepkgFlags
    --, buildPath
    --, buildUser
    --, auraOperMsg
    --, Flag(..) ) where

import BasicPrelude hiding (FilePath, empty)

import Options.Applicative
import qualified Data.Text as T

--import Aura.Colour.Text (yellow)
--import Aura.Settings.Base
--import Aura.Languages

import Shelly (FilePath, fromText)

---

type FlagMap = Flag -> T.Text

data Flag = ABSInstall
          | AURInstall
          | SaveState
          | Cache
          | LogFile
          | Orphans
          | Search
          | Info
          | Refresh
          | GetPkgbuild
          | ViewDeps
          | DelMDeps
          | Upgrade
          | Download
          | Unsuppress
          | TreeSync
          | HotEdit
          | NoConfirm
          | DryRun
          | Quiet
          | AURIgnore T.Text
          | Ignore T.Text
          | IgnoreGroup T.Text
          | BuildPath FilePath
          | BuildUser T.Text
          | ABCSort
          | TruncHead Int
          | TruncTail Int
          | DiffPkgbuilds
          | Devel
          | Customizepkg
          | KeepSource
          | BuildABSDeps
          | Debug
          | CacheBackup
          | Clean
          | Abandon
          | ViewConf
          | RestoreState
          | NoPowerPill
          | IgnoreArch
          | Needed
          | Languages
          | Version
          | Help
          | JapOut
          | PolishOut
          | CroatianOut
          | SwedishOut
          | GermanOut
          | SpanishOut
          | PortuOut
          | FrenchOut
          | RussianOut
          | ItalianOut
          | SerbianOut
          | NorwegiOut
          | PacmanArg T.Text T.Text
            deriving (Eq, Ord, Show)

allFlags ::  Parser [Flag]
allFlags = join <$> sequenceA [ auraOperations
                              , auraOptions
                              , pacmanOptions
                              , dualOptions
                              , languageOptions
                              , longPacmanOptions ]

simpleOption :: String -> [String] -> Flag -> String -> Parser Flag
simpleOption c s f h = flag' f (help h <> foldl appendLong mempty s <> foldl appendShort mempty c)
  where appendLong a l = a <> long l
        appendShort a s = a <> short s

simpleOptionWarg :: String -> [String] -> (String -> Flag) -> String -> Parser Flag
simpleOptionWarg c s f h = f <$> strOption (help h <> foldl appendLong mempty s <> foldl appendShort mempty c)
  where appendLong a l = a <> long l
        appendShort a s = a <> short s

choose :: Alternative f => [f a] -> f a
choose = foldl (<|>) empty

auraOperations :: Parser [Flag]
auraOperations = choose
    [(\a b -> [a] <> b) <$> simpleOption "A" ["aursync"]   AURInstall ""
      <*> many (choose [ simpleOption "u" ["sysupgrade"]   Upgrade       "upgrade AUR packages"
                       , simpleOption "i" ["info"]         Info          "get package info"
                       , simpleOption "s" ["search"]       Search        "Search the AUR using a Regexp"
                       , simpleOption "p" ["pkgbuild"]     GetPkgbuild   "Display an AUR Package's PKGBUILD"
                       , simpleOption "d" ["deps"]         ViewDeps      "Display an AUR package's dependencies"
                       , simpleOption "x" ["unsuppress"]   Unsuppress    "Don't supress makepkg's output"
                       , simpleOption "a" ["delmakedeps"]  DelMDeps      "Remove make depends after installing"
                       , simpleOption "k" ["diff"]         DiffPkgbuilds "Show PKGBUILD differences"
                       ])
    ,(\a b -> [a] <> b) <$> simpleOption "B" ["save"]      SaveState  ""
      <*> many (choose [ simpleOption  "r" ["restore"] RestoreState "Restore a saved record. Rolls back, uninstalls, and reinstalls packages as necessary"])
    ,(\a b -> [a] <> b) <$> simpleOption "C" ["downgrade"] Cache      ""
      <*> many (choose [ simpleOption "s" ["search"] Search      "Search the package cache for package files via a regex"
                       , simpleOption "b" ["backup"] CacheBackup "Backup the package cache"
                       , simpleOption "c" ["clean"]  Clean       "Reduce the package cache to contain only 'x' of each package file"
                       ])
    ,(\a b -> [a] <> b) <$> simpleOption "L" ["viewlog"]   LogFile    ""
      <*> some (choose [ simpleOption "i" ["info"]   Info   "Display install / upgrade history for a package"
                       , simpleOption "s" ["search"] Search "Search the pacman logfile via a regex"
                       ])
    ,(\a b -> [a] <> b) <$> simpleOption "M" ["abssync"]   ABSInstall ""
      <*> many (choose [ simpleOption []  ["absdeps"]  BuildABSDeps "Build a repository package and all its dependencies manually"
                       , simpleOption "t" ["treesync"] TreeSync     "Sync a single package's data to the local ABS Tree"
                       , simpleOption "y" ["refresh"]  Refresh      "Sync all package data in the local ABS Tree"
                       ])
    ,(\a b -> [a] <> b) <$> simpleOption "O" ["orphans"]   Orphans    ""
      <*> many (choose [simpleOption "j" ["abandon"] Abandon "Uninstall all orphan packages"
                       ])
    ]

auraOptions :: Parser [Flag]
auraOptions = many $ choose
  [simpleOptionWarg []  ["aurignore"] (AURIgnore . T.pack) ""
  ,simpleOptionWarg []  ["build"]     (BuildPath . fromText . T.pack) ""
  ,simpleOptionWarg []  ["builduser"] (BuildUser . T.pack) ""
  ,simpleOptionWarg []  ["head"]      (TruncHead .  read .T.pack) ""
  ,simpleOptionWarg []  ["tail"]      (TruncTail .  read .T.pack) ""
  ,simpleOption "w" ["downloadonly"] Download     ""
  ,simpleOption "u" ["sysupgrade"]   Upgrade      ""
  ,simpleOption "q" ["quiet"]        Quiet        ""
  ,simpleOption []  ["abc"]          ABCSort      ""
  ,simpleOption []  ["allsource"]    KeepSource   ""
  ,simpleOption []  ["auradebug"]    Debug        ""
  ,simpleOption []  ["custom"]       Customizepkg ""
  ,simpleOption []  ["devel"]        Devel        ""
  ,simpleOption []  ["hotedit"]      HotEdit      ""
  ,simpleOption []  ["ignorearch"]   IgnoreArch   ""
  ,simpleOption []  ["languages"]    Languages    ""
  ,simpleOption []  ["no-pp"]        NoPowerPill  ""
  ,simpleOption []  ["dryrun"]       DryRun       ""
  ,simpleOption []  ["viewconf"]     ViewConf     "" ]

-- These are intercepted Pacman flags. Their functionality is different.
pacmanOptions :: Parser [Flag]
pacmanOptions = many $ choose
  [ simpleOption "y" ["refresh"] Refresh "Sync all package data in the local ABS Tree"
  , simpleOption "V" ["version"] Version "display version information"
  , simpleOption "h" ["help"]    Help    "display help"
  ]

-- Options that have functionality stretching across both Aura and Pacman.
dualOptions :: Parser [Flag]
dualOptions = many $ choose
  [ simpleOptionWarg [] ["ignore"]      (Ignore . T.pack)  ""
  , simpleOptionWarg [] ["ignoregroup"] (IgnoreGroup . T.pack) ""
  , simpleOption     [] ["noconfirm"] NoConfirm ""
  , simpleOption     [] ["needed"]    Needed   ""
  ]

-- These Pacman options are ignored,
-- but parser needs to know that they require an argument
longPacmanOptions :: Parser [Flag]
longPacmanOptions =  many $ choose $ fmap pacArg $ zip
  [ "dbpath", "root", "arch", "cachedir", "color"
  , "config", "gpgdir" , "logfile", "assume-installed"
  , "print-format" ]
  ( "b" : "r" : repeat [] )
  -- "owns" is apparently okay as is?
  -- TODO: check all others
  where pacArg (option, letter) = (PacmanArg (T.pack option) . T.pack) <$> strOption (long option <> foldl appendShort mempty letter)
        appendShort a s = a <> short s

pacmanFlagMap :: FlagMap
pacmanFlagMap (PacmanArg option arg) = "--" <> option <> "=" <> arg
pacmanFlagMap _                      = ""

languageOptions :: Parser [Flag]
languageOptions = fmap maybeToList $ optional $ choose $ fmap (\(a,b,c,d) -> simpleOption a b c d)
                  [ ( [], ["japanese", "日本語"],      JapOut      , "")
                  , ( [], ["polish", "polski"],        PolishOut   , "")
                  , ( [], ["croatian", "hrvatski"],    CroatianOut , "")
                  , ( [], ["swedish", "svenska"],      SwedishOut  , "")
                  , ( [], ["german", "deutsch"],       GermanOut   , "")
                  , ( [], ["spanish", "español"],      SpanishOut  , "")
                  , ( [], ["portuguese", "português"], PortuOut    , "")
                  , ( [], ["french", "français"],      FrenchOut   , "")
                  , ( [], ["russian", "русский"],      RussianOut  , "")
                  , ( [], ["italian", "italiano"],     ItalianOut  , "")
                  , ( [], ["serbian", "српски"],       SerbianOut  , "")
                  , ( [], ["norwegian", "norsk"],      NorwegiOut  , "") ]

-- `Hijacked` flags. They have original pacman functionality, but
-- that is masked and made unique in an Aura context.
hijackedFlagMap :: FlagMap
hijackedFlagMap = simpleFlagMap [ (CacheBackup,   "-b" )
                                , (Clean,         "-c" )
                                , (ViewDeps,      "-d" )
                                , (Info,          "-i" )
                                , (DiffPkgbuilds, "-k" )
                                , (RestoreState,  "-r" )
                                , (Search,        "-s" )
                                , (TreeSync,      "-t" )
                                , (Upgrade,       "-u" )
                                , (Download,      "-w" )
                                , (Refresh,       "-y" ) ]

-- These are flags which do the same thing in Aura or Pacman.
dualFlagMap :: FlagMap
dualFlagMap (Ignore      a) = "--ignore="      <> a
dualFlagMap (IgnoreGroup a) = "--ignoregroup=" <> a
dualFlagMap f = flip simpleFlagMap f [ (Quiet,     "-q"          )
                                     , (NoConfirm, "--noconfirm" )
                                     , (Needed,    "--needed"    ) ]

main :: IO ()
main = execParser opts >>= print
  where
    opts = info (helper <*> allFlags)
      (fullDesc <> progDesc "Description of Program")

simpleFlagMap :: [(Flag, T.Text)] -> Flag -> T.Text
simpleFlagMap fm = fromMaybe "" . flip lookup fm