{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
module Debian.Debianize.Optparse (
  CommandLineOptions(..),
  BehaviorAdjustment,
  Flags(..),
  parseProgramArguments,
  handleBehaviorAdjustment) where
import Control.Applicative ((<$>), (<*>), many, pure, (<|>))
import Control.Lens
import Control.Monad.State.Class (MonadState)
import Control.Monad.Trans
import Control.Newtype
import Data.Bifunctor (first)
import Data.Char(toUpper)
import Data.Foldable (forM_)
import Data.Maybe.Extended (fromMaybe)
import Data.Maybe.Extended (nothingIf)
import Data.Monoid ((<>), mempty)
import Debian.Debianize.BasicInfo
import Debian.Debianize.Monad
import Debian.Debianize.Prelude (maybeRead)
import Debian.Debianize.VersionSplits
import Debian.Policy
import Debian.Relation
import Debian.Version.Common (DebianVersion, parseDebianVersion)
import Distribution.Compiler (CompilerFlavor(..))
import Distribution.Package (PackageName(..))
import GHC.Generics
import System.Environment (getArgs)
import System.FilePath(splitFileName)
import System.Posix.Env (getEnv)
import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..))
import Text.PrettyPrint.ANSI.Leijen (linebreak, (<+>), string, indent)
import qualified  Debian.Debianize.DebInfo as D
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Debian.Debianize.BinaryDebDescription as B
import qualified Debian.Debianize.CabalInfo as A
import qualified Debian.Debianize.SourceDebDescription as S
import qualified Options.Applicative as O

data HaddockStatus = HaddockEnabled | HaddockDisabled deriving Eq
data ProfilingStatus = ProfilingEnabled | ProfilingDisabled deriving Eq
data OfficialStatus = Official| NonOfficial deriving Eq
data TestsStatus = TestsDisable | TestsBuild | TestsRun
newtype BuildDep = BuildDep Relations deriving Generic
instance Newtype BuildDep
newtype BuildDepIndep = BuildDepIndep Relations deriving Generic
instance Newtype BuildDepIndep
newtype DevDep = DevDep Relations deriving Generic
instance Newtype DevDep
newtype ExtraDepends = ExtraDepends (BinPkgName, Relations) deriving Generic
instance Newtype ExtraDepends
newtype ExtraConflicts = ExtraConflicts (BinPkgName, Relations) deriving Generic
instance Newtype ExtraConflicts
newtype ExtraProvides = ExtraProvides (BinPkgName, Relations) deriving Generic
instance Newtype ExtraProvides
newtype ExtraReplaces = ExtraReplaces (BinPkgName, Relations) deriving Generic
instance Newtype ExtraReplaces
newtype ExtraRecommends = ExtraRecommends (BinPkgName, Relations) deriving Generic
instance Newtype ExtraRecommends
newtype ExtraSuggests = ExtraSuggests (BinPkgName, Relations) deriving Generic
instance Newtype ExtraSuggests
newtype CabalDebMapping = CabalDebMapping (PackageName, Relations) deriving Generic
instance Newtype CabalDebMapping
newtype ExecDebMapping = ExecDebMapping (String, Relations) deriving Generic
instance Newtype ExecDebMapping
newtype Revision = Revision String deriving Generic
instance Newtype Revision

-- | This data type is an abomination. It represent information,
-- provided on command line. Part of such information provides
-- means to create initial 'CabalT' state and is stored in
-- '_flags' field. See 'newCabalInfo'.
--
-- Other, much greater part represent changes to already created
-- state. They are stored in '_adjustment' field.
--
-- All this can be understood from (simplified) types:
--
-- > type CabalT m a = StateT CabalInfo m a
-- > newCabalInfo :: Flags -> IO CabalInfo
-- > handleBehaviorAdjustment :: BehaviorAdjustment -> CabalT IO ()

