{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
{-# OPTIONS_HADDOCK show-extensions #-}

{-|
Module: Distribution.Simple.Toolkit
Copyright: (c) 2017 Shao Cheng
License: BSD3
Maintainer: astrohavoc@gmail.com
Stability: alpha
Portability: non-portable

This module provides helper functions for writing custom @Setup.hs@ scripts.
-}

module Distribution.Simple.Toolkit (
  -- * Writing build metadata in @Setup.hs@
    userHooksWithBuildInfo
  , simpleUserHooksWithBuildInfo
  , defaultMainWithBuildInfo
  -- * Retrieving build metadata via Template Haskell
  , packageDescriptionQ
  , packageDescriptionTypedQ
  , localBuildInfoQ
  , localBuildInfoTypedQ
  -- * Convenient functions for working with build metadata
  , getComponentInstallDirs
  , getComponentBuildInfo
  , getGHCLibDir
  , runLBIProgram
  , getLBIProgramOutput
  -- * Convenient functions for working with GHC API
  , getGHCPackageDBFlags
  -- * Extra 'Program's
  , cmakeProgram
  , makeProgram
  , ninjaProgram
  ) where

import Data.Binary
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.Map as Map
import Data.List (intercalate)
import Distribution.Text
import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Setup
#if !MIN_VERSION_Cabal(2,0,0)
import qualified Distribution.Simple.InstallDirs as InstallDirs
#endif
import Distribution.System
import Distribution.PackageDescription
import Distribution.Verbosity
import DynFlags
import Language.Haskell.TH.Syntax
import System.IO.Unsafe

{-|
Attach a post-configure action to a 'UserHooks' which serializes 'PackageDescription' to @.pkg_descr.buildinfo@ and 'LocalBuildInfo' to @.lbi.buildinfo@.
They should be added to your project's @.gitignore@ file.
Don't forget to edit the <https://cabal.readthedocs.io/en/latest/developing-packages.html#custom-setup-scripts custom-setup> stanza of your project's @.cabal@ file and add @cabal-toolkit@ to the dependencies.
-}
userHooksWithBuildInfo :: UserHooks -> UserHooks
userHooksWithBuildInfo h =
  h
  { postConf =
      \args flags pkg_descr lbi -> do
        encodeFile ".pkg_descr.buildinfo" pkg_descr
        encodeFile ".lbi.buildinfo" lbi
        postConf h args flags pkg_descr lbi
  }


simpleUserHooksWithBuildInfo :: UserHooks
simpleUserHooksWithBuildInfo = userHooksWithBuildInfo simpleUserHooks

defaultMainWithBuildInfo :: IO ()
defaultMainWithBuildInfo = defaultMainWithHooks simpleUserHooksWithBuildInfo

syringe :: FilePath -> Q Type -> Q Exp
syringe p t = do
  addDependentFile p
  buf <- runIO $ LBS.readFile p
  [|unsafePerformIO $ do
      bs <-
        BS.unsafePackAddressLen
          $(lift $ LBS.length buf)
          $(pure $ LitE $ StringPrimL $ LBS.unpack buf)
      pure ((decode $ LBS.fromStrict bs) :: $(t))|]

{-|
The Template Haskell splice to retrieve 'PackageDescription'.
-}
packageDescriptionQ :: Q Exp
packageDescriptionQ = syringe ".pkg_descr.buildinfo" [t|PackageDescription|]

packageDescriptionTypedQ :: Q (TExp PackageDescription)
packageDescriptionTypedQ = unsafeTExpCoerce packageDescriptionQ

{-|
The Template Haskell splice to retrieve 'LocalBuildInfo'.
-}
localBuildInfoQ :: Q Exp
localBuildInfoQ = syringe ".lbi.buildinfo" [t|LocalBuildInfo|]

localBuildInfoTypedQ :: Q (TExp LocalBuildInfo)
localBuildInfoTypedQ = unsafeTExpCoerce localBuildInfoQ

#if !MIN_VERSION_Cabal(2,0,0)
-- | As defined in @Cabal-2.0.0.2@. See 'Distribution.Simple.InstallDirs.absoluteInstallDirs'.
absoluteComponentInstallDirs
  :: PackageDescription -> LocalBuildInfo
  -> UnitId
  -> CopyDest
  -> InstallDirs FilePath
absoluteComponentInstallDirs pkg lbi uid copydest =
  InstallDirs.absoluteInstallDirs
  (packageId pkg)
  uid
  (Distribution.Simple.compilerInfo (compiler lbi))
  copydest
  (hostPlatform lbi)
  (installDirTemplates lbi)
#endif

#if MIN_VERSION_Cabal(3,0,0)
-- getComponentLocalBuildInfo was removed in Cabal 3.
-- We simply define our own variant with the same flaws here,
-- but in terms of Cabal 3 definitions.
getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
getComponentLocalBuildInfo lbi cname =
    case Map.lookup cname (componentNameMap lbi) of
      Just [clbi] -> clbi
      Just clbis  ->
          error $ "internal error: the component name " ++ show cname
               ++ "is ambiguous.  Refers to: "
               ++ intercalate ", " (fmap (display . componentUnitId) clbis)
      Nothing ->
          error $ "internal error: there is no configuration data "
               ++ "for component " ++ show cname
#endif

{-|
Retrieve the 'InstallDirs' corresponding to a 'ComponentName', assuming that component does exist and is unique.
-}
getComponentInstallDirs ::
     PackageDescription
  -> LocalBuildInfo
  -> ComponentName
  -> InstallDirs FilePath
getComponentInstallDirs pkg_descr lbi k =
  absoluteComponentInstallDirs
    pkg_descr
    lbi
    (componentUnitId $ getComponentLocalBuildInfo lbi k)
    NoCopyDest

{-|
Retrieve the 'BuildInfo' corresponding to a 'ComponentName', assuming that component does exist and is unique.
-}
getComponentBuildInfo :: PackageDescription -> ComponentName -> BuildInfo
getComponentBuildInfo pkg_descr k =
  componentBuildInfo $ getComponent pkg_descr k

{-|
Equivalent to what you get from @ghc --print-libdir@.
-}
getGHCLibDir :: LocalBuildInfo -> FilePath
getGHCLibDir lbi = compilerProperties (compiler lbi) Map.! "LibDir"

{-|
Run a 'Program' with default 'Verbosity'.
-}
runLBIProgram :: LocalBuildInfo -> Program -> [ProgArg] -> IO ()
runLBIProgram lbi prog =
  runDbProgram
    (fromFlagOrDefault normal $ configVerbosity $ configFlags lbi)
    prog
    (withPrograms lbi)

{-|
Run a 'Program' and retrieve @stdout@ with default 'Verbosity'.
-}
getLBIProgramOutput :: LocalBuildInfo -> Program -> [ProgArg] -> IO String
getLBIProgramOutput lbi prog =
  getDbProgramOutput
    (fromFlagOrDefault normal $ configVerbosity $ configFlags lbi)
    prog
    (withPrograms lbi)


#if MIN_VERSION_Cabal(2,0,0)
{-|
Extract 'PackageDBFlag's from 'LocalBuildInfo' to put into the 'packageDBFlags' field of 'DynFlags'.
This is useful to ensure the invocation of GHC API shares the same package databases (e.g. a @stack@ snapshot)
-}
getGHCPackageDBFlags :: LocalBuildInfo -> [PackageDBFlag]
getGHCPackageDBFlags lbi =
  reverse $
  case withPackageDB lbi of
    (GlobalPackageDB:UserPackageDB:dbs)
      | all isSpecific dbs -> fmap single dbs
    (GlobalPackageDB:dbs)
      | all isSpecific dbs -> NoUserPackageDB : fmap single dbs
    dbs -> ClearPackageDBs : fmap single dbs
  where
    single (SpecificPackageDB db) = PackageDB $ PkgConfFile db
    single GlobalPackageDB = PackageDB GlobalPkgConf
    single UserPackageDB = PackageDB UserPkgConf
    isSpecific (SpecificPackageDB _) = True
    isSpecific _ = False
#else
-- 'PackageDBFlag' is a new wrapper around 'PkgConfRef' introduced in ghc-8.2.1 and Cabal-2.
-- ghc-8.0.2/Cabal-1.24 has a similar mechanism around 'extraPkgConfs' which was superseded
-- by 'packageDBFlags'.
{-|
Extract 'PkgConfRef's from 'LocalBuildInfo' to be prepended to the 'extraPkgConfs' field of 'DynFlags'.
This is useful to ensure the invocation of GHC API shares the same package databases (e.g. a @stack@ snapshot)
-}
getGHCPackageDBFlags :: LocalBuildInfo -> [PkgConfRef]
getGHCPackageDBFlags = reverse . fmap toPkgConfRef . withPackageDB
  where
    toPkgConfRef (SpecificPackageDB db) = PkgConfFile db
    toPkgConfRef GlobalPackageDB = GlobalPkgConf
    toPkgConfRef UserPackageDB = UserPkgConf
#endif

endOfFirstLineVersion :: Verbosity -> FilePath -> IO (Maybe Version)
endOfFirstLineVersion =
  findProgramVersion "--version" $ last . words . head . lines

cmakeProgram :: Program
cmakeProgram =
  (simpleProgram "cmake") {programFindVersion = endOfFirstLineVersion}

makeProgram :: Program
makeProgram =
  (simpleProgram $
   case buildOS of
     Windows -> "mingw32-make"
     _ -> "make")
  {programFindVersion = endOfFirstLineVersion}

ninjaProgram :: Program
ninjaProgram =
  (simpleProgram "ninja")
  {programFindVersion = findProgramVersion "--version" id}