-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Build.Macros
-- Copyright   :  Isaac Jones 2003-2005,
--                Ross Paterson 2006,
--                Duncan Coutts 2007-2008
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Generating the Paths_pkgname module.
--
-- This is a module that Cabal generates for the benefit of packages. It
-- enables them to find their version number and find any installed data files
-- at runtime. This code should probably be split off into another module.
--
module Distribution.Simple.Build.PathsModule (
    generate, pkgPathEnvVar
  ) where

import Distribution.System
         ( OS(Windows), buildOS )
import Distribution.Simple.Compiler
         ( CompilerFlavor(..), compilerFlavor, compilerVersion )
import Distribution.Package
         ( packageId, packageName, packageVersion )
import Distribution.PackageDescription
         ( PackageDescription(..), hasLibs )
import Distribution.Simple.LocalBuildInfo
         ( LocalBuildInfo(..), InstallDirs(..)
         , absoluteInstallDirs, prefixRelativeInstallDirs )
import Distribution.Simple.Setup ( CopyDest(NoCopyDest) )
import Distribution.Simple.BuildPaths
         ( autogenModuleName )
import Distribution.Text
         ( display )
import Distribution.Version
         ( Version(..), orLaterVersion, withinRange )

import System.FilePath
         ( pathSeparator )
import Data.Maybe
         ( fromJust, isNothing )

-- ------------------------------------------------------------
-- * Building Paths_<pkg>.hs
-- ------------------------------------------------------------