data CommandLineOptions = CommandLineOptions {
  _flags :: Flags,
  _adjustment :: BehaviorAdjustment
}
-- | This data type represents changes to 'CabalT' state,
-- requested at command line.
data BehaviorAdjustment = BehaviorAdjustment {
  _maintainer        :: NameAddr,
  _uploaders         :: [NameAddr],
  _executable        :: [(BinPkgName, D.InstallFile)],
  _defaultPackage    :: Maybe String,
  _missingDependency :: [BinPkgName],
  _debianNameBase    :: Maybe DebBase,
  _debianVersion     :: Maybe DebianVersion,
  _revision          :: Maybe Revision,
  _sourcePackageName :: Maybe SrcPkgName,
  _sourceSection     :: Section,
  _standardsVersion  :: StandardsVersion,
  _buildDep          :: [BuildDep],
  _buildDepIndep     :: [BuildDepIndep],
  _devDep            :: [DevDep],
  _extraDepends      :: [ExtraDepends],
  _extraConflicts    :: [ExtraConflicts],
  _extraProvides     :: [ExtraProvides],
  _extraReplaces     :: [ExtraReplaces],
  _extraRecommends   :: [ExtraRecommends],
  _extraSuggests     :: [ExtraSuggests],
  _cabalDebMapping   :: [CabalDebMapping],
  _execDebMapping    :: [ExecDebMapping],
  _profiling         :: ProfilingStatus,
  _haddock           :: HaddockStatus,
  _official          :: OfficialStatus,
  _sourceFormat      :: SourceFormat,
  _tests             :: TestsStatus
}

-- Brief instruction to save you, dear developer from scrutinizing
-- `optparse-applicative` documentation.
--
-- There is two main types in command line parsing.
--
-- 'ReadM' is description how make object from string.
-- For every object of type 'a' with some parsing logic
-- we define auxiliary function with 'R' suffix and
-- type 'ReadM a'.
--
-- 'Parser' is type, containing information about
-- which string in command line should be converted
-- to object. Every field in 'BehaviorAdjustment'
-- and 'Flags' type of type 'b' have corresponding function
-- of type 'Parser' with suffix 'P'.


-- Here are all 'ReadM' values.

executableR :: O.ReadM (BinPkgName, D.InstallFile)
executableR = parsePair . span (/= ':') <$> O.str where
  parsePair :: (String, String) -> (BinPkgName, D.InstallFile)
  parsePair (sp, md) = let (sd, name) = splitFileName sp in
    (BinPkgName name, D.InstallFile { D.execName  = name,
                                      D.destName  = name,
                                      D.sourceDir = nothingIf ( == "./") sd,
                                      D.destDir   = case md of
                                                      (':' : dd) -> Just dd
                                                      _          -> Nothing })

binPkgNameR :: O.ReadM BinPkgName
binPkgNameR = BinPkgName <$> O.str

nameAddrR :: O.ReadM NameAddr
nameAddrR = either fail return =<< parseMaintainer <$> O.str

relationsR :: O.ReadM Relations
relationsR = either (fail . show) return =<< parseRelations <$> O.str

mappingR :: O.ReadM (String, Relations)
mappingR = span (/= ':') <$> O.str >>= \case
  (str, "") -> fail $ "Does not contains colon: `" ++ str ++ "'"
  (pkgstr, _ : relstr) -> do
    rels <- either (fail . show) return $ parseRelations relstr
    return (pkgstr, rels)

extraRelationsR :: O.ReadM (BinPkgName, Relations)
extraRelationsR = first BinPkgName <$> mappingR

cabalDebMappingR :: O.ReadM CabalDebMapping
cabalDebMappingR = CabalDebMapping . first PackageName <$> mappingR

-- Here are parser for BehaviorAdjustment and next are parsers for
-- every field of this data.  Please, keep parsers declarations in
-- same order, as are fields.

