-- ------------------------------------------------------ --
-- Copyright © 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>
-- Copyright © 2014 AlephCloud Systems, Inc.
-- ------------------------------------------------------ --

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_HADDOCK show-extensions #-}

-- | This module contains a @Setup.hs@ script that hooks into the cabal build
-- process at the end of the configuration phase and generates a module with
-- package information for each component of the cabal package.
--
-- The modules are created in the /autogen/ build directories where also the
-- @Path_@ modules are created by cabal's simple build setup.
--
-- = Usage as Setup Script
--
-- There are three ways how this module can be used:
--
-- 1. Copy the code of this module into a file called @Setup.hs@ in the root
--    directory of your package.
--
-- 2. If the /configuration-tools/ package is already installed in the system
--    where the build is done, following code can be used as @Setup.hs@ script:
--
--    > module Main (main) where
--    >
--    > import Configuration.Utils.Setup
--
-- 3. For usage within a more complex @Setup.hs@ script you shall import this
--    module qualified and use the 'mkPkgInfoModules' function. For example:
--
--    > module Main (main) where
--    >
--    > import qualified Configuration.Utils.Setup as ConfTools
--    >
--    > main :: IO ()
--    > main = defaultMainWithHooks (ConfTools.mkPkgInfoModules simpleUserHooks)
--    >
--
-- With all methods the field @Build-Type@ in the package description (cabal) file
-- must be set to @Custom@:
--
-- > Build-Type: Custom
--
--
-- = Integration With "Configuration.Utils"
--
-- You can integrate the information provided by the @PkgInfo@ modules with the
-- command line interface of an application by importing the respective module
-- for the component and using the
-- 'Configuration.Utils.runWithPkgInfoConfiguration' function from the module
-- "Configuration.Utils" as show in the following example:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > {-# LANGUAGE FlexibleInstances #-}
-- >
-- > module Main
-- > ( main
-- > ) where
-- >
-- > import Configuration.Utils
-- > import PkgInfo
-- >
-- > instance FromJSON (() -> ()) where parseJSON _ = pure id
-- >
-- > mainInfo :: ProgramInfo ()
-- > mainInfo = programInfo "Hello World" (pure id) ()
-- >
-- > main :: IO ()
-- > main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world"
--
-- With that the resulting application supports the following additional command
-- line options:
--
-- [@--version@, @-v@]
--     prints the version of the application and exits.
--
-- [@--info@, @-i@]
--     prints a short info message for the application and exits.
--
-- [@--long-info@]
--     print a detailed info message for the application and exits.
--     Beside component name, package name, version, revision, and copyright
--     the message also contain information about the compiler that
--     was used for the build, the build architecture, build flags,
--     the author, the license type, and a list of all direct and
--     indirect dependencies along with their licenses and copyrights.
--
-- [@--license@]
--     prints the text of the lincense of the application and exits.
--
module Configuration.Utils.Setup
( main
, mkPkgInfoModules
) where

#ifndef MIN_VERSION_Cabal
#define MIN_VERSION_Cabal(a,b,c) 0
#endif

import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.Setup
import qualified Distribution.InstalledPackageInfo as I
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.BuildPaths
import Distribution.Simple.PackageIndex
import Distribution.Text

#if MIN_VERSION_Cabal(2,0,0)
import qualified Distribution.Compat.Graph as Graph
import Distribution.Types.LocalBuildInfo
import Distribution.Types.UnqualComponentName
#endif

#if MIN_VERSION_Cabal(2,2,0)
import Distribution.Pretty
#endif

import System.Process

import Control.Applicative
import Control.Monad

import qualified Data.ByteString as B
import Data.ByteString.Char8 (pack)
import Data.Char (isSpace)
import Data.List (intercalate)
import Data.Monoid

import Prelude hiding (readFile, writeFile)

import System.Directory
    ( doesFileExist
    , doesDirectoryExist
    , createDirectoryIfMissing
    , getCurrentDirectory
    , canonicalizePath
    )
import System.FilePath (isDrive, (</>), takeDirectory)
import System.Exit (ExitCode(ExitSuccess))

-- | Include this function when your setup doesn't contain any
-- extra functionality.
--
main :: IO ()
main = defaultMainWithHooks (mkPkgInfoModules simpleUserHooks)

-- | Modifies the given record of hooks by adding functionality that
-- creates a package info module for each component of the cabal package.
--
-- This function is intended for usage in more complex @Setup.hs@ scripts.
-- If your setup doesn't contain any other function you can just import
-- the 'main' function from this module.
--
-- The modules are created in the /autogen/ build directories where also the
-- @Path_@ modules are created by cabal's simple build setup.
--
mkPkgInfoModules
    :: UserHooks
    -> UserHooks
mkPkgInfoModules hooks = hooks
    { postConf = mkPkgInfoModulesPostConf (postConf hooks)
    }

-- -------------------------------------------------------------------------- --
-- Compat Implementations

#if !MIN_VERSION_Cabal(2,0,0)
unFlagName :: FlagName -> String
unFlagName (FlagName s) = s
#endif

#if !MIN_VERSION_Cabal(2,2,0)
unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment = id
#endif

#if !MIN_VERSION_Cabal(2,2,0)
prettyShow :: Text a => a -> String
prettyShow = display
#endif

#if !MIN_VERSION_Cabal(2,0,0)
-- unUnqualComponentName :: UnqualComponentName -> String
unUnqualComponentName :: String -> String
unUnqualComponentName = id
#endif

prettyLicense :: I.InstalledPackageInfo -> String
#if MIN_VERSION_Cabal(2,2,0)
prettyLicense = either prettyShow prettyShow . I.license
#else
prettyLicense = prettyShow . I.license
#endif

-- -------------------------------------------------------------------------- --
-- Cabal 2.0

#if MIN_VERSION_Cabal(2,0,0)
mkPkgInfoModulesPostConf
    :: (Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ())
    -> Args
    -> ConfigFlags
    -> PackageDescription
    -> LocalBuildInfo
    -> IO ()
mkPkgInfoModulesPostConf hook args flags pkgDesc bInfo = do
    mapM_ (updatePkgInfoModule pkgDesc bInfo) $ Graph.toList $ componentGraph bInfo
    hook args flags pkgDesc bInfo

updatePkgInfoModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO ()
updatePkgInfoModule pkgDesc bInfo clbInfo = do
    createDirectoryIfMissing True dirName
    moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo
    updateFile fileName moduleBytes

    -- legacy module
    legacyModuleBytes <- pkgInfoModule legacyModuleName cName pkgDesc bInfo
    updateFile legacyFileName legacyModuleBytes

  where
    dirName = autogenComponentModulesDir bInfo clbInfo
    cName = unUnqualComponentName <$> componentNameString (componentLocalName clbInfo)

    moduleName = pkgInfoModuleName
    fileName = dirName ++ "/" ++ moduleName ++ ".hs"

    legacyModuleName = legacyPkgInfoModuleName cName
    legacyFileName = dirName ++ "/" ++ legacyModuleName ++ ".hs"

-- -------------------------------------------------------------------------- --
-- Cabal 1.24

#else

mkPkgInfoModulesPostConf
    :: (Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ())
    -> Args
    -> ConfigFlags
    -> PackageDescription
    -> LocalBuildInfo
    -> IO ()
mkPkgInfoModulesPostConf hook args flags pkgDesc bInfo = do
    mkModules
    hook args flags pkgDesc bInfo
  where
    mkModules = mapM_ (f . \(a,_,_) -> a) $ componentsConfigs bInfo
    f cname = case cname of
        CLibName -> updatePkgInfoModule Nothing pkgDesc bInfo
        CExeName s -> updatePkgInfoModule (Just $ unUnqualComponentName s) pkgDesc bInfo
        CTestName s -> updatePkgInfoModule (Just $ unUnqualComponentName s) pkgDesc bInfo
        CBenchName s -> updatePkgInfoModule (Just $ unUnqualComponentName s) pkgDesc bInfo

updatePkgInfoModule :: Maybe String -> PackageDescription -> LocalBuildInfo -> IO ()
updatePkgInfoModule cName pkgDesc bInfo = do
    createDirectoryIfMissing True dirName
    moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo
    updateFile fileName moduleBytes
  where
    dirName = autogenModulesDir bInfo
    moduleName = legacyPkgInfoModuleName cName
    fileName = dirName ++ "/" ++ moduleName ++ ".hs"
#endif

-- -------------------------------------------------------------------------- --
-- Generate PkgInfo Module

pkgInfoModuleName :: String
pkgInfoModuleName = "PkgInfo"

updateFile :: FilePath -> B.ByteString -> IO ()
updateFile fileName content = do
    doesFileExist fileName >>= \x -> if x
    then do
        oldRevisionFile <- B.readFile fileName
        when (oldRevisionFile /= content) update
    else
        update
  where
    update = B.writeFile fileName content

legacyPkgInfoModuleName :: Maybe String -> String
legacyPkgInfoModuleName Nothing = "PkgInfo"
legacyPkgInfoModuleName (Just cn) = "PkgInfo_" ++ map tr cn
  where
    tr '-' = '_'
    tr c = c

trim :: String -> String
trim = f . f
  where f = reverse . dropWhile isSpace

getVCS :: IO (Maybe RepoType)
getVCS = getCurrentDirectory >>= getVcsOfDir

getVcsOfDir :: FilePath -> IO (Maybe RepoType)
getVcsOfDir d = do
    canonicDir <- canonicalizePath d
    doesDirectoryExist (canonicDir </> ".hg") >>= \x0 -> if x0
    then return (Just Mercurial)
    else doesDirectoryExist (canonicDir </> ".git") >>= \x1 -> if x1
        then return $ Just Git
        else if isDrive canonicDir
            then return Nothing
            else getVcsOfDir (takeDirectory canonicDir)

pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString
pkgInfoModule moduleName cName pkgDesc bInfo = do
    (tag, revision, branch) <- getVCS >>= \x -> case x of
        Just Mercurial -> hgInfo
        Just Git -> gitInfo
        _ -> noVcsInfo

    let vcsBranch = if branch == "default" || branch == "master" then "" else branch
        vcsVersion = intercalate "-" . filter (/= "") $ [tag, revision, vcsBranch]
        flags = map (unFlagName . fst) . filter snd . unFlagAssignment . configConfigurationsFlags . configFlags $ bInfo

    licenseString <- licenseFilesText pkgDesc

    return $ B.intercalate "\n"
            [ "{-# LANGUAGE OverloadedStrings #-}"
            , "{-# LANGUAGE RankNTypes #-}"
            , ""
            , "module " <> pack moduleName <> " " <> deprecatedMsg <> " where"
            , ""
            , "    import Data.String (IsString)"
            , "    import Data.Monoid"
            , "    import Prelude hiding ((<>))"
            , ""
            , "    name :: IsString a => Maybe a"
            , "    name = " <> maybe "Nothing" (\x -> "Just \"" <> pack x <> "\"") cName
            , ""
            , "    tag :: IsString a => a"
            , "    tag = \"" <> pack tag <> "\""
            , ""
            , "    revision :: IsString a => a"
            , "    revision = \"" <> pack revision <> "\""
            , ""
            , "    branch :: IsString a => a"
            , "    branch = \"" <> pack branch <> "\""
            , ""
            , "    branch' :: IsString a => a"
            , "    branch' = \"" <> pack vcsBranch <> "\""
            , ""
            , "    vcsVersion :: IsString a => a"
            , "    vcsVersion = \"" <> pack vcsVersion <> "\""
            , ""
            , "    compiler :: IsString a => a"
            , "    compiler = \"" <> (pack . display . compilerId . compiler) bInfo <> "\""
            , ""
            , "    flags :: IsString a => [a]"
            , "    flags = " <> (pack . show) flags
            , ""
            , "    optimisation :: IsString a => a"
            , "    optimisation = \"" <> (displayOptimisationLevel . withOptimization) bInfo <> "\""
            , ""
            , "    arch :: IsString a => a"
            , "    arch = \"" <> (pack . display . hostPlatform) bInfo <> "\""
            , ""
            , "    license :: IsString a => a"
            , "    license = \"" <> (pack . prettyShow . license) pkgDesc <> "\""
            , ""
            , "    licenseText :: IsString a => a"
            , "    licenseText = " <> (pack . show) licenseString
            , ""
            , "    copyright :: IsString a => a"
            , "    copyright = " <> (pack . show . copyright) pkgDesc
            , ""
            , "    author :: IsString a => a"
            , "    author = \"" <> (pack . author) pkgDesc <> "\""
            , ""
            , "    homepage :: IsString a => a"
            , "    homepage = \"" <> (pack . homepage) pkgDesc <> "\""
            , ""
            , "    package :: IsString a => a"
            , "    package = \"" <> (pack . display . package) pkgDesc <> "\""
            , ""
            , "    packageName :: IsString a => a"
            , "    packageName = \"" <> (pack . display . packageName) pkgDesc <> "\""
            , ""
            , "    packageVersion :: IsString a => a"
            , "    packageVersion = \"" <> (pack . display . packageVersion) pkgDesc <> "\""
            , ""
            , "    dependencies :: IsString a => [a]"
            , "    dependencies = " <> (pack . show . map (display . packageId) . allPackages . installedPkgs) bInfo
            , ""
            , "    dependenciesWithLicenses :: IsString a => [a]"
            , "    dependenciesWithLicenses = " <> (pack . show . map pkgIdWithLicense . allPackages . installedPkgs) bInfo
            , ""
            , "    versionString :: (Monoid a, IsString a) => a"
            , "    versionString = case name of"
            , "        Nothing -> package <> \" (revision \" <> vcsVersion <> \")\""
            , "        Just n -> n <> \"-\" <> packageVersion <> \" (package \" <> package <> \" revision \" <> vcsVersion <> \")\""
            , ""
            , "    info :: (Monoid a, IsString a) => a"
            , "    info = versionString <> \"\\n\" <> copyright"
            , ""
            , "    longInfo :: (Monoid a, IsString a) => a"
            , "    longInfo = info <> \"\\n\\n\""
            , "        <> \"Author: \" <> author <> \"\\n\""
            , "        <> \"License: \" <> license <> \"\\n\""
            , "        <> \"Homepage: \" <> homepage <> \"\\n\""
            , "        <> \"Build with: \" <> compiler <> \" (\" <> arch <> \")\" <> \"\\n\""
            , "        <> \"Build flags: \" <> mconcat (map (\\x -> \" \" <> x) flags) <> \"\\n\""
            , "        <> \"Optimisation: \" <> optimisation <> \"\\n\\n\""
            , "        <> \"Dependencies:\\n\" <> mconcat (map (\\x -> \"    \" <> x <> \"\\n\") dependenciesWithLicenses)"
            , ""
            , "    pkgInfo :: (Monoid a, IsString a) => (a, a, a, a)"
            , "    pkgInfo ="
            , "        ( info"
            , "        , longInfo"
            , "        , versionString"
            , "        , licenseText"
            , "        )"
            , ""
            ]
  where
    displayOptimisationLevel NoOptimisation = "none"
    displayOptimisationLevel NormalOptimisation = "normal"
    displayOptimisationLevel MaximumOptimisation = "maximum"

    deprecatedMsg = if moduleName /= pkgInfoModuleName
        then "{-# DEPRECATED \"Update to Cabal 2.0 or later and use just PkgInfo as module name.\" #-}"
        else ""

licenseFilesText :: PackageDescription -> IO B.ByteString
licenseFilesText pkgDesc =
    B.intercalate "\n------------------------------------------------------------\n" <$> mapM fileText
        (licenseFiles pkgDesc)
  where
    fileText file = doesFileExist file >>= \x -> if x
        then B.readFile file
        else return ""

hgInfo :: IO (String, String, String)
hgInfo = do
    tag <- trim <$> readProcess "hg" ["id", "-r", "max(ancestors(\".\") and tag())", "-t"] ""
    rev <- trim <$> readProcess "hg" ["id", "-i"] ""
    branch <- trim <$> readProcess "hg" ["id", "-b"] ""
    return (tag, rev, branch)

gitInfo :: IO (String, String, String)
gitInfo = do
    tag <- do
        (exitCode, out, _err) <- readProcessWithExitCode "git" ["describe", "--exact-match", "--tags", "--abbrev=0"] ""
        case exitCode of
            ExitSuccess -> return $ trim out
            _ -> return ""
    rev <- trim <$> readProcess "git" ["rev-parse", "--short", "HEAD"] ""
    branch <- trim <$> readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] ""
    return (tag, rev, branch)

noVcsInfo :: IO (String, String, String)
noVcsInfo = return ("", "", "")

pkgIdWithLicense :: I.InstalledPackageInfo -> String
pkgIdWithLicense a = (display . packageId) a
    ++ " ["
    ++ prettyLicense a
    ++ (if cr /= "" then ", " ++ cr else "")
    ++ "]"
  where
    cr = (unwords . words . I.copyright) a