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