ghc/compiler/main/SysTools.lhs

   1 -----------------------------------------------------------------------------
   2 -- Access to system tools: gcc, cp, rm etc
   3 --
   4 -- (c) The University of Glasgow 2000
   5 --
   6 -----------------------------------------------------------------------------
   7
   8 \begin{code}
   9 module SysTools (
  10         -- Initialisation
  11         initSysTools,
  12         setPgm,                 -- String -> IO ()
  13                                 -- Command-line override
  14         setDryRun,
  15
  16         packageConfigPath,      -- IO String
  17                                 -- Where package.conf is
  18
  19         -- Interface to system tools
  20         runUnlit, runCpp, runCc, -- [String] -> IO ()
  21         runMangle, runSplit,     -- [String] -> IO ()
  22         runAs, runLink,          -- [String] -> IO ()
  23         runMkDLL,
  24
  25         touch,                  -- String -> String -> IO ()
  26         copy,                   -- String -> String -> String -> IO ()
  27
  28         -- Temporary-file management
  29         setTmpDir,
  30         newTempName,
  31         cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
  32         addFilesToClean,
  33
  34         -- System interface
  35         getProcessID,           -- IO Int
  36         system,                 -- String -> IO Int
  37
  38         -- Misc
  39         showGhcUsage,           -- IO ()        Shows usage message and exits
  40         getSysMan,              -- IO String    Parallel system only
  41
  42         runSomething    -- ToDo: make private
  43  ) where
  44
  45 import DriverUtil
  46 import Config
  47 import Outputable
  48 import Panic            ( progName, GhcException(..) )
  49 import Util             ( global )
  50 import CmdLineOpts      ( dynFlag, verbosity )
  51
  52 import Exception        ( throwDyn, catchAllIO )
  53 import IO               ( hPutStr, hPutChar, hPutStrLn, hFlush, stderr )
  54 import Directory        ( doesFileExist, removeFile )
  55 import IOExts           ( IORef, readIORef, writeIORef )
  56 import Monad            ( when, unless )
  57 import System           ( system, ExitCode(..), exitWith )
  58 import CString
  59
  60 #if __GLASGOW_HASKELL__ < 500
  61 import Addr
  62 import Storable
  63 import Int
  64 #endif
  65
  66 #include "../includes/config.h"
  67
  68 #if !defined(mingw32_TARGET_OS)
  69 import qualified Posix
  70 #else
  71 import Addr             ( nullAddr )
  72 import List             ( isPrefixOf )
  73 #endif
  74
  75 #include "HsVersions.h"
  76
  77 {-# DEPRECATED runSomething "runSomething should be private to SysTools" #-}
  78
  79 \end{code}
  80
  81
  82                 The configuration story
  83                 ~~~~~~~~~~~~~~~~~~~~~~~
  84
  85 GHC needs various support files (library packages, RTS etc), plus
  86 various auxiliary programs (cp, gcc, etc).  It finds these in one
  87 of two places:
  88
  89 * When running as an *installed program*, GHC finds most of this support
  90   stuff in the installed library tree.  The path to this tree is passed
  91   to GHC via the -B flag, and given to initSysTools .
  92
  93 * When running *in-place* in a build tree, GHC finds most of this support
  94   stuff in the build tree.  The path to the build tree is, again passed
  95   to GHC via -B.
  96
  97 GHC tells which of the two is the case by seeing whether package.conf
  98 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
  99
 100
 101 SysTools.initSysProgs figures out exactly where all the auxiliary programs
 102 are, and initialises mutable variables to make it easy to call them.
 103 To to this, it makes use of definitions in Config.hs, which is a Haskell
 104 file containing variables whose value is figured out by the build system.
 105
 106 Config.hs contains two sorts of things
 107
 108   cGCC,         The *names* of the programs
 109   cCPP            e.g.  cGCC = gcc
 110   cUNLIT                cCPP = gcc -E
 111   etc           They do *not* include paths
 112
 113
 114   cUNLIT_DIR    The *path* to the directory containing unlit, split etc
 115   cSPLIT_DIR    *relative* to the root of the build tree,
 116                 for use when running *in-place* in a build tree (only)
 117
 118
 119
 120 %************************************************************************
 121 %*                                                                      *
 122 \subsection{Global variables to contain system programs}
 123 %*                                                                      *
 124 %************************************************************************
 125
 126 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
 127 (See remarks under pathnames below)
 128
 129 \begin{code}
 130 GLOBAL_VAR(v_Pgm_L,     error "pgm_L",   String)        -- unlit
 131 GLOBAL_VAR(v_Pgm_P,     error "pgm_P",   String)        -- cpp
 132 GLOBAL_VAR(v_Pgm_c,     error "pgm_c",   String)        -- gcc
 133 GLOBAL_VAR(v_Pgm_m,     error "pgm_m",   String)        -- asm code mangler
 134 GLOBAL_VAR(v_Pgm_s,     error "pgm_s",   String)        -- asm code splitter
 135 GLOBAL_VAR(v_Pgm_a,     error "pgm_a",   String)        -- as
 136 GLOBAL_VAR(v_Pgm_l,     error "pgm_l",   String)        -- ld
 137 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String)        -- mkdll
 138
 139 GLOBAL_VAR(v_Pgm_T,    error "pgm_T",    String)        -- touch
 140 GLOBAL_VAR(v_Pgm_CP,   error "pgm_CP",   String)        -- cp
 141
 142 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
 143 GLOBAL_VAR(v_Path_usage,          error "ghc_usage.txt",       String)
 144
 145 -- Parallel system only
 146 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)    -- system manager
 147 \end{code}
 148
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 \subsection{Initialisation}
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 \begin{code}
 157 initSysTools :: [String]        -- Command-line arguments starting "-B"
 158
 159              -> IO String       -- Set all the mutable variables above, holding
 160                                 --      (a) the system programs
 161                                 --      (b) the package-config file
 162                                 --      (c) the GHC usage message
 163                                 -- Return TopDir
 164
 165
 166 initSysTools minusB_args
 167   = do  { (am_installed, top_dir) <- getTopDir minusB_args
 168                 -- top_dir
 169                 --      for "installed" this is the root of GHC's support files
 170                 --      for "in-place" it is the root of the build tree
 171                 -- NB: top_dir is assumed to be in standard Unix format '/' separated
 172
 173         ; let installed_bin pgm   =  pgmPath (top_dir `slash` "bin") pgm
 174               installed     file  =  pgmPath top_dir file
 175               inplace dir   pgm   =  pgmPath (top_dir `slash` dir) pgm
 176
 177         ; let pkgconfig_path
 178                 | am_installed = installed "package.conf"
 179                 | otherwise    = inplace cGHC_DRIVER_DIR "package.conf.inplace"
 180
 181               ghc_usage_msg_path
 182                 | am_installed = installed "ghc-usage.txt"
 183                 | otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
 184
 185                 -- For all systems, unlit, split, mangle are GHC utilities
 186                 -- architecture-specific stuff is done when building Config.hs
 187               unlit_path
 188                 | am_installed = installed_bin cGHC_UNLIT
 189                 | otherwise    = inplace cGHC_UNLIT_DIR cGHC_UNLIT
 190
 191                 -- split and mangle are Perl scripts
 192               split_script
 193                 | am_installed = installed_bin cGHC_SPLIT
 194                 | otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT
 195
 196               mangle_script
 197                 | am_installed = installed_bin cGHC_MANGLER
 198                 | otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER
 199
 200         -- Check that the package config exists
 201         ; config_exists <- doesFileExist pkgconfig_path
 202         ; when (not config_exists) $
 203              throwDyn (InstallationError
 204                          ("Can't find package.conf in " ++ pkgconfig_path))
 205
 206 #if defined(mingw32_TARGET_OS)
 207         --              WINDOWS-SPECIFIC STUFF
 208         -- On Windows, gcc and friends are distributed with GHC,
 209         --      so when "installed" we look in TopDir/bin
 210         -- When "in-place" we look wherever the build-time configure
 211         --      script found them
 212         ; let cpp_path  | am_installed = installed cRAWCPP
 213                         | otherwise    = cRAWCPP
 214               gcc_path  | am_installed = installed cGCC
 215                         | otherwise    = cGCC
 216               perl_path | am_installed = installed cGHC_PERL
 217                         | otherwise    = cGHC_PERL
 218
 219         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 220         ; let touch_path  | am_installed = installed cGHC_TOUCHY
 221                           | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
 222
 223         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 224         -- a call to Perl to get the invocation of split and mangle
 225         ; let split_path  = perl_path ++ " " ++ split_script
 226               mangle_path = perl_path ++ " " ++ mangle_script
 227
 228         ; let mkdll_path = cMKDLL
 229 #else
 230         --              UNIX-SPECIFIC STUFF
 231         -- On Unix, the "standard" tools are assumed to be
 232         -- in the same place whether we are running "in-place" or "installed"
 233         -- That place is wherever the build-time configure script found them.
 234         ; let   cpp_path   = cRAWCPP
 235                 gcc_path   = cGCC
 236                 touch_path = cGHC_TOUCHY
 237                 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
 238
 239         -- On Unix, scripts are invoked using the '#!' method.  Binary
 240         -- installations of GHC on Unix place the correct line on the front
 241         -- of the script at installation time, so we don't want to wire-in
 242         -- our knowledge of $(PERL) on the host system here.
 243         ; let split_path  = split_script
 244               mangle_path = mangle_script
 245
 246 #endif
 247
 248         -- For all systems, copy and remove are provided by the host
 249         -- system; architecture-specific stuff is done when building Config.hs
 250         ; let   cp_path = cGHC_CP
 251
 252         -- Other things being equal, as and ld are simply gcc
 253         ; let   as_path  = gcc_path
 254                 ld_path  = gcc_path
 255
 256
 257         -- Initialise the global vars
 258         ; writeIORef v_Path_package_config pkgconfig_path
 259         ; writeIORef v_Path_usage          ghc_usage_msg_path
 260
 261         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 262                 -- Hans: this isn't right in general, but you can
 263                 -- elaborate it in the same way as the others
 264
 265         ; writeIORef v_Pgm_L               unlit_path
 266         ; writeIORef v_Pgm_P               cpp_path
 267         ; writeIORef v_Pgm_c               gcc_path
 268         ; writeIORef v_Pgm_m               mangle_path
 269         ; writeIORef v_Pgm_s               split_path
 270         ; writeIORef v_Pgm_a               as_path
 271         ; writeIORef v_Pgm_l               ld_path
 272         ; writeIORef v_Pgm_MkDLL           mkdll_path
 273         ; writeIORef v_Pgm_T               touch_path
 274         ; writeIORef v_Pgm_CP              cp_path
 275
 276         ; return top_dir
 277         }
 278 \end{code}
 279
 280 setPgm is called when a command-line option like
 281         -pgmLld
 282 is used to override a particular program with a new onw
 283
 284 \begin{code}
 285 setPgm :: String -> IO ()
 286 -- The string is the flag, minus the '-pgm' prefix
 287 -- So the first character says which program to override
 288
 289 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
 290 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
 291 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
 292 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
 293 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
 294 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
 295 setPgm pgm         = unknownFlagErr ("-pgm" ++ pgm)
 296 \end{code}
 297
 298
 299 \begin{code}
 300 -- Find TopDir
 301 --      for "installed" this is the root of GHC's support files
 302 --      for "in-place" it is the root of the build tree
 303 --
 304 -- Plan of action:
 305 -- 1. Set proto_top_dir
 306 --      a) look for (the last) -B flag, and use it
 307 --      b) if there are no -B flags, get the directory
 308 --         where GHC is running
 309 --
 310 -- 2. If package.conf exists in proto_top_dir, we are running
 311 --      installed; and TopDir = proto_top_dir
 312 --
 313 -- 3. Otherwise we are running in-place, so
 314 --      proto_top_dir will be /...stuff.../ghc/compiler
 315 --      Set TopDir to /...stuff..., which is the root of the build tree
 316 --
 317 -- This is very gruesome indeed
 318
 319 getTopDir :: [String]
 320           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 321                  String)        -- TopDir (in Unix format '/' separated)
 322
 323 getTopDir minusbs
 324   = do { top_dir1 <- get_proto
 325        ; let top_dir2 = unDosifyPath top_dir1   -- Convert to standard internal form
 326
 327         -- Discover whether we're running in a build tree or in an installation,
 328         -- by looking for the package configuration file.
 329        ; am_installed <- doesFileExist (top_dir2 `slash` "package.conf")
 330
 331        ; if am_installed then
 332             return (True, top_dir2)
 333          else
 334             return (False, remove_suffix top_dir2)
 335        }
 336   where
 337     get_proto | not (null minusbs)
 338               = return (drop 2 (last minusbs))  -- 2 for "-B"
 339               | otherwise
 340               = do { maybe_exec_dir <- getExecDir -- Get directory of executable
 341                    ; case maybe_exec_dir of       -- (only works on Windows;
 342                                                   --  returns Nothing on Unix)
 343                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 344                         Just dir -> return dir
 345                    }
 346
 347     remove_suffix dir   -- "/...stuff.../ghc/compiler" --> "/...stuff..."
 348         = ASSERT2( not (null p1) &&
 349                    not (null p2) &&
 350                    dir == top_dir ++ "/ghc/compiler",
 351                    text dir )
 352           top_dir
 353         where
 354          p1      = dropWhile (not . isSlash) (reverse dir)
 355          p2      = dropWhile (not . isSlash) (tail p1)  -- head is '/'
 356          top_dir = reverse (tail p2)                    -- head is '/'
 357 \end{code}
 358
 359
 360 %************************************************************************
 361 %*                                                                      *
 362 \subsection{Running an external program}
 363 n%*                                                                     *
 364 %************************************************************************
 365
 366
 367 \begin{code}
 368 runUnlit :: [String] -> IO ()
 369 runUnlit args = do p <- readIORef v_Pgm_L
 370                    runSomething "Literate pre-processor" p args
 371
 372 runCpp :: [String] -> IO ()
 373 runCpp args =   do p <- readIORef v_Pgm_P
 374                    runSomething "C pre-processor" p args
 375
 376 runCc :: [String] -> IO ()
 377 runCc args =   do p <- readIORef v_Pgm_c
 378                   runSomething "C Compiler" p args
 379
 380 runMangle :: [String] -> IO ()
 381 runMangle args = do p <- readIORef v_Pgm_m
 382                     runSomething "Mangler" p args
 383
 384 runSplit :: [String] -> IO ()
 385 runSplit args = do p <- readIORef v_Pgm_s
 386                    runSomething "Splitter" p args
 387
 388 runAs :: [String] -> IO ()
 389 runAs args = do p <- readIORef v_Pgm_a
 390                 runSomething "Assembler" p args
 391
 392 runLink :: [String] -> IO ()
 393 runLink args = do p <- readIORef v_Pgm_l
 394                   runSomething "Linker" p args
 395
 396 runMkDLL :: [String] -> IO ()
 397 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 398                    runSomething "Make DLL" p args
 399
 400 touch :: String -> String -> IO ()
 401 touch purpose arg =  do p <- readIORef v_Pgm_T
 402                         runSomething purpose p [arg]
 403
 404 copy :: String -> String -> String -> IO ()
 405 copy purpose from to = do p <- readIORef v_Pgm_CP
 406                           runSomething purpose p [from,to]
 407 \end{code}
 408
 409 \begin{code}
 410 getSysMan :: IO String  -- How to invoke the system manager
 411                         -- (parallel system only)
 412 getSysMan = readIORef v_Pgm_sysman
 413 \end{code}
 414
 415 %************************************************************************
 416 %*                                                                      *
 417 \subsection{GHC Usage message}
 418 %*                                                                      *
 419 %************************************************************************
 420
 421 Show the usage message and exit
 422
 423 \begin{code}
 424 showGhcUsage = do { usage_path <- readIORef v_Path_usage
 425                   ; usage      <- readFile usage_path
 426                   ; dump usage
 427                   ; exitWith ExitSuccess }
 428   where
 429      dump ""          = return ()
 430      dump ('$':'$':s) = hPutStr stderr progName >> dump s
 431      dump (c:s)       = hPutChar stderr c >> dump s
 432
 433 packageConfigPath = readIORef v_Path_package_config
 434 \end{code}
 435
 436
 437 %************************************************************************
 438 %*                                                                      *
 439 \subsection{Managing temporary files
 440 %*                                                                      *
 441 %************************************************************************
 442
 443 \begin{code}
 444 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 445 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 446         -- v_TmpDir has no closing '/'
 447 \end{code}
 448
 449 \begin{code}
 450 setTmpDir dir = writeIORef v_TmpDir dir
 451
 452 cleanTempFiles :: Int -> IO ()
 453 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
 454                          removeTmpFiles verb fs
 455
 456 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
 457 cleanTempFilesExcept verb dont_delete
 458   = do fs <- readIORef v_FilesToClean
 459        let leftovers = filter (`notElem` dont_delete) fs
 460        removeTmpFiles verb leftovers
 461        writeIORef v_FilesToClean dont_delete
 462
 463
 464 -- find a temporary name that doesn't already exist.
 465 newTempName :: Suffix -> IO FilePath
 466 newTempName extn
 467   = do x <- getProcessID
 468        tmp_dir <- readIORef v_TmpDir
 469        findTempName tmp_dir x
 470   where
 471     findTempName tmp_dir x
 472       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 473            b  <- doesFileExist filename
 474            if b then findTempName tmp_dir (x+1)
 475                 else do add v_FilesToClean filename -- clean it up later
 476                         return filename
 477
 478 addFilesToClean :: [FilePath] -> IO ()
 479 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 480 addFilesToClean files = mapM_ (add v_FilesToClean) files
 481
 482 removeTmpFiles :: Int -> [FilePath] -> IO ()
 483 removeTmpFiles verb fs
 484   = traceCmd "Deleting temp files"
 485              ("Deleting: " ++ unwords fs)
 486              (mapM_ rm fs)
 487   where
 488     rm f = removeFile f `catchAllIO`
 489                 (\exn -> hPutStrLn stderr ("Warning: deleting non-existent " ++ f) >>
 490                          return ())
 491
 492 \end{code}
 493
 494
 495 %************************************************************************
 496 %*                                                                      *
 497 \subsection{Running a program}
 498 %*                                                                      *
 499 %************************************************************************
 500
 501 \begin{code}
 502 GLOBAL_VAR(v_Dry_run, False, Bool)
 503
 504 setDryRun :: IO ()
 505 setDryRun = writeIORef v_Dry_run True
 506
 507 -----------------------------------------------------------------------------
 508 -- Running an external program
 509
 510 runSomething :: String          -- For -v message
 511              -> String          -- Command name (possibly a full path)
 512                                 --      assumed already dos-ified
 513              -> [String]        -- Arguments
 514                                 --      runSomething will dos-ify them
 515              -> IO ()
 516
 517 runSomething phase_name pgm args
 518  = traceCmd phase_name cmd_line $
 519    do   { exit_code <- system cmd_line
 520         ; if exit_code /= ExitSuccess
 521           then throwDyn (PhaseFailed phase_name exit_code)
 522           else return ()
 523         }
 524   where
 525     cmd_line = unwords (pgm : dosifyPaths args)
 526         -- The pgm is already in native format
 527
 528 traceCmd :: String -> String -> IO () -> IO ()
 529 -- a) trace the command (at two levels of verbosity)
 530 -- b) don't do it at all if dry-run is set
 531 traceCmd phase_name cmd_line action
 532  = do   { verb <- dynFlag verbosity
 533         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 534         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 535         ; hFlush stderr
 536
 537            -- Test for -n flag
 538         ; n <- readIORef v_Dry_run
 539         ; unless n $ do {
 540
 541            -- And run it!
 542         ; action `catchAllIO` handle_exn verb
 543         }}
 544   where
 545     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 546                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
 547                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 548 \end{code}
 549
 550
 551 %************************************************************************
 552 %*                                                                      *
 553 \subsection{Path names}
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 We maintain path names in Unix form ('/'-separated) right until
 558 the last moment.  On Windows we dos-ify them just before passing them
 559 to the Windows command.
 560
 561 The alternative, of using '/' consistently on Unix and '\' on Windows,
 562 proved quite awkward.  There were a lot more calls to dosifyPath,
 563 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 564 interpreted a command line 'foo\baz' as 'foobaz'.
 565
 566 \begin{code}
 567 -----------------------------------------------------------------------------
 568 -- Convert filepath into MSDOS form.
 569
 570 dosifyPaths :: [String] -> [String]
 571 -- dosifyPaths does two things
 572 -- a) change '/' to '\'
 573 -- b) remove initial '/cygdrive/'
 574
 575 unDosifyPath :: String -> String
 576 -- Just change '\' to '/'
 577
 578 pgmPath :: String               -- Directory string in Unix format
 579         -> String               -- Program name with no directory separators
 580                                 --      (e.g. copy /y)
 581         -> String               -- Program invocation string in native format
 582
 583
 584
 585 #if defined(mingw32_TARGET_OS)
 586
 587 --------------------- Windows version ------------------
 588 unDosifyPath xs = xs
 589
 590 dosifyPaths xs = map dosifyPath xs
 591
 592 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
 593
 594 dosifyPath stuff
 595   = subst '/' '\\' real_stuff
 596  where
 597    -- fully convince myself that /cygdrive/ prefixes cannot
 598    -- really appear here.
 599   cygdrive_prefix = "/cygdrive/"
 600
 601   real_stuff
 602     | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
 603     | otherwise = stuff
 604
 605 #else
 606
 607 --------------------- Unix version ---------------------
 608 dosifyPaths  ps = ps
 609 unDosifyPath xs = subst '\\' '/' xs
 610 pgmPath dir pgm = dir ++ '/' : pgm
 611 --------------------------------------------------------
 612 #endif
 613
 614 subst a b ls = map (\ x -> if x == a then b else x) ls
 615 \end{code}
 616
 617
 618 -----------------------------------------------------------------------------
 619    Path name construction
 620
 621 \begin{code}
 622 slash            :: String -> String -> String
 623 absPath, relPath :: [String] -> String
 624
 625 isSlash '/'   = True
 626 isSlash other = False
 627
 628 relPath [] = ""
 629 relPath xs = foldr1 slash xs
 630
 631 absPath xs = "" `slash` relPath xs
 632
 633 slash s1 s2 = s1 ++ ('/' : s2)
 634 \end{code}
 635
 636
 637 %************************************************************************
 638 %*                                                                      *
 639 \subsection{Support code}
 640 %*                                                                      *
 641 %************************************************************************
 642
 643 \begin{code}
 644 -----------------------------------------------------------------------------
 645 -- Define       myGetProcessId :: IO Int
 646 --              getExecDir     :: IO (Maybe String)
 647
 648 #ifdef mingw32_TARGET_OS
 649 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 650
 651 #if __GLASGOW_HASKELL__ >= 500
 652 foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> CString -> IO Int32
 653 getExecDir :: IO (Maybe String)
 654 getExecDir = do len <- getCurrentDirectory 0 nullAddr
 655                 buf <- mallocArray (fromIntegral len)
 656                 ret <- getCurrentDirectory len buf
 657                 if ret == 0 then return Nothing
 658                             else do s <- peekCString buf
 659                                     destructArray (fromIntegral len) buf
 660                                     return (Just s)
 661 #else
 662 foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> Addr -> IO Int32
 663 getExecDir :: IO (Maybe String)
 664 getExecDir = do len <- getCurrentDirectory 0 nullAddr
 665                 buf <- malloc (fromIntegral len)
 666                 ret <- getCurrentDirectory len buf
 667                 if ret == 0 then return Nothing
 668                             else do s <- unpackCStringIO buf
 669                                     free buf
 670                                     return (Just s)
 671 #endif
 672 #else
 673 getProcessID :: IO Int
 674 getProcessID = Posix.getProcessID
 675 getExecDir :: IO (Maybe String) = do return Nothing
 676 #endif
 677 \end{code}