generate :: PackageDescription -> LocalBuildInfo -> String
generate pkg_descr lbi =
   let pragmas
        | absolute :: Boolabsolute (||) :: Bool -> Bool -> Bool|| isHugs :: BoolisHugs = ""
        | supports_language_pragma :: Boolsupports_language_pragma =
          "{-# LANGUAGE ForeignFunctionInterface #-}\n"
        | otherwise :: Boolotherwise =
          "{-# OPTIONS_GHC -fffi #-}\n"(++) :: [a] -> [a] -> [a]++
          "{-# OPTIONS_JHC -fffi #-}\n"

       foreign_imports
        | absolute :: Boolabsolute = ""
        | isHugs :: BoolisHugs = "import System.Environment\n"
        | otherwise :: Boolotherwise =
          "import Foreign\n"(++) :: [a] -> [a] -> [a]++
          "import Foreign.C\n"

       header =
        pragmas :: [Char]pragmas(++) :: [a] -> [a] -> [a]++
        "module " (++) :: [a] -> [a] -> [a]++ display :: Text a => a -> Stringdisplay paths_modulename :: ModuleNamepaths_modulename (++) :: [a] -> [a] -> [a]++ " (\n"(++) :: [a] -> [a] -> [a]++
        "    version,\n"(++) :: [a] -> [a] -> [a]++
        "    getBinDir, getLibDir, getDataDir, getLibexecDir,\n"(++) :: [a] -> [a] -> [a]++
        "    getDataFileName\n"(++) :: [a] -> [a] -> [a]++
        "  ) where\n"(++) :: [a] -> [a] -> [a]++
        "\n"(++) :: [a] -> [a] -> [a]++
        foreign_imports :: [Char]foreign_imports(++) :: [a] -> [a] -> [a]++
        "import qualified Control.Exception as Exception\n"(++) :: [a] -> [a] -> [a]++
        "import Data.Version (Version(..))\n"(++) :: [a] -> [a] -> [a]++
        "import System.Environment (getEnv)"(++) :: [a] -> [a] -> [a]++
        "\n"(++) :: [a] -> [a] -> [a]++
        "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"(++) :: [a] -> [a] -> [a]++
        "catchIO = Exception.catch\n" (++) :: [a] -> [a] -> [a]++
        "\n"(++) :: [a] -> [a] -> [a]++
        "\nversion :: Version"(++) :: [a] -> [a] -> [a]++
        "\nversion = " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow (packageVersion :: Package pkg => pkg -> VersionpackageVersion pkg_descr :: PackageDescriptionpkg_descr)

       body
        | absolute :: Boolabsolute =
          "\nbindir, libdir, datadir, libexecdir :: FilePath\n"(++) :: [a] -> [a] -> [a]++
          "\nbindir     = " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow flat_bindir :: FilePathflat_bindir (++) :: [a] -> [a] -> [a]++
          "\nlibdir     = " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow flat_libdir :: FilePathflat_libdir (++) :: [a] -> [a] -> [a]++
          "\ndatadir    = " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow flat_datadir :: FilePathflat_datadir (++) :: [a] -> [a] -> [a]++
          "\nlibexecdir = " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow flat_libexecdir :: FilePathflat_libexecdir (++) :: [a] -> [a] -> [a]++
          "\n"(++) :: [a] -> [a] -> [a]++
          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"(++) :: [a] -> [a] -> [a]++
          "getBinDir = "(++) :: [a] -> [a] -> [a]++mkGetEnvOr :: String -> [Char] -> [Char]mkGetEnvOr "bindir" "return bindir"(++) :: [a] -> [a] -> [a]++"\n"(++) :: [a] -> [a] -> [a]++
          "getLibDir = "(++) :: [a] -> [a] -> [a]++mkGetEnvOr :: String -> [Char] -> [Char]mkGetEnvOr "libdir" "return libdir"(++) :: [a] -> [a] -> [a]++"\n"(++) :: [a] -> [a] -> [a]++
          "getDataDir = "(++) :: [a] -> [a] -> [a]++mkGetEnvOr :: String -> [Char] -> [Char]mkGetEnvOr "datadir" "return datadir"(++) :: [a] -> [a] -> [a]++"\n"(++) :: [a] -> [a] -> [a]++
          "getLibexecDir = "(++) :: [a] -> [a] -> [a]++mkGetEnvOr :: String -> [Char] -> [Char]mkGetEnvOr "libexecdir" "return libexecdir"(++) :: [a] -> [a] -> [a]++"\n"(++) :: [a] -> [a] -> [a]++
          "\n"(++) :: [a] -> [a] -> [a]++
          "getDataFileName :: FilePath -> IO FilePath\n"(++) :: [a] -> [a] -> [a]++
          "getDataFileName name = do\n"(++) :: [a] -> [a] -> [a]++
          "  dir <- getDataDir\n"(++) :: [a] -> [a] -> [a]++
          "  return (dir ++ "(++) :: [a] -> [a] -> [a]++path_sep :: Stringpath_sep(++) :: [a] -> [a] -> [a]++" ++ name)\n"
        | otherwise :: Boolotherwise =
          "\nprefix, bindirrel :: FilePath" (++) :: [a] -> [a] -> [a]++
          "\nprefix        = " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow flat_prefix :: FilePathflat_prefix (++) :: [a] -> [a] -> [a]++
          "\nbindirrel     = " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow (fromJust :: Maybe a -> afromJust flat_bindirrel :: Maybe FilePathflat_bindirrel) (++) :: [a] -> [a] -> [a]++
          "\n\n"(++) :: [a] -> [a] -> [a]++
          "getBinDir :: IO FilePath\n"(++) :: [a] -> [a] -> [a]++
          "getBinDir = getPrefixDirRel bindirrel\n\n"(++) :: [a] -> [a] -> [a]++
          "getLibDir :: IO FilePath\n"(++) :: [a] -> [a] -> [a]++
          "getLibDir = "(++) :: [a] -> [a] -> [a]++mkGetDir :: a -> Maybe a -> [Char]mkGetDir flat_libdir :: FilePathflat_libdir flat_libdirrel :: Maybe FilePathflat_libdirrel(++) :: [a] -> [a] -> [a]++"\n\n"(++) :: [a] -> [a] -> [a]++
          "getDataDir :: IO FilePath\n"(++) :: [a] -> [a] -> [a]++
          "getDataDir =  "(++) :: [a] -> [a] -> [a]++ mkGetEnvOr :: String -> [Char] -> [Char]mkGetEnvOr "datadir"
                              (mkGetDir :: a -> Maybe a -> [Char]mkGetDir flat_datadir :: FilePathflat_datadir flat_datadirrel :: Maybe FilePathflat_datadirrel)(++) :: [a] -> [a] -> [a]++"\n\n"(++) :: [a] -> [a] -> [a]++
          "getLibexecDir :: IO FilePath\n"(++) :: [a] -> [a] -> [a]++
          "getLibexecDir = "(++) :: [a] -> [a] -> [a]++mkGetDir :: a -> Maybe a -> [Char]mkGetDir flat_libexecdir :: FilePathflat_libexecdir flat_libexecdirrel :: Maybe FilePathflat_libexecdirrel(++) :: [a] -> [a] -> [a]++"\n\n"(++) :: [a] -> [a] -> [a]++
          "getDataFileName :: FilePath -> IO FilePath\n"(++) :: [a] -> [a] -> [a]++
          "getDataFileName name = do\n"(++) :: [a] -> [a] -> [a]++
          "  dir <- getDataDir\n"(++) :: [a] -> [a] -> [a]++
          "  return (dir `joinFileName` name)\n"(++) :: [a] -> [a] -> [a]++
          "\n"(++) :: [a] -> [a] -> [a]++
          get_prefix_stuff :: [Char]get_prefix_stuff(++) :: [a] -> [a] -> [a]++
          "\n"(++) :: [a] -> [a] -> [a]++
          filename_stuff :: Stringfilename_stuff
   in header :: [Char]header(++) :: [a] -> [a] -> [a]++body :: [Char]body

 where
        InstallDirs {
          prefix     = flat_prefix,
          bindir     = flat_bindir,
          libdir     = flat_libdir,
          datadir    = flat_datadir,
          libexecdir = flat_libexecdir
        } = absoluteInstallDirs ::
  PackageDescription
  -> LocalBuildInfo
  -> CopyDest
  -> InstallDirs FilePathabsoluteInstallDirs pkg_descr :: PackageDescriptionpkg_descr lbi :: LocalBuildInfolbi NoCopyDest :: CopyDestNoCopyDest
        InstallDirs {
          bindir     = flat_bindirrel,
          libdir     = flat_libdirrel,
          datadir    = flat_datadirrel,
          libexecdir = flat_libexecdirrel,
          progdir    = flat_progdirrel
        } = prefixRelativeInstallDirs ::
  PackageId -> LocalBuildInfo -> InstallDirs (Maybe FilePath)prefixRelativeInstallDirs (packageId :: Package pkg => pkg -> PackageIdentifierpackageId pkg_descr :: PackageDescriptionpkg_descr) lbi :: LocalBuildInfolbi

        mkGetDir _   (Just dirrel) = "getPrefixDirRel " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow dirrel :: adirrel
        mkGetDir dir Nothing       = "return " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow dir :: adir

        mkGetEnvOr var expr = "catchIO (getEnv \""(++) :: [a] -> [a] -> [a]++var' :: Stringvar'(++) :: [a] -> [a] -> [a]++"\")"(++) :: [a] -> [a] -> [a]++
                              " (\\_ -> "(++) :: [a] -> [a] -> [a]++expr :: [Char]expr(++) :: [a] -> [a] -> [a]++")"
          where var' = pkgPathEnvVar :: PackageDescription -> String -> StringpkgPathEnvVar pkg_descr :: PackageDescriptionpkg_descr var :: Stringvar

        -- In several cases we cannot make relocatable installations
        absolute =
             hasLibs :: PackageDescription -> BoolhasLibs pkg_descr :: PackageDescriptionpkg_descr        -- we can only make progs relocatable
          (||) :: Bool -> Bool -> Bool|| isNothing :: Maybe a -> BoolisNothing flat_bindirrel :: Maybe FilePathflat_bindirrel -- if the bin dir is an absolute path
          (||) :: Bool -> Bool -> Bool|| (isHugs :: BoolisHugs (&&) :: Bool -> Bool -> Bool&& isNothing :: Maybe a -> BoolisNothing flat_progdirrel :: Maybe FilePathflat_progdirrel)
          (||) :: Bool -> Bool -> Bool|| not :: Bool -> Boolnot (supportsRelocatableProgs :: CompilerFlavor -> BoolsupportsRelocatableProgs (compilerFlavor :: Compiler -> CompilerFlavorcompilerFlavor (compiler :: LocalBuildInfo -> Compilercompiler lbi :: LocalBuildInfolbi)))

        supportsRelocatableProgs Hugs = True :: BoolTrue
        supportsRelocatableProgs GHC  = case buildOS :: OSbuildOS of
                           Windows   -> True :: BoolTrue
                           _         -> False :: BoolFalse
        supportsRelocatableProgs _    = False :: BoolFalse

        paths_modulename = autogenModuleName :: PackageDescription -> ModuleNameautogenModuleName pkg_descr :: PackageDescriptionpkg_descr

        isHugs = compilerFlavor :: Compiler -> CompilerFlavorcompilerFlavor (compiler :: LocalBuildInfo -> Compilercompiler lbi :: LocalBuildInfolbi) (==) :: Eq a => a -> a -> Bool== Hugs :: CompilerFlavorHugs
        get_prefix_stuff
          | isHugs :: BoolisHugs    = "progdirrel :: String\n"(++) :: [a] -> [a] -> [a]++
                        "progdirrel = "(++) :: [a] -> [a] -> [a]++show :: Show a => a -> Stringshow (fromJust :: Maybe a -> afromJust flat_progdirrel :: Maybe FilePathflat_progdirrel)(++) :: [a] -> [a] -> [a]++"\n\n"(++) :: [a] -> [a] -> [a]++
                        get_prefix_hugs :: Stringget_prefix_hugs
          | otherwise :: Boolotherwise = get_prefix_win32 :: Stringget_prefix_win32

        path_sep = show :: Show a => a -> Stringshow [pathSeparator :: CharpathSeparator]

        supports_language_pragma =
          compilerFlavor :: Compiler -> CompilerFlavorcompilerFlavor (compiler :: LocalBuildInfo -> Compilercompiler lbi :: LocalBuildInfolbi) (==) :: Eq a => a -> a -> Bool== GHC :: CompilerFlavorGHC (&&) :: Bool -> Bool -> Bool&&
            (compilerVersion :: Compiler -> VersioncompilerVersion (compiler :: LocalBuildInfo -> Compilercompiler lbi :: LocalBuildInfolbi)
              withinRange :: Version -> VersionRange -> Bool`withinRange` orLaterVersion :: Version -> VersionRangeorLaterVersion (Version :: [Int] -> [String] -> VersionVersion [6,6,1] [] :: [a][]))

