-----------------------------------------------------------------------------
-- |
-- 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 (
    generatePathsModule, pkgPathEnvVar
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.System
import Distribution.Simple.Compiler
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.BuildPaths
import Distribution.Simple.Utils
import Distribution.Pretty
import Distribution.Version

import System.FilePath ( pathSeparator )

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

generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String
generatePathsModule pkg_descr lbi clbi =
   let pragmas =
            cpp_pragma
         ++ no_rebindable_syntax_pragma
         ++ ffi_pragmas
         ++ warning_pragmas

       cpp_pragma
         | supports_cpp = "{-# LANGUAGE CPP #-}\n"
         | otherwise    = ""

       -- -XRebindableSyntax is problematic because when paired with
       -- -XOverloadedLists, 'fromListN' is not in scope,
       -- or -XOverloadedStrings 'fromString' is not in scope,
       -- so we disable 'RebindableSyntax'.
       no_rebindable_syntax_pragma
         | supports_rebindable_syntax = "{-# LANGUAGE NoRebindableSyntax #-}\n"
         | otherwise                  = ""

       ffi_pragmas
        | absolute = ""
        | supports_language_pragma =
          "{-# LANGUAGE ForeignFunctionInterface #-}\n"
        | otherwise =
          "{-# OPTIONS_GHC -fffi #-}\n"

       warning_pragmas =
        "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"

       foreign_imports
        | absolute = ""
        | otherwise =
          "import Foreign\n"++
          "import Foreign.C\n"

       reloc_imports
        | reloc =
          "import System.Environment (getExecutablePath)\n"
        | otherwise = ""

       header =
        pragmas++
        "module " ++ prettyShow paths_modulename ++ " (\n"++
        "    version,\n"++
        "    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,\n"++
        "    getDataFileName, getSysconfDir\n"++
        "  ) where\n"++
        "\n"++
        foreign_imports++
        "import qualified Control.Exception as Exception\n"++
        "import Data.Version (Version(..))\n"++
        "import System.Environment (getEnv)\n"++
        reloc_imports ++
        "import Prelude\n"++
        "\n"++
        (if supports_cpp
         then
           ("#if defined(VERSION_base)\n"++
            "\n"++
            "#if MIN_VERSION_base(4,0,0)\n"++
            "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++
            "#else\n"++
            "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"++
            "#endif\n"++
            "\n"++
            "#else\n"++
            "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++
            "#endif\n")
         else
           "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n")++
        "catchIO = Exception.catch\n" ++
        "\n"++
        "version :: Version"++
        "\nversion = Version " ++ show branch ++ " []"
          where branch = versionNumbers $ packageVersion pkg_descr

       body
        | reloc =
          "\n\nbindirrel :: FilePath\n" ++
          "bindirrel = " ++ show flat_bindirreloc ++
          "\n"++
          "\ngetBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++
          "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++
          "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++
          "getDynLibDir = "++mkGetEnvOrReloc "libdir" flat_dynlibdirreloc++"\n"++
          "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++
          "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++
          "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++
          "\n"++
          "getDataFileName :: FilePath -> IO FilePath\n"++
          "getDataFileName name = do\n"++
          "  dir <- getDataDir\n"++
          "  return (dir `joinFileName` name)\n"++
          "\n"++
          get_prefix_reloc_stuff++
          "\n"++
          filename_stuff
        | absolute =
          "\nbindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n"++
          "\nbindir     = " ++ show flat_bindir ++
          "\nlibdir     = " ++ show flat_libdir ++
          "\ndynlibdir  = " ++ show flat_dynlibdir ++
          "\ndatadir    = " ++ show flat_datadir ++
          "\nlibexecdir = " ++ show flat_libexecdir ++
          "\nsysconfdir = " ++ show flat_sysconfdir ++
          "\n"++
          "\ngetBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++
          "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++
          "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++
          "getDynLibDir = "++mkGetEnvOr "dynlibdir" "return dynlibdir"++"\n"++
          "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++
          "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++
          "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\n"++
          "\n"++
          "getDataFileName :: FilePath -> IO FilePath\n"++
          "getDataFileName name = do\n"++
          "  dir <- getDataDir\n"++
          "  return (dir ++ "++path_sep++" ++ name)\n"
        | otherwise =
          "\nprefix, bindirrel :: FilePath" ++
          "\nprefix        = " ++ show flat_prefix ++
          "\nbindirrel     = " ++ show (fromMaybe (error "PathsModule.generate") flat_bindirrel) ++
          "\n\n"++
          "getBinDir :: IO FilePath\n"++
          "getBinDir = getPrefixDirRel bindirrel\n\n"++
          "getLibDir :: IO FilePath\n"++
          "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++
          "getDynLibDir :: IO FilePath\n"++
          "getDynLibDir = "++mkGetDir flat_dynlibdir flat_dynlibdirrel++"\n\n"++
          "getDataDir :: IO FilePath\n"++
          "getDataDir =  "++ mkGetEnvOr "datadir"
                              (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++
          "getLibexecDir :: IO FilePath\n"++
          "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++
          "getSysconfDir :: IO FilePath\n"++
          "getSysconfDir = "++mkGetDir flat_sysconfdir flat_sysconfdirrel++"\n\n"++
          "getDataFileName :: FilePath -> IO FilePath\n"++
          "getDataFileName name = do\n"++
          "  dir <- getDataDir\n"++
          "  return (dir `joinFileName` name)\n"++
          "\n"++
          get_prefix_stuff++
          "\n"++
          filename_stuff
   in header++body

 where
        cid = componentUnitId clbi

        InstallDirs {
          prefix     = flat_prefix,
          bindir     = flat_bindir,
          libdir     = flat_libdir,
          dynlibdir  = flat_dynlibdir,
          datadir    = flat_datadir,
          libexecdir = flat_libexecdir,
          sysconfdir = flat_sysconfdir
        } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest

        InstallDirs {
          bindir     = flat_bindirrel,
          libdir     = flat_libdirrel,
          dynlibdir  = flat_dynlibdirrel,
          datadir    = flat_datadirrel,
          libexecdir = flat_libexecdirrel,
          sysconfdir = flat_sysconfdirrel
        } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid

        flat_bindirreloc = shortRelativePath flat_prefix flat_bindir
        flat_libdirreloc = shortRelativePath flat_prefix flat_libdir
        flat_dynlibdirreloc = shortRelativePath flat_prefix flat_dynlibdir
        flat_datadirreloc = shortRelativePath flat_prefix flat_datadir
        flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir
        flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir

        mkGetDir _   (Just dirrel) = "getPrefixDirRel " ++ show dirrel
        mkGetDir dir Nothing       = "return " ++ show dir

        mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" ++
                                     " (\\_ -> getPrefixDirReloc \"" ++ dirrel ++
                                     "\")"
          where var' = pkgPathEnvVar pkg_descr var

        mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++
                              " (\\_ -> "++expr++")"
          where var' = pkgPathEnvVar pkg_descr var

        -- In several cases we cannot make relocatable installations
        absolute =
             hasLibs pkg_descr        -- we can only make progs relocatable
          || isNothing flat_bindirrel -- if the bin dir is an absolute path
          || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))

        reloc = relocatable lbi

        supportsRelocatableProgs GHC  = case buildOS of
                           Windows   -> True
                           _         -> False
        supportsRelocatableProgs GHCJS = case buildOS of
                           Windows   -> True
                           _         -> False
        supportsRelocatableProgs _    = False

        paths_modulename = autogenPathsModuleName pkg_descr

        get_prefix_stuff = get_prefix_win32 supports_cpp buildArch

        path_sep = show [pathSeparator]

        supports_cpp = supports_language_pragma
        supports_rebindable_syntax= ghc_newer_than (mkVersion [7,0,1])
        supports_language_pragma = ghc_newer_than (mkVersion [6,6,1])

        ghc_newer_than minVersion =
          case compilerCompatVersion GHC (compiler lbi) of
            Nothing -> False
            Just version -> version `withinRange` orLaterVersion minVersion