behaviorAdjustmentP :: O.Parser BehaviorAdjustment
behaviorAdjustmentP = BehaviorAdjustment <$> maintainerP
                                         <*> uploadersP
                                         <*> executableP
                                         <*> defaultPackageP
                                         <*> missingDependencyP
                                         <*> debianNameBaseP
                                         <*> debianVersionP
                                         <*> debianRevisionP
                                         <*> sourcePackageNameP
                                         <*> sourceSectionP
                                         <*> standardsVersionP
                                         <*> buildDepP
                                         <*> buildDepIndepP
                                         <*> devDepP
                                         <*> extraDependsP
                                         <*> extraConflictsP
                                         <*> extraProvidesP
                                         <*> extraReplacesP
                                         <*> extraRecommendsP
                                         <*> extraSuggestsP
                                         <*> cabalDebMappingP
                                         <*> execDebMappingP
                                         <*> profilingP
                                         <*> haddockP
                                         <*> officialP
                                         <*> sourceFormatP
                                         <*> testsP

maintainerP :: O.Parser NameAddr
maintainerP = O.option nameAddrR m where
  m = O.help helpMsg
      <> O.long "maintainer"
      <> O.short 'm'
      <> O.value (NameAddr (Just "Debian Haskell Group")
                           "pkg-haskell-maintainers@lists.alioth.debian.org")
      <> O.metavar "'NAME <EMAIL>'"
  helpMsg = "Set the `Maintainer' field in debian/control file."

uploadersP :: O.Parser [NameAddr]
uploadersP = many $ O.option nameAddrR m where
  m = O.help helpMsg
      <> O.long "uploader"
      <> O.short 'u'
      <> O.metavar "'NAME <EMAIL>'"
  helpMsg = "Add entry to `Uploaders' field in debian/control file."

executableP :: O.Parser [(BinPkgName, D.InstallFile)]
executableP = many $ O.option executableR m where
  m = O.help helpMsg
      <> O.long "executable"
      <> O.short 'e'
      <> O.metavar "SOURCEPATH[:DESTDIR]"
  helpMsg = unlines [
   "Create an individual binary package to hold this executable.",
   "Other executables and data files are gathered into a single package",
   "named `haskell-PACKAGENAME-utils'"
   ]

defaultPackageP :: O.Parser (Maybe String)
defaultPackageP = O.option (Just <$> O.str) m where
  m = O.help helpMsg
      <> O.long "default-package"
      <> O.short 'd'
      <> O.value Nothing
      <> O.metavar "PKGNAME"
  helpMsg = unlines [
    "Set the name of the catch-all package that receives",
    "all the files not included in a library package or some",
    "other executable package. By default this is `haskell-PACKAGENAME-utils'"
    ]

missingDependencyP :: O.Parser [BinPkgName]
missingDependencyP = many $ O.option binPkgNameR m where
  m = O.help helpMsg
      <> O.long "missing-dependency"
      <> O.metavar "DEB"
  helpMsg = unlines [
    "This is the counterpart to --disable-haddock.  It prevents a package",
    "from being added to the build dependencies.  This is necessary,",
    "for example, when a dependency package was built with the",
    "--disable-haddock option, because normally cabal-debian assumes",
    "that the -doc package exists and adds it as a build dependency."
    ]

debianNameBaseP :: O.Parser (Maybe DebBase)
debianNameBaseP = O.option (Just . DebBase <$> O.str) m where
  m = O.help helpMsg
      <> O.long "debian-name-base"
      <> O.short 'b'
      <> O.value Nothing
      <> O.metavar "NAME"
  helpMsg = unlines [
    "Use this name for the base of the debian binary packages - the string between",
    "'libghc-' and '-dev'. Normally this is derived from the hackage package name."
    ]

debianVersionP :: O.Parser (Maybe DebianVersion)
debianVersionP = O.option (Just . parseDebianVersion <$> O.str) m where
  m = O.help helpMsg
      <> O.long "deb-version"
      <> O.metavar "VERSION"
      <> O.value Nothing
  helpMsg = unlines [
    "Specify the version number for the debian package.",
    "This will pin the version and should be considered dangerous."
    ]

debianRevisionP :: O.Parser (Maybe Revision)
debianRevisionP = O.option (Just . Revision <$> O.str) m where
  m = O.help helpMsg
      <> O.long "revision"
      <> O.value Nothing
      <> O.metavar "REVISION"
  helpMsg = unlines [
    "Add this string to the cabal version to get the debian version number.",
    "Debian policy says this must either be empty (--revision '')",
    "or begin with a dash."
    ]

