PathsModule.hs 8.97 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
-----------------------------------------------------------------------------
-- |
-- 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
  ) where

import Distribution.System
         ( OS(Windows), buildOS )
import Distribution.Simple.Compiler
         ( CompilerFlavor(..), compilerFlavor )
import Distribution.Package
         ( 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 System.FilePath
         ( pathSeparator )
import Data.Maybe
         ( fromJust, isNothing )

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

generate :: PackageDescription -> LocalBuildInfo -> String
generate pkg_descr lbi =
   let pragmas
        | absolute || isHugs = ""
        | otherwise =
          "{-# LANGUAGE ForeignFunctionInterface #-}\n" ++
          "{-# OPTIONS_GHC -fffi #-}\n"++
          "{-# OPTIONS_JHC -fffi #-}\n"

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

       header =
        pragmas++
        "module " ++ display paths_modulename ++ " (\n"++
        "    version,\n"++
        "    getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++
        "    getDataFileName\n"++
        "  ) where\n"++
        "\n"++
        foreign_imports++
        "import Data.Version (Version(..))\n"++
        "import System.Environment (getEnv)"++
        "\n"++
        "\nversion :: Version"++
        "\nversion = " ++ show (packageVersion pkg_descr)++
        "\n"

       body
        | absolute =
          "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++
          "\nbindir     = " ++ show flat_bindir ++
          "\nlibdir     = " ++ show flat_libdir ++
          "\ndatadir    = " ++ show flat_datadir ++
          "\nlibexecdir = " ++ show flat_libexecdir ++
          "\n"++
          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++
          "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++
          "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++
          "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++
          "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\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 (fromJust 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"++
          "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"++
          "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
        InstallDirs {
          prefix     = flat_prefix,
          bindir     = flat_bindir,
          libdir     = flat_libdir,
          datadir    = flat_datadir,
          libexecdir = flat_libexecdir
        } = absoluteInstallDirs pkg_descr lbi NoCopyDest
        InstallDirs {
          bindir     = flat_bindirrel,
          libdir     = flat_libdirrel,
          datadir    = flat_datadirrel,
          libexecdir = flat_libexecdirrel,
          progdir    = flat_progdirrel
        } = prefixRelativeInstallDirs pkg_descr lbi

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

        mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"++
                              " (\\_ -> "++expr++")"
142
143
144
145
          where var' = showPkgName (packageName pkg_descr) ++ "_" ++ var
                showPkgName = map fixchar . display
                fixchar '-' = '_'
                fixchar c   = c
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235

        -- 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)))

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

        paths_modulename = autogenModuleName pkg_descr

        isHugs = compilerFlavor (compiler lbi) == Hugs
        get_prefix_stuff
          | isHugs    = "progdirrel :: String\n"++
                        "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++
                        get_prefix_hugs
          | otherwise = get_prefix_win32

        path_sep = show [pathSeparator]

get_prefix_win32 :: String
get_prefix_win32 =
  "getPrefixDirRel :: FilePath -> IO FilePath\n"++
  "getPrefixDirRel dirRel = do \n"++
  "  let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.\n"++
  "  buf <- mallocArray len\n"++
  "  ret <- getModuleFileName nullPtr buf len\n"++
  "  if ret == 0 \n"++
  "     then do free buf;\n"++
  "             return (prefix `joinFileName` dirRel)\n"++
  "     else do exePath <- peekCString buf\n"++
  "             free buf\n"++
  "             let (bindir,_) = splitFileName exePath\n"++
  "             return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++
  "\n"++
  "foreign import stdcall unsafe \"windows.h GetModuleFileNameA\"\n"++
  "  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n"

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

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")