-- | Generates the name of the environment variable controlling the path
-- component of interest.
pkgPathEnvVar :: PackageDescription
              -> String     -- ^ path component; one of \"bindir\", \"libdir\",
                            -- \"datadir\" or \"libexecdir\"
              -> String     -- ^ environment variable name
pkgPathEnvVar pkg_descr var =
    showPkgName :: PackageName -> [Char]showPkgName (packageName :: Package pkg => pkg -> PackageNamepackageName pkg_descr :: PackageDescriptionpkg_descr) (++) :: [a] -> [a] -> [a]++ "_" (++) :: [a] -> [a] -> [a]++ var :: Stringvar
    where
        showPkgName = map :: (a -> b) -> [a] -> [b]map fixchar :: Char -> Charfixchar (.) :: (b -> c) -> (a -> b) -> a -> c. display :: Text a => a -> Stringdisplay
        fixchar '-' = '_'
        fixchar c   = c :: Charc

get_prefix_win32 :: String
get_prefix_win32 =
  "getPrefixDirRel :: FilePath -> IO FilePath\n"(++) :: [a] -> [a] -> [a]++
  "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"(++) :: [a] -> [a] -> [a]++
  "  where\n"(++) :: [a] -> [a] -> [a]++
  "    try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"(++) :: [a] -> [a] -> [a]++
  "        ret <- c_GetModuleFileName nullPtr buf size\n"(++) :: [a] -> [a] -> [a]++
  "        case ret of\n"(++) :: [a] -> [a] -> [a]++
  "          0 -> return (prefix `joinFileName` dirRel)\n"(++) :: [a] -> [a] -> [a]++
  "          _ | ret < size -> do\n"(++) :: [a] -> [a] -> [a]++
  "              exePath <- peekCWString buf\n"(++) :: [a] -> [a] -> [a]++
  "              let (bindir,_) = splitFileName exePath\n"(++) :: [a] -> [a] -> [a]++
  "              return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"(++) :: [a] -> [a] -> [a]++
  "            | otherwise  -> try_size (size * 2)\n"(++) :: [a] -> [a] -> [a]++
  "\n"(++) :: [a] -> [a] -> [a]++
  "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"(++) :: [a] -> [a] -> [a]++
  "  c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"


