summaryrefslogtreecommitdiff
path: root/compat
diff options
context:
space:
mode:
Diffstat (limited to 'compat')
-rw-r--r--compat/Compat/Directory.hs131
-rw-r--r--compat/Compat/RawSystem.hs156
-rw-r--r--compat/Compat/Unicode.hs66
-rw-r--r--compat/Distribution/Compat/FilePath.hs3
-rw-r--r--compat/Distribution/Compat/ReadP.hs3
-rw-r--r--compat/Distribution/Compiler.hs3
-rw-r--r--compat/Distribution/GetOpt.hs3
-rw-r--r--compat/Distribution/InstalledPackageInfo.hs3
-rw-r--r--compat/Distribution/License.hs4
-rw-r--r--compat/Distribution/Package.hs3
-rw-r--r--compat/Distribution/ParseUtils.hs3
-rw-r--r--compat/Distribution/Version.hs3
-rw-r--r--compat/Language/Haskell/Extension.hs3
-rw-r--r--compat/Makefile101
-rw-r--r--compat/README32
-rw-r--r--compat/System/Directory/Internals.hs4
-rw-r--r--compat/cbits/directory.c96
-rw-r--r--compat/cbits/rawSystem.c140
-rw-r--r--compat/cbits/unicode.c3
-rw-r--r--compat/compat.mk44
-rw-r--r--compat/include/directory.h13
21 files changed, 817 insertions, 0 deletions
diff --git a/compat/Compat/Directory.hs b/compat/Compat/Directory.hs
new file mode 100644
index 0000000000..e6e4cd4a2c
--- /dev/null
+++ b/compat/Compat/Directory.hs
@@ -0,0 +1,131 @@
+{-# OPTIONS -cpp #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Compat.Directory
+-- Copyright : (c) The University of Glasgow 2001-2004
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- Functions from System.Directory that aren't present in older versions
+-- of that library.
+--
+-----------------------------------------------------------------------------
+
+module Compat.Directory (
+ getAppUserDataDirectory,
+ copyFile,
+ findExecutable,
+ createDirectoryIfMissing
+ ) where
+
+#include "../../includes/ghcconfig.h"
+
+import System.Environment (getEnv)
+import System.Directory.Internals
+#if __GLASGOW_HASKELL__ > 600
+import Control.Exception ( bracket )
+import Control.Monad ( when )
+import Foreign.Marshal.Alloc ( allocaBytes )
+import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose)
+import System.IO.Error ( try )
+import GHC.IOBase ( IOException(..), IOErrorType(..) )
+#else
+import System.IO ( try )
+#endif
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
+import Foreign.Ptr
+import Foreign.C
+#endif
+import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
+
+getAppUserDataDirectory :: String -> IO FilePath
+getAppUserDataDirectory appName = do
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
+ allocaBytes long_path_size $ \pPath -> do
+ r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
+ when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory")
+ s <- peekCString pPath
+ return (s++'\\':appName)
+#else
+ path <- getEnv "HOME"
+ return (path++'/':'.':appName)
+#endif
+
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
+foreign import ccall unsafe "directory.h __hscore_getFolderPath"
+ c_SHGetFolderPath :: Ptr ()
+ -> CInt
+ -> Ptr ()
+ -> CInt
+ -> CString
+ -> IO CInt
+
+-- __compat_long_path_size defined in cbits/directory.c
+foreign import ccall unsafe "directory.h __compat_long_path_size"
+ long_path_size :: Int
+
+foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
+
+raiseUnsupported loc =
+ ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
+#endif
+
+
+copyFile :: FilePath -> FilePath -> IO ()
+copyFile fromFPath toFPath =
+#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
+ do readFile fromFPath >>= writeFile toFPath
+ try (getPermissions fromFPath >>= setPermissions toFPath)
+ return ()
+#else
+ (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
+ bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
+ allocaBytes bufferSize $ \buffer -> do
+ copyContents hFrom hTo buffer
+ try (getPermissions fromFPath >>= setPermissions toFPath)
+ return ()) `catch` (ioError . changeFunName)
+ where
+ bufferSize = 1024
+
+ changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
+
+ copyContents hFrom hTo buffer = do
+ count <- hGetBuf hFrom buffer bufferSize
+ when (count > 0) $ do
+ hPutBuf hTo buffer count
+ copyContents hFrom hTo buffer
+#endif
+
+
+findExecutable :: String -> IO (Maybe FilePath)
+findExecutable binary = do
+ path <- getEnv "PATH"
+ search (parseSearchPath path)
+ where
+#ifdef mingw32_HOST_OS
+ fileName = binary `joinFileExt` "exe"
+#else
+ fileName = binary
+#endif
+
+ search :: [FilePath] -> IO (Maybe FilePath)
+ search [] = return Nothing
+ search (d:ds) = do
+ let path = d `joinFileName` fileName
+ b <- doesFileExist path
+ if b then return (Just path)
+ else search ds
+
+createDirectoryIfMissing :: Bool -- ^ Create its parents too?
+ -> FilePath -- ^ The path to the directory you want to make
+ -> IO ()
+createDirectoryIfMissing parents file = do
+ b <- doesDirectoryExist file
+ case (b,parents, file) of
+ (_, _, "") -> return ()
+ (True, _, _) -> return ()
+ (_, True, _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
+ (_, False, _) -> createDirectory file
diff --git a/compat/Compat/RawSystem.hs b/compat/Compat/RawSystem.hs
new file mode 100644
index 0000000000..f0f8aa3ac7
--- /dev/null
+++ b/compat/Compat/RawSystem.hs
@@ -0,0 +1,156 @@
+{-# OPTIONS -cpp #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Compat.RawSystem
+-- Copyright : (c) The University of Glasgow 2001-2004
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- This is an implementation of rawSystem for use on older versions of GHC
+-- which had missing or buggy implementations of this function.
+--
+-----------------------------------------------------------------------------
+
+module Compat.RawSystem (rawSystem) where
+
+#include "../../includes/ghcconfig.h"
+
+#if __GLASGOW_HASKELL__ >= 603
+
+import System.Cmd (rawSystem)
+
+#else /* to end of file */
+
+import System.Exit
+import Foreign
+import Foreign.C
+
+{- |
+The computation @'rawSystem' cmd args@ runs the operating system command
+whose file name is @cmd@, passing it the arguments @args@. It
+bypasses the shell, so that @cmd@ should see precisely the argument
+strings @args@, with no funny escaping or shell meta-syntax expansion.
+(Unix users will recognise this behaviour
+as @execvp@, and indeed that's how it's implemented.)
+It will therefore behave more portably between operating systems than 'system'.
+
+The return codes are the same as for 'system'.
+-}
+
+rawSystem :: FilePath -> [String] -> IO ExitCode
+
+{- -------------------------------------------------------------------------
+ IMPORTANT IMPLEMENTATION NOTES
+ (see also libraries/base/cbits/rawSystem.c)
+
+On Unix, rawSystem is easy to implement: use execvp.
+
+On Windows it's more tricky. We use CreateProcess, passing a single
+command-line string (lpCommandLine) as its argument. (CreateProcess
+is well documented on http://msdn.microsoft/com.)
+
+ - It parses the beginning of the string to find the command. If the
+ file name has embedded spaces, it must be quoted, using double
+ quotes thus
+ "foo\this that\cmd" arg1 arg2
+
+ - The invoked command can in turn access the entire lpCommandLine string,
+ and the C runtime does indeed do so, parsing it to generate the
+ traditional argument vector argv[0], argv[1], etc. It does this
+ using a complex and arcane set of rules which are described here:
+
+ http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp
+
+ (if this URL stops working, you might be able to find it by
+ searching for "Parsing C Command-Line Arguments" on MSDN. Also,
+ the code in the Microsoft C runtime that does this translation
+ is shipped with VC++).
+
+
+Our goal in rawSystem is to take a command filename and list of
+arguments, and construct a string which inverts the translatsions
+described above, such that the program at the other end sees exactly
+the same arguments in its argv[] that we passed to rawSystem.
+
+This inverse translation is implemented by 'translate' below.
+
+Here are some pages that give informations on Windows-related
+limitations and deviations from Unix conventions:
+
+ http://support.microsoft.com/default.aspx?scid=kb;en-us;830473
+ Command lines and environment variables effectively limited to 8191
+ characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x):
+
+ http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp
+ Command-line substitution under Windows XP. IIRC these facilities (or at
+ least a large subset of them) are available on Win NT and 2000. Some
+ might be available on Win 9x.
+
+ http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp
+ How CMD.EXE processes command lines.
+
+
+Note: CreateProcess does have a separate argument (lpApplicationName)
+with which you can specify the command, but we have to slap the
+command into lpCommandLine anyway, so that argv[0] is what a C program
+expects (namely the application name). So it seems simpler to just
+use lpCommandLine alone, which CreateProcess supports.
+
+----------------------------------------------------------------------------- -}
+
+#ifndef mingw32_HOST_OS
+
+rawSystem cmd args =
+ withCString cmd $ \pcmd ->
+ withMany withCString (cmd:args) $ \cstrs ->
+ withArray0 nullPtr cstrs $ \arr -> do
+ status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmd arr)
+ case status of
+ 0 -> return ExitSuccess
+ n -> return (ExitFailure n)
+
+foreign import ccall unsafe "rawSystem"
+ c_rawSystem :: CString -> Ptr CString -> IO Int
+
+#else
+
+-- On Windows, the command line is passed to the operating system as
+-- a single string. Command-line parsing is done by the executable
+-- itself.
+rawSystem cmd args = do
+ -- NOTE: 'cmd' is assumed to contain the application to run _only_,
+ -- as it'll be quoted surrounded in quotes here.
+ let cmdline = translate cmd ++ concat (map ((' ':) . translate) args)
+ withCString cmdline $ \pcmdline -> do
+ status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline)
+ case status of
+ 0 -> return ExitSuccess
+ n -> return (ExitFailure n)
+
+translate :: String -> String
+translate str@('"':_) = str -- already escaped.
+ -- ToDo: this case is wrong. It is only here because we
+ -- abuse the system in GHC's SysTools by putting arguments into
+ -- the command name; at some point we should fix it up and remove
+ -- the case above.
+translate str = '"' : snd (foldr escape (True,"\"") str)
+ where escape '"' (b, str) = (True, '\\' : '"' : str)
+ escape '\\' (True, str) = (True, '\\' : '\\' : str)
+ escape '\\' (False, str) = (False, '\\' : str)
+ escape c (b, str) = (False, c : str)
+ -- See long comment above for what this function is trying to do.
+ --
+ -- The Bool passed back along the string is True iff the
+ -- rest of the string is a sequence of backslashes followed by
+ -- a double quote.
+
+foreign import ccall unsafe "rawSystem"
+ c_rawSystem :: CString -> IO Int
+
+#endif
+
+#endif
+
diff --git a/compat/Compat/Unicode.hs b/compat/Compat/Unicode.hs
new file mode 100644
index 0000000000..2637fac818
--- /dev/null
+++ b/compat/Compat/Unicode.hs
@@ -0,0 +1,66 @@
+{-# OPTIONS -cpp #-}
+module Compat.Unicode (
+ GeneralCategory(..), generalCategory, isPrint, isUpper
+ ) where
+
+#if __GLASGOW_HASKELL__ > 604
+
+import Data.Char (GeneralCategory(..), generalCategory,isPrint,isUpper)
+
+#else
+
+import Foreign.C ( CInt )
+import Data.Char ( ord )
+
+-- | Unicode General Categories (column 2 of the UnicodeData table)
+-- in the order they are listed in the Unicode standard.
+
+data GeneralCategory
+ = UppercaseLetter -- Lu Letter, Uppercase
+ | LowercaseLetter -- Ll Letter, Lowercase
+ | TitlecaseLetter -- Lt Letter, Titlecase
+ | ModifierLetter -- Lm Letter, Modifier
+ | OtherLetter -- Lo Letter, Other
+ | NonSpacingMark -- Mn Mark, Non-Spacing
+ | SpacingCombiningMark -- Mc Mark, Spacing Combining
+ | EnclosingMark -- Me Mark, Enclosing
+ | DecimalNumber -- Nd Number, Decimal
+ | LetterNumber -- Nl Number, Letter
+ | OtherNumber -- No Number, Other
+ | ConnectorPunctuation -- Pc Punctuation, Connector
+ | DashPunctuation -- Pd Punctuation, Dash
+ | OpenPunctuation -- Ps Punctuation, Open
+ | ClosePunctuation -- Pe Punctuation, Close
+ | InitialQuote -- Pi Punctuation, Initial quote
+ | FinalQuote -- Pf Punctuation, Final quote
+ | OtherPunctuation -- Po Punctuation, Other
+ | MathSymbol -- Sm Symbol, Math
+ | CurrencySymbol -- Sc Symbol, Currency
+ | ModifierSymbol -- Sk Symbol, Modifier
+ | OtherSymbol -- So Symbol, Other
+ | Space -- Zs Separator, Space
+ | LineSeparator -- Zl Separator, Line
+ | ParagraphSeparator -- Zp Separator, Paragraph
+ | Control -- Cc Other, Control
+ | Format -- Cf Other, Format
+ | Surrogate -- Cs Other, Surrogate
+ | PrivateUse -- Co Other, Private Use
+ | NotAssigned -- Cn Other, Not Assigned
+ deriving (Eq, Ord, Enum, Read, Show, Bounded)
+
+-- | Retrieves the general Unicode category of the character.
+generalCategory :: Char -> GeneralCategory
+generalCategory c = toEnum (wgencat (fromIntegral (ord c)))
+
+foreign import ccall unsafe "u_gencat"
+ wgencat :: CInt -> Int
+
+isPrint c = iswprint (fromIntegral (ord c)) /= 0
+isUpper c = iswupper (fromIntegral (ord c)) /= 0
+
+foreign import ccall unsafe "u_iswprint"
+ iswprint :: CInt -> CInt
+
+foreign import ccall unsafe "u_iswupper"
+ iswupper :: CInt -> CInt
+#endif
diff --git a/compat/Distribution/Compat/FilePath.hs b/compat/Distribution/Compat/FilePath.hs
new file mode 100644
index 0000000000..2dbd337b67
--- /dev/null
+++ b/compat/Distribution/Compat/FilePath.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Distribution/Compat/FilePath.hs"
+-- dummy comment
diff --git a/compat/Distribution/Compat/ReadP.hs b/compat/Distribution/Compat/ReadP.hs
new file mode 100644
index 0000000000..5fc69da3da
--- /dev/null
+++ b/compat/Distribution/Compat/ReadP.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Distribution/Compat/ReadP.hs"
+-- dummy comment
diff --git a/compat/Distribution/Compiler.hs b/compat/Distribution/Compiler.hs
new file mode 100644
index 0000000000..b5a2f68f1e
--- /dev/null
+++ b/compat/Distribution/Compiler.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Distribution/Compiler.hs"
+-- dummy comment
diff --git a/compat/Distribution/GetOpt.hs b/compat/Distribution/GetOpt.hs
new file mode 100644
index 0000000000..7da2e30431
--- /dev/null
+++ b/compat/Distribution/GetOpt.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Distribution/GetOpt.hs"
+-- dummy comment
diff --git a/compat/Distribution/InstalledPackageInfo.hs b/compat/Distribution/InstalledPackageInfo.hs
new file mode 100644
index 0000000000..03f509216a
--- /dev/null
+++ b/compat/Distribution/InstalledPackageInfo.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Distribution/InstalledPackageInfo.hs"
+-- dummy comment
diff --git a/compat/Distribution/License.hs b/compat/Distribution/License.hs
new file mode 100644
index 0000000000..31b1b271a6
--- /dev/null
+++ b/compat/Distribution/License.hs
@@ -0,0 +1,4 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Distribution/License.hs"
+
+-- dummy comment
diff --git a/compat/Distribution/Package.hs b/compat/Distribution/Package.hs
new file mode 100644
index 0000000000..d40171eec5
--- /dev/null
+++ b/compat/Distribution/Package.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Distribution/Package.hs"
+-- dummy comment
diff --git a/compat/Distribution/ParseUtils.hs b/compat/Distribution/ParseUtils.hs
new file mode 100644
index 0000000000..f5bf266a95
--- /dev/null
+++ b/compat/Distribution/ParseUtils.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Distribution/ParseUtils.hs"
+-- dummy comment
diff --git a/compat/Distribution/Version.hs b/compat/Distribution/Version.hs
new file mode 100644
index 0000000000..1140c03cbd
--- /dev/null
+++ b/compat/Distribution/Version.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Distribution/Version.hs"
+-- dummy comment
diff --git a/compat/Language/Haskell/Extension.hs b/compat/Language/Haskell/Extension.hs
new file mode 100644
index 0000000000..410a07b4d6
--- /dev/null
+++ b/compat/Language/Haskell/Extension.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS -cpp #-}
+#include "Cabal/Language/Haskell/Extension.hs"
+-- dummy comment
diff --git a/compat/Makefile b/compat/Makefile
new file mode 100644
index 0000000000..b4e18c9bbc
--- /dev/null
+++ b/compat/Makefile
@@ -0,0 +1,101 @@
+TOP=..
+include $(TOP)/mk/boilerplate.mk
+
+ALL_DIRS = \
+ Data \
+ Compat \
+ Distribution \
+ Distribution/Compat \
+ Language/Haskell \
+ System \
+ System/Directory \
+ cbits
+
+SplitObjs=NO
+LIBRARY = libghccompat.a
+
+# We don't want this installed
+NO_INSTALL_LIBRARY = YES
+
+# Avoid building the GHCi lib, since we don't need it
+GhcWithInterpreter = NO
+
+# Needed so that the libraries can #include relative to this directory.
+INCLUDE_DIRS=-I. -Iinclude
+
+SRC_HC_OPTS += $(INCLUDE_DIRS)
+SRC_CC_OPTS += $(INCLUDE_DIRS)
+MKDEPENDC_OPTS += $(INCLUDE_DIRS)
+
+# Just to silence warnings
+MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR)
+
+UseGhcForCc = YES
+
+# This library is linked to the compiler, at least in stage1, so we
+# better make sure it is built the same "way".
+#
+# BUT, if GhcHcOpts includes -DDEBUG we *don't* want to compile
+# lib/compat with -DDEBUG, because the preprocessor symbols used
+# by the compiler may be understood differently by library code.
+# In this particular case, it turned out that -DDEBUG made Cabal
+# import HUnit, which might not be installed for the compiler we are
+# compiling with (e.g. 6.2.1). Hence the filter-out.
+SRC_HC_OPTS += $(filter-out -D%, $(GhcHcOpts))
+
+# GHC 6.4 didn't have WCsubst.c, but 6.4.1 did, and we need to know
+# this in cbits/unicode.c The patchlevel isn't normally exposed as a
+# CPP symbol, so we have to do it by hand:
+SRC_CC_OPTS += -D__GHC_PATCHLEVEL__=$(GhcPatchLevel)
+
+ifeq "$(ghc_ge_603)" "YES"
+# These modules are provided in GHC 6.3+
+EXCLUDED_SRCS += \
+ System/Directory/Internals.hs
+
+SRC_MKDEPENDHS_OPTS += \
+ -optdep--exclude-module=System.Directory.Internals
+
+# GHC 6.3+ has Cabal, but we're replacing it:
+SRC_HC_OPTS += -ignore-package Cabal
+endif
+
+# Some explicit dependencies, needed because ghc -M can't discover the
+# true dependencies of these stub files.
+System/Directory/Internals.$(way_)o : $(FPTOOLS_TOP)/libraries/base/System/Directory/Internals.hs
+Distribution/Compat/FilePath.$(way_) : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Compat/FilePath.hs
+Distribution/Compat/ReadP.$(way_) : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Compat/ReadP.hs
+Distribution/GetOpt.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/GetOpt.hs
+Distribution/InstalledPackageInfo.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/InstalledPackageInfo.hs
+Distribution/License.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/License.hs
+Distribution/Package.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Package.hs
+Distribution/ParseUtils.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/ParseUtils.hs
+Distribution/Compiler.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Compiler.hs
+Distribution/Version.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Version.hs
+Language/Haskell/Extension.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Language/Haskell/Extension.hs
+cbits/unicode.o : $(FPTOOLS_TOP)/libraries/base/cbits/WCsubst.c $(FPTOOLS_TOP)/libraries/base/include/WCsubst.h
+
+SRC_CC_OPTS += -I$(FPTOOLS_TOP)/libraries/base/cbits -I$(FPTOOLS_TOP)/libraries/base/include
+
+# Make the #includes in the stubs independent of the current location
+SRC_HC_OPTS += -I$(FPTOOLS_TOP)/libraries
+
+SRC_HC_OPTS += -fglasgow-exts -no-recomp
+
+ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
+Compat/Directory_HC_OPTS += -\#include shlobj.h
+endif
+
+# libghccompat is needed to build ghc-pkg, which is built during 'make boot',
+# so we must build this library during 'make boot' too.
+# Do a recursive 'make all' after generating dependencies, because this
+# will work with 'make -j'.
+ifneq "$(BootingFromHc)" "YES"
+boot :: depend
+ $(MAKE) all
+endif
+
+# We don't ever want to build libghccompat as a shared library.
+GhcBuildDylibs=NO
+
+include $(TOP)/mk/target.mk
diff --git a/compat/README b/compat/README
new file mode 100644
index 0000000000..8d0697beb4
--- /dev/null
+++ b/compat/README
@@ -0,0 +1,32 @@
+GHC compatibiliy library: libghccompat.a
+----------------------------------------
+
+This library contains interfaces that are available in recent versions
+of GHC, but may or may not be available in older versions. The idea
+is to provide an abstraction layer and reduce the amount of #ifdefery
+and code duplication in GHC and its tools. Furthermore, we can add
+modules to the main library and start using them right away in GHC, by
+adding a stub to this compat library.
+
+There are two types of modules in here:
+
+(a) a module with the same name as a module in the main library
+ (eg. Distribution.Package). If the module is available in
+ the main library, then we don't include it in libghccompat.
+ Otherwise, we have a stub module here that just #includes
+ the source from the real location under libraries/. Go look
+ at Distribution/Package.hs for example.
+
+(b) a module that doesn't exist in another library. For example,
+ Compat.RawSystem. These modules are used to provide functions
+ that are available in newer versions of the main libraries.
+
+BIG NOTE: when building stage 2 of GHC, libghccompat is not used,
+because we would have to build another version of it. Instead, we
+just use the appropriate libraries directly. For (a)-type modules,
+just import the module directly. For (b)-type modules, a single
+#ifdef will be required to choose between the Compat version and
+the real version.
+
+In stage 1 of GHC, and tools (eg. ghc-pkg, runghc), libghccompat.a
+is linked in, so all its libraries will be accessible.
diff --git a/compat/System/Directory/Internals.hs b/compat/System/Directory/Internals.hs
new file mode 100644
index 0000000000..5ac8e3ba24
--- /dev/null
+++ b/compat/System/Directory/Internals.hs
@@ -0,0 +1,4 @@
+{-# OPTIONS -cpp #-}
+#include "../../includes/ghcplatform.h"
+#include "base/System/Directory/Internals.hs"
+-- dummy comment
diff --git a/compat/cbits/directory.c b/compat/cbits/directory.c
new file mode 100644
index 0000000000..79d6cd4d44
--- /dev/null
+++ b/compat/cbits/directory.c
@@ -0,0 +1,96 @@
+#include "HsFFI.h"
+
+#include "../../../includes/ghcconfig.h"
+
+#if HAVE_LIMITS_H
+#include <limits.h>
+#endif
+#if HAVE_WINDOWS_H
+#include <windows.h>
+#endif
+#include "directory.h"
+
+#define INLINE /* nothing */
+
+/*
+ * Following code copied from libraries/base/includes/HsBase.h
+ */
+
+#ifdef PATH_MAX
+/* A size that will contain many path names, but not necessarily all
+ * (PATH_MAX is not defined on systems with unlimited path length,
+ * e.g. the Hurd).
+ */
+INLINE HsInt __compat_long_path_size() { return PATH_MAX; }
+#else
+INLINE HsInt __compat_long_path_size() { return 4096; }
+#endif
+
+#if defined(mingw32_HOST_OS)
+
+/* Make sure we've got the reqd CSIDL_ constants in scope;
+ * w32api header files are lagging a bit in defining the full set.
+ */
+#if !defined(CSIDL_APPDATA)
+#define CSIDL_APPDATA 0x001a
+#endif
+#if !defined(CSIDL_PERSONAL)
+#define CSIDL_PERSONAL 0x0005
+#endif
+#if !defined(CSIDL_PROFILE)
+#define CSIDL_PROFILE 0x0028
+#endif
+#if !defined(CSIDL_WINDOWS)
+#define CSIDL_WINDOWS 0x0024
+#endif
+
+INLINE int __hscore_CSIDL_PROFILE() { return CSIDL_PROFILE; }
+INLINE int __hscore_CSIDL_APPDATA() { return CSIDL_APPDATA; }
+INLINE int __hscore_CSIDL_WINDOWS() { return CSIDL_WINDOWS; }
+INLINE int __hscore_CSIDL_PERSONAL() { return CSIDL_PERSONAL; }
+
+#if __GLASGOW_HASKELL__ < 604
+/*
+ * Function: __hscore_getFolderPath()
+ *
+ * Late-bound version of SHGetFolderPath(), coping with OS versions
+ * that have shell32's lacking that particular API.
+ *
+ */
+typedef HRESULT (*HSCORE_GETAPPFOLDERFUNTY)(HWND,int,HANDLE,DWORD,char*);
+int
+__hscore_getFolderPath(HWND hwndOwner,
+ int nFolder,
+ HANDLE hToken,
+ DWORD dwFlags,
+ char* pszPath)
+{
+ static int loaded_dll = 0;
+ static HMODULE hMod = (HMODULE)NULL;
+ static HSCORE_GETAPPFOLDERFUNTY funcPtr = NULL;
+ /* The DLLs to try loading entry point from */
+ char* dlls[] = { "shell32.dll", "shfolder.dll" };
+
+ if (loaded_dll < 0) {
+ return (-1);
+ } else if (loaded_dll == 0) {
+ int i;
+ for(i=0;i < sizeof(dlls); i++) {
+ hMod = LoadLibrary(dlls[i]);
+ if ( hMod != NULL &&
+ (funcPtr = (HSCORE_GETAPPFOLDERFUNTY)GetProcAddress(hMod, "SHGetFolderPathA")) ) {
+ loaded_dll = 1;
+ break;
+ }
+ }
+ if (loaded_dll == 0) {
+ loaded_dll = (-1);
+ return (-1);
+ }
+ }
+ /* OK, if we got this far the function has been bound */
+ return (int)funcPtr(hwndOwner,nFolder,hToken,dwFlags,pszPath);
+ /* ToDo: unload the DLL on shutdown? */
+}
+#endif /* __GLASGOW_HASKELL__ < 604 */
+#endif
diff --git a/compat/cbits/rawSystem.c b/compat/cbits/rawSystem.c
new file mode 100644
index 0000000000..00b8c49cc1
--- /dev/null
+++ b/compat/cbits/rawSystem.c
@@ -0,0 +1,140 @@
+/*
+ * (c) The University of Glasgow 1994-2004
+ *
+ * WARNING: this file is here for backwards compatibility only. It is
+ * not included as part of the base package, but is #included into the
+ * compiler and the runghc utility when building either of these with
+ * an old version of GHC.
+ *
+ * shell-less system Runtime Support (see System.Cmd.rawSystem).
+ */
+
+/* The itimer stuff in this module is non-posix */
+/* #include "PosixSource.h" */
+
+#include "../../../includes/ghcconfig.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_ERRNO_H
+#include <errno.h>
+#endif
+#ifdef HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+
+# ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+# else
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# include <time.h>
+# endif
+# endif
+
+#include "HsFFI.h"
+
+#if defined(mingw32_HOST_OS)
+#include <windows.h>
+#endif
+
+#ifdef HAVE_VFORK_H
+#include <vfork.h>
+#endif
+
+#ifdef HAVE_VFORK
+#define fork vfork
+#endif
+
+#if defined(mingw32_HOST_OS)
+/* -------------------- WINDOWS VERSION --------------------- */
+
+HsInt
+rawSystem(HsAddr cmd)
+{
+ STARTUPINFO sInfo;
+ PROCESS_INFORMATION pInfo;
+ DWORD retCode;
+
+ ZeroMemory(&sInfo, sizeof(sInfo));
+ sInfo.cb = sizeof(sInfo);
+
+ if (!CreateProcess(NULL, cmd, NULL, NULL, TRUE, 0, NULL, NULL, &sInfo, &pInfo)) {
+ /* The 'TRUE' says that the created process should share
+ handles with the current process. This is vital to ensure
+ that error messages sent to stderr actually appear on the screen.
+ Since we are going to wait for the process to terminate anyway,
+ there is no problem with such sharing. */
+
+ errno = EINVAL; // ToDo: wrong, caller should use GetLastError()
+ return -1;
+ }
+ WaitForSingleObject(pInfo.hProcess, INFINITE);
+ if (GetExitCodeProcess(pInfo.hProcess, &retCode) == 0) {
+ errno = EINVAL; // ToDo: wrong, caller should use GetLastError()
+ return -1;
+ }
+
+ CloseHandle(pInfo.hProcess);
+ CloseHandle(pInfo.hThread);
+ return retCode;
+}
+
+#else
+/* -------------------- UNIX VERSION --------------------- */
+
+HsInt
+rawSystem(HsAddr cmd, HsAddr args)
+{
+ int pid;
+ int wstat;
+
+ switch(pid = fork()) {
+ case -1:
+ {
+ return -1;
+ }
+ case 0:
+ {
+#ifdef HAVE_SETITIMER
+ /* Reset the itimers in the child, so it doesn't get plagued
+ * by SIGVTALRM interrupts.
+ */
+ struct timeval tv_null = { 0, 0 };
+ struct itimerval itv;
+ itv.it_interval = tv_null;
+ itv.it_value = tv_null;
+ setitimer(ITIMER_REAL, &itv, NULL);
+ setitimer(ITIMER_VIRTUAL, &itv, NULL);
+ setitimer(ITIMER_PROF, &itv, NULL);
+#endif
+
+ /* the child */
+ execvp(cmd, args);
+ _exit(127);
+ }
+ }
+
+ while (waitpid(pid, &wstat, 0) < 0) {
+ if (errno != EINTR) {
+ return -1;
+ }
+ }
+
+ if (WIFEXITED(wstat))
+ return WEXITSTATUS(wstat);
+ else if (WIFSIGNALED(wstat)) {
+ errno = EINTR;
+ }
+ else {
+ /* This should never happen */
+ }
+ return -1;
+}
+#endif
diff --git a/compat/cbits/unicode.c b/compat/cbits/unicode.c
new file mode 100644
index 0000000000..c744cc9436
--- /dev/null
+++ b/compat/cbits/unicode.c
@@ -0,0 +1,3 @@
+#if __GLASGOW_HASKELL__ < 604 || (__GLASGOW_HASKELL__==604 && __GHC_PATCHLEVEL__==0)
+#include "WCsubst.c"
+#endif
diff --git a/compat/compat.mk b/compat/compat.mk
new file mode 100644
index 0000000000..48b2bea76d
--- /dev/null
+++ b/compat/compat.mk
@@ -0,0 +1,44 @@
+# Settings for using the libghccompat.a library elsewhere in the build
+# tree: this file is just included into Makefiles, see
+# utils/ghc-pkg/Makefile for example.
+#
+# This is a poor-mans package, but simpler because we don't
+# have to deal with variations in the package support of different
+# versions of GHC.
+
+# Use libghccompat.a:
+SRC_HC_OPTS += -i$(GHC_COMPAT_DIR)
+SRC_LD_OPTS += -L$(GHC_COMPAT_DIR) -lghccompat
+
+# Do *not* use the installed Cabal:
+ifeq "$(ghc_ge_603)" "YES"
+SRC_HC_OPTS += -ignore-package Cabal
+endif
+
+# And similarly for when booting from .hc files:
+HC_BOOT_LD_OPTS += -L$(GHC_COMPAT_DIR)
+HC_BOOT_LIBS += -lghccompat
+
+ifeq "$(Windows)" "YES"
+# not very nice, but required for -lghccompat on Windows
+SRC_LD_OPTS += -lshell32
+HC_BOOT_LIBS += -lshell32
+endif
+
+# This is horrible. We ought to be able to omit the entire directory
+# from mkDependHS.
+SRC_MKDEPENDHS_OPTS += \
+ -optdep--exclude-module=Compat.RawSystem \
+ -optdep--exclude-module=Compat.Directory \
+ -optdep--exclude-module=Compat.Unicode \
+ -optdep--exclude-module=Distribution.Compat.FilePath \
+ -optdep--exclude-module=Distribution.Compat.ReadP \
+ -optdep--exclude-module=Distribution.Extension \
+ -optdep--exclude-module=Distribution.GetOpt \
+ -optdep--exclude-module=Distribution.InstalledPackageInfo \
+ -optdep--exclude-module=Distribution.License \
+ -optdep--exclude-module=Distribution.Package \
+ -optdep--exclude-module=Distribution.ParseUtils \
+ -optdep--exclude-module=Distribution.Compiler \
+ -optdep--exclude-module=Distribution.Version \
+ -optdep--exclude-module=System.Directory.Internals
diff --git a/compat/include/directory.h b/compat/include/directory.h
new file mode 100644
index 0000000000..2e26c3d5a1
--- /dev/null
+++ b/compat/include/directory.h
@@ -0,0 +1,13 @@
+#ifndef __DIRECTORY_H__
+#define __DIRECTORY_H__
+
+#if defined(mingw32_HOST_OS)
+extern int __compat_long_path_size();
+extern int __hscore_CSIDL_APPDATA();
+extern int __hscore_getFolderPath(HWND hwndOwner,
+ int nFolder,
+ HANDLE hToken,
+ DWORD dwFlags,
+ char* pszPath);
+#endif
+#endif
View Lorry Controller Status