sourcePackageNameP :: O.Parser (Maybe SrcPkgName)
sourcePackageNameP = O.option (Just . SrcPkgName <$> O.str) m where
  m = O.help helpMsg
      <> O.long "source-package-name"
      <> O.short 's'
      <> O.value Nothing
      <> O.metavar "NAME"
  helpMsg = unlines [
    "Use this name for the debian source package, the name in the Source field",
    "at the top of the debian/control file, and also at the very beginning",
    "of the debian/changelog file.  By default it is haskell-<cabalname>,",
    "where the cabal package name is downcased."
    ]

sourceSectionP :: O.Parser Section
sourceSectionP = O.option (MainSection <$> O.str) m where
  m = O.help helpMsg
      <> O.long "source-section"
      <> O.short 'S'
      <> O.value (MainSection "haskell")
      <> O.metavar "SECTION"
  helpMsg = "Set the `Section' field in debian/control file."

standardsVersionP :: O.Parser StandardsVersion
standardsVersionP = O.option (parseStandardsVersion <$> O.str) m where
  m = O.help helpMsg
      <> O.long "standards-version"
      <> O.value (parseStandardsVersion "3.9.6")
      <> O.metavar "VERSION"
  helpMsg = unlines [
    "Claim compatibility to this version of the Debian policy",
    "(i.e. the value of the Standards-Version field)"
    ]

buildDepP :: O.Parser [BuildDep]
buildDepP = many $ O.option (BuildDep <$> relationsR) m where
  m = O.help helpMsg
      <> O.long "build-dep"
      <> O.metavar "RELATION"
  helpMsg = unlines [
    "Add a dependency relation to the `Build-Depends'",
    "field for this source package."
    ]

buildDepIndepP :: O.Parser [BuildDepIndep]
buildDepIndepP = many $ O.option (BuildDepIndep <$> relationsR) m where
  m = O.help helpMsg
      <> O.long "build-dep-indep"
      <> O.metavar "RELATION"
  helpMsg = unlines [
    "Add a dependency relation to the `Build-Depends-Indep'",
    "field for this source package."
    ]

devDepP :: O.Parser [DevDep]
devDepP = many $ O.option (DevDep <$> relationsR) m where
  m = O.help helpMsg
      <> O.long "dev-dep"
      <> O.metavar "RELATION"
  helpMsg = "Add an entry to the `Depends' field of the -dev package"


-- Since `depends', `conflicts' and so on options are totally same,
-- we can avoid code via this function, which, given long option name
-- makes correct O.Parser. Newtype around (BinPkgName, Relations)
-- is inferred, but there is still some duplication.
--
-- Long option name can also be inferred from Typeable instance of
-- mentioned newtype, but this would introduce some amount of
-- low-level string manipulations.
--
-- Nice to know, but now, to me, it would introduce more complexity,
-- than eliminate.
mkExtraP :: (Newtype n, O n ~ (BinPkgName, Relations))
            => String -> O.Parser [n]
mkExtraP long@(c:cr) = many $ O.option (pack <$> extraRelationsR) m where
    fieldName = toUpper c : cr
    m = O.help helpMsg
        <> O.long long
        <> O.metavar "DEB:RELATION"
    helpMsg = "Add extry to '" ++ fieldName ++ " 'field of DEB binary package"
mkExtraP "" = error "mkExtraP: empty long option"

extraDependsP :: O.Parser [ExtraDepends]
extraDependsP = mkExtraP "depends"

extraConflictsP :: O.Parser [ExtraConflicts]
extraConflictsP = mkExtraP "conflicts"

extraProvidesP :: O.Parser [ExtraProvides]
extraProvidesP = mkExtraP "conflicts"

extraReplacesP :: O.Parser [ExtraReplaces]
extraReplacesP = mkExtraP "replaces"

extraRecommendsP :: O.Parser [ExtraRecommends]
extraRecommendsP = mkExtraP "recommends"