get_prefix_hugs :: String
get_prefix_hugs =
  "getPrefixDirRel :: FilePath -> IO FilePath\n"(++) :: [a] -> [a] -> [a]++
  "getPrefixDirRel dirRel = do\n"(++) :: [a] -> [a] -> [a]++
  "  mainPath <- getProgName\n"(++) :: [a] -> [a] -> [a]++
  "  let (progPath,_) = splitFileName mainPath\n"(++) :: [a] -> [a] -> [a]++
  "  let (progdir,_) = splitFileName progPath\n"(++) :: [a] -> [a] -> [a]++
  "  return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n"

filename_stuff :: String
filename_stuff =
  "minusFileName :: FilePath -> String -> FilePath\n"(++) :: [a] -> [a] -> [a]++
  "minusFileName dir \"\"     = dir\n"(++) :: [a] -> [a] -> [a]++
  "minusFileName dir \".\"    = dir\n"(++) :: [a] -> [a] -> [a]++
  "minusFileName dir suffix =\n"(++) :: [a] -> [a] -> [a]++
  "  minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"(++) :: [a] -> [a] -> [a]++
  "\n"(++) :: [a] -> [a] -> [a]++
  "joinFileName :: String -> String -> FilePath\n"(++) :: [a] -> [a] -> [a]++
  "joinFileName \"\"  fname = fname\n"(++) :: [a] -> [a] -> [a]++
  "joinFileName \".\" fname = fname\n"(++) :: [a] -> [a] -> [a]++
  "joinFileName dir \"\"    = dir\n"(++) :: [a] -> [a] -> [a]++
  "joinFileName dir fname\n"(++) :: [a] -> [a] -> [a]++
  "  | isPathSeparator (last dir) = dir++fname\n"(++) :: [a] -> [a] -> [a]++
  "  | otherwise                  = dir++pathSeparator:fname\n"(++) :: [a] -> [a] -> [a]++
  "\n"(++) :: [a] -> [a] -> [a]++
  "splitFileName :: FilePath -> (String, String)\n"(++) :: [a] -> [a] -> [a]++
  "splitFileName p = (reverse (path2++drive), reverse fname)\n"(++) :: [a] -> [a] -> [a]++
  "  where\n"(++) :: [a] -> [a] -> [a]++
  "    (path,drive) = case p of\n"(++) :: [a] -> [a] -> [a]++
  "       (c:':':p') -> (reverse p',[':',c])\n"(++) :: [a] -> [a] -> [a]++
  "       _          -> (reverse p ,\"\")\n"(++) :: [a] -> [a] -> [a]++
  "    (fname,path1) = break isPathSeparator path\n"(++) :: [a] -> [a] -> [a]++
  "    path2 = case path1 of\n"(++) :: [a] -> [a] -> [a]++
  "      []                           -> \".\"\n"(++) :: [a] -> [a] -> [a]++
  "      [_]                          -> path1   -- don't remove the trailing slash if \n"(++) :: [a] -> [a] -> [a]++
  "                                              -- there is only one character\n"(++) :: [a] -> [a] -> [a]++
  "      (c:path') | isPathSeparator c -> path'\n"(++) :: [a] -> [a] -> [a]++
  "      _                             -> path1\n"(++) :: [a] -> [a] -> [a]++
  "\n"(++) :: [a] -> [a] -> [a]++
  "pathSeparator :: Char\n"(++) :: [a] -> [a] -> [a]++
  (case buildOS :: OSbuildOS of
       Windows   -> "pathSeparator = '\\\\'\n"
       _         -> "pathSeparator = '/'\n") (++) :: [a] -> [a] -> [a]++
  "\n"(++) :: [a] -> [a] -> [a]++
  "isPathSeparator :: Char -> Bool\n"(++) :: [a] -> [a] -> [a]++
  (case buildOS :: OSbuildOS of
       Windows   -> "isPathSeparator c = c == '/' || c == '\\\\'\n"
       _         -> "isPathSeparator c = c == '/'\n")