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, 128 insertions, 0 deletions

diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
new file mode 100644
index 0000000000..eea61bafb2
--- /dev/null
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -0,0 +1,128 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
+
+\begin{code}
+module DsGRHSs ( dsGuarded, dsGRHSs ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} Match   ( matchSinglePat )
+
+import HsSyn		( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), 
+			  LHsExpr, HsMatchContext(..), Pat(..) )
+import CoreSyn		( CoreExpr )
+import Var		( Id )
+import Type		( Type )
+
+import DsMonad
+import DsUtils
+import Unique		( Uniquable(..) )
+import PrelInfo		( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
+import TysWiredIn	( trueDataConId )
+import PrelNames	( otherwiseIdKey, hasKey )
+import Name		( Name )
+import SrcLoc		( unLoc, Located(..) )
+\end{code}
+
+@dsGuarded@ is used for both @case@ expressions and pattern bindings.
+It desugars:
+\begin{verbatim}
+	| g1 -> e1
+	...
+	| gn -> en
+	where binds
+\end{verbatim}
+producing an expression with a runtime error in the corner if
+necessary.  The type argument gives the type of the @ei@.
+
+\begin{code}
+dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
+
+dsGuarded grhss rhs_ty
+  = dsGRHSs PatBindRhs [] grhss rhs_ty 				`thenDs` \ match_result ->
+    mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty ""	`thenDs` \ error_expr ->
+    extractMatchResult match_result error_expr
+\end{code}
+
+In contrast, @dsGRHSs@ produces a @MatchResult@.
+
+\begin{code}
+dsGRHSs :: HsMatchContext Name -> [Pat Id]	-- These are to build a MatchContext from
+	-> GRHSs Id				-- Guarded RHSs
+	-> Type					-- Type of RHS
+	-> DsM MatchResult
+
+dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty
+  = mappM (dsGRHS hs_ctx pats rhs_ty) grhss	`thenDs` \ match_results ->
+    let 
+	match_result1 = foldr1 combineMatchResults match_results
+	match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
+		-- NB: nested dsLet inside matchResult
+    in
+    returnDs match_result2
+
+dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
+  = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*  matchGuard : make a MatchResult from a guarded RHS			*
+%*									*
+%************************************************************************
+
+\begin{code}
+matchGuards :: [Stmt Id] 		-- Guard
+            -> HsMatchContext Name	-- Context
+	    -> LHsExpr Id		-- RHS
+	    -> Type			-- Type of RHS of guard
+	    -> DsM MatchResult
+
+-- See comments with HsExpr.Stmt re what an ExprStmt means
+-- Here we must be in a guard context (not do-expression, nor list-comp)	
+
+matchGuards [] ctx rhs rhs_ty
+  = do	{ core_rhs <- dsLExpr rhs
+	; return (cantFailMatchResult core_rhs) }
+
+	-- ExprStmts must be guards
+	-- Turn an "otherwise" guard is a no-op.  This ensures that 
+	-- you don't get a "non-exhaustive eqns" message when the guards 
+	-- finish in "otherwise".
+	-- NB:	The success of this clause depends on the typechecker not
+	-- 	wrapping the 'otherwise' in empty HsTyApp or HsCoerce constructors
+	--	If it does, you'll get bogus overlap warnings
+matchGuards (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
+  |  v `hasKey` otherwiseIdKey
+  || v `hasKey` getUnique trueDataConId	
+	-- trueDataConId doesn't have the same unique as trueDataCon
+  = matchGuards stmts ctx rhs rhs_ty
+
+matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
+  = matchGuards stmts ctx rhs rhs_ty	`thenDs` \ match_result ->
+    dsLExpr expr			`thenDs` \ pred_expr ->
+    returnDs (mkGuardedMatchResult pred_expr match_result)
+
+matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
+  = matchGuards stmts ctx rhs rhs_ty	`thenDs` \ match_result ->
+    returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result)
+	-- NB the dsLet occurs inside the match_result
+	-- Reason: dsLet takes the body expression as its argument
+	--	   so we can't desugar the bindings without the
+	--	   body expression in hand
+
+matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
+  = matchGuards stmts ctx rhs rhs_ty	`thenDs` \ match_result ->
+    dsLExpr bind_rhs			`thenDs` \ core_rhs ->
+    matchSinglePat core_rhs ctx pat rhs_ty match_result
+\end{code}
+
+Should {\em fail} if @e@ returns @D@
+\begin{verbatim}
+f x | p <- e', let C y# = e, f y# = r1
+    | otherwise 	 = r2 
+\end{verbatim}