extraSuggestsP :: O.Parser [ExtraSuggests]
extraSuggestsP = mkExtraP "suggests"

cabalDebMappingP :: O.Parser [CabalDebMapping]
cabalDebMappingP = many $ O.option cabalDebMappingR m where
  m = O.help helpMsg
      <> O.long "dep-map"
  helpMsg = unlines [
    "Specify what debian package name corresponds with a name that appears",
    "in the Extra-Library field of a cabal file,",
    "e.g. --map-dep cryptopp=libcrypto-dev."
    ]

execDebMappingP :: O.Parser [ExecDebMapping]
execDebMappingP = many $ O.option (ExecDebMapping <$> mappingR) m where
  m = O.help helpMsg
      <> O.long "exec-map"
  helpMsg = unlines [
    "Specify a mapping from the name appearing in the Build-Tool",
    "field of the cabal file to a debian binary package name,",
    "e.g. --exec-map trhsx:haskell-hsx-utils"
    ]

profilingP :: O.Parser ProfilingStatus
profilingP = O.flag ProfilingEnabled ProfilingDisabled m where
  m = O.help helpMsg
      <> O.long "disable-profiling"
  helpMsg = "Do not generate profiling (-prof) library package."

haddockP :: O.Parser HaddockStatus
haddockP = O.flag HaddockEnabled HaddockDisabled m where
  m = O.help helpMsg
      <> O.long "disable-haddock"
  helpMsg = "Do not build haddoc documentation"

officialP :: O.Parser OfficialStatus
officialP = O.flag NonOfficial Official m where
  m = O.help helpMsg
      <> O.long "official"
  helpMsg = "Follow guidelines of Debian Haskell Group"

sourceFormatP :: O.Parser SourceFormat
sourceFormatP = O.flag Quilt3 Native3 m where
  m = O.help helpMsg
      <> O.long "native"
  helpMsg = unlines [
    "Package has an no upstream tarball,",
    "write '3.0 (native)' into source/format."
    ]

testsP :: O.Parser TestsStatus
testsP = buildOnlyTestsP <|> disableTestsP

disableTestsP :: O.Parser TestsStatus
disableTestsP = O.flag TestsRun TestsDisable m where
  m = O.help "disable test suite"
      <> O.long "disable-tests"
      <> O.long "no-tests"

buildOnlyTestsP :: O.Parser TestsStatus
buildOnlyTestsP = O.flag TestsRun TestsBuild m where
  m = O.help "build, but do not run test suite"
      <> O.long "no-run-tests"
      <> O.long "disable-running-tests"

-- Here is 'Flags' parser and parsers for every it's field.

flagsP :: O.Parser Flags
flagsP = Flags <$> verbosityP
               <*> dryRunP
               <*> pure False     -- validate
               <*> pure GHC       -- CompilerFlavor
               <*> pure mempty    -- cabalFlagAssignments
               <*> pure (EnvSet {cleanOS = "/", dependOS = "/", buildOS = "/"})

