Reorganisation of the source tree

Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.

The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level.  The build system now makes no
pretense at being multi-project, it is just the GHC build system.

No doubt this will break many things, and there will be a period of
instability while we fix the dependencies.  A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.

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