-- | Generates the name of the environment variable controlling the path
-- component of interest.
--
-- Note: The format of these strings is part of Cabal's public API;
-- changing this function constitutes a *backwards-compatibility* break.
pkgPathEnvVar :: PackageDescription
              -> String     -- ^ path component; one of \"bindir\", \"libdir\",
                            -- \"datadir\", \"libexecdir\", or \"sysconfdir\"
              -> String     -- ^ environment variable name
pkgPathEnvVar pkg_descr var =
    showPkgName (packageName pkg_descr) ++ "_" ++ var
    where
        showPkgName = map fixchar . prettyShow
        fixchar '-' = '_'
        fixchar c   = c

get_prefix_reloc_stuff :: String
get_prefix_reloc_stuff =
  "getPrefixDirReloc :: FilePath -> IO FilePath\n"++
  "getPrefixDirReloc dirRel = do\n"++
  "  exePath <- getExecutablePath\n"++
  "  let (bindir,_) = splitFileName exePath\n"++
  "  return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"

get_prefix_win32 :: Bool -> Arch -> String
get_prefix_win32 supports_cpp arch =
  "getPrefixDirRel :: FilePath -> IO FilePath\n"++
  "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++
  "  where\n"++
  "    try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++
  "        ret <- c_GetModuleFileName nullPtr buf size\n"++
  "        case ret of\n"++
  "          0 -> return (prefix `joinFileName` dirRel)\n"++
  "          _ | ret < size -> do\n"++
  "              exePath <- peekCWString buf\n"++
  "              let (bindir,_) = splitFileName exePath\n"++
  "              return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++
  "            | otherwise  -> try_size (size * 2)\n"++
  "\n"++
  (case supports_cpp of
    False -> ""
    True  -> "#if defined(i386_HOST_ARCH)\n"++
             "# define WINDOWS_CCONV stdcall\n"++
             "#elif defined(x86_64_HOST_ARCH)\n"++
             "# define WINDOWS_CCONV ccall\n"++
             "#else\n"++
             "# error Unknown mingw32 arch\n"++
             "#endif\n")++
  "foreign import " ++ cconv ++ " unsafe \"windows.h GetModuleFileNameW\"\n"++
  "  c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"
    where cconv = if supports_cpp
                     then "WINDOWS_CCONV"
                     else case arch of
                            I386 -> "stdcall"
                            X86_64 -> "ccall"
                            _ -> error "win32 supported only with I386, X86_64"

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