verbosityP :: O.Parser Int
verbosityP = length <$> many (O.flag' () m) where
  m = O.help helpMsg
      <> O.short 'v'
      <> O.long "verbose"
  helpMsg = unlines [
    "Every instance of this flag increases amount",
    "of progress messages generated"
    ]

dryRunP :: O.Parser Bool
dryRunP = O.switch m where
  m = O.help helpMsg
      <> O.short 'n'
      <> O.long "dry-run"
  helpMsg = unlines [
    "Just compare the existing debianization",
    "to the one we would generate."
    ]

commandLineOptionsP :: O.Parser CommandLineOptions
commandLineOptionsP = CommandLineOptions <$> flagsP <*> behaviorAdjustmentP

commandLineOptionsParserInfo :: O.ParserInfo CommandLineOptions
commandLineOptionsParserInfo = O.info (O.helper <*> commandLineOptionsP) im where
  im = O.header "cabal-debian -- create debianization of cabal package"
       <> O.fullDesc
       <> O.progDescDoc (Just descDoc)
  descDoc =
    "Typical usage is run in unpacked source root directory"
    <+> linebreak <+> linebreak
    <+> indent 2 "% cabal-debian  --maintainer 'Maintainer Name <maintainer@email>'"
    <+> linebreak <+> linebreak
    <+> (string . unlines $ [
     "This will read the package's cabal file and any existing debian/changelog file and",
     "deduce what it can about the debianization, then it will create or modify files in",
     "the debian subdirectory.  Note that it will not remove any files in debian, and",
     "these could affect the operation of the debianization in unknown ways.  For this",
     "reason it is recommended either using a pristine unpacked directory each time, or else",
     "using a revision control system to revert the package to a known state before running."
     ])

-- FIXME: Separation of parsing of `BehaviorAdjustment' and performing
-- of corresponding actions is all great, but now it is pretty easy
-- to not handle particular field in `BehaviorAdjustment' field and
-- ghc will not complain.
handleBehaviorAdjustment :: (MonadIO m, Functor m) => BehaviorAdjustment -> CabalT m ()
handleBehaviorAdjustment (BehaviorAdjustment {..}) = zoom A.debInfo $ do
  forM_ _executable $ (D.executable %=) . uncurry Map.insert
  forM_ _execDebMapping $ (D.execMap %=) . uncurry Map.insert . unpack
  forM_ _missingDependency $ (D.missingDependencies %=) . Set.insert
  D.utilsPackageNameBase .= _defaultPackage
  D.noDocumentationLibrary .= (_haddock == HaddockDisabled)
  D.noProfilingLibrary .= (_profiling == ProfilingDisabled)
  D.overrideDebianNameBase .= _debianNameBase
  D.sourcePackageName .= _sourcePackageName
  D.maintainerOption .= Just _maintainer
  D.sourceFormat .= _sourceFormat
  D.revision .= unpack `fmap` _revision
  D.debVersion .= _debianVersion
  D.uploadersOption %= (++ _uploaders)
  D.extraDevDeps %= (++ concatMap unpack _devDep)
  forM_ _cabalDebMapping $ \(CabalDebMapping (PackageName pkg, rels)) -> do
    D.extraLibMap %= Map.insert pkg rels
  addExtra _extraDepends B.depends
  addExtra _extraConflicts B.conflicts
  addExtra _extraProvides B.provides
  addExtra _extraReplaces B.replaces
  addExtra _extraRecommends B.recommends
  addExtra _extraSuggests B.suggests
  case _tests of
  -- FIXME: You can't run, but not build tests. It should be type-enforced.
    TestsDisable -> do
      D.enableTests .= False
      D.runTests .= False
    TestsBuild -> do
      D.enableTests .= True
      D.runTests .= False
    TestsRun -> do
      D.enableTests .= True
      D.runTests .= True

  D.official .= (_official == Official)
  zoom D.control $ do
    S.section .= Just _sourceSection
    S.standardsVersion .= Just _standardsVersion
    S.buildDepends %= (++ concatMap unpack _buildDep)
    S.buildDepends %= (++ concatMap unpack _devDep)
    S.buildDependsIndep %= (++ concatMap unpack _buildDepIndep)

addExtra :: (MonadState D.DebInfo m, Newtype n, O n ~ (BinPkgName, Relations)) =>
            [n] -> Lens' B.PackageRelations Relations -> m ()
addExtra extra lens' = forM_ extra $ \arg -> do
  let (pkg, rel) = unpack arg
  D.binaryDebDescription pkg . B.relations . lens' %= (++ rel)

parseProgramArguments' :: [String] -> IO CommandLineOptions
parseProgramArguments' args =  O.handleParseResult result where
  prefs = O.prefs O.idm
  result = O.execParserPure prefs commandLineOptionsParserInfo args

parseProgramArguments :: IO CommandLineOptions
parseProgramArguments = defArgs >>= parseProgramArguments'

defArgs :: IO [String]
defArgs = (++) <$> getArgs <*> (fromMaybe [] . (maybeRead =<<) <$> getEnv "CABALDEBIAN")