3 files changed, 353 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