{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | Utility functions for reading cabal file fields through template haskell.
module Distribution.PackageDescription.TH (
    -- * Template Haskell functions
    packageVariable,
    packageVariableFrom,
    packageString,
    -- * Cabal file data structures
    -- | The data structures for the cabal file are re-exported here for ease of use.
    PackageDescription(..),
    PackageIdentifier(..),
#if MIN_VERSION_Cabal(2,0,0)
    module Distribution.Version
#else
    Version(..)
#endif
    ) where

import Distribution.PackageDescription 
import Distribution.Package
import Distribution.Version

-- Distribution.Text is deprecated and Distribution.Compat.ReadP
-- was removed in Cabal-3.0.0.0
#if MIN_VERSION_Cabal(3,0,0)
import Distribution.Pretty
#else
import Distribution.Text
import Distribution.Compat.ReadP
#endif
import Distribution.Verbosity (Verbosity, silent)
import Text.PrettyPrint
import System.Directory (getCurrentDirectory, getDirectoryContents)
import Data.List (isSuffixOf)
import Language.Haskell.TH (Q, Exp, stringE, runIO)

-- readPackageDescription was deprecated by readGenericPackageDescription
-- which was introduced in Cabal-2.0.0.2.
-- readPackageDescription was removed in Cabal-2.2.0.0
#if MIN_VERSION_Cabal(2,2,0)
#if MIN_VERSION_Cabal(3,8,0)
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
#else
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
#endif
readPkgDesc :: Verbosity -> FilePath -> IO GenericPackageDescription
readPkgDesc = Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription
#else
import Distribution.PackageDescription.Parse (readPackageDescription)
readPkgDesc = readPackageDescription
#endif
readPkgDesc :: Verbosity -> FilePath -> IO GenericPackageDescription

newtype DocString = DocString String

-- Text class was removed in Cabal-3.0.0.0
#if MIN_VERSION_Cabal(3,0,0)
instance Pretty DocString where
  pretty :: DocString -> Doc
pretty (DocString FilePath
s) =  FilePath -> Doc
text FilePath
s
#else
instance Text DocString where
  parse = DocString `fmap` (readS_to_P read)
  disp (DocString s) = text s
#endif

-- | Provides a Pretty instance for String, allowing text fields to be used
--   in `packageVariable`. Use it composed with an accessor, eg.
--       packageVariable (packageString . copyright)
packageString :: String -> DocString
packageString :: FilePath -> DocString
packageString = FilePath -> DocString
DocString

-- | Renders the package variable specified by the function.
-- The cabal file interrogated is the first one that is found 
-- in the current working directory.

#if MIN_VERSION_Cabal(3,0,0)
packageVariable :: Pretty a => (PackageDescription -> a) -> Q Exp
#else
packageVariable :: Text a => (PackageDescription -> a) -> Q Exp
#endif
packageVariable :: forall a. Pretty a => (PackageDescription -> a) -> Q Exp
packageVariable = forall b a. Pretty b => IO a -> (a -> b) -> Q Exp
renderField IO PackageDescription
currentPackageDescription

-- | Renders the package variable specified by the function, from a cabal file
-- and the given path.
#if MIN_VERSION_Cabal(3,0,0)
packageVariableFrom :: Pretty a => FilePath -> (PackageDescription -> a) -> Q Exp
#else
packageVariableFrom :: Text a => FilePath -> (PackageDescription -> a) -> Q Exp
#endif
packageVariableFrom :: forall a.
Pretty a =>
FilePath -> (PackageDescription -> a) -> Q Exp
packageVariableFrom FilePath
s = forall b a. Pretty b => IO a -> (a -> b) -> Q Exp
renderField forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenericPackageDescription -> PackageDescription
packageDescription (Verbosity -> FilePath -> IO GenericPackageDescription
readPkgDesc Verbosity
silent FilePath
s)

------
#if MIN_VERSION_Cabal(3,0,0)
renderField :: Pretty b => IO a -> (a -> b) -> Q Exp
renderField :: forall b a. Pretty b => IO a -> (a -> b) -> Q Exp
renderField IO a
pd a -> b
f = forall a. IO a -> (a -> FilePath) -> Q Exp
renderFieldS IO a
pd (forall a. Pretty a => a -> FilePath
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
#else
renderField :: Text b => IO a -> (a -> b) -> Q Exp
renderField pd f = renderFieldS pd (display . f)
#endif

renderFieldS :: IO a -> (a -> String) -> Q Exp
renderFieldS :: forall a. IO a -> (a -> FilePath) -> Q Exp
renderFieldS IO a
pd a -> FilePath
f = forall a. IO a -> Q a
runIO IO a
pd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Quote m => FilePath -> m Exp
stringE forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
f

currentPackageDescription :: IO PackageDescription
currentPackageDescription :: IO PackageDescription
currentPackageDescription = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenericPackageDescription -> PackageDescription
packageDescription forall a b. (a -> b) -> a -> b
$ do
  FilePath
dir <- IO FilePath
getCurrentDirectory
  [FilePath]
cs <- FilePath -> IO [FilePath]
cabalFiles FilePath
dir
  case [FilePath]
cs of
    (FilePath
c:[FilePath]
_) -> Verbosity -> FilePath -> IO GenericPackageDescription
readPkgDesc Verbosity
silent FilePath
c
    [] -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Couldn't find a cabal file in the current working directory (" forall a. [a] -> [a] -> [a]
++ FilePath
dir forall a. [a] -> [a] -> [a]
++ FilePath
")"

cabalFiles :: FilePath -> IO [FilePath]
cabalFiles :: FilePath -> IO [FilePath]
cabalFiles FilePath
dir = do
  [FilePath]
files <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath
".cabal" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [FilePath]
files

{-

Smart ways of getting the cabal file:
  * Get this module name, use TH.location and loc_module. Parse each
    cabal file in the cwd and look for references to this module
    in each thing.


  -}