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.

1 files changed, 201 insertions, 0 deletions

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
new file mode 100644
index 0000000000..913ac33a33
--- /dev/null
+++ b/compiler/main/HeaderInfo.hs
@@ -0,0 +1,201 @@
+-----------------------------------------------------------------------------
+--
+-- Parsing the top of a Haskell source file to get its module name,
+-- imports and options.
+--
+-- (c) Simon Marlow 2005
+-- (c) Lemmih 2006
+--
+-----------------------------------------------------------------------------
+
+module HeaderInfo ( getImportsFromFile, getImports
+                  , getOptionsFromFile, getOptions
+                  , optionsErrorMsgs ) where
+
+#include "HsVersions.h"
+
+import Parser		( parseHeader )
+import Lexer		( P(..), ParseResult(..), mkPState, pragState
+                        , lexer, Token(..), PState(..) )
+import FastString
+import HsSyn		( ImportDecl(..), HsModule(..) )
+import Module		( Module, mkModule )
+import PrelNames        ( gHC_PRIM )
+import StringBuffer	( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock
+                        , appendStringBuffers )
+import SrcLoc		( Located(..), mkSrcLoc, unLoc, noSrcSpan )
+import FastString	( mkFastString )
+import DynFlags	( DynFlags )
+import ErrUtils
+import Util
+import Outputable
+import Pretty           ()
+import Panic
+import Bag		( unitBag, emptyBag, listToBag )
+
+import Distribution.Compiler
+
+import TRACE
+
+import EXCEPTION	( throwDyn )
+import IO
+import List
+
+#if __GLASGOW_HASKELL__ >= 601
+import System.IO		( openBinaryFile )
+#else
+import IOExts                   ( openFileEx, IOModeEx(..) )
+#endif
+
+#if __GLASGOW_HASKELL__ < 601
+openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
+#endif
+
+-- getImportsFromFile is careful to close the file afterwards, otherwise
+-- we can end up with a large number of open handles before the garbage
+-- collector gets around to closing them.
+getImportsFromFile :: DynFlags -> FilePath
+   -> IO ([Located Module], [Located Module], Located Module)
+getImportsFromFile dflags filename = do
+  buf <- hGetStringBuffer filename
+  getImports dflags buf filename
+
+getImports :: DynFlags -> StringBuffer -> FilePath
+    -> IO ([Located Module], [Located Module], Located Module)
+getImports dflags buf filename = do
+  let loc  = mkSrcLoc (mkFastString filename) 1 0
+  case unP parseHeader (mkPState buf loc dflags) of
+	PFailed span err -> parseError span err
+	POk _ rdr_module -> 
+	  case rdr_module of
+	    L _ (HsModule mod _ imps _ _) ->
+	      let
+		mod_name | Just located_mod <- mod = located_mod
+			 | otherwise               = L noSrcSpan (mkModule "Main")
+	        (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
+		source_imps   = map getImpMod src_idecls	
+		ordinary_imps = filter ((/= gHC_PRIM) . unLoc) 
+					(map getImpMod ord_idecls)
+		     -- GHC.Prim doesn't exist physically, so don't go looking for it.
+	      in
+	      return (source_imps, ordinary_imps, mod_name)
+  
+parseError span err = throwDyn $ mkPlainErrMsg span err
+
+isSourceIdecl (ImportDecl _ s _ _ _) = s
+
+getImpMod (ImportDecl located_mod _ _ _ _) = located_mod
+
+--------------------------------------------------------------
+-- Get options
+--------------------------------------------------------------
+
+
+getOptionsFromFile :: FilePath            -- input file
+                   -> IO [Located String] -- options, if any
+getOptionsFromFile filename
+    = bracket (openBinaryFile filename ReadMode)
+              (hClose)
+              (\handle ->
+                   do buf <- hGetStringBufferBlock handle blockSize
+                      loop handle buf)
+    where blockSize = 1024
+          loop handle buf
+              | len buf == 0 = return []
+              | otherwise
+              = case getOptions' buf filename of
+                  (Nothing, opts) -> return opts
+                  (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
+                                          newBuf <- appendStringBuffers buf' nextBlock
+                                          if len newBuf == len buf
+                                             then return opts
+                                             else do opts' <- loop handle newBuf
+                                                     return (opts++opts')
+
+getOptions :: StringBuffer -> FilePath -> [Located String]
+getOptions buf filename
+    = case getOptions' buf filename of
+        (_,opts) -> opts
+
+-- The token parser is written manually because Happy can't
+-- return a partial result when it encounters a lexer error.
+-- We want to extract options before the buffer is passed through
+-- CPP, so we can't use the same trick as 'getImports'.
+getOptions' :: StringBuffer         -- Input buffer
+            -> FilePath             -- Source file. Used for msgs only.
+            -> ( Maybe StringBuffer -- Just => we can use more input
+               , [Located String]   -- Options.
+               )
+getOptions' buf filename
+    = parseToks (lexAll (pragState buf loc))
+    where loc  = mkSrcLoc (mkFastString filename) 1 0
+
+          getToken (buf,L _loc tok) = tok
+          getLoc (buf,L loc _tok) = loc
+          getBuf (buf,_tok) = buf
+          combine opts (flag, opts') = (flag, opts++opts')
+          add opt (flag, opts) = (flag, opt:opts)
+
+          parseToks (open:close:xs)
+              | IToptions_prag str <- getToken open
+              , ITclose_prag       <- getToken close
+              = map (L (getLoc open)) (words str) `combine`
+                parseToks xs
+          parseToks (open:close:xs)
+              | ITinclude_prag str <- getToken open
+              , ITclose_prag       <- getToken close
+              = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
+                parseToks xs
+          parseToks (open:xs)
+              | ITlanguage_prag <- getToken open
+              = parseLanguage xs
+          -- The last token before EOF could have been truncated.
+          -- We ignore it to be on the safe side.
+          parseToks [tok,eof]
+              | ITeof <- getToken eof
+              = (Just (getBuf tok),[])
+          parseToks (eof:_)
+              | ITeof <- getToken eof
+              = (Just (getBuf eof),[])
+          parseToks _ = (Nothing,[])
+          parseLanguage ((_buf,L loc (ITconid fs)):rest)
+              = checkExtension (L loc fs) `add`
+                case rest of
+                  (_,L loc ITcomma):more -> parseLanguage more
+                  (_,L loc ITclose_prag):more -> parseToks more
+                  (_,L loc _):_ -> languagePragParseError loc
+          parseLanguage (tok:_)
+              = languagePragParseError (getLoc tok)
+          lexToken t = return t
+          lexAll state = case unP (lexer lexToken) state of
+                           POk state' t@(L _ ITeof) -> [(buffer state,t)]
+                           POk state' t -> (buffer state,t):lexAll state'
+                           _ -> [(buffer state,L (last_loc state) ITeof)]
+
+checkExtension :: Located FastString -> Located String
+checkExtension (L l ext)
+    = case reads (unpackFS ext) of
+        [] -> languagePragParseError l
+        (okExt,""):_ -> case extensionsToGHCFlag [okExt] of
+                          ([],[opt]) -> L l opt
+                          _ -> unsupportedExtnError l okExt
+
+languagePragParseError loc =
+  pgmError (showSDoc (mkLocMessage loc (
+                text "cannot parse LANGUAGE pragma")))
+
+unsupportedExtnError loc unsup =
+  pgmError (showSDoc (mkLocMessage loc (
+                text "unsupported extension: " <>
+                (text.show) unsup)))
+
+
+optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
+optionsErrorMsgs unhandled_flags flags_lines filename
+  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
+  where	unhandled_flags_lines = [ L l f | f <- unhandled_flags, 
+					  L l f' <- flags_lines, f == f' ]
+        mkMsg (L flagSpan flag) = 
+            ErrUtils.mkPlainErrMsg flagSpan $
+                    text "unknown flag in  {-# OPTIONS #-} pragma:" <+> text flag
+