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.

22 files changed, 9252 insertions, 0 deletions

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
new file mode 100644
index 0000000000..9aac5ce777
--- /dev/null
+++ b/compiler/deSugar/Check.lhs
@@ -0,0 +1,698 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
+%
+% Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>
+\section{Module @Check@ in @deSugar@}
+
+\begin{code}
+
+
+module Check ( check , ExhaustivePat ) where
+
+
+import HsSyn		
+import TcHsSyn		( hsPatType, mkVanillaTuplePat )
+import TcType		( tcTyConAppTyCon )
+import DsUtils		( EquationInfo(..), MatchResult(..), 
+			  CanItFail(..), firstPat )
+import MatchLit		( tidyLitPat, tidyNPat )
+import Id		( Id, idType )
+import DataCon		( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels )
+import Name             ( Name, mkInternalName, getOccName, isDataSymOcc,
+			  getName, mkVarOccFS )
+import TysWiredIn
+import PrelNames	( unboundKey )
+import TyCon            ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
+import BasicTypes	( Boxity(..) )
+import SrcLoc		( noSrcLoc, Located(..), unLoc, noLoc )
+import UniqSet
+import Util             ( takeList, splitAtList, notNull )
+import Outputable
+import FastString
+
+#include "HsVersions.h"
+\end{code}
+
+This module performs checks about if one list of equations are:
+\begin{itemize}
+\item Overlapped
+\item Non exhaustive
+\end{itemize}
+To discover that we go through the list of equations in a tree-like fashion.
+
+If you like theory, a similar algorithm is described in:
+\begin{quotation}
+	{\em Two Techniques for Compiling Lazy Pattern Matching},
+	Luc Maranguet,
+	INRIA Rocquencourt (RR-2385, 1994)
+\end{quotation}
+The algorithm is based on the first technique, but there are some differences:
+\begin{itemize}
+\item We don't generate code
+\item We have constructors and literals (not only literals as in the 
+	  article)
+\item We don't use directions, we must select the columns from 
+	  left-to-right
+\end{itemize}
+(By the way the second technique is really similar to the one used in 
+ @Match.lhs@ to generate code)
+
+This function takes the equations of a pattern and returns:
+\begin{itemize}
+\item The patterns that are not recognized
+\item The equations that are not overlapped
+\end{itemize}
+It simplify the patterns and then call @check'@ (the same semantics), and it 
+needs to reconstruct the patterns again ....
+
+The problem appear with things like:
+\begin{verbatim}
+  f [x,y]   = ....
+  f (x:xs)  = .....
+\end{verbatim}
+We want to put the two patterns with the same syntax, (prefix form) and 
+then all the constructors are equal:
+\begin{verbatim}
+  f (: x (: y []))   = ....
+  f (: x xs)         = .....
+\end{verbatim}
+(more about that in @simplify_eqns@)
+
+We would prefer to have a @WarningPat@ of type @String@, but Strings and the 
+Pretty Printer are not friends.
+
+We use @InPat@ in @WarningPat@ instead of @OutPat@
+because we need to print the 
+warning messages in the same way they are introduced, i.e. if the user 
+wrote:
+\begin{verbatim}
+	f [x,y] = ..
+\end{verbatim}
+He don't want a warning message written:
+\begin{verbatim}
+        f (: x (: y [])) ........
+\end{verbatim}
+Then we need to use InPats.
+\begin{quotation}
+     Juan Quintela 5 JUL 1998\\
+	  User-friendliness and compiler writers are no friends.
+\end{quotation}
+
+\begin{code}
+type WarningPat = InPat Name
+type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
+type EqnNo  = Int
+type EqnSet = UniqSet EqnNo
+
+
+check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
+	-- Second result is the shadowed equations
+check qs = (untidy_warns, shadowed_eqns)
+      where
+	(warns, used_nos) = check' ([1..] `zip` map simplify_eqn qs)
+	untidy_warns = map untidy_exhaustive warns 
+	shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], 
+				not (i `elementOfUniqSet` used_nos)]
+
+untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
+untidy_exhaustive ([pat], messages) = 
+		  ([untidy_no_pars pat], map untidy_message messages)
+untidy_exhaustive (pats, messages) = 
+		  (map untidy_pars pats, map untidy_message messages)
+
+untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
+untidy_message (string, lits) = (string, map untidy_lit lits)
+\end{code}
+
+The function @untidy@ does the reverse work of the @simplify_pat@ funcion.
+
+\begin{code}
+
+type NeedPars = Bool 
+
+untidy_no_pars :: WarningPat -> WarningPat
+untidy_no_pars p = untidy False p
+
+untidy_pars :: WarningPat -> WarningPat
+untidy_pars p = untidy True p
+
+untidy :: NeedPars -> WarningPat -> WarningPat
+untidy b (L loc p) = L loc (untidy' b p)
+  where
+    untidy' _ p@(WildPat _)   = p
+    untidy' _ p@(VarPat name) = p
+    untidy' _ (LitPat lit)    = LitPat (untidy_lit lit)
+    untidy' _ p@(ConPatIn name (PrefixCon [])) = p
+    untidy' b (ConPatIn name ps)     = pars b (L loc (ConPatIn name (untidy_con ps)))
+    untidy' _ (ListPat pats ty)      = ListPat (map untidy_no_pars pats) ty
+    untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
+    untidy' _ (PArrPat _ _)	     = panic "Check.untidy: Shouldn't get a parallel array here!"
+    untidy' _ (SigPatIn _ _) 	     = panic "Check.untidy: SigPat"
+
+untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) 
+untidy_con (InfixCon p1 p2) = InfixCon  (untidy_pars p1) (untidy_pars p2)
+untidy_con (RecCon bs)      = RecCon    [(f,untidy_pars p) | (f,p) <- bs]
+
+pars :: NeedPars -> WarningPat -> Pat Name
+pars True p = ParPat p
+pars _    p = unLoc p
+
+untidy_lit :: HsLit -> HsLit
+untidy_lit (HsCharPrim c) = HsChar c
+untidy_lit lit 		  = lit
+\end{code}
+
+This equation is the same that check, the only difference is that the
+boring work is done, that work needs to be done only once, this is
+the reason top have two functions, check is the external interface,
+@check'@ is called recursively.
+
+There are several cases:
+
+\begin{itemize} 
+\item There are no equations: Everything is OK. 
+\item There are only one equation, that can fail, and all the patterns are
+      variables. Then that equation is used and the same equation is 
+      non-exhaustive.
+\item All the patterns are variables, and the match can fail, there are 
+      more equations then the results is the result of the rest of equations 
+      and this equation is used also.
+
+\item The general case, if all the patterns are variables (here the match 
+      can't fail) then the result is that this equation is used and this 
+      equation doesn't generate non-exhaustive cases.
+
+\item In the general case, there can exist literals ,constructors or only 
+      vars in the first column, we actuate in consequence.
+
+\end{itemize}
+
+
+\begin{code}
+
+check' :: [(EqnNo, EquationInfo)] 
+	-> ([ExhaustivePat], 	-- Pattern scheme that might not be matched at all
+	    EqnSet)  		-- Eqns that are used (others are overlapped)
+
+check' [] = ([([],[])],emptyUniqSet)
+
+check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs) 
+   | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False }
+   = ([], unitUniqSet n)	-- One eqn, which can't fail
+
+   | first_eqn_all_vars && null rs	-- One eqn, but it can fail
+   = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
+
+   | first_eqn_all_vars		-- Several eqns, first can fail
+   = (pats, addOneToUniqSet indexs n)
+  where
+    first_eqn_all_vars = all_vars ps
+    (pats,indexs) = check' rs
+
+check' qs
+   | literals     = split_by_literals qs
+   | constructors = split_by_constructor qs
+   | only_vars    = first_column_only_vars qs
+   | otherwise    = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
+  where
+     -- Note: RecPats will have been simplified to ConPats
+     --       at this stage.
+    first_pats   = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs
+    constructors = any is_con first_pats
+    literals     = any is_lit first_pats
+    only_vars    = all is_var first_pats
+\end{code}
+
+Here begins the code to deal with literals, we need to split the matrix
+in different matrix beginning by each literal and a last matrix with the 
+rest of values.
+
+\begin{code}
+split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
+split_by_literals qs = process_literals used_lits qs
+           where
+             used_lits = get_used_lits qs
+\end{code}
+
+@process_explicit_literals@ is a function that process each literal that appears 
+in the column of the matrix. 
+
+\begin{code}
+process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
+    where                  
+      pats_indexs   = map (\x -> construct_literal_matrix x qs) lits
+      (pats,indexs) = unzip pats_indexs 
+\end{code}
+
+
+@process_literals@ calls @process_explicit_literals@ to deal with the literals 
+that appears in the matrix and deal also with the rest of the cases. It 
+must be one Variable to be complete.
+
+\begin{code}
+
+process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+process_literals used_lits qs 
+  | null default_eqns  = ([make_row_vars used_lits (head qs)] ++ pats,indexs)
+  | otherwise          = (pats_default,indexs_default)
+     where
+       (pats,indexs)   = process_explicit_literals used_lits qs
+       default_eqns    = ASSERT2( okGroup qs, pprGroup qs ) 
+			 [remove_var q | q <- qs, is_var (firstPatN q)]
+       (pats',indexs') = check' default_eqns 
+       pats_default    = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats 
+       indexs_default  = unionUniqSets indexs' indexs
+\end{code}
+
+Here we have selected the literal and we will select all the equations that 
+begins for that literal and create a new matrix.
+
+\begin{code}
+construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+construct_literal_matrix lit qs =
+    (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs) 
+  where
+    (pats,indexs) = (check' (remove_first_column_lit lit qs)) 
+    new_lit = nlLitPat lit
+
+remove_first_column_lit :: HsLit
+                        -> [(EqnNo, EquationInfo)] 
+                        -> [(EqnNo, EquationInfo)]
+remove_first_column_lit lit qs
+  = ASSERT2( okGroup qs, pprGroup qs ) 
+    [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]
+  where
+     shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }
+     shift_pat eqn@(EqnInfo { eqn_pats = []})   = panic "Check.shift_var: no patterns"
+\end{code}
+
+This function splits the equations @qs@ in groups that deal with the 
+same constructor.
+
+\begin{code}
+split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
+split_by_constructor qs 
+  | notNull unused_cons = need_default_case used_cons unused_cons qs 
+  | otherwise           = no_need_default_case used_cons qs 
+                       where 
+                          used_cons   = get_used_cons qs 
+                          unused_cons = get_unused_cons used_cons 
+\end{code}
+
+The first column of the patterns matrix only have vars, then there is 
+nothing to do.
+
+\begin{code}
+first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)
+                          where
+                            (pats, indexs) = check' (map remove_var qs)
+\end{code}
+
+This equation takes a matrix of patterns and split the equations by 
+constructor, using all the constructors that appears in the first column 
+of the pattern matching.
+
+We can need a default clause or not ...., it depends if we used all the 
+constructors or not explicitly. The reasoning is similar to @process_literals@,
+the difference is that here the default case is not always needed.
+
+\begin{code}
+no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
+    where                  
+      pats_indexs   = map (\x -> construct_matrix x qs) cons
+      (pats,indexs) = unzip pats_indexs 
+
+need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+need_default_case used_cons unused_cons qs 
+  | null default_eqns  = (pats_default_no_eqns,indexs)
+  | otherwise          = (pats_default,indexs_default)
+     where
+       (pats,indexs)   = no_need_default_case used_cons qs
+       default_eqns    = ASSERT2( okGroup qs, pprGroup qs ) 
+			 [remove_var q | q <- qs, is_var (firstPatN q)]
+       (pats',indexs') = check' default_eqns 
+       pats_default    = [(make_whole_con c:ps,constraints) | 
+                          c <- unused_cons, (ps,constraints) <- pats'] ++ pats
+       new_wilds       = make_row_vars_for_constructor (head qs)
+       pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
+       indexs_default  = unionUniqSets indexs' indexs
+
+construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+construct_matrix con qs =
+    (map (make_con con) pats,indexs) 
+  where
+    (pats,indexs) = (check' (remove_first_column con qs)) 
+\end{code}
+
+Here remove first column is more difficult that with literals due to the fact 
+that constructors can have arguments.
+
+For instance, the matrix
+\begin{verbatim}
+ (: x xs) y
+ z        y
+\end{verbatim}
+is transformed in:
+\begin{verbatim}
+ x xs y
+ _ _  y
+\end{verbatim}
+
+\begin{code}
+remove_first_column :: Pat Id                -- Constructor 
+                    -> [(EqnNo, EquationInfo)] 
+                    -> [(EqnNo, EquationInfo)]
+remove_first_column (ConPatOut (L _ con) _ _ _ (PrefixCon con_pats) _) qs
+  = ASSERT2( okGroup qs, pprGroup qs ) 
+    [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]
+  where
+     new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats]
+     shift_var eqn@(EqnInfo { eqn_pats = ConPatOut _ _ _ _ (PrefixCon ps') _ : ps}) 
+ 	= eqn { eqn_pats = map unLoc ps' ++ ps }
+     shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps })
+  	= eqn { eqn_pats = new_wilds ++ ps }
+     shift_var _ = panic "Check.Shift_var:No done"
+
+make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
+make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
+   = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])
+  where 
+     new_var = hash_x
+
+hash_x = mkInternalName unboundKey {- doesn't matter much -}
+		     (mkVarOccFS FSLIT("#x"))
+		     noSrcLoc
+
+make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
+make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) 
+  = takeList (tail pats) (repeat nlWildPat)
+
+compare_cons :: Pat Id -> Pat Id -> Bool
+compare_cons (ConPatOut (L _ id1) _ _ _ _ _) (ConPatOut (L _ id2) _ _ _ _ _) = id1 == id2  
+
+remove_dups :: [Pat Id] -> [Pat Id]
+remove_dups []     = []
+remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups  xs
+                   | otherwise                            = x : remove_dups xs
+
+get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]
+get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q, 
+				      isConPatOut pat]
+
+isConPatOut (ConPatOut {}) = True
+isConPatOut other	   = False
+
+remove_dups' :: [HsLit] -> [HsLit] 
+remove_dups' []                   = []
+remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
+                    | otherwise   = x : remove_dups' xs 
+
+
+get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]
+get_used_lits qs = remove_dups' all_literals
+	         where
+	           all_literals = get_used_lits' qs
+
+get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
+get_used_lits' [] = []
+get_used_lits' (q:qs) 
+  | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs
+  | otherwise		              = get_used_lits qs
+
+get_lit :: Pat id -> Maybe HsLit 
+-- Get a representative HsLit to stand for the OverLit
+-- It doesn't matter which one, because they will only be compared
+-- with other HsLits gotten in the same way
+get_lit (LitPat lit)			 = Just lit
+get_lit (NPat (HsIntegral i   _) mb _ _) = Just (HsIntPrim   (mb_neg mb i))
+get_lit (NPat (HsFractional f _) mb _ _) = Just (HsFloatPrim (mb_neg mb f))
+get_lit other_pat			 = Nothing
+
+mb_neg :: Num a => Maybe b -> a -> a
+mb_neg Nothing  v = v
+mb_neg (Just _) v = -v
+
+get_unused_cons :: [Pat Id] -> [DataCon]
+get_unused_cons used_cons = unused_cons
+     where
+       (ConPatOut _ _ _ _ _ ty) = head used_cons
+       ty_con 		      = tcTyConAppTyCon ty		-- Newtype observable
+       all_cons        	      = tyConDataCons ty_con
+       used_cons_as_id 	      = map (\ (ConPatOut (L _ d) _ _ _ _ _) -> d) used_cons
+       unused_cons     	      = uniqSetToList
+		 (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) 
+
+all_vars :: [Pat Id] -> Bool
+all_vars []             = True
+all_vars (WildPat _:ps) = all_vars ps
+all_vars _              = False
+
+remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo)
+remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps })
+remove_var _  = panic "Check.remove_var: equation does not begin with a variable"
+
+-----------------------
+eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]
+eqnPats (_, eqn) = eqn_pats eqn
+
+okGroup :: [(EqnNo, EquationInfo)] -> Bool
+-- True if all equations have at least one pattern, and
+-- all have the same number of patterns
+okGroup [] = True
+okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]
+	       where
+		 n_pats = length (eqnPats e)
+
+-- Half-baked print
+pprGroup es = vcat (map pprEqnInfo es)
+pprEqnInfo e = ppr (eqnPats e)
+
+
+firstPatN :: (EqnNo, EquationInfo) -> Pat Id
+firstPatN (_, eqn) = firstPat eqn
+
+is_con :: Pat Id -> Bool
+is_con (ConPatOut _ _ _ _ _ _) = True
+is_con _                     = False
+
+is_lit :: Pat Id -> Bool
+is_lit (LitPat _)      = True
+is_lit (NPat _ _ _ _)  = True
+is_lit _               = False
+
+is_var :: Pat Id -> Bool
+is_var (WildPat _) = True
+is_var _           = False
+
+is_var_con :: DataCon -> Pat Id -> Bool
+is_var_con con (WildPat _)                          = True
+is_var_con con (ConPatOut (L _ id) _ _ _ _ _) | id == con = True
+is_var_con con _                                    = False
+
+is_var_lit :: HsLit -> Pat Id -> Bool
+is_var_lit lit (WildPat _)   = True
+is_var_lit lit pat 
+  | Just lit' <- get_lit pat = lit == lit'
+  | otherwise		     = False
+\end{code}
+
+The difference beteewn @make_con@ and @make_whole_con@ is that
+@make_wole_con@ creates a new constructor with all their arguments, and
+@make_con@ takes a list of argumntes, creates the contructor getting their
+arguments from the list. See where \fbox{\ ???\ } are used for details.
+
+We need to reconstruct the patterns (make the constructors infix and
+similar) at the same time that we create the constructors.
+
+You can tell tuple constructors using
+\begin{verbatim}
+        Id.isTupleCon
+\end{verbatim}
+You can see if one constructor is infix with this clearer code :-))))))))))
+\begin{verbatim}
+        Lex.isLexConSym (Name.occNameString (Name.getOccName con))
+\end{verbatim}
+
+       Rather clumsy but it works. (Simon Peyton Jones)
+
+
+We don't mind the @nilDataCon@ because it doesn't change the way to
+print the messsage, we are searching only for things like: @[1,2,3]@,
+not @x:xs@ ....
+
+In @reconstruct_pat@ we want to ``undo'' the work
+that we have done in @simplify_pat@.
+In particular:
+\begin{tabular}{lll}
+	@((,) x y)@   & returns to be & @(x, y)@
+\\      @((:) x xs)@  & returns to be & @(x:xs)@
+\\      @(x:(...:[])@ & returns to be & @[x,...]@
+\end{tabular}
+%
+The difficult case is the third one becouse we need to follow all the
+contructors until the @[]@ to know that we need to use the second case,
+not the second. \fbox{\ ???\ }
+%
+\begin{code}
+isInfixCon con = isDataSymOcc (getOccName con)
+
+is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
+is_nil _               		     = False
+
+is_list (ListPat _ _) = True
+is_list _             = False
+
+return_list id q = id == consDataCon && (is_nil q || is_list q) 
+
+make_list p q | is_nil q    = ListPat [p] placeHolderType
+make_list p (ListPat ps ty) = ListPat (p:ps) ty
+make_list _ _               = panic "Check.make_list: Invalid argument"
+
+make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat           
+make_con (ConPatOut (L _ id) _ _ _ _ _) (lp:lq:ps, constraints) 
+     | return_list id q = (noLoc (make_list lp q) : ps, constraints)
+     | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints) 
+   where q  = unLoc lq	
+
+make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) ty) (ps, constraints) 
+      | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints) 
+      | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)           : rest_pats, constraints) 
+      | otherwise        = (nlConPat name pats_con      : rest_pats, constraints)
+    where 
+	name     	      = getName id
+	(pats_con, rest_pats) = splitAtList pats ps
+	tc	    	      = dataConTyCon id
+
+-- reconstruct parallel array pattern
+--
+--  * don't check for the type only; we need to make sure that we are really
+--   dealing with one of the fake constructors and not with the real
+--   representation 
+
+make_whole_con :: DataCon -> WarningPat
+make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat
+                   | otherwise      = nlConPat name pats
+                where 
+                  name   = getName con
+                  pats   = [nlWildPat | t <- dataConOrigArgTys con]
+\end{code}
+
+This equation makes the same thing as @tidy@ in @Match.lhs@, the
+difference is that here we can do all the tidy in one place and in the
+@Match@ tidy it must be done one column each time due to bookkeeping 
+constraints.
+
+\begin{code}
+
+simplify_eqn :: EquationInfo -> EquationInfo
+simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn), 
+		         eqn_rhs  = simplify_rhs (eqn_rhs eqn) }
+  where
+	-- Horrible hack.  The simplify_pat stuff converts NPlusK pats to WildPats
+	-- which of course loses the info that they can fail to match.  So we 
+	-- stick in a CanFail as if it were a guard.
+	-- The Right Thing to do is for the whole system to treat NPlusK pats properly
+    simplify_rhs (MatchResult can_fail body)
+	| any has_nplusk_pat (eqn_pats eqn) = MatchResult CanFail body
+	| otherwise			    = MatchResult can_fail body
+
+has_nplusk_lpat :: LPat Id -> Bool
+has_nplusk_lpat (L _ p) = has_nplusk_pat p
+
+has_nplusk_pat :: Pat Id -> Bool
+has_nplusk_pat (NPlusKPat _ _ _ _) 	 = True
+has_nplusk_pat (ParPat p)  	   	 = has_nplusk_lpat p
+has_nplusk_pat (AsPat _ p) 	   	 = has_nplusk_lpat p
+has_nplusk_pat (SigPatOut p _ )    	 = has_nplusk_lpat p
+has_nplusk_pat (ConPatOut _ _ _ _ ps ty) = any has_nplusk_lpat (hsConArgs ps)
+has_nplusk_pat (ListPat ps _)  		 = any has_nplusk_lpat ps
+has_nplusk_pat (TuplePat ps _ _) 	 = any has_nplusk_lpat ps
+has_nplusk_pat (PArrPat ps _)  		 = any has_nplusk_lpat ps
+has_nplusk_pat (LazyPat p)     		 = False	-- Why?
+has_nplusk_pat (BangPat p)     		 = has_nplusk_lpat p	-- I think
+has_nplusk_pat p = False 	-- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat
+
+simplify_lpat :: LPat Id -> LPat Id  
+simplify_lpat p = fmap simplify_pat p
+
+simplify_pat :: Pat Id -> Pat Id
+simplify_pat pat@(WildPat gt) = pat
+simplify_pat (VarPat id)      = WildPat (idType id) 
+simplify_pat (VarPatOut id _) = WildPat (idType id) 	-- Ignore the bindings
+simplify_pat (ParPat p)       = unLoc (simplify_lpat p)
+simplify_pat (LazyPat p)      = unLoc (simplify_lpat p)
+simplify_pat (BangPat p)      = unLoc (simplify_lpat p)
+simplify_pat (AsPat id p)     = unLoc (simplify_lpat p)
+simplify_pat (SigPatOut p _)  = unLoc (simplify_lpat p)	-- I'm not sure this is right
+
+simplify_pat (ConPatOut (L loc id) tvs dicts binds ps ty) 
+  = ConPatOut (L loc id) tvs dicts binds (simplify_con id ps) ty
+
+simplify_pat (ListPat ps ty) = 
+  unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
+	                          (mkNilPat list_ty)
+	                          (map simplify_lpat ps)
+         where list_ty = mkListTy ty
+
+-- introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+--
+simplify_pat (PArrPat ps ty)
+  = mk_simple_con_pat (parrFakeCon (length ps))
+		      (PrefixCon (map simplify_lpat ps)) 
+		      (mkPArrTy ty)
+
+simplify_pat (TuplePat ps boxity ty)
+  = mk_simple_con_pat (tupleCon boxity arity)
+		      (PrefixCon (map simplify_lpat ps))
+		      ty
+  where
+    arity = length ps
+
+-- unpack string patterns fully, so we can see when they overlap with
+-- each other, or even explicit lists of Chars.
+simplify_pat pat@(LitPat (HsString s)) = 
+   foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy)
+	 (mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s)
+  where
+    mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy)
+
+simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
+
+simplify_pat pat@(NPat lit mb_neg _ lit_ty) = unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat))
+
+simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2)
+   = WildPat (idType (unLoc id))
+
+simplify_pat (DictPat dicts methods)
+  = case num_of_d_and_ms of
+       0 -> simplify_pat (TuplePat [] Boxed unitTy) 
+       1 -> simplify_pat (head dict_and_method_pats) 
+       _ -> simplify_pat (mkVanillaTuplePat (map noLoc dict_and_method_pats) Boxed)
+    where
+       num_of_d_and_ms	 = length dicts + length methods
+       dict_and_method_pats = map VarPat (dicts ++ methods)
+
+mk_simple_con_pat con args ty = ConPatOut (noLoc con) [] [] emptyLHsBinds args ty
+
+-----------------
+simplify_con con (PrefixCon ps)   = PrefixCon (map simplify_lpat ps)
+simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2]
+simplify_con con (RecCon fs)      
+  | null fs   = PrefixCon [nlWildPat | t <- dataConOrigArgTys con]
+		-- Special case for null patterns; maybe not a record at all
+  | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats)
+  where
+     -- pad out all the missing fields with WildPats.
+    field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
+    all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
+		     field_pats fs
+       
+    insertNm nm p [] = [(nm,p)]
+    insertNm nm p (x@(n,_):xs)
+      | nm == n    = (nm,p):xs
+      | otherwise  = x : insertNm nm p xs
+\end{code}
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
new file mode 100644
index 0000000000..45dc113cc1
--- /dev/null
+++ b/compiler/deSugar/Desugar.lhs
@@ -0,0 +1,298 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Desugar]{@deSugar@: the main function}
+
+\begin{code}
+module Desugar ( deSugar, deSugarExpr ) where
+
+#include "HsVersions.h"
+
+import DynFlags		( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
+import StaticFlags	( opt_SccProfilingOn )
+import DriverPhases	( isHsBoot )
+import HscTypes		( ModGuts(..), HscEnv(..), 
+			  Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface )
+import HsSyn		( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
+import TcRnTypes	( TcGblEnv(..), ImportAvails(..) )
+import MkIface		( mkUsageInfo )
+import Id		( Id, setIdExported, idName )
+import Name		( Name, isExternalName, nameIsLocalOrFrom, nameOccName )
+import CoreSyn
+import PprCore		( pprRules, pprCoreExpr )
+import DsMonad
+import DsExpr		( dsLExpr )
+import DsBinds		( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) )
+import DsForeign	( dsForeigns )
+import DsExpr		()	-- Forces DsExpr to be compiled; DsBinds only
+				-- depends on DsExpr.hi-boot.
+import Module		( Module, moduleEnvElts, delModuleEnv, moduleFS )
+import RdrName	 	( GlobalRdrEnv )
+import NameSet
+import VarSet
+import Bag		( Bag, isEmptyBag, emptyBag )
+import Rules		( roughTopNames )
+import CoreLint		( showPass, endPass )
+import CoreFVs		( ruleRhsFreeVars, exprsFreeNames )
+import Packages	  	( PackageState(thPackageId), PackageIdH(..) )
+import ErrUtils		( doIfSet, dumpIfSet_dyn, printBagOfWarnings, 
+			  errorsFound, WarnMsg )
+import ListSetOps	( insertList )
+import Outputable
+import UniqSupply	( mkSplitUniqSupply )
+import SrcLoc		( Located(..) )
+import DATA_IOREF	( readIORef )
+import Maybes		( catMaybes )
+import FastString
+import Util		( sortLe )
+\end{code}
+
+%************************************************************************
+%*									*
+%* 		The main function: deSugar
+%*									*
+%************************************************************************
+
+\begin{code}
+deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts)
+-- Can modify PCS by faulting in more declarations
+
+deSugar hsc_env 
+        tcg_env@(TcGblEnv { tcg_mod       = mod,
+			    tcg_src	  = hsc_src,
+		    	    tcg_type_env  = type_env,
+		    	    tcg_imports   = imports,
+			    tcg_home_mods  = home_mods,
+		    	    tcg_exports   = exports,
+		    	    tcg_dus	  = dus, 
+		    	    tcg_inst_uses = dfun_uses_var,
+			    tcg_th_used   = th_var,
+			    tcg_keep	  = keep_var,
+		    	    tcg_rdr_env   = rdr_env,
+		    	    tcg_fix_env   = fix_env,
+	    	    	    tcg_deprecs   = deprecs,
+			    tcg_binds     = binds,
+			    tcg_fords     = fords,
+			    tcg_rules     = rules,
+		    	    tcg_insts     = insts })
+  = do	{ showPass dflags "Desugar"
+
+	-- Desugar the program
+	; ((all_prs, ds_rules, ds_fords), warns) 
+		<- case ghcMode (hsc_dflags hsc_env) of
+	             JustTypecheck -> return (([], [], NoStubs), emptyBag)
+	             _             -> initDs hsc_env mod rdr_env type_env $ do
+		                        { core_prs <- dsTopLHsBinds auto_scc binds
+		                        ; (ds_fords, foreign_prs) <- dsForeigns fords
+		                        ; let all_prs = foreign_prs ++ core_prs
+		                              local_bndrs = mkVarSet (map fst all_prs)
+		                        ; ds_rules <- mappM (dsRule mod local_bndrs) rules
+		                        ; return (all_prs, catMaybes ds_rules, ds_fords)
+		                        }
+
+	-- If warnings are considered errors, leave.
+	; if errorsFound dflags (warns, emptyBag)
+	   then return (warns, Nothing)
+	   else do
+
+	{ 	-- Add export flags to bindings
+	  keep_alive <- readIORef keep_var
+	; let final_prs = addExportFlags ghci_mode exports keep_alive 
+				   	 all_prs ds_rules
+	      ds_binds  = [Rec final_prs]
+	-- Notice that we put the whole lot in a big Rec, even the foreign binds
+	-- When compiling PrelFloat, which defines data Float = F# Float#
+	-- we want F# to be in scope in the foreign marshalling code!
+	-- You might think it doesn't matter, but the simplifier brings all top-level
+	-- things into the in-scope set before simplifying; so we get no unfolding for F#!
+
+	-- Lint result if necessary
+	; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
+
+	-- Dump output
+	; doIfSet (dopt Opt_D_dump_ds dflags) 
+		  (printDump (ppr_ds_rules ds_rules))
+
+	; dfun_uses <- readIORef dfun_uses_var		-- What dfuns are used
+	; th_used   <- readIORef th_var			-- Whether TH is used
+	; let used_names = allUses dus `unionNameSets` dfun_uses
+	      thPackage = thPackageId (pkgState dflags)
+	      pkgs | ExtPackage th_id <- thPackage, th_used
+		   = insertList th_id  (imp_dep_pkgs imports)
+	      	   | otherwise
+		   = imp_dep_pkgs imports
+
+	      dep_mods = moduleEnvElts (delModuleEnv (imp_dep_mods imports) mod)
+		-- M.hi-boot can be in the imp_dep_mods, but we must remove
+		-- it before recording the modules on which this one depends!
+		-- (We want to retain M.hi-boot in imp_dep_mods so that 
+		--  loadHiBootInterface can see if M's direct imports depend 
+		--  on M.hi-boot, and hence that we should do the hi-boot consistency 
+		--  check.)
+
+	      dir_imp_mods = imp_mods imports
+
+	; usages <- mkUsageInfo hsc_env home_mods dir_imp_mods dep_mods used_names
+
+	; let 
+		-- Modules don't compare lexicographically usually, 
+		-- but we want them to do so here.
+	     le_mod :: Module -> Module -> Bool	 
+	     le_mod m1 m2 = moduleFS m1 <= moduleFS m2
+	     le_dep_mod :: (Module, IsBootInterface) -> (Module, IsBootInterface) -> Bool	 
+	     le_dep_mod (m1,_) (m2,_) = m1 `le_mod` m2
+
+	     deps = Deps { dep_mods  = sortLe le_dep_mod dep_mods,
+			   dep_pkgs  = sortLe (<=)   pkgs,	
+			   dep_orphs = sortLe le_mod (imp_orphs imports) }
+		-- sort to get into canonical order
+
+	     mod_guts = ModGuts {	
+		mg_module   = mod,
+		mg_boot	    = isHsBoot hsc_src,
+		mg_exports  = exports,
+		mg_deps	    = deps,
+		mg_home_mods = home_mods,
+		mg_usages   = usages,
+		mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
+	        mg_rdr_env  = rdr_env,
+		mg_fix_env  = fix_env,
+		mg_deprecs  = deprecs,
+		mg_types    = type_env,
+		mg_insts    = insts,
+	        mg_rules    = ds_rules,
+		mg_binds    = ds_binds,
+		mg_foreign  = ds_fords }
+	
+        ; return (warns, Just mod_guts)
+	}}
+
+  where
+    dflags       = hsc_dflags hsc_env
+    ghci_mode    = ghcMode (hsc_dflags hsc_env)
+    auto_scc | opt_SccProfilingOn = TopLevel
+	     | otherwise          = NoSccs
+
+deSugarExpr :: HscEnv
+	    -> Module -> GlobalRdrEnv -> TypeEnv 
+ 	    -> LHsExpr Id
+	    -> IO CoreExpr
+deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
+  = do	{ showPass dflags "Desugar"
+	; us <- mkSplitUniqSupply 'd'
+
+	-- Do desugaring
+	; (core_expr, ds_warns) <- initDs hsc_env this_mod rdr_env type_env $
+				   dsLExpr tc_expr
+
+	-- Display any warnings 
+	-- Note: if -Werror is used, we don't signal an error here.
+        ; doIfSet (not (isEmptyBag ds_warns))
+		  (printBagOfWarnings dflags ds_warns)
+
+	-- Dump output
+	; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
+
+        ; return core_expr
+	}
+  where
+    dflags       = hsc_dflags hsc_env
+
+
+--		addExportFlags
+-- Set the no-discard flag if either 
+--	a) the Id is exported
+--	b) it's mentioned in the RHS of an orphan rule
+--	c) it's in the keep-alive set
+--
+-- It means that the binding won't be discarded EVEN if the binding
+-- ends up being trivial (v = w) -- the simplifier would usually just 
+-- substitute w for v throughout, but we don't apply the substitution to
+-- the rules (maybe we should?), so this substitution would make the rule
+-- bogus.
+
+-- You might wonder why exported Ids aren't already marked as such;
+-- it's just because the type checker is rather busy already and
+-- I didn't want to pass in yet another mapping.
+
+addExportFlags ghci_mode exports keep_alive prs rules
+  = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
+  where
+    add_export bndr
+	| dont_discard bndr = setIdExported bndr
+	| otherwise	    = bndr
+
+    orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
+			        | rule <- rules, 
+				  not (isLocalRule rule) ]
+	-- A non-local rule keeps alive the free vars of its right-hand side. 
+	-- (A "non-local" is one whose head function is not locally defined.)
+	-- Local rules are (later, after gentle simplification) 
+	-- attached to the Id, and that keeps the rhs free vars alive.
+
+    dont_discard bndr = is_exported name
+		     || name `elemNameSet` keep_alive
+		     || bndr `elemVarSet` orph_rhs_fvs 
+		     where
+			name = idName bndr
+
+    	-- In interactive mode, we don't want to discard any top-level
+    	-- entities at all (eg. do not inline them away during
+    	-- simplification), and retain them all in the TypeEnv so they are
+    	-- available from the command line.
+	--
+	-- isExternalName separates the user-defined top-level names from those
+	-- introduced by the type checker.
+    is_exported :: Name -> Bool
+    is_exported | ghci_mode == Interactive = isExternalName
+		| otherwise 		   = (`elemNameSet` exports)
+
+ppr_ds_rules [] = empty
+ppr_ds_rules rules
+  = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
+    pprRules rules
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+%* 		Desugaring transformation rules
+%*									*
+%************************************************************************
+
+\begin{code}
+dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
+dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
+  = putSrcSpanDs loc $ 
+    do	{ let bndrs     = [var | RuleBndr (L _ var) <- vars]
+	; lhs'  <- dsLExpr lhs
+	; rhs'  <- dsLExpr rhs
+
+	; case decomposeRuleLhs bndrs lhs' of {
+		Nothing -> do { dsWarn msg; return Nothing } ;
+		Just (bndrs', fn_id, args) -> do
+	
+	-- Substitute the dict bindings eagerly,
+	-- and take the body apart into a (f args) form
+	{ let local_rule = nameIsLocalOrFrom mod fn_name
+		-- NB we can't use isLocalId in the orphan test, 
+		-- because isLocalId isn't true of class methods
+	      fn_name   = idName fn_id
+	      lhs_names = fn_name : nameSetToList (exprsFreeNames args)
+		-- No need to delete bndrs, because
+		-- exprsFreeNames finds only External names
+	      orph = case filter (nameIsLocalOrFrom mod) lhs_names of
+			(n:ns) -> Just (nameOccName n)
+			[]     -> Nothing
+
+	      rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
+			    ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs', 
+			    ru_rough = roughTopNames args, 
+			    ru_local = local_rule, ru_orph = orph }
+	; return (Just rule)
+	} } }
+  where
+    msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored"))
+	     2 (ppr lhs)
+\end{code}
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
new file mode 100644
index 0000000000..111e0bccd0
--- /dev/null
+++ b/compiler/deSugar/DsArrows.lhs
@@ -0,0 +1,1055 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsArrows]{Desugaring arrow commands}
+
+\begin{code}
+module DsArrows ( dsProcExpr ) where
+
+#include "HsVersions.h"
+
+import Match		( matchSimply )
+import DsUtils		( mkErrorAppDs,
+			  mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
+			  mkTupleCase, mkBigCoreTup, mkTupleType,
+			  mkTupleExpr, mkTupleSelector,
+			  dsSyntaxTable, lookupEvidence )
+import DsMonad
+
+import HsSyn
+import TcHsSyn		( hsPatType )
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+--     needs to see source types (newtypes etc), and sometimes not
+--     So WATCH OUT; check each use of split*Ty functions.
+-- Sigh.  This is a pain.
+
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
+
+import TcType		( Type, tcSplitAppTy, mkFunTy )
+import Type		( mkTyConApp, funArgTy )
+import CoreSyn
+import CoreFVs		( exprFreeVars )
+import CoreUtils	( mkIfThenElse, bindNonRec, exprType )
+
+import Id		( Id, idType )
+import Name		( Name )
+import PrelInfo		( pAT_ERROR_ID )
+import DataCon		( dataConWrapId )
+import TysWiredIn	( tupleCon )
+import BasicTypes	( Boxity(..) )
+import PrelNames	( eitherTyConName, leftDataConName, rightDataConName,
+			  arrAName, composeAName, firstAName,
+			  appAName, choiceAName, loopAName )
+import Util		( mapAccumL )
+import Outputable
+
+import HsUtils		( collectPatBinders, collectPatsBinders )
+import VarSet		( IdSet, mkVarSet, varSetElems,
+			  intersectVarSet, minusVarSet, extendVarSetList, 
+			  unionVarSet, unionVarSets, elemVarSet )
+import SrcLoc		( Located(..), unLoc, noLoc )
+\end{code}
+
+\begin{code}
+data DsCmdEnv = DsCmdEnv {
+	meth_binds :: [CoreBind],
+	arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
+    }
+
+mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
+mkCmdEnv ids
+  = dsSyntaxTable ids			`thenDs` \ (meth_binds, ds_meths) ->
+    return $ DsCmdEnv {
+		meth_binds = meth_binds,
+		arr_id	   = Var (lookupEvidence ds_meths arrAName),
+		compose_id = Var (lookupEvidence ds_meths composeAName),
+		first_id   = Var (lookupEvidence ds_meths firstAName),
+		app_id	   = Var (lookupEvidence ds_meths appAName),
+		choice_id  = Var (lookupEvidence ds_meths choiceAName),
+		loop_id	   = Var (lookupEvidence ds_meths loopAName)
+	    }
+
+bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
+bindCmdEnv ids body = foldr Let body (meth_binds ids)
+
+-- arr :: forall b c. (b -> c) -> a b c
+do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
+do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
+
+-- (>>>) :: forall b c d. a b c -> a c d -> a b d
+do_compose :: DsCmdEnv -> Type -> Type -> Type ->
+		CoreExpr -> CoreExpr -> CoreExpr
+do_compose ids b_ty c_ty d_ty f g
+  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
+
+-- first :: forall b c d. a b c -> a (b,d) (c,d)
+do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_first ids b_ty c_ty d_ty f
+  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
+
+-- app :: forall b c. a (a b c, b) c
+do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
+do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
+
+-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
+-- note the swapping of d and c
+do_choice :: DsCmdEnv -> Type -> Type -> Type ->
+		CoreExpr -> CoreExpr -> CoreExpr
+do_choice ids b_ty c_ty d_ty f g
+  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
+
+-- loop :: forall b d c. a (b,d) (c,d) -> a b c
+-- note the swapping of d and c
+do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_loop ids b_ty c_ty d_ty f
+  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
+
+-- map_arrow (f :: b -> c) (g :: a c d) = arr f >>> g :: a b d
+do_map_arrow :: DsCmdEnv -> Type -> Type -> Type ->
+		CoreExpr -> CoreExpr -> CoreExpr
+do_map_arrow ids b_ty c_ty d_ty f c
+  = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c
+
+mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
+mkFailExpr ctxt ty
+  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
+
+-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
+mkSndExpr :: Type -> Type -> DsM CoreExpr
+mkSndExpr a_ty b_ty
+  = newSysLocalDs a_ty			`thenDs` \ a_var ->
+    newSysLocalDs b_ty			`thenDs` \ b_var ->
+    newSysLocalDs (mkCorePairTy a_ty b_ty)	`thenDs` \ pair_var ->
+    returnDs (Lam pair_var
+		  (coreCasePair pair_var a_var b_var (Var b_var)))
+\end{code}
+
+Build case analysis of a tuple.  This cannot be done in the DsM monad,
+because the list of variables is typically not yet defined.
+
+\begin{code}
+-- coreCaseTuple [u1..] v [x1..xn] body
+--	= case v of v { (x1, .., xn) -> body }
+-- But the matching may be nested if the tuple is very big
+
+coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
+coreCaseTuple uniqs scrut_var vars body
+  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
+
+coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
+coreCasePair scrut_var var1 var2 body
+  = Case (Var scrut_var) scrut_var (exprType body)
+         [(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
+\end{code}
+
+\begin{code}
+mkCorePairTy :: Type -> Type -> Type
+mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2]
+
+mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
+mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
+\end{code}
+
+The input is divided into a local environment, which is a flat tuple
+(unless it's too big), and a stack, each element of which is paired
+with the stack in turn.  In general, the input has the form
+
+	(...((x1,...,xn),s1),...sk)
+
+where xi are the environment values, and si the ones on the stack,
+with s1 being the "top", the first one to be matched with a lambda.
+
+\begin{code}
+envStackType :: [Id] -> [Type] -> Type
+envStackType ids stack_tys = foldl mkCorePairTy (mkTupleType ids) stack_tys
+
+----------------------------------------------
+--		buildEnvStack
+--
+--	(...((x1,...,xn),s1),...sk)
+
+buildEnvStack :: [Id] -> [Id] -> CoreExpr
+buildEnvStack env_ids stack_ids
+  = foldl mkCorePairExpr (mkTupleExpr env_ids) (map Var stack_ids)
+
+----------------------------------------------
+-- 		matchEnvStack
+--
+--	\ (...((x1,...,xn),s1),...sk) -> e
+--	=>
+--	\ zk ->
+--	case zk of (zk-1,sk) ->
+--	...
+--	case z1 of (z0,s1) ->
+--	case z0 of (x1,...,xn) ->
+--	e
+
+matchEnvStack	:: [Id] 	-- x1..xn
+		-> [Id] 	-- s1..sk
+		-> CoreExpr 	-- e
+		-> DsM CoreExpr
+matchEnvStack env_ids stack_ids body
+  = newUniqueSupply			`thenDs` \ uniqs ->
+    newSysLocalDs (mkTupleType env_ids)	`thenDs` \ tup_var ->
+    matchVarStack tup_var stack_ids 
+		  (coreCaseTuple uniqs tup_var env_ids body)
+
+
+----------------------------------------------
+-- 		matchVarStack
+--
+--	\ (...(z0,s1),...sk) -> e
+--	=>
+--	\ zk ->
+--	case zk of (zk-1,sk) ->
+--	...
+--	case z1 of (z0,s1) ->
+--	e
+
+matchVarStack :: Id 		-- z0
+	      -> [Id] 		-- s1..sk
+	      -> CoreExpr 	-- e
+	      -> DsM CoreExpr
+matchVarStack env_id [] body
+  = returnDs (Lam env_id body)
+matchVarStack env_id (stack_id:stack_ids) body
+  = newSysLocalDs (mkCorePairTy (idType env_id) (idType stack_id))
+					`thenDs` \ pair_id ->
+    matchVarStack pair_id stack_ids 
+		  (coreCasePair pair_id env_id stack_id body)
+\end{code}
+
+\begin{code}
+mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id
+mkHsTupleExpr [e] = e
+mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed
+
+mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id
+mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
+
+mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id
+mkHsEnvStackExpr env_ids stack_ids
+  = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids)
+\end{code}
+
+Translation of arrow abstraction
+
+\begin{code}
+
+--	A | xs |- c :: [] t'  	    ---> c'
+--	--------------------------
+--	A |- proc p -> c :: a t t'  ---> arr (\ p -> (xs)) >>> c'
+--
+--		where (xs) is the tuple of variables bound by p
+
+dsProcExpr
+	:: LPat Id
+	-> LHsCmdTop Id
+	-> DsM CoreExpr
+dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids))
+  = mkCmdEnv ids			`thenDs` \ meth_ids ->
+    let
+	locals = mkVarSet (collectPatBinders pat)
+    in
+    dsfixCmd meth_ids locals [] cmd_ty cmd
+				`thenDs` \ (core_cmd, free_vars, env_ids) ->
+    let
+	env_ty = mkTupleType env_ids
+    in
+    mkFailExpr ProcExpr env_ty		`thenDs` \ fail_expr ->
+    selectSimpleMatchVarL pat		`thenDs` \ var ->
+    matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
+					`thenDs` \ match_code ->
+    let
+	pat_ty = hsPatType pat
+	proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
+		(Lam var match_code)
+		core_cmd
+    in
+    returnDs (bindCmdEnv meth_ids proc_code)
+\end{code}
+
+Translation of command judgements of the form
+
+	A | xs |- c :: [ts] t
+
+\begin{code}
+dsLCmd ids local_vars env_ids stack res_ty cmd
+  = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
+
+dsCmd   :: DsCmdEnv		-- arrow combinators
+	-> IdSet		-- set of local vars available to this command
+	-> [Id]			-- list of vars in the input to this command
+				-- This is typically fed back,
+				-- so don't pull on it too early
+	-> [Type]		-- type of the stack
+	-> Type			-- return type of the command
+	-> HsCmd Id		-- command to desugar
+	-> DsM (CoreExpr,	-- desugared expression
+		IdSet)		-- set of local vars that occur free
+
+--	A |- f :: a (t*ts) t'
+--	A, xs |- arg :: t
+--	-----------------------------
+--	A | xs |- f -< arg :: [ts] t'
+--
+--		---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
+
+dsCmd ids local_vars env_ids stack res_ty
+	(HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
+  = let
+	(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+	env_ty = mkTupleType env_ids
+    in
+    dsLExpr arrow			`thenDs` \ core_arrow ->
+    dsLExpr arg				`thenDs` \ core_arg ->
+    mappM newSysLocalDs stack		`thenDs` \ stack_ids ->
+    matchEnvStack env_ids stack_ids
+	(foldl mkCorePairExpr core_arg (map Var stack_ids))
+					`thenDs` \ core_make_arg ->
+    returnDs (do_map_arrow ids
+		(envStackType env_ids stack)
+		arg_ty
+		res_ty
+		core_make_arg
+		core_arrow,
+	      exprFreeVars core_arg `intersectVarSet` local_vars)
+
+--	A, xs |- f :: a (t*ts) t'
+--	A, xs |- arg :: t
+--	------------------------------
+--	A | xs |- f -<< arg :: [ts] t'
+--
+--		---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
+
+dsCmd ids local_vars env_ids stack res_ty
+	(HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
+  = let
+	(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+	env_ty = mkTupleType env_ids
+    in
+    dsLExpr arrow			`thenDs` \ core_arrow ->
+    dsLExpr arg				`thenDs` \ core_arg ->
+    mappM newSysLocalDs stack		`thenDs` \ stack_ids ->
+    matchEnvStack env_ids stack_ids
+	(mkCorePairExpr core_arrow
+		(foldl mkCorePairExpr core_arg (map Var stack_ids)))
+					`thenDs` \ core_make_pair ->
+    returnDs (do_map_arrow ids
+		(envStackType env_ids stack)
+		(mkCorePairTy arrow_ty arg_ty)
+		res_ty
+		core_make_pair
+		(do_app ids arg_ty res_ty),
+	      (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
+		`intersectVarSet` local_vars)
+
+--	A | ys |- c :: [t:ts] t'
+--	A, xs  |- e :: t
+--	------------------------
+--	A | xs |- c e :: [ts] t'
+--
+--		---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
+  = dsLExpr arg			`thenDs` \ core_arg ->
+    let
+	arg_ty = exprType core_arg
+	stack' = arg_ty:stack
+    in
+    dsfixCmd ids local_vars stack' res_ty cmd
+				`thenDs` \ (core_cmd, free_vars, env_ids') ->
+    mappM newSysLocalDs stack	`thenDs` \ stack_ids ->
+    newSysLocalDs arg_ty	`thenDs` \ arg_id ->
+    -- push the argument expression onto the stack
+    let
+	core_body = bindNonRec arg_id core_arg
+			(buildEnvStack env_ids' (arg_id:stack_ids))
+    in
+    -- match the environment and stack against the input
+    matchEnvStack env_ids stack_ids core_body
+				`thenDs` \ core_map ->
+    returnDs (do_map_arrow ids
+			(envStackType env_ids stack)
+			(envStackType env_ids' stack')
+			res_ty
+			core_map
+			core_cmd,
+	(exprFreeVars core_arg `intersectVarSet` local_vars)
+		`unionVarSet` free_vars)
+
+--	A | ys |- c :: [ts] t'
+--	-----------------------------------------------
+--	A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'
+--
+--		---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty
+    (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
+  = let
+	pat_vars = mkVarSet (collectPatsBinders pats)
+	local_vars' = local_vars `unionVarSet` pat_vars
+	stack' = drop (length pats) stack
+    in
+    dsfixCmd ids local_vars' stack' res_ty body
+				`thenDs` \ (core_body, free_vars, env_ids') ->
+    mappM newSysLocalDs stack	`thenDs` \ stack_ids ->
+
+    -- the expression is built from the inside out, so the actions
+    -- are presented in reverse order
+
+    let
+        (actual_ids, stack_ids') = splitAt (length pats) stack_ids
+	-- build a new environment, plus what's left of the stack
+	core_expr = buildEnvStack env_ids' stack_ids'
+	in_ty = envStackType env_ids stack
+	in_ty' = envStackType env_ids' stack'
+    in
+    mkFailExpr LambdaExpr in_ty'	`thenDs` \ fail_expr ->
+    -- match the patterns against the top of the old stack
+    matchSimplys (map Var actual_ids) LambdaExpr pats core_expr fail_expr
+					`thenDs` \ match_code ->
+    -- match the old environment and stack against the input
+    matchEnvStack env_ids stack_ids match_code
+					`thenDs` \ select_code ->
+    returnDs (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
+	     free_vars `minusVarSet` pat_vars)
+
+dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
+  = dsLCmd ids local_vars env_ids stack res_ty cmd
+
+--	A, xs |- e :: Bool
+--	A | xs1 |- c1 :: [ts] t
+--	A | xs2 |- c2 :: [ts] t
+--	----------------------------------------
+--	A | xs |- if e then c1 else c2 :: [ts] t
+--
+--		---> arr (\ ((xs)*ts) ->
+--			if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
+--		     c1 ||| c2
+
+dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd)
+  = dsLExpr cond			`thenDs` \ core_cond ->
+    dsfixCmd ids local_vars stack res_ty then_cmd
+				`thenDs` \ (core_then, fvs_then, then_ids) ->
+    dsfixCmd ids local_vars stack res_ty else_cmd
+				`thenDs` \ (core_else, fvs_else, else_ids) ->
+    mappM newSysLocalDs stack		`thenDs` \ stack_ids ->
+    dsLookupTyCon eitherTyConName	`thenDs` \ either_con ->
+    dsLookupDataCon leftDataConName	`thenDs` \ left_con ->
+    dsLookupDataCon rightDataConName	`thenDs` \ right_con ->
+    let
+	left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
+	right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
+
+	in_ty = envStackType env_ids stack
+	then_ty = envStackType then_ids stack
+	else_ty = envStackType else_ids stack
+	sum_ty = mkTyConApp either_con [then_ty, else_ty]
+	fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars
+    in
+    matchEnvStack env_ids stack_ids
+	(mkIfThenElse core_cond
+	    (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids))
+	    (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
+					`thenDs` \ core_if ->
+    returnDs(do_map_arrow ids in_ty sum_ty res_ty
+		core_if
+		(do_choice ids then_ty else_ty res_ty core_then core_else),
+	fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+\end{code}
+
+Case commands are treated in much the same way as if commands
+(see above) except that there are more alternatives.  For example
+
+	case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+
+is translated to
+
+	arr (\ ((xs)*ts) -> case e of
+		p1 -> (Left (Left (xs1)*ts))
+		p2 -> Left ((Right (xs2)*ts))
+		p3 -> Right ((xs3)*ts)) >>>
+	(c1 ||| c2) ||| c3
+
+The idea is to extract the commands from the case, build a balanced tree
+of choices, and replace the commands with expressions that build tagged
+tuples, obtaining a case expression that can be desugared normally.
+To build all this, we use quadruples decribing segments of the list of
+case bodies, containing the following fields:
+1. an IdSet containing the environment variables free in the case bodies
+2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
+   into the case replacing the commands
+3. a sum type that is the common type of these expressions, and also the
+   input type of the arrow
+4. a CoreExpr for an arrow built by combining the translated command
+   bodies with |||.
+
+\begin{code}
+dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty))
+  = dsLExpr exp				`thenDs` \ core_exp ->
+    mappM newSysLocalDs stack		`thenDs` \ stack_ids ->
+
+    -- Extract and desugar the leaf commands in the case, building tuple
+    -- expressions that will (after tagging) replace these leaves
+
+    let
+        leaves = concatMap leavesMatch matches
+	make_branch (leaf, bound_vars)
+	  = dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
+			   `thenDs` \ (core_leaf, fvs, leaf_ids) ->
+	    returnDs (fvs `minusVarSet` bound_vars,
+		      [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids],
+		      envStackType leaf_ids stack,
+		      core_leaf)
+    in
+    mappM make_branch leaves		`thenDs` \ branches ->
+    dsLookupTyCon eitherTyConName	`thenDs` \ either_con ->
+    dsLookupDataCon leftDataConName	`thenDs` \ left_con ->
+    dsLookupDataCon rightDataConName	`thenDs` \ right_con ->
+    let
+	left_id = nlHsVar (dataConWrapId left_con)
+	right_id = nlHsVar (dataConWrapId right_con)
+	left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e
+	right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) e
+
+	-- Prefix each tuple with a distinct series of Left's and Right's,
+	-- in a balanced way, keeping track of the types.
+
+        merge_branches (fvs1, builds1, in_ty1, core_exp1)
+		       (fvs2, builds2, in_ty2, core_exp2) 
+	  = (fvs1 `unionVarSet` fvs2,
+	     map (left_expr in_ty1 in_ty2) builds1 ++
+		map (right_expr in_ty1 in_ty2) builds2,
+	     mkTyConApp either_con [in_ty1, in_ty2],
+	     do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
+	(fvs_alts, leaves', sum_ty, core_choices)
+	  = foldb merge_branches branches
+
+	-- Replace the commands in the case with these tagged tuples,
+	-- yielding a HsExpr Id we can feed to dsExpr.
+
+	(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+	in_ty = envStackType env_ids stack
+	fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
+
+	pat_ty    = funArgTy match_ty
+	match_ty' = mkFunTy pat_ty sum_ty
+	-- Note that we replace the HsCase result type by sum_ty,
+	-- which is the type of matches'
+    in
+    dsExpr (HsCase exp (MatchGroup matches' match_ty')) `thenDs` \ core_body ->
+    matchEnvStack env_ids stack_ids core_body
+					`thenDs` \ core_matches ->
+    returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
+	     fvs_exp `unionVarSet` fvs_alts)
+
+--	A | ys |- c :: [ts] t
+--	----------------------------------
+--	A | xs |- let binds in c :: [ts] t
+--
+--		---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
+  = let
+	defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
+	local_vars' = local_vars `unionVarSet` defined_vars
+    in
+    dsfixCmd ids local_vars' stack res_ty body
+				`thenDs` \ (core_body, free_vars, env_ids') ->
+    mappM newSysLocalDs stack		`thenDs` \ stack_ids ->
+    -- build a new environment, plus the stack, using the let bindings
+    dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
+					`thenDs` \ core_binds ->
+    -- match the old environment and stack against the input
+    matchEnvStack env_ids stack_ids core_binds
+					`thenDs` \ core_map ->
+    returnDs (do_map_arrow ids
+			(envStackType env_ids stack)
+			(envStackType env_ids' stack)
+			res_ty
+			core_map
+			core_body,
+	exprFreeVars core_binds `intersectVarSet` local_vars)
+
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
+  = dsCmdDo ids local_vars env_ids res_ty stmts body
+
+--	A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
+--	A | xs |- ci :: [tsi] ti
+--	-----------------------------------
+--	A | xs |- (|e c1 ... cn|) :: [ts] t	---> e [t_xs] c1 ... cn
+
+dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
+  = let
+	env_ty = mkTupleType env_ids
+    in
+    dsLExpr op				`thenDs` \ core_op ->
+    mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args
+					`thenDs` \ (core_args, fv_sets) ->
+    returnDs (mkApps (App core_op (Type env_ty)) core_args,
+	      unionVarSets fv_sets)
+
+--	A | ys |- c :: [ts] t	(ys <= xs)
+--	---------------------
+--	A | xs |- c :: [ts] t	---> arr_ts (\ (xs) -> (ys)) >>> c
+
+dsTrimCmdArg
+	:: IdSet		-- set of local vars available to this command
+	-> [Id]			-- list of vars in the input to this command
+	-> LHsCmdTop Id	-- command argument to desugar
+	-> DsM (CoreExpr,	-- desugared expression
+		IdSet)		-- set of local vars that occur free
+dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids))
+  = mkCmdEnv ids			`thenDs` \ meth_ids ->
+    dsfixCmd meth_ids local_vars stack cmd_ty cmd
+				`thenDs` \ (core_cmd, free_vars, env_ids') ->
+    mappM newSysLocalDs stack		`thenDs` \ stack_ids ->
+    matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids)
+					`thenDs` \ trim_code ->
+    let
+	in_ty = envStackType env_ids stack
+	in_ty' = envStackType env_ids' stack
+	arg_code = if env_ids' == env_ids then core_cmd else
+		do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
+    in
+    returnDs (bindCmdEnv meth_ids arg_code, free_vars)
+
+-- Given A | xs |- c :: [ts] t, builds c with xs fed back.
+-- Typically needs to be prefixed with arr (\p -> ((xs)*ts))
+
+dsfixCmd
+	:: DsCmdEnv		-- arrow combinators
+	-> IdSet		-- set of local vars available to this command
+	-> [Type]		-- type of the stack
+	-> Type			-- return type of the command
+	-> LHsCmd Id		-- command to desugar
+	-> DsM (CoreExpr,	-- desugared expression
+		IdSet,		-- set of local vars that occur free
+		[Id])		-- set as a list, fed back
+dsfixCmd ids local_vars stack cmd_ty cmd
+  = fixDs (\ ~(_,_,env_ids') ->
+	dsLCmd ids local_vars env_ids' stack cmd_ty cmd
+					`thenDs` \ (core_cmd, free_vars) ->
+	returnDs (core_cmd, free_vars, varSetElems free_vars))
+
+\end{code}
+
+Translation of command judgements of the form
+
+	A | xs |- do { ss } :: [] t
+
+\begin{code}
+
+dsCmdDo :: DsCmdEnv		-- arrow combinators
+	-> IdSet		-- set of local vars available to this statement
+	-> [Id]			-- list of vars in the input to this statement
+				-- This is typically fed back,
+				-- so don't pull on it too early
+	-> Type			-- return type of the statement
+	-> [LStmt Id]		-- statements to desugar
+	-> LHsExpr Id		-- body
+	-> DsM (CoreExpr,	-- desugared expression
+		IdSet)		-- set of local vars that occur free
+
+--	A | xs |- c :: [] t
+--	--------------------------
+--	A | xs |- do { c } :: [] t
+
+dsCmdDo ids local_vars env_ids res_ty [] body
+  = dsLCmd ids local_vars env_ids [] res_ty body
+
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body
+  = let
+	bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
+	local_vars' = local_vars `unionVarSet` bound_vars
+    in
+    fixDs (\ ~(_,_,env_ids') ->
+	dsCmdDo ids local_vars' env_ids' res_ty stmts body
+					`thenDs` \ (core_stmts, fv_stmts) ->
+	returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
+				`thenDs` \ (core_stmts, fv_stmts, env_ids') ->
+    dsCmdLStmt ids local_vars env_ids env_ids' stmt
+				`thenDs` \ (core_stmt, fv_stmt) ->
+    returnDs (do_compose ids
+		(mkTupleType env_ids)
+		(mkTupleType env_ids')
+		res_ty
+		core_stmt
+		core_stmts,
+	      fv_stmt)
+
+\end{code}
+A statement maps one local environment to another, and is represented
+as an arrow from one tuple type to another.  A statement sequence is
+translated to a composition of such arrows.
+\begin{code}
+dsCmdLStmt ids local_vars env_ids out_ids cmd
+  = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
+
+dsCmdStmt
+	:: DsCmdEnv		-- arrow combinators
+	-> IdSet		-- set of local vars available to this statement
+	-> [Id]			-- list of vars in the input to this statement
+				-- This is typically fed back,
+				-- so don't pull on it too early
+	-> [Id]			-- list of vars in the output of this statement
+	-> Stmt Id	-- statement to desugar
+	-> DsM (CoreExpr,	-- desugared expression
+		IdSet)		-- set of local vars that occur free
+
+--	A | xs1 |- c :: [] t
+--	A | xs' |- do { ss } :: [] t'
+--	------------------------------
+--	A | xs |- do { c; ss } :: [] t'
+--
+--		---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
+--			arr snd >>> ss
+
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
+  = dsfixCmd ids local_vars [] c_ty cmd
+				`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
+    matchEnvStack env_ids []
+	(mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr out_ids))
+					`thenDs` \ core_mux ->
+    let
+	in_ty = mkTupleType env_ids
+	in_ty1 = mkTupleType env_ids1
+	out_ty = mkTupleType out_ids
+	before_c_ty = mkCorePairTy in_ty1 out_ty
+	after_c_ty = mkCorePairTy c_ty out_ty
+    in
+    mkSndExpr c_ty out_ty		`thenDs` \ snd_fn ->
+    returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
+		do_compose ids before_c_ty after_c_ty out_ty
+			(do_first ids in_ty1 c_ty out_ty core_cmd) $
+		do_arr ids after_c_ty out_ty snd_fn,
+	      extendVarSetList fv_cmd out_ids)
+  where
+
+--	A | xs1 |- c :: [] t
+--	A | xs' |- do { ss } :: [] t'		xs2 = xs' - defs(p)
+--	-----------------------------------
+--	A | xs |- do { p <- c; ss } :: [] t'
+--
+--		---> arr (\ (xs) -> ((xs1),(xs2))) >>> first c >>>
+--			arr (\ (p, (xs2)) -> (xs')) >>> ss
+--
+-- It would be simpler and more consistent to do this using second,
+-- but that's likely to be defined in terms of first.
+
+dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
+  = dsfixCmd ids local_vars [] (hsPatType pat) cmd
+				`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
+    let
+	pat_ty = hsPatType pat
+	pat_vars = mkVarSet (collectPatBinders pat)
+	env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
+	env_ty2 = mkTupleType env_ids2
+    in
+
+    -- multiplexing function
+    --		\ (xs) -> ((xs1),(xs2))
+
+    matchEnvStack env_ids []
+	(mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr env_ids2))
+					`thenDs` \ core_mux ->
+
+    -- projection function
+    --		\ (p, (xs2)) -> (zs)
+
+    newSysLocalDs env_ty2		`thenDs` \ env_id ->
+    newUniqueSupply			`thenDs` \ uniqs ->
+    let
+	after_c_ty = mkCorePairTy pat_ty env_ty2
+	out_ty = mkTupleType out_ids
+	body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids)
+    in
+    mkFailExpr (StmtCtxt DoExpr) out_ty	`thenDs` \ fail_expr ->
+    selectSimpleMatchVarL pat		`thenDs` \ pat_id ->
+    matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
+					`thenDs` \ match_code ->
+    newSysLocalDs after_c_ty		`thenDs` \ pair_id ->
+    let
+	proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
+    in
+
+    -- put it all together
+    let
+	in_ty = mkTupleType env_ids
+	in_ty1 = mkTupleType env_ids1
+	in_ty2 = mkTupleType env_ids2
+	before_c_ty = mkCorePairTy in_ty1 in_ty2
+    in
+    returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
+		do_compose ids before_c_ty after_c_ty out_ty
+			(do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
+		do_arr ids after_c_ty out_ty proj_expr,
+	      fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
+
+--	A | xs' |- do { ss } :: [] t
+--	--------------------------------------
+--	A | xs |- do { let binds; ss } :: [] t
+--
+--		---> arr (\ (xs) -> let binds in (xs')) >>> ss
+
+dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
+    -- build a new environment using the let bindings
+  = dsLocalBinds binds (mkTupleExpr out_ids)	`thenDs` \ core_binds ->
+    -- match the old environment against the input
+    matchEnvStack env_ids [] core_binds	`thenDs` \ core_map ->
+    returnDs (do_arr ids
+			(mkTupleType env_ids)
+			(mkTupleType out_ids)
+			core_map,
+	exprFreeVars core_binds `intersectVarSet` local_vars)
+
+--	A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ...
+--	A | xs' |- do { ss' } :: [] t
+--	------------------------------------
+--	A | xs |- do { rec ss; ss' } :: [] t
+--
+--			xs1 = xs' /\ defs(ss)
+--			xs2 = xs' - defs(ss)
+--			ys1 = ys - defs(ss)
+--			ys2 = ys /\ defs(ss)
+--
+--		---> arr (\(xs) -> ((ys1),(xs2))) >>>
+--			first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
+--			arr (\((xs1),(xs2)) -> (xs')) >>> ss'
+
+dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds)
+  = let		-- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
+	env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
+	env2_ids = varSetElems env2_id_set
+	env2_ty = mkTupleType env2_ids
+    in
+
+    -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
+
+    newUniqueSupply		`thenDs` \ uniqs ->
+    newSysLocalDs env2_ty	`thenDs` \ env2_id ->
+    let
+	later_ty = mkTupleType later_ids
+	post_pair_ty = mkCorePairTy later_ty env2_ty
+	post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkTupleExpr out_ids)
+    in
+    matchEnvStack later_ids [env2_id] post_loop_body
+				`thenDs` \ post_loop_fn ->
+
+    --- loop (...)
+
+    dsRecCmd ids local_vars stmts later_ids rec_ids rhss
+				`thenDs` \ (core_loop, env1_id_set, env1_ids) ->
+
+    -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
+
+    let
+	env1_ty = mkTupleType env1_ids
+	pre_pair_ty = mkCorePairTy env1_ty env2_ty
+	pre_loop_body = mkCorePairExpr (mkTupleExpr env1_ids)
+					(mkTupleExpr env2_ids)
+
+    in
+    matchEnvStack env_ids [] pre_loop_body
+				`thenDs` \ pre_loop_fn ->
+
+    -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
+
+    let
+	env_ty = mkTupleType env_ids
+	out_ty = mkTupleType out_ids
+	core_body = do_map_arrow ids env_ty pre_pair_ty out_ty
+		pre_loop_fn
+		(do_compose ids pre_pair_ty post_pair_ty out_ty
+			(do_first ids env1_ty later_ty env2_ty
+				core_loop)
+			(do_arr ids post_pair_ty out_ty
+				post_loop_fn))
+    in
+    returnDs (core_body, env1_id_set `unionVarSet` env2_id_set)
+
+--	loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
+--	      ss >>>
+--	      arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
+
+dsRecCmd ids local_vars stmts later_ids rec_ids rhss
+  = let
+	rec_id_set = mkVarSet rec_ids
+	out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set)
+	out_ty = mkTupleType out_ids
+	local_vars' = local_vars `unionVarSet` rec_id_set
+    in
+
+    -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
+
+    mappM dsExpr rhss		`thenDs` \ core_rhss ->
+    let
+	later_tuple = mkTupleExpr later_ids
+	later_ty = mkTupleType later_ids
+	rec_tuple = mkBigCoreTup core_rhss
+	rec_ty = mkTupleType rec_ids
+	out_pair = mkCorePairExpr later_tuple rec_tuple
+	out_pair_ty = mkCorePairTy later_ty rec_ty
+    in
+	matchEnvStack out_ids [] out_pair
+				`thenDs` \ mk_pair_fn ->
+
+    -- ss
+
+    dsfixCmdStmts ids local_vars' out_ids stmts
+				`thenDs` \ (core_stmts, fv_stmts, env_ids) ->
+
+    -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
+
+    newSysLocalDs rec_ty	`thenDs` \ rec_id ->
+    let
+	env1_id_set = fv_stmts `minusVarSet` rec_id_set
+	env1_ids = varSetElems env1_id_set
+	env1_ty = mkTupleType env1_ids
+	in_pair_ty = mkCorePairTy env1_ty rec_ty
+	core_body = mkBigCoreTup (map selectVar env_ids)
+	  where
+	    selectVar v
+		| v `elemVarSet` rec_id_set
+		  = mkTupleSelector rec_ids v rec_id (Var rec_id)
+		| otherwise = Var v
+    in
+    matchEnvStack env1_ids [rec_id] core_body
+				`thenDs` \ squash_pair_fn ->
+
+    -- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)
+
+    let
+	env_ty = mkTupleType env_ids
+	core_loop = do_loop ids env1_ty later_ty rec_ty
+		(do_map_arrow ids in_pair_ty env_ty out_pair_ty
+			squash_pair_fn
+			(do_compose ids env_ty out_ty out_pair_ty
+				core_stmts
+				(do_arr ids out_ty out_pair_ty mk_pair_fn)))
+    in
+    returnDs (core_loop, env1_id_set, env1_ids)
+
+\end{code}
+A sequence of statements (as in a rec) is desugared to an arrow between
+two environments
+\begin{code}
+
+dsfixCmdStmts
+	:: DsCmdEnv		-- arrow combinators
+	-> IdSet		-- set of local vars available to this statement
+	-> [Id]			-- output vars of these statements
+	-> [LStmt Id]	-- statements to desugar
+	-> DsM (CoreExpr,	-- desugared expression
+		IdSet,		-- set of local vars that occur free
+		[Id])		-- input vars
+
+dsfixCmdStmts ids local_vars out_ids stmts
+  = fixDs (\ ~(_,_,env_ids) ->
+	dsCmdStmts ids local_vars env_ids out_ids stmts
+					`thenDs` \ (core_stmts, fv_stmts) ->
+	returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
+
+dsCmdStmts
+	:: DsCmdEnv		-- arrow combinators
+	-> IdSet		-- set of local vars available to this statement
+	-> [Id]			-- list of vars in the input to these statements
+	-> [Id]			-- output vars of these statements
+	-> [LStmt Id]	-- statements to desugar
+	-> DsM (CoreExpr,	-- desugared expression
+		IdSet)		-- set of local vars that occur free
+
+dsCmdStmts ids local_vars env_ids out_ids [stmt]
+  = dsCmdLStmt ids local_vars env_ids out_ids stmt
+
+dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts)
+  = let
+	bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
+	local_vars' = local_vars `unionVarSet` bound_vars
+    in
+    dsfixCmdStmts ids local_vars' out_ids stmts
+				`thenDs` \ (core_stmts, fv_stmts, env_ids') ->
+    dsCmdLStmt ids local_vars env_ids env_ids' stmt
+				`thenDs` \ (core_stmt, fv_stmt) ->
+    returnDs (do_compose ids
+		(mkTupleType env_ids)
+		(mkTupleType env_ids')
+		(mkTupleType out_ids)
+		core_stmt
+		core_stmts,
+	      fv_stmt)
+
+\end{code}
+
+Match a list of expressions against a list of patterns, left-to-right.
+
+\begin{code}
+matchSimplys :: [CoreExpr]              -- Scrutinees
+	     -> HsMatchContext Name	-- Match kind
+	     -> [LPat Id]         	-- Patterns they should match
+	     -> CoreExpr                -- Return this if they all match
+	     -> CoreExpr                -- Return this if they don't
+	     -> DsM CoreExpr
+matchSimplys [] _ctxt [] result_expr _fail_expr = returnDs result_expr
+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr
+  = matchSimplys exps ctxt pats result_expr fail_expr
+					`thenDs` \ match_code ->
+    matchSimply exp ctxt pat match_code fail_expr
+\end{code}
+
+List of leaf expressions, with set of variables bound in each
+
+\begin{code}
+leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)]
+leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
+  = let
+	defined_vars = mkVarSet (collectPatsBinders pats)
+			`unionVarSet`
+		       mkVarSet (map unLoc (collectLocalBinders binds))
+    in
+    [(expr, 
+      mkVarSet (map unLoc (collectLStmtsBinders stmts)) 
+	`unionVarSet` defined_vars) 
+    | L _ (GRHS stmts expr) <- grhss]
+\end{code}
+
+Replace the leaf commands in a match
+
+\begin{code}
+replaceLeavesMatch
+	:: Type			-- new result type
+	-> [LHsExpr Id]	-- replacement leaf expressions of that type
+	-> LMatch Id	-- the matches of a case command
+	-> ([LHsExpr Id],-- remaining leaf expressions
+	    LMatch Id)	-- updated match
+replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
+  = let
+	(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
+    in
+    (leaves', L loc (Match pat mt (GRHSs grhss' binds)))
+
+replaceLeavesGRHS
+	:: [LHsExpr Id]	-- replacement leaf expressions of that type
+	-> LGRHS Id	-- rhss of a case command
+	-> ([LHsExpr Id],-- remaining leaf expressions
+	    LGRHS Id)	-- updated GRHS
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs))
+  = (leaves, L loc (GRHS stmts leaf))
+\end{code}
+
+Balanced fold of a non-empty list.
+
+\begin{code}
+foldb :: (a -> a -> a) -> [a] -> a
+foldb _ [] = error "foldb of empty list"
+foldb _ [x] = x
+foldb f xs = foldb f (fold_pairs xs)
+  where
+    fold_pairs [] = []
+    fold_pairs [x] = [x]
+    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
+\end{code}
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
new file mode 100644
index 0000000000..8f3006d0f3
--- /dev/null
+++ b/compiler/deSugar/DsBinds.lhs
@@ -0,0 +1,417 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
+
+Handles @HsBinds@; those at the top level require different handling,
+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
+lower levels it is preserved with @let@/@letrec@s).
+
+\begin{code}
+module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 
+		 dsCoercion,
+		 AutoScc(..)
+  ) where
+
+#include "HsVersions.h"
+
+
+import {-# SOURCE #-}	DsExpr( dsLExpr, dsExpr )
+import {-# SOURCE #-}	Match( matchWrapper )
+
+import DsMonad
+import DsGRHSs		( dsGuarded )
+import DsUtils
+
+import HsSyn		-- lots of things
+import CoreSyn		-- lots of things
+import CoreUtils	( exprType, mkInlineMe, mkSCC )
+
+import StaticFlags	( opt_AutoSccsOnAllToplevs,
+			  opt_AutoSccsOnExportedToplevs )
+import OccurAnal	( occurAnalyseExpr )
+import CostCentre	( mkAutoCC, IsCafCC(..) )
+import Id		( Id, DictId, idType, idName, isExportedId, mkLocalId, setInlinePragma )
+import Rules		( addIdSpecialisations, mkLocalRule )
+import Var		( TyVar, Var, isGlobalId, setIdNotExported )
+import VarEnv
+import Type		( mkTyVarTy, substTyWith )
+import TysWiredIn	( voidTy )
+import Outputable
+import SrcLoc		( Located(..) )
+import Maybes		( isJust, catMaybes, orElse )
+import Bag		( bagToList )
+import BasicTypes	( Activation(..), InlineSpec(..), isAlwaysActive, defaultInlineSpec )
+import Monad		( foldM )
+import FastString	( mkFastString )
+import List		( (\\) )
+import Util		( mapSnd )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
+%*									*
+%************************************************************************
+
+\begin{code}
+dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
+dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+
+dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
+dsLHsBinds binds = ds_lhs_binds NoSccs binds
+
+
+------------------------
+ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
+	 -- scc annotation policy (see below)
+ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
+
+dsLHsBind :: AutoScc
+	 -> [(Id,CoreExpr)]	-- Put this on the end (avoid quadratic append)
+	 -> LHsBind Id
+	 -> DsM [(Id,CoreExpr)] -- Result
+dsLHsBind auto_scc rest (L loc bind)
+  = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
+
+dsHsBind :: AutoScc
+	 -> [(Id,CoreExpr)]	-- Put this on the end (avoid quadratic append)
+	 -> HsBind Id
+	 -> DsM [(Id,CoreExpr)] -- Result
+
+dsHsBind auto_scc rest (VarBind var expr)
+  = dsLExpr expr		`thenDs` \ core_expr ->
+
+	-- Dictionary bindings are always VarMonoBinds, so
+	-- we only need do this here
+    addDictScc var core_expr	`thenDs` \ core_expr' ->
+    returnDs ((var, core_expr') : rest)
+
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
+  = matchWrapper (FunRhs (idName fun)) matches		`thenDs` \ (args, body) ->
+    dsCoercion co_fn (return (mkLams args body))	`thenDs` \ rhs ->
+    addAutoScc auto_scc (fun, rhs)			`thenDs` \ pair ->
+    returnDs (pair : rest)
+
+dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+  = dsGuarded grhss ty				`thenDs` \ body_expr ->
+    mkSelectorBinds pat body_expr		`thenDs` \ sel_binds ->
+    mappM (addAutoScc auto_scc) sel_binds	`thenDs` \ sel_binds ->
+    returnDs (sel_binds ++ rest)
+
+	-- Common special case: no type or dictionary abstraction
+	-- For the (rare) case when there are some mixed-up
+	-- dictionary bindings (for which a Rec is convenient)
+	-- we reply on the enclosing dsBind to wrap a Rec around.
+dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
+  = ds_lhs_binds (addSccs auto_scc exports) binds 	`thenDs` \ core_prs ->
+    let
+	core_prs' = addLocalInlines exports core_prs
+	exports'  = [(global, Var local) | (_, global, local, _) <- exports]
+    in
+    returnDs (core_prs' ++ exports' ++ rest)
+
+	-- Another common case: one exported variable
+	-- Non-recursive bindings come through this way
+dsHsBind auto_scc rest
+     (AbsBinds all_tyvars dicts exports@[(tyvars, global, local, prags)] binds)
+  = ASSERT( all (`elem` tyvars) all_tyvars )
+    ds_lhs_binds (addSccs auto_scc exports) binds 	`thenDs` \ core_prs ->
+    let 
+	-- Always treat the binds as recursive, because the typechecker
+	-- makes rather mixed-up dictionary bindings
+	core_bind = Rec core_prs
+    in
+    mappM (dsSpec all_tyvars dicts tyvars global local core_bind) 
+	  prags				`thenDs` \ mb_specs ->
+    let
+	(spec_binds, rules) = unzip (catMaybes mb_specs)
+	global' = addIdSpecialisations global rules
+	rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+	inl 	= case [inl | InlinePrag inl <- prags] of
+	    	 	[]      -> defaultInlineSpec 
+	    	 	(inl:_) -> inl
+    in
+    returnDs (addInlineInfo inl global' rhs' : spec_binds ++ rest)
+
+dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
+  = ds_lhs_binds (addSccs auto_scc exports) binds 	`thenDs` \ core_prs ->
+     let 
+	-- Rec because of mixed-up dictionary bindings
+	core_bind = Rec (addLocalInlines exports core_prs)
+
+	tup_expr      = mkTupleExpr locals
+	tup_ty	      = exprType tup_expr
+	poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
+		        Let core_bind tup_expr
+	locals        = [local | (_, _, local, _) <- exports]
+	local_tys     = map idType locals
+    in
+    newSysLocalDs (exprType poly_tup_expr)		`thenDs` \ poly_tup_id ->
+    let
+	dict_args = map Var dicts
+
+	mk_bind ((tyvars, global, local, prags), n)	-- locals !! n == local
+	  = 	-- Need to make fresh locals to bind in the selector, because
+		-- some of the tyvars will be bound to voidTy
+	    newSysLocalsDs (map substitute local_tys) 	`thenDs` \ locals' ->
+	    newSysLocalDs  (substitute tup_ty)		`thenDs` \ tup_id ->
+	    mapM (dsSpec all_tyvars dicts tyvars global local core_bind) 
+		 prags				`thenDs` \ mb_specs ->
+	    let
+		(spec_binds, rules) = unzip (catMaybes mb_specs)
+		global' = addIdSpecialisations global rules
+	        rhs = mkLams tyvars $ mkLams dicts $
+		      mkTupleSelector locals' (locals' !! n) tup_id $
+		      mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
+	    in
+	    returnDs ((global', rhs) : spec_binds)
+	  where
+	    mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
+				| otherwise		  = voidTy
+	    ty_args    = map mk_ty_arg all_tyvars
+	    substitute = substTyWith all_tyvars ty_args
+    in
+    mappM mk_bind (exports `zip` [0..])		`thenDs` \ export_binds_s ->
+     -- don't scc (auto-)annotate the tuple itself.
+
+    returnDs ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest))
+
+dsSpec :: [TyVar] -> [DictId] -> [TyVar]
+       -> Id -> Id		-- Global, local
+       -> CoreBind -> Prag
+       -> DsM (Maybe ((Id,CoreExpr), 	-- Binding for specialised Id
+		      CoreRule))	-- Rule for the Global Id
+
+-- Example:
+--	f :: (Eq a, Ix b) => a -> b -> b
+--	{-# SPECIALISE f :: Ix b => Int -> b -> b #-}
+--
+--	AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
+-- 
+-- 	SpecPrag (/\b.\(d:Ix b). f Int b dInt d) 
+--		 (forall b. Ix b => Int -> b -> b)
+--
+-- Rule: 	forall b,(d:Ix b). f Int b dInt d = f_spec b d
+--
+-- Spec bind:	f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono 
+--			 /\b.\(d:Ix b). in f Int b dInt d
+--		The idea is that f occurs just once, so it'll be 
+--		inlined and specialised
+
+dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {})
+  = return Nothing
+
+dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
+       (SpecPrag spec_expr spec_ty const_dicts inl)
+  = do	{ let poly_name = idName poly_id
+	; spec_name <- newLocalName poly_name
+	; ds_spec_expr  <- dsExpr spec_expr
+	; let (bndrs, body) = collectBinders ds_spec_expr
+	      mb_lhs  	    = decomposeRuleLhs (bndrs ++ const_dicts) body
+
+	; case mb_lhs of
+	    Nothing -> do { dsWarn msg; return Nothing }
+
+	    Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
+		where
+		  local_poly  = setIdNotExported poly_id
+			-- Very important to make the 'f' non-exported,
+			-- else it won't be inlined!
+		  spec_id     = mkLocalId spec_name spec_ty
+		  spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
+		  poly_f_body = mkLams (tvs ++ dicts) $
+			   	fix_up (Let mono_bind (Var mono_id))
+
+			-- Quantify over constant dicts on the LHS, since
+			-- their value depends only on their type
+			-- The ones we are interested in may even be imported
+			-- e.g. GHC.Base.dEqInt
+
+		  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
+				AlwaysActive poly_name
+			        bndrs'	-- Includes constant dicts
+				args
+				(mkVarApps (Var spec_id) bndrs)
+	}
+  where
+	-- Bind to voidTy any of all_ptvs that aren't 
+	-- relevant for this particular function 
+    fix_up body | null void_tvs = body
+		| otherwise	= mkTyApps (mkLams void_tvs body) 
+					   (map (const voidTy) void_tvs)
+    void_tvs = all_tvs \\ tvs
+
+    msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))
+	     2 (ppr spec_expr)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Adding inline pragmas}
+%*									*
+%************************************************************************
+
+\begin{code}
+decomposeRuleLhs :: [Var] -> CoreExpr -> Maybe ([Var], Id, [CoreExpr])
+-- Returns Nothing if the LHS isn't of the expected shape
+-- The argument 'all_bndrs' includes the "constant dicts" of the LHS,
+-- and they may be GlobalIds, which we can't forall-ify. 
+-- So we substitute them out instead
+decomposeRuleLhs all_bndrs lhs 
+  = go init_env (occurAnalyseExpr lhs)	-- Occurrence analysis sorts out the dict
+					-- bindings so we know if they are recursive
+  where
+
+	-- all_bndrs may include top-level imported dicts, 
+	-- imported things with a for-all.  
+	-- So we localise them and subtitute them out
+    bndr_prs =	[ (id, Var (localise id)) | id <- all_bndrs, isGlobalId id ]
+    localise d = mkLocalId (idName d) (idType d)
+
+    init_env = mkVarEnv bndr_prs
+    all_bndrs' = map subst_bndr all_bndrs
+    subst_bndr bndr = case lookupVarEnv init_env bndr of
+			Just (Var bndr') -> bndr'
+			Just other	 -> panic "decomposeRuleLhs"
+			Nothing		 -> bndr
+
+	-- Substitute dicts in the LHS args, so that there 
+	-- aren't any lets getting in the way
+	-- Note that we substitute the function too; we might have this as
+	-- a LHS:	let f71 = M.f Int in f71
+    go env (Let (NonRec dict rhs) body) 
+	= go (extendVarEnv env dict (simpleSubst env rhs)) body
+    go env body 
+	= case collectArgs (simpleSubst env body) of
+	    (Var fn, args) -> Just (all_bndrs', fn, args)
+	    other 	   -> Nothing
+
+simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
+-- Similar to CoreSubst.substExpr, except that 
+-- (a) takes no account of capture; dictionary bindings use new names
+-- (b) can have a GlobalId (imported) in its domain
+-- (c) Ids only; no types are substituted
+
+simpleSubst subst expr
+  = go expr
+  where
+    go (Var v)	       = lookupVarEnv subst v `orElse` Var v
+    go (Type ty)       = Type ty
+    go (Lit lit)       = Lit lit
+    go (App fun arg)   = App (go fun) (go arg)
+    go (Note note e)   = Note note (go e)
+    go (Lam bndr body) = Lam bndr (go body)
+    go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
+    go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
+    go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty 
+					   [(c,bs,go r) | (c,bs,r) <- alts]
+
+addLocalInlines exports core_prs
+  = map add_inline core_prs
+  where
+    add_inline (bndr,rhs) | Just inl <- lookupVarEnv inline_env bndr
+			  = addInlineInfo inl bndr rhs
+			  | otherwise 
+			  = (bndr,rhs)
+    inline_env = mkVarEnv [(mono_id, prag) 
+			  | (_, _, mono_id, prags) <- exports,
+			    InlinePrag prag <- prags]
+					   
+addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
+addInlineInfo (Inline phase is_inline) bndr rhs
+  = (attach_phase bndr phase, wrap_inline is_inline rhs)
+  where
+    attach_phase bndr phase 
+	| isAlwaysActive phase = bndr	-- Default phase
+	| otherwise  	       = bndr `setInlinePragma` phase
+
+    wrap_inline True  body = mkInlineMe body
+    wrap_inline False body = body
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[addAutoScc]{Adding automatic sccs}
+%*									*
+%************************************************************************
+
+\begin{code}
+data AutoScc
+ 	= TopLevel
+	| TopLevelAddSccs (Id -> Maybe Id)
+	| NoSccs
+
+addSccs :: AutoScc -> [(a,Id,Id,[Prag])] -> AutoScc
+addSccs auto_scc@(TopLevelAddSccs _) exports = auto_scc
+addSccs NoSccs   exports = NoSccs
+addSccs TopLevel exports 
+  = TopLevelAddSccs (\id -> case [ exp | (_,exp,loc,_) <- exports, loc == id ] of
+				(exp:_)  | opt_AutoSccsOnAllToplevs || 
+					    (isExportedId exp && 
+					     opt_AutoSccsOnExportedToplevs)
+					-> Just exp
+				_ -> Nothing)
+
+addAutoScc :: AutoScc		-- if needs be, decorate toplevs?
+	   -> (Id, CoreExpr)
+	   -> DsM (Id, CoreExpr)
+
+addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr) 
+ | do_auto_scc
+     = getModuleDs `thenDs` \ mod ->
+       returnDs (bndr, mkSCC (mkAutoCC top_bndr mod NotCafCC) core_expr)
+ where do_auto_scc = isJust maybe_auto_scc
+       maybe_auto_scc = auto_scc_fn bndr
+       (Just top_bndr) = maybe_auto_scc
+
+addAutoScc _ pair
+     = returnDs pair
+\end{code}
+
+If profiling and dealing with a dict binding,
+wrap the dict in @_scc_ DICT <dict>@:
+
+\begin{code}
+addDictScc var rhs = returnDs rhs
+
+{- DISABLED for now (need to somehow make up a name for the scc) -- SDM
+  | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
+    || not (isDictId var)
+  = returnDs rhs				-- That's easy: do nothing
+
+  | otherwise
+  = getModuleAndGroupDs 	`thenDs` \ (mod, grp) ->
+	-- ToDo: do -dicts-all flag (mark dict things with individual CCs)
+    returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs)
+-}
+\end{code}
+
+
+%************************************************************************
+%*									*
+		Desugaring coercions
+%*									*
+%************************************************************************
+
+
+\begin{code}
+dsCoercion :: ExprCoFn -> DsM CoreExpr -> DsM CoreExpr
+dsCoercion CoHole 	     thing_inside = thing_inside
+dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
+dsCoercion (CoLams ids c)    thing_inside = do { expr <- dsCoercion c thing_inside
+					       ; return (mkLams ids expr) }
+dsCoercion (CoTyLams tvs c)  thing_inside = do { expr <- dsCoercion c thing_inside
+					       ; return (mkLams tvs expr) }
+dsCoercion (CoApps c ids)    thing_inside = do { expr <- dsCoercion c thing_inside
+					       ; return (mkVarApps expr ids) }
+dsCoercion (CoTyApps c tys)  thing_inside = do { expr <- dsCoercion c thing_inside
+					       ; return (mkTyApps expr tys) }
+dsCoercion (CoLet bs c)      thing_inside = do { prs <- dsLHsBinds bs
+					       ; expr <- dsCoercion c thing_inside
+					       ; return (Let (Rec prs) expr) }
+\end{code}
+
+
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
new file mode 100644
index 0000000000..3554197fb8
--- /dev/null
+++ b/compiler/deSugar/DsCCall.lhs
@@ -0,0 +1,456 @@
+%
+% (c) The AQUA Project, Glasgow University, 1994-1998
+%
+\section[DsCCall]{Desugaring C calls}
+
+\begin{code}
+module DsCCall 
+	( dsCCall
+	, mkFCall
+	, unboxArg
+	, boxResult
+	, resultWrapper
+	) where
+
+#include "HsVersions.h"
+
+
+import CoreSyn
+
+import DsMonad
+
+import CoreUtils	( exprType, coreAltType, mkCoerce2 )
+import Id		( Id, mkWildId )
+import MkId		( mkFCallId, realWorldPrimId, mkPrimOpId )
+import Maybes		( maybeToBool )
+import ForeignCall	( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, 
+			  CCallConv(..), CLabelString )
+import DataCon		( splitProductType_maybe, dataConSourceArity, dataConWrapId )
+
+import TcType		( tcSplitTyConApp_maybe )
+import Type		( Type, isUnLiftedType, mkFunTys, mkFunTy,
+			  tyVarsOfType, mkForAllTys, mkTyConApp, 
+			  isPrimitiveType, splitTyConApp_maybe, 
+			  splitRecNewType_maybe, splitForAllTy_maybe,
+			  isUnboxedTupleType
+			)
+
+import PrimOp		( PrimOp(..) )
+import TysPrim		( realWorldStatePrimTy, intPrimTy,
+			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
+			  addrPrimTy
+			)
+import TyCon		( TyCon, tyConDataCons, tyConName )
+import TysWiredIn	( unitDataConId,
+			  unboxedSingletonDataCon, unboxedPairDataCon,
+			  unboxedSingletonTyCon, unboxedPairTyCon,
+			  trueDataCon, falseDataCon, 
+			  trueDataConId, falseDataConId,
+			  listTyCon, charTyCon, boolTy, 
+			  tupleTyCon, tupleCon
+			)
+import BasicTypes       ( Boxity(..) )
+import Literal		( mkMachInt )
+import PrelNames	( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
+			  int8TyConKey, int16TyConKey, int32TyConKey,
+			  word8TyConKey, word16TyConKey, word32TyConKey
+			  -- dotnet interop
+			  , marshalStringName, unmarshalStringName
+			  , marshalObjectName, unmarshalObjectName
+			  , objectTyConName
+			)
+import VarSet		( varSetElems )
+import Constants	( wORD_SIZE)
+import Outputable
+
+#ifdef DEBUG
+import TypeRep
+#endif
+
+\end{code}
+
+Desugaring of @ccall@s consists of adding some state manipulation,
+unboxing any boxed primitive arguments and boxing the result if
+desired.
+
+The state stuff just consists of adding in
+@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
+
+The unboxing is straightforward, as all information needed to unbox is
+available from the type.  For each boxed-primitive argument, we
+transform:
+\begin{verbatim}
+   _ccall_ foo [ r, t1, ... tm ] e1 ... em
+   |
+   |
+   V
+   case e1 of { T1# x1# ->
+   ...
+   case em of { Tm# xm# -> xm#
+   ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
+   } ... }
+\end{verbatim}
+
+The reboxing of a @_ccall_@ result is a bit tricker: the types don't
+contain information about the state-pairing functions so we have to
+keep a list of \tr{(type, s-p-function)} pairs.  We transform as
+follows:
+\begin{verbatim}
+   ccall# foo [ r, t1#, ... tm# ] e1# ... em#
+   |
+   |
+   V
+   \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
+	  (StateAnd<r># result# state#) -> (R# result#, realWorld#)
+\end{verbatim}
+
+\begin{code}
+dsCCall :: CLabelString	-- C routine to invoke
+	-> [CoreExpr]	-- Arguments (desugared)
+	-> Safety	-- Safety of the call
+	-> Type		-- Type of the result: IO t
+	-> DsM CoreExpr
+
+dsCCall lbl args may_gc result_ty
+  = mapAndUnzipDs unboxArg args	       `thenDs` \ (unboxed_args, arg_wrappers) ->
+    boxResult id Nothing result_ty  `thenDs` \ (ccall_result_ty, res_wrapper) ->
+    newUnique			       `thenDs` \ uniq ->
+    let
+	target = StaticTarget lbl
+	the_fcall    = CCall (CCallSpec target CCallConv may_gc)
+ 	the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
+    in
+    returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+
+mkFCall :: Unique -> ForeignCall 
+	-> [CoreExpr] 	-- Args
+	-> Type 	-- Result type
+	-> CoreExpr
+-- Construct the ccall.  The only tricky bit is that the ccall Id should have
+-- no free vars, so if any of the arg tys do we must give it a polymorphic type.
+-- 	[I forget *why* it should have no free vars!]
+-- For example:
+--	mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
+--
+-- Here we build a ccall thus
+--	(ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
+--			a b s x c
+mkFCall uniq the_fcall val_args res_ty
+  = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
+  where
+    arg_tys = map exprType val_args
+    body_ty = (mkFunTys arg_tys res_ty)
+    tyvars  = varSetElems (tyVarsOfType body_ty)
+    ty 	    = mkForAllTys tyvars body_ty
+    the_fcall_id = mkFCallId uniq the_fcall ty
+\end{code}
+
+\begin{code}
+unboxArg :: CoreExpr			-- The supplied argument
+	 -> DsM (CoreExpr,		-- To pass as the actual argument
+		 CoreExpr -> CoreExpr	-- Wrapper to unbox the arg
+		)
+-- Example: if the arg is e::Int, unboxArg will return
+--	(x#::Int#, \W. case x of I# x# -> W)
+-- where W is a CoreExpr that probably mentions x#
+
+unboxArg arg
+  -- Primtive types: nothing to unbox
+  | isPrimitiveType arg_ty
+  = returnDs (arg, \body -> body)
+
+  -- Recursive newtypes
+  | Just rep_ty <- splitRecNewType_maybe arg_ty
+  = unboxArg (mkCoerce2 rep_ty arg_ty arg)
+      
+  -- Booleans
+  | Just (tc,_) <- splitTyConApp_maybe arg_ty, 
+    tc `hasKey` boolTyConKey
+  = newSysLocalDs intPrimTy		`thenDs` \ prim_arg ->
+    returnDs (Var prim_arg,
+	      \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
+  		                       [(DataAlt falseDataCon,[],mkIntLit 0),
+	                                (DataAlt trueDataCon, [],mkIntLit 1)])
+					-- In increasing tag order!
+                             prim_arg
+                             (exprType body) 
+			     [(DEFAULT,[],body)])
+
+  -- Data types with a single constructor, which has a single, primitive-typed arg
+  -- This deals with Int, Float etc; also Ptr, ForeignPtr
+  | is_product_type && data_con_arity == 1 
+  = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
+			-- Typechecker ensures this
+    newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
+    newSysLocalDs data_con_arg_ty1	`thenDs` \ prim_arg ->
+    returnDs (Var prim_arg,
+	      \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
+    )
+
+  -- Byte-arrays, both mutable and otherwise; hack warning
+  -- We're looking for values of type ByteArray, MutableByteArray
+  --	data ByteArray          ix = ByteArray        ix ix ByteArray#
+  --	data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
+  | is_product_type &&
+    data_con_arity == 3 &&
+    maybeToBool maybe_arg3_tycon &&
+    (arg3_tycon ==  byteArrayPrimTyCon ||
+     arg3_tycon ==  mutableByteArrayPrimTyCon)
+  = newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
+    newSysLocalsDs data_con_arg_tys	`thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
+    returnDs (Var arr_cts_var,
+	      \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+
+    )
+
+  | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
+    tc == listTyCon,
+    Just (cc,[]) <- splitTyConApp_maybe arg_ty,
+    cc == charTyCon
+    -- String; dotnet only
+  = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
+    newSysLocalDs addrPrimTy	       `thenDs` \ prim_string ->
+    returnDs (Var prim_string,
+    	      \ body ->
+	        let
+		 io_ty = exprType body
+		 (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
+		in
+	      	mkApps (Var unpack_id)
+		       [ Type io_arg
+		       , arg
+		       , Lam prim_string body
+		       ])
+  | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
+    tyConName tc == objectTyConName
+    -- Object; dotnet only
+  = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
+    newSysLocalDs addrPrimTy	       `thenDs` \ prim_obj  ->
+    returnDs (Var prim_obj,
+    	      \ body ->
+	        let
+		 io_ty = exprType body
+		 (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
+		in
+	      	mkApps (Var unpack_id)
+		       [ Type io_arg
+		       , arg
+		       , Lam prim_obj body
+		       ])
+
+  | otherwise
+  = getSrcSpanDs `thenDs` \ l ->
+    pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
+  where
+    arg_ty					= exprType arg
+    maybe_product_type 			   	= splitProductType_maybe arg_ty
+    is_product_type			   	= maybeToBool maybe_product_type
+    Just (_, _, data_con, data_con_arg_tys)	= maybe_product_type
+    data_con_arity				= dataConSourceArity data_con
+    (data_con_arg_ty1 : _)			= data_con_arg_tys
+
+    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
+    maybe_arg3_tycon    	   = splitTyConApp_maybe data_con_arg_ty3
+    Just (arg3_tycon,_)		   = maybe_arg3_tycon
+\end{code}
+
+
+\begin{code}
+boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
+	  -> Maybe Id
+	  -> Type
+	  -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall: 
+--	either (IO t), 
+--	or maybe just t for an side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall.  This result type
+-- will be of the form  
+--	State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t.  If t is simply (), then
+-- the result type will be 
+--	State# RealWorld -> (# State# RealWorld #)
+
+boxResult augment mbTopCon result_ty
+  = case tcSplitTyConApp_maybe result_ty of
+	-- This split absolutely has to be a tcSplit, because we must
+	-- see the IO type; and it's a newtype which is transparent to splitTyConApp.
+
+	-- The result is IO t, so wrap the result in an IO constructor
+	Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
+		-> resultWrapper io_res_ty             `thenDs` \ res ->
+		   let aug_res          = augment res
+		       extra_result_tys =
+		         case aug_res of
+			   (Just ty,_) 
+			     | isUnboxedTupleType ty ->
+			        let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
+			   _ -> []
+	           in
+		   mk_alt (return_result extra_result_tys) aug_res 
+		   					`thenDs` \ (ccall_res_ty, the_alt) ->
+		   newSysLocalDs  realWorldStatePrimTy  `thenDs` \ state_id ->
+		   let
+			io_data_con = head (tyConDataCons io_tycon)
+			toIOCon = 
+			  case mbTopCon of
+			    Nothing -> dataConWrapId io_data_con
+			    Just x  -> x
+			wrap = \ the_call -> 
+				 mkApps (Var toIOCon)
+					   [ Type io_res_ty, 
+					     Lam state_id $
+					      Case (App the_call (Var state_id))
+						   (mkWildId ccall_res_ty)
+                                                   (coreAltType the_alt) 
+						   [the_alt]
+					   ]
+		   in
+		   returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+		where
+		   return_result ts state anss 
+		     = mkConApp (tupleCon Unboxed (2 + length ts))
+			        (Type realWorldStatePrimTy : Type io_res_ty : map Type ts ++
+			         state : anss) 
+	-- It isn't, so do unsafePerformIO
+	-- It's not conveniently available, so we inline it
+	other -> resultWrapper result_ty            `thenDs` \ res ->
+	         mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
+		 let
+		    wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
+					      (mkWildId ccall_res_ty)
+                                              (coreAltType the_alt)
+					      [the_alt]
+		 in
+		 returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+	      where
+		 return_result state [ans] = ans
+		 return_result _ _ = panic "return_result: expected single result"
+  where
+    mk_alt return_result (Nothing, wrap_result)
+	= 	-- The ccall returns ()
+	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
+	  let
+		the_rhs = return_result (Var state_id) 
+					[wrap_result (panic "boxResult")]
+
+		ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
+		the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
+	  in
+	  returnDs (ccall_res_ty, the_alt)
+
+    mk_alt return_result (Just prim_res_ty, wrap_result)
+    		-- The ccall returns a non-() value
+        | isUnboxedTupleType prim_res_ty
+        = let
+		Just (_, ls) = splitTyConApp_maybe prim_res_ty
+		arity = 1 + length ls
+	  in
+	  mappM newSysLocalDs ls 		`thenDs` \ args_ids@(result_id:as) ->
+	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
+	  let
+		the_rhs = return_result (Var state_id) 
+					(wrap_result (Var result_id) : map Var as)
+		ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
+					  (realWorldStatePrimTy : ls)
+		the_alt	     = ( DataAlt (tupleCon Unboxed arity)
+			       , (state_id : args_ids)
+			       , the_rhs
+			       )
+	  in
+	  returnDs (ccall_res_ty, the_alt)
+	| otherwise
+	= newSysLocalDs prim_res_ty 		`thenDs` \ result_id ->
+	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
+	  let
+		the_rhs = return_result (Var state_id) 
+					[wrap_result (Var result_id)]
+
+		ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
+		the_alt	     = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
+	  in
+	  returnDs (ccall_res_ty, the_alt)
+
+
+resultWrapper :: Type
+   	      -> DsM (Maybe Type,		-- Type of the expected result, if any
+		      CoreExpr -> CoreExpr)	-- Wrapper for the result 
+resultWrapper result_ty
+  -- Base case 1: primitive types
+  | isPrimitiveType result_ty
+  = returnDs (Just result_ty, \e -> e)
+
+  -- Base case 2: the unit type ()
+  | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
+  = returnDs (Nothing, \e -> Var unitDataConId)
+
+  -- Base case 3: the boolean type
+  | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
+  = returnDs
+     (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+                                   boolTy
+	                           [(DEFAULT             ,[],Var trueDataConId ),
+				    (LitAlt (mkMachInt 0),[],Var falseDataConId)])
+
+  -- Recursive newtypes
+  | Just rep_ty <- splitRecNewType_maybe result_ty
+  = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
+    returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
+
+  -- The type might contain foralls (eg. for dummy type arguments,
+  -- referring to 'Ptr a' is legal).
+  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
+  = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
+    returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
+
+  -- Data types with a single constructor, which has a single arg
+  -- This includes types like Ptr and ForeignPtr
+  | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
+    dataConSourceArity data_con == 1
+  = let
+	(unwrapped_res_ty : _) = data_con_arg_tys
+	narrow_wrapper         = maybeNarrow tycon
+    in
+    resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
+    returnDs
+      (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) 
+			      (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
+
+    -- Strings; 'dotnet' only.
+  | Just (tc, [arg_ty]) <- maybe_tc_app,               tc == listTyCon,
+    Just (cc,[])        <- splitTyConApp_maybe arg_ty, cc == charTyCon
+  = dsLookupGlobalId unmarshalStringName	`thenDs` \ pack_id ->
+    returnDs (Just addrPrimTy,
+    	      \ e -> App (Var pack_id) e)
+
+    -- Objects; 'dotnet' only.
+  | Just (tc, [arg_ty]) <- maybe_tc_app, 
+    tyConName tc == objectTyConName
+  = dsLookupGlobalId unmarshalObjectName	`thenDs` \ pack_id ->
+    returnDs (Just addrPrimTy,
+    	      \ e -> App (Var pack_id) e)
+
+  | otherwise
+  = pprPanic "resultWrapper" (ppr result_ty)
+  where
+    maybe_tc_app = splitTyConApp_maybe result_ty
+
+-- When the result of a foreign call is smaller than the word size, we
+-- need to sign- or zero-extend the result up to the word size.  The C
+-- standard appears to say that this is the responsibility of the
+-- caller, not the callee.
+
+maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr)
+maybeNarrow tycon
+  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
+  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
+  | tycon `hasKey` int32TyConKey
+	 && wORD_SIZE > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
+
+  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
+  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
+  | tycon `hasKey` word32TyConKey
+	 && wORD_SIZE > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
+  | otherwise			  = id
+\end{code}
diff --git a/compiler/deSugar/DsExpr.hi-boot-5 b/compiler/deSugar/DsExpr.hi-boot-5
new file mode 100644
index 0000000000..7e5bbaab7f
--- /dev/null
+++ b/compiler/deSugar/DsExpr.hi-boot-5
@@ -0,0 +1,5 @@
+__interface DsExpr 1 0 where
+__export DsExpr dsExpr dsLet;
+1 dsExpr :: HsExpr.HsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr ;
+1 dsLExpr :: HsExpr.HsLExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr ;
+1 dsLet  :: [HsBinds.HsBindGroup Var.Id] -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
diff --git a/compiler/deSugar/DsExpr.hi-boot-6 b/compiler/deSugar/DsExpr.hi-boot-6
new file mode 100644
index 0000000000..c7ddb2ddfd
--- /dev/null
+++ b/compiler/deSugar/DsExpr.hi-boot-6
@@ -0,0 +1,6 @@
+module DsExpr where
+
+dsExpr :: HsExpr.HsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr
+dsLExpr :: HsExpr.LHsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr
+dsLocalBinds :: HsBinds.HsLocalBinds Var.Id -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr
+dsValBinds   :: HsBinds.HsValBinds Var.Id   -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
new file mode 100644
index 0000000000..e8e9e7b370
--- /dev/null
+++ b/compiler/deSugar/DsExpr.lhs
@@ -0,0 +1,781 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsExpr]{Matching expressions (Exprs)}
+
+\begin{code}
+module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
+
+#include "HsVersions.h"
+#if defined(GHCI) && defined(BREAKPOINT)
+import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
+import GHC.Exts         ( Ptr(..), Int(..), addr2Int# )
+import IOEnv            ( ioToIOEnv )
+import PrelNames        ( breakpointJumpName )
+import TysWiredIn       ( unitTy )
+import TypeRep          ( Type(..) )
+#endif
+
+import Match		( matchWrapper, matchSinglePat, matchEquations )
+import MatchLit		( dsLit, dsOverLit )
+import DsBinds		( dsLHsBinds, dsCoercion )
+import DsGRHSs		( dsGuarded )
+import DsListComp	( dsListComp, dsPArrComp )
+import DsUtils		( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
+			  extractMatchResult, cantFailMatchResult, matchCanFail,
+			  mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence, selectMatchVar )
+import DsArrows		( dsProcExpr )
+import DsMonad
+
+#ifdef GHCI
+	-- Template Haskell stuff iff bootstrapped
+import DsMeta		( dsBracket )
+#endif
+
+import HsSyn
+import TcHsSyn		( hsPatType, mkVanillaTuplePat )
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+--     needs to see source types (newtypes etc), and sometimes not
+--     So WATCH OUT; check each use of split*Ty functions.
+-- Sigh.  This is a pain.
+
+import TcType		( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon, 
+			  tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
+import Type		( funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
+import CoreSyn
+import CoreUtils	( exprType, mkIfThenElse, bindNonRec )
+
+import CostCentre	( mkUserCC )
+import Id		( Id, idType, idName, idDataCon )
+import PrelInfo		( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
+import DataCon		( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
+import DataCon		( isVanillaDataCon )
+import TyCon		( FieldLabel, tyConDataCons )
+import TysWiredIn	( tupleCon )
+import BasicTypes	( RecFlag(..), Boxity(..), ipNameName )
+import PrelNames	( toPName,
+			  returnMName, bindMName, thenMName, failMName,
+			  mfixName )
+import SrcLoc		( Located(..), unLoc, getLoc, noLoc )
+import Util		( zipEqual, zipWithEqual )
+import Bag		( bagToList )
+import Outputable
+import FastString
+\end{code}
+
+
+%************************************************************************
+%*									*
+		dsLocalBinds, dsValBinds
+%*									*
+%************************************************************************
+
+\begin{code}
+dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+dsLocalBinds EmptyLocalBinds	body = return body
+dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
+dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
+
+-------------------------
+dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
+dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
+
+-------------------------
+dsIPBinds (IPBinds ip_binds dict_binds) body
+  = do	{ prs <- dsLHsBinds dict_binds
+	; let inner = foldr (\(x,r) e -> Let (NonRec x r) e) body prs 
+	; foldrDs ds_ip_bind inner ip_binds }
+  where
+    ds_ip_bind (L _ (IPBind n e)) body
+      = dsLExpr e	`thenDs` \ e' ->
+	returnDs (Let (NonRec (ipNameName n) e') body)
+
+-------------------------
+ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
+-- Special case for bindings which bind unlifted variables
+-- We need to do a case right away, rather than building
+-- a tuple and doing selections.
+-- Silently ignore INLINE and SPECIALISE pragmas...
+ds_val_bind (NonRecursive, hsbinds) body
+  | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
+    (L loc bind : null_binds) <- bagToList binds,
+    isBangHsBind bind
+    || isUnboxedTupleBind bind
+    || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
+  = let
+      body_w_exports		      = foldr bind_export body exports
+      bind_export (tvs, g, l, _) body = ASSERT( null tvs )
+				        bindNonRec g (Var l) body
+    in
+    ASSERT (null null_binds)
+	-- Non-recursive, non-overloaded bindings only come in ones
+	-- ToDo: in some bizarre case it's conceivable that there
+	--       could be dict binds in the 'binds'.  (See the notes
+	--	 below.  Then pattern-match would fail.  Urk.)
+    putSrcSpanDs loc	$
+    case bind of
+      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }
+	-> matchWrapper (FunRhs (idName fun)) matches 	 	`thenDs` \ (args, rhs) ->
+	   ASSERT( null args )	-- Functions aren't lifted
+	   ASSERT( isIdCoercion co_fn )
+	   returnDs (bindNonRec fun rhs body_w_exports)
+
+      PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
+	-> 	-- let C x# y# = rhs in body
+		-- ==> case rhs of C x# y# -> body
+	   putSrcSpanDs loc			$
+	   do { rhs <- dsGuarded grhss ty
+	      ; let upat = unLoc pat
+		    eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat], 
+				    eqn_rhs = cantFailMatchResult body_w_exports }
+	      ; var    <- selectMatchVar upat ty
+	      ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+	      ; return (scrungleMatch var rhs result) }
+
+      other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
+
+
+-- Ordinary case for bindings; none should be unlifted
+ds_val_bind (is_rec, binds) body
+  = do	{ prs <- dsLHsBinds binds
+	; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
+	  case prs of
+	    []    -> return body
+	    other -> return (Let (Rec prs) body) }
+	-- Use a Rec regardless of is_rec. 
+	-- Why? Because it allows the binds to be all
+	-- mixed up, which is what happens in one rare case
+	-- Namely, for an AbsBind with no tyvars and no dicts,
+	-- 	   but which does have dictionary bindings.
+	-- See notes with TcSimplify.inferLoop [NO TYVARS]
+	-- It turned out that wrapping a Rec here was the easiest solution
+	--
+	-- NB The previous case dealt with unlifted bindings, so we
+	--    only have to deal with lifted ones now; so Rec is ok
+
+isUnboxedTupleBind :: HsBind Id -> Bool
+isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
+isUnboxedTupleBind other			 = False
+
+scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- Returns something like (let var = scrut in body)
+-- but if var is an unboxed-tuple type, it inlines it in a fragile way
+-- Special case to handle unboxed tuple patterns; they can't appear nested
+-- The idea is that 
+--	case e of (# p1, p2 #) -> rhs
+-- should desugar to
+--	case e of (# x1, x2 #) -> ... match p1, p2 ...
+-- NOT
+--	let x = e in case x of ....
+--
+-- But there may be a big 
+--	let fail = ... in case e of ...
+-- wrapping the whole case, which complicates matters slightly
+-- It all seems a bit fragile.  Test is dsrun013.
+
+scrungleMatch var scrut body
+  | isUnboxedTupleType (idType var) = scrungle body
+  | otherwise			    = bindNonRec var scrut body
+  where
+    scrungle (Case (Var x) bndr ty alts)
+		    | x == var = Case scrut bndr ty alts
+    scrungle (Let binds body)  = Let binds (scrungle body)
+    scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
+\end{code}	
+
+%************************************************************************
+%*									*
+\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
+%*									*
+%************************************************************************
+
+\begin{code}
+dsLExpr :: LHsExpr Id -> DsM CoreExpr
+dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
+
+dsExpr :: HsExpr Id -> DsM CoreExpr
+
+dsExpr (HsPar e) 	      = dsLExpr e
+dsExpr (ExprWithTySigOut e _) = dsLExpr e
+dsExpr (HsVar var)     	      = returnDs (Var var)
+dsExpr (HsIPVar ip)    	      = returnDs (Var (ipNameName ip))
+dsExpr (HsLit lit)     	      = dsLit lit
+dsExpr (HsOverLit lit) 	      = dsOverLit lit
+
+dsExpr (NegApp expr neg_expr) 
+  = do	{ core_expr <- dsLExpr expr
+	; core_neg  <- dsExpr neg_expr
+	; return (core_neg `App` core_expr) }
+
+dsExpr expr@(HsLam a_Match)
+  = matchWrapper LambdaExpr a_Match	`thenDs` \ (binders, matching_code) ->
+    returnDs (mkLams binders matching_code)
+
+#if defined(GHCI) && defined(BREAKPOINT)
+dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
+    | HsVar funId <- fun
+    , idName funId == breakpointJumpName
+    , ids <- filter (not.hasTyVar.idType) (extractIds arg)
+    = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
+         stablePtr <- ioToIOEnv $ newStablePtr ids
+         -- Yes, I know... I'm gonna burn in hell.
+         let Ptr addr# = castStablePtrToPtr stablePtr
+         funCore <- dsLExpr realFun
+         argCore <- dsLExpr (L loc (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))))
+         hvalCore <- dsLExpr (L loc (extractHVals ids))
+         return ((funCore `App` argCore) `App` hvalCore)
+    where extractIds :: HsExpr Id -> [Id]
+          extractIds (HsApp fn arg)
+              | HsVar argId <- unLoc arg
+              = argId:extractIds (unLoc fn)
+              | TyApp arg' ts <- unLoc arg
+              , HsVar argId <- unLoc arg'
+              = error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
+          extractIds x = []
+          extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
+          hasTyVar (TyVarTy _) = True
+          hasTyVar (FunTy a b) = hasTyVar a || hasTyVar b
+          hasTyVar (NoteTy _ t) = hasTyVar t
+          hasTyVar (AppTy a b) = hasTyVar a || hasTyVar b
+          hasTyVar (TyConApp _ ts) = any hasTyVar ts
+          hasTyVar _ = False
+#endif
+
+dsExpr expr@(HsApp fun arg)      
+  = dsLExpr fun		`thenDs` \ core_fun ->
+    dsLExpr arg		`thenDs` \ core_arg ->
+    returnDs (core_fun `App` core_arg)
+\end{code}
+
+Operator sections.  At first it looks as if we can convert
+\begin{verbatim}
+	(expr op)
+\end{verbatim}
+to
+\begin{verbatim}
+	\x -> op expr x
+\end{verbatim}
+
+But no!  expr might be a redex, and we can lose laziness badly this
+way.  Consider
+\begin{verbatim}
+	map (expr op) xs
+\end{verbatim}
+for example.  So we convert instead to
+\begin{verbatim}
+	let y = expr in \x -> op y x
+\end{verbatim}
+If \tr{expr} is actually just a variable, say, then the simplifier
+will sort it out.
+
+\begin{code}
+dsExpr (OpApp e1 op _ e2)
+  = dsLExpr op						`thenDs` \ core_op ->
+    -- for the type of y, we need the type of op's 2nd argument
+    dsLExpr e1				`thenDs` \ x_core ->
+    dsLExpr e2				`thenDs` \ y_core ->
+    returnDs (mkApps core_op [x_core, y_core])
+    
+dsExpr (SectionL expr op)
+  = dsLExpr op						`thenDs` \ core_op ->
+    -- for the type of y, we need the type of op's 2nd argument
+    let
+	(x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+	-- Must look through an implicit-parameter type; 
+	-- newtype impossible; hence Type.splitFunTys
+    in
+    dsLExpr expr				`thenDs` \ x_core ->
+    newSysLocalDs x_ty			`thenDs` \ x_id ->
+    newSysLocalDs y_ty			`thenDs` \ y_id ->
+
+    returnDs (bindNonRec x_id x_core $
+	      Lam y_id (mkApps core_op [Var x_id, Var y_id]))
+
+-- dsLExpr (SectionR op expr)	-- \ x -> op x expr
+dsExpr (SectionR op expr)
+  = dsLExpr op			`thenDs` \ core_op ->
+    -- for the type of x, we need the type of op's 2nd argument
+    let
+	(x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+	-- See comment with SectionL
+    in
+    dsLExpr expr				`thenDs` \ y_core ->
+    newSysLocalDs x_ty			`thenDs` \ x_id ->
+    newSysLocalDs y_ty			`thenDs` \ y_id ->
+
+    returnDs (bindNonRec y_id y_core $
+	      Lam x_id (mkApps core_op [Var x_id, Var y_id]))
+
+dsExpr (HsSCC cc expr)
+  = dsLExpr expr			`thenDs` \ core_expr ->
+    getModuleDs			`thenDs` \ mod_name ->
+    returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
+
+
+-- hdaume: core annotation
+
+dsExpr (HsCoreAnn fs expr)
+  = dsLExpr expr        `thenDs` \ core_expr ->
+    returnDs (Note (CoreNote $ unpackFS fs) core_expr)
+
+dsExpr (HsCase discrim matches)
+  = dsLExpr discrim			`thenDs` \ core_discrim ->
+    matchWrapper CaseAlt matches 	`thenDs` \ ([discrim_var], matching_code) ->
+    returnDs (scrungleMatch discrim_var core_discrim matching_code)
+
+dsExpr (HsLet binds body)
+  = dsLExpr body		`thenDs` \ body' ->
+    dsLocalBinds binds body'
+
+-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
+-- because the interpretation of `stmts' depends on what sort of thing it is.
+--
+dsExpr (HsDo ListComp stmts body result_ty)
+  =	-- Special case for list comprehensions
+    dsListComp stmts body elt_ty
+  where
+    [elt_ty] = tcTyConAppArgs result_ty
+
+dsExpr (HsDo DoExpr stmts body result_ty)
+  = dsDo stmts body result_ty
+
+dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
+  = dsMDo tbl stmts body result_ty
+
+dsExpr (HsDo PArrComp stmts body result_ty)
+  =	-- Special case for array comprehensions
+    dsPArrComp (map unLoc stmts) body elt_ty
+  where
+    [elt_ty] = tcTyConAppArgs result_ty
+
+dsExpr (HsIf guard_expr then_expr else_expr)
+  = dsLExpr guard_expr	`thenDs` \ core_guard ->
+    dsLExpr then_expr	`thenDs` \ core_then ->
+    dsLExpr else_expr	`thenDs` \ core_else ->
+    returnDs (mkIfThenElse core_guard core_then core_else)
+\end{code}
+
+
+\noindent
+\underline{\bf Type lambda and application}
+%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+dsExpr (TyLam tyvars expr)
+  = dsLExpr expr `thenDs` \ core_expr ->
+    returnDs (mkLams tyvars core_expr)
+
+dsExpr (TyApp expr tys)
+  = dsLExpr expr		`thenDs` \ core_expr ->
+    returnDs (mkTyApps core_expr tys)
+\end{code}
+
+
+\noindent
+\underline{\bf Various data construction things}
+%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+dsExpr (ExplicitList ty xs)
+  = go xs
+  where
+    go []     = returnDs (mkNilExpr ty)
+    go (x:xs) = dsLExpr x				`thenDs` \ core_x ->
+		go xs					`thenDs` \ core_xs ->
+		returnDs (mkConsExpr ty core_x core_xs)
+
+-- we create a list from the array elements and convert them into a list using
+-- `PrelPArr.toP'
+--
+--  * the main disadvantage to this scheme is that `toP' traverses the list
+--   twice: once to determine the length and a second time to put to elements
+--   into the array; this inefficiency could be avoided by exposing some of
+--   the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
+--   that we can exploit the fact that we already know the length of the array
+--   here at compile time
+--
+dsExpr (ExplicitPArr ty xs)
+  = dsLookupGlobalId toPName				`thenDs` \toP      ->
+    dsExpr (ExplicitList ty xs)				`thenDs` \coreList ->
+    returnDs (mkApps (Var toP) [Type ty, coreList])
+
+dsExpr (ExplicitTuple expr_list boxity)
+  = mappM dsLExpr expr_list	  `thenDs` \ core_exprs  ->
+    returnDs (mkConApp (tupleCon boxity (length expr_list))
+	    	       (map (Type .  exprType) core_exprs ++ core_exprs))
+
+dsExpr (ArithSeq expr (From from))
+  = dsExpr expr		  `thenDs` \ expr2 ->
+    dsLExpr from	  `thenDs` \ from2 ->
+    returnDs (App expr2 from2)
+
+dsExpr (ArithSeq expr (FromTo from two))
+  = dsExpr expr		  `thenDs` \ expr2 ->
+    dsLExpr from	  `thenDs` \ from2 ->
+    dsLExpr two		  `thenDs` \ two2 ->
+    returnDs (mkApps expr2 [from2, two2])
+
+dsExpr (ArithSeq expr (FromThen from thn))
+  = dsExpr expr		  `thenDs` \ expr2 ->
+    dsLExpr from	  `thenDs` \ from2 ->
+    dsLExpr thn		  `thenDs` \ thn2 ->
+    returnDs (mkApps expr2 [from2, thn2])
+
+dsExpr (ArithSeq expr (FromThenTo from thn two))
+  = dsExpr expr		  `thenDs` \ expr2 ->
+    dsLExpr from	  `thenDs` \ from2 ->
+    dsLExpr thn		  `thenDs` \ thn2 ->
+    dsLExpr two		  `thenDs` \ two2 ->
+    returnDs (mkApps expr2 [from2, thn2, two2])
+
+dsExpr (PArrSeq expr (FromTo from two))
+  = dsExpr expr		  `thenDs` \ expr2 ->
+    dsLExpr from	  `thenDs` \ from2 ->
+    dsLExpr two		  `thenDs` \ two2 ->
+    returnDs (mkApps expr2 [from2, two2])
+
+dsExpr (PArrSeq expr (FromThenTo from thn two))
+  = dsExpr expr		  `thenDs` \ expr2 ->
+    dsLExpr from	  `thenDs` \ from2 ->
+    dsLExpr thn		  `thenDs` \ thn2 ->
+    dsLExpr two		  `thenDs` \ two2 ->
+    returnDs (mkApps expr2 [from2, thn2, two2])
+
+dsExpr (PArrSeq expr _)
+  = panic "DsExpr.dsExpr: Infinite parallel array!"
+    -- the parser shouldn't have generated it and the renamer and typechecker
+    -- shouldn't have let it through
+\end{code}
+
+\noindent
+\underline{\bf Record construction and update}
+%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For record construction we do this (assuming T has three arguments)
+\begin{verbatim}
+	T { op2 = e }
+==>
+	let err = /\a -> recConErr a 
+	T (recConErr t1 "M.lhs/230/op1") 
+	  e 
+	  (recConErr t1 "M.lhs/230/op3")
+\end{verbatim}
+@recConErr@ then converts its arugment string into a proper message
+before printing it as
+\begin{verbatim}
+	M.lhs, line 230: missing field op1 was evaluated
+\end{verbatim}
+
+We also handle @C{}@ as valid construction syntax for an unlabelled
+constructor @C@, setting all of @C@'s fields to bottom.
+
+\begin{code}
+dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
+  = dsExpr con_expr	`thenDs` \ con_expr' ->
+    let
+	(arg_tys, _) = tcSplitFunTys (exprType con_expr')
+	-- A newtype in the corner should be opaque; 
+	-- hence TcType.tcSplitFunTys
+
+	mk_arg (arg_ty, lbl)	-- Selector id has the field label as its name
+	  = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of
+	      (rhs:rhss) -> ASSERT( null rhss )
+		 	    dsLExpr rhs
+	      []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
+	unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
+
+	labels = dataConFieldLabels (idDataCon data_con_id)
+	-- The data_con_id is guaranteed to be the wrapper id of the constructor
+    in
+
+    (if null labels
+	then mappM unlabelled_bottom arg_tys
+	else mappM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels))
+	`thenDs` \ con_args ->
+
+    returnDs (mkApps con_expr' con_args)
+\end{code}
+
+Record update is a little harder. Suppose we have the decl:
+\begin{verbatim}
+	data T = T1 {op1, op2, op3 :: Int}
+	       | T2 {op4, op2 :: Int}
+	       | T3
+\end{verbatim}
+Then we translate as follows:
+\begin{verbatim}
+	r { op2 = e }
+===>
+	let op2 = e in
+	case r of
+	  T1 op1 _ op3 -> T1 op1 op2 op3
+	  T2 op4 _     -> T2 op4 op2
+	  other	       -> recUpdError "M.lhs/230"
+\end{verbatim}
+It's important that we use the constructor Ids for @T1@, @T2@ etc on the
+RHSs, and do not generate a Core constructor application directly, because the constructor
+might do some argument-evaluation first; and may have to throw away some
+dictionaries.
+
+\begin{code}
+dsExpr (RecordUpd record_expr [] record_in_ty record_out_ty)
+  = dsLExpr record_expr
+
+dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
+  = dsLExpr record_expr	 	`thenDs` \ record_expr' ->
+
+	-- Desugar the rbinds, and generate let-bindings if
+	-- necessary so that we don't lose sharing
+
+    let
+	in_inst_tys  = tcTyConAppArgs record_in_ty	-- Newtype opaque
+	out_inst_tys = tcTyConAppArgs record_out_ty	-- Newtype opaque
+	in_out_ty    = mkFunTy record_in_ty record_out_ty
+
+	mk_val_arg field old_arg_id 
+	  = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
+	      (rhs:rest) -> ASSERT(null rest) rhs
+	      []	 -> nlHsVar old_arg_id
+
+	mk_alt con
+	  = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
+		-- This call to dataConInstOrigArgTys won't work for existentials
+		-- but existentials don't have record types anyway
+	    let 
+		val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
+					(dataConFieldLabels con) arg_ids
+		rhs = foldl (\a b -> nlHsApp a b)
+			(noLoc $ TyApp (nlHsVar (dataConWrapId con)) 
+				out_inst_tys)
+			  val_args
+	    in
+	    returnDs (mkSimpleMatch [noLoc $ ConPatOut (noLoc con) [] [] emptyLHsBinds 
+						       (PrefixCon (map nlVarPat arg_ids)) record_in_ty]
+				    rhs)
+    in
+	-- Record stuff doesn't work for existentials
+	-- The type checker checks for this, but we need 
+	-- worry only about the constructors that are to be updated
+    ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr )
+
+	-- It's important to generate the match with matchWrapper,
+	-- and the right hand sides with applications of the wrapper Id
+	-- so that everything works when we are doing fancy unboxing on the
+	-- constructor aguments.
+    mappM mk_alt cons_to_upd				`thenDs` \ alts ->
+    matchWrapper RecUpd (MatchGroup alts in_out_ty)	`thenDs` \ ([discrim_var], matching_code) ->
+
+    returnDs (bindNonRec discrim_var record_expr' matching_code)
+
+  where
+    updated_fields :: [FieldLabel]
+    updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds]
+
+	-- Get the type constructor from the record_in_ty
+	-- so that we are sure it'll have all its DataCons
+	-- (In GHCI, it's possible that some TyCons may not have all
+	--  their constructors, in a module-loop situation.)
+    tycon       = tcTyConAppTyCon record_in_ty
+    data_cons   = tyConDataCons tycon
+    cons_to_upd = filter has_all_fields data_cons
+
+    has_all_fields :: DataCon -> Bool
+    has_all_fields con_id 
+      = all (`elem` con_fields) updated_fields
+      where
+	con_fields = dataConFieldLabels con_id
+\end{code}
+
+
+\noindent
+\underline{\bf Dictionary lambda and application}
+%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+@DictLam@ and @DictApp@ turn into the regular old things.
+(OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
+complicated; reminiscent of fully-applied constructors.
+\begin{code}
+dsExpr (DictLam dictvars expr)
+  = dsLExpr expr `thenDs` \ core_expr ->
+    returnDs (mkLams dictvars core_expr)
+
+------------------
+
+dsExpr (DictApp expr dicts)	-- becomes a curried application
+  = dsLExpr expr			`thenDs` \ core_expr ->
+    returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
+
+dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
+\end{code}
+
+Here is where we desugar the Template Haskell brackets and escapes
+
+\begin{code}
+-- Template Haskell stuff
+
+#ifdef GHCI	/* Only if bootstrapping */
+dsExpr (HsBracketOut x ps) = dsBracket x ps
+dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
+#endif
+
+-- Arrow notation extension
+dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
+\end{code}
+
+
+\begin{code}
+
+#ifdef DEBUG
+-- HsSyn constructs that just shouldn't be here:
+dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
+#endif
+
+\end{code}
+
+%--------------------------------------------------------------------
+
+Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
+handled in DsListComp).  Basically does the translation given in the
+Haskell 98 report:
+
+\begin{code}
+dsDo	:: [LStmt Id]
+	-> LHsExpr Id
+	-> Type			-- Type of the whole expression
+	-> DsM CoreExpr
+
+dsDo stmts body result_ty
+  = go (map unLoc stmts)
+  where
+    go [] = dsLExpr body
+    
+    go (ExprStmt rhs then_expr _ : stmts)
+      = do { rhs2 <- dsLExpr rhs
+	   ; then_expr2 <- dsExpr then_expr
+	   ; rest <- go stmts
+	   ; returnDs (mkApps then_expr2 [rhs2, rest]) }
+    
+    go (LetStmt binds : stmts)
+      = do { rest <- go stmts
+	   ; dsLocalBinds binds rest }
+        
+    go (BindStmt pat rhs bind_op fail_op : stmts)
+      = do { body  <- go stmts
+	   ; var   <- selectSimpleMatchVarL pat
+	   ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+    				  result_ty (cantFailMatchResult body)
+	   ; match_code <- handle_failure pat match fail_op
+	   ; rhs'       <- dsLExpr rhs
+	   ; bind_op'   <- dsExpr bind_op
+	   ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
+    
+    -- In a do expression, pattern-match failure just calls
+    -- the monadic 'fail' rather than throwing an exception
+    handle_failure pat match fail_op
+      | matchCanFail match
+      = do { fail_op' <- dsExpr fail_op
+	   ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+    	   ; extractMatchResult match (App fail_op' fail_msg) }
+      | otherwise
+      = extractMatchResult match (error "It can't fail") 
+
+mk_fail_msg pat = "Pattern match failure in do expression at " ++ 
+		  showSDoc (ppr (getLoc pat))
+\end{code}
+
+Translation for RecStmt's: 
+-----------------------------
+We turn (RecStmt [v1,..vn] stmts) into:
+  
+  (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
+				      return (v1,..vn))
+
+\begin{code}
+dsMDo	:: PostTcTable
+	-> [LStmt Id]
+	-> LHsExpr Id
+	-> Type			-- Type of the whole expression
+	-> DsM CoreExpr
+
+dsMDo tbl stmts body result_ty
+  = go (map unLoc stmts)
+  where
+    (m_ty, b_ty) = tcSplitAppTy result_ty	-- result_ty must be of the form (m b)
+    mfix_id   = lookupEvidence tbl mfixName
+    return_id = lookupEvidence tbl returnMName
+    bind_id   = lookupEvidence tbl bindMName
+    then_id   = lookupEvidence tbl thenMName
+    fail_id   = lookupEvidence tbl failMName
+    ctxt      = MDoExpr tbl
+
+    go [] = dsLExpr body
+    
+    go (LetStmt binds : stmts)
+      = do { rest <- go stmts
+	   ; dsLocalBinds binds rest }
+
+    go (ExprStmt rhs _ rhs_ty : stmts)
+      = do { rhs2 <- dsLExpr rhs
+	   ; rest <- go stmts
+	   ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
+    
+    go (BindStmt pat rhs _ _ : stmts)
+      = do { body  <- go stmts
+	   ; var   <- selectSimpleMatchVarL pat
+	   ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
+    				  result_ty (cantFailMatchResult body)
+	   ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
+	   ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
+	   ; match_code <- extractMatchResult match fail_expr
+
+	   ; rhs'       <- dsLExpr rhs
+	   ; returnDs (mkApps (Var bind_id) [Type (hsPatType pat), Type b_ty, 
+					     rhs', Lam var match_code]) }
+    
+    go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
+      = ASSERT( length rec_ids > 0 )
+        ASSERT( length rec_ids == length rec_rets )
+	go (new_bind_stmt : let_stmt : stmts)
+      where
+        new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
+	let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
+
+	
+		-- Remove the later_ids that appear (without fancy coercions) 
+		-- in rec_rets, because there's no need to knot-tie them separately
+		-- See Note [RecStmt] in HsExpr
+	later_ids'   = filter (`notElem` mono_rec_ids) later_ids
+	mono_rec_ids = [ id | HsVar id <- rec_rets ]
+    
+	mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
+	mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
+					     (mkFunTy tup_ty body_ty))
+
+	-- The rec_tup_pat must bind the rec_ids only; remember that the 
+	-- 	trimmed_laters may share the same Names
+	-- Meanwhile, the later_pats must bind the later_vars
+	rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
+	later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
+	rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
+
+	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
+	body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
+	body_ty = mkAppTy m_ty tup_ty
+	tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
+		  -- mkCoreTupTy deals with singleton case
+
+	return_app  = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty]) 
+			      (mk_ret_tup rets)
+
+	mk_wild_pat :: Id -> LPat Id 
+   	mk_wild_pat v = noLoc $ WildPat $ idType v
+
+	mk_later_pat :: Id -> LPat Id
+	mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
+		       | otherwise	     = nlVarPat v
+
+ 	mk_tup_pat :: [LPat Id] -> LPat Id
+  	mk_tup_pat [p] = p
+	mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
+
+	mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
+	mk_ret_tup [r] = r
+	mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
+\end{code}
diff --git a/compiler/deSugar/DsExpr.lhs-boot b/compiler/deSugar/DsExpr.lhs-boot
new file mode 100644
index 0000000000..c65e99d80d
--- /dev/null
+++ b/compiler/deSugar/DsExpr.lhs-boot
@@ -0,0 +1,11 @@
+\begin{code}
+module DsExpr where
+import HsSyn	( HsExpr, LHsExpr, HsLocalBinds )
+import Var  	( Id )
+import DsMonad	( DsM )
+import CoreSyn	( CoreExpr )
+
+dsExpr  :: HsExpr  Id -> DsM CoreExpr
+dsLExpr :: LHsExpr Id -> DsM CoreExpr
+dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+\end{code}
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
new file mode 100644
index 0000000000..52956a09ff
--- /dev/null
+++ b/compiler/deSugar/DsForeign.lhs
@@ -0,0 +1,646 @@
+%
+% (c) The AQUA Project, Glasgow University, 1998
+%
+\section[DsCCall]{Desugaring \tr{foreign} declarations}
+
+Expanding out @foreign import@ and @foreign export@ declarations.
+
+\begin{code}
+module DsForeign ( dsForeigns ) where
+
+#include "HsVersions.h"
+import TcRnMonad	-- temp
+
+import CoreSyn
+
+import DsCCall		( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
+import DsMonad
+
+import HsSyn		( ForeignDecl(..), ForeignExport(..), LForeignDecl,
+			  ForeignImport(..), CImportSpec(..) )
+import DataCon		( splitProductType_maybe )
+#ifdef DEBUG
+import DataCon		( dataConSourceArity )
+import Type		( isUnLiftedType )
+#endif
+import MachOp		( machRepByteWidth, MachRep(..) )
+import SMRep		( argMachRep, typeCgRep )
+import CoreUtils	( exprType, mkInlineMe )
+import Id		( Id, idType, idName, mkSysLocal, setInlinePragma )
+import Literal		( Literal(..), mkStringLit )
+import Module		( moduleFS )
+import Name		( getOccString, NamedThing(..) )
+import Type		( repType, coreEqType )
+import TcType		( Type, mkFunTys, mkForAllTys, mkTyConApp,
+			  mkFunTy, tcSplitTyConApp_maybe, 
+			  tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
+			)
+
+import BasicTypes       ( Boxity(..) )
+import HscTypes		( ForeignStubs(..) )
+import ForeignCall	( ForeignCall(..), CCallSpec(..), 
+			  Safety(..), playSafe,
+			  CExportSpec(..), CLabelString,
+			  CCallConv(..), ccallConvToInt,
+			  ccallConvAttribute
+			)
+import TysWiredIn	( unitTy, tupleTyCon )
+import TysPrim		( addrPrimTy, mkStablePtrPrimTy, alphaTy )
+import PrelNames	( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
+			  checkDotnetResName )
+import BasicTypes	( Activation( NeverActive ) )
+import SrcLoc		( Located(..), unLoc )
+import Outputable
+import Maybe 		( fromJust, isNothing )
+import FastString
+\end{code}
+
+Desugaring of @foreign@ declarations is naturally split up into
+parts, an @import@ and an @export@  part. A @foreign import@ 
+declaration
+\begin{verbatim}
+  foreign import cc nm f :: prim_args -> IO prim_res
+\end{verbatim}
+is the same as
+\begin{verbatim}
+  f :: prim_args -> IO prim_res
+  f a1 ... an = _ccall_ nm cc a1 ... an
+\end{verbatim}
+so we reuse the desugaring code in @DsCCall@ to deal with these.
+
+\begin{code}
+type Binding = (Id, CoreExpr)	-- No rec/nonrec structure;
+				-- the occurrence analyser will sort it all out
+
+dsForeigns :: [LForeignDecl Id] 
+	   -> DsM (ForeignStubs, [Binding])
+dsForeigns [] 
+  = returnDs (NoStubs, [])
+dsForeigns fos
+  = foldlDs combine (ForeignStubs empty empty [] [], []) fos
+ where
+  combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl)
+
+  combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
+	   (ForeignImport id _ spec depr)
+    = traceIf (text "fi start" <+> ppr id)	`thenDs` \ _ ->
+      dsFImport (unLoc id) spec	                `thenDs` \ (bs, h, c, mbhd) -> 
+      warnDepr depr				`thenDs` \ _                ->
+      traceIf (text "fi end" <+> ppr id)	`thenDs` \ _ ->
+      returnDs (ForeignStubs (h $$ acc_h)
+      			     (c $$ acc_c)
+			     (addH mbhd acc_hdrs)
+			     acc_feb, 
+		bs ++ acc_f)
+
+  combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
+	   (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)
+    = dsFExport id (idType id) 
+		ext_nm cconv False                 `thenDs` \(h, c, _, _) ->
+      warnDepr depr				   `thenDs` \_              ->
+      returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), 
+		acc_f)
+
+  addH Nothing  ls = ls
+  addH (Just e) ls
+   | e `elem` ls = ls
+   | otherwise   = e:ls
+
+  warnDepr False = returnDs ()
+  warnDepr True  = dsWarn msg
+     where
+       msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Foreign import}
+%*									*
+%************************************************************************
+
+Desugaring foreign imports is just the matter of creating a binding
+that on its RHS unboxes its arguments, performs the external call
+(using the @CCallOp@ primop), before boxing the result up and returning it.
+
+However, we create a worker/wrapper pair, thus:
+
+	foreign import f :: Int -> IO Int
+==>
+	f x = IO ( \s -> case x of { I# x# ->
+			 case fw s x# of { (# s1, y# #) ->
+			 (# s1, I# y# #)}})
+
+	fw s x# = ccall f s x#
+
+The strictness/CPR analyser won't do this automatically because it doesn't look
+inside returned tuples; but inlining this wrapper is a Really Good Idea 
+because it exposes the boxing to the call site.
+
+\begin{code}
+dsFImport :: Id
+	  -> ForeignImport
+	  -> DsM ([Binding], SDoc, SDoc, Maybe FastString)
+dsFImport id (CImport cconv safety header lib spec)
+  = dsCImport id spec cconv safety no_hdrs	  `thenDs` \(ids, h, c) ->
+    returnDs (ids, h, c, if no_hdrs then Nothing else Just header)
+  where
+    no_hdrs = nullFS header
+
+  -- FIXME: the `lib' field is needed for .NET ILX generation when invoking
+  --	    routines that are external to the .NET runtime, but GHC doesn't
+  --	    support such calls yet; if `nullFastString lib', the value was not given
+dsFImport id (DNImport spec)
+  = dsFCall id (DNCall spec) True {- No headers -} `thenDs` \(ids, h, c) ->
+    returnDs (ids, h, c, Nothing)
+
+dsCImport :: Id
+	  -> CImportSpec
+	  -> CCallConv
+	  -> Safety
+	  -> Bool	-- True <=> no headers in the f.i decl
+	  -> DsM ([Binding], SDoc, SDoc)
+dsCImport id (CLabel cid) _ _ no_hdrs
+ = resultWrapper (idType id) `thenDs` \ (resTy, foRhs) ->
+   ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
+    let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
+    returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
+dsCImport id (CFunction target) cconv safety no_hdrs
+  = dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs
+dsCImport id CWrapper cconv _ _
+  = dsFExportDynamic id cconv
+
+setImpInline :: Bool 	-- True <=> No #include headers 
+			-- in the foreign import declaration
+	     -> Id -> Id
+-- If there is a #include header in the foreign import
+-- we make the worker non-inlinable, because we currently
+-- don't keep the #include stuff in the CCallId, and hence
+-- it won't be visible in the importing module, which can be
+-- fatal. 
+-- (The #include stuff is just collected from the foreign import
+--  decls in a module.)
+-- If you want to do cross-module inlining of the c-calls themselves,
+-- put the #include stuff in the package spec, not the foreign 
+-- import decl.
+setImpInline True  id = id
+setImpInline False id = id `setInlinePragma` NeverActive
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Foreign calls}
+%*									*
+%************************************************************************
+
+\begin{code}
+dsFCall fn_id fcall no_hdrs
+  = let
+	ty		     = idType fn_id
+	(tvs, fun_ty)        = tcSplitForAllTys ty
+	(arg_tys, io_res_ty) = tcSplitFunTys fun_ty
+		-- Must use tcSplit* functions because we want to 
+		-- see that (IO t) in the corner
+    in
+    newSysLocalsDs arg_tys  			`thenDs` \ args ->
+    mapAndUnzipDs unboxArg (map Var args)	`thenDs` \ (val_args, arg_wrappers) ->
+
+    let
+	work_arg_ids  = [v | Var v <- val_args]	-- All guaranteed to be vars
+
+	forDotnet = 
+	 case fcall of
+	   DNCall{} -> True
+	   _        -> False
+
+	topConDs
+	  | forDotnet = 
+	     dsLookupGlobalId checkDotnetResName `thenDs` \ check_id -> 
+	     return (Just check_id)
+          | otherwise = return Nothing
+	     
+	augmentResultDs
+	  | forDotnet = 
+	  	newSysLocalDs addrPrimTy `thenDs` \ err_res -> 
+		returnDs (\ (mb_res_ty, resWrap) ->
+			      case mb_res_ty of
+			  	Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
+							     [ addrPrimTy ]),
+						 resWrap)
+				Just x  -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
+							     [ x, addrPrimTy ]),
+						 resWrap))
+	  | otherwise = returnDs id
+    in
+    augmentResultDs				     `thenDs` \ augment -> 
+    topConDs					     `thenDs` \ topCon -> 
+    boxResult augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+
+    newUnique					`thenDs` \ ccall_uniq ->
+    newUnique					`thenDs` \ work_uniq ->
+    let
+	-- Build the worker
+	worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
+ 	the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
+	work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
+	work_id       = setImpInline no_hdrs $	-- See comments with setImpInline
+			mkSysLocal FSLIT("$wccall") work_uniq worker_ty
+
+	-- Build the wrapper
+	work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
+	wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
+        wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
+    in
+    returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
+
+unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety
+unsafe_call (DNCall _)			   = False
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Foreign export}
+%*									*
+%************************************************************************
+
+The function that does most of the work for `@foreign export@' declarations.
+(see below for the boilerplate code a `@foreign export@' declaration expands
+ into.)
+
+For each `@foreign export foo@' in a module M we generate:
+\begin{itemize}
+\item a C function `@foo@', which calls
+\item a Haskell stub `@M.$ffoo@', which calls
+\end{itemize}
+the user-written Haskell function `@M.foo@'.
+
+\begin{code}
+dsFExport :: Id			-- Either the exported Id, 
+				-- or the foreign-export-dynamic constructor
+	  -> Type		-- The type of the thing callable from C
+	  -> CLabelString	-- The name to export to C land
+	  -> CCallConv
+	  -> Bool		-- True => foreign export dynamic
+				-- 	   so invoke IO action that's hanging off 
+				-- 	   the first argument's stable pointer
+	  -> DsM ( SDoc		-- contents of Module_stub.h
+		 , SDoc		-- contents of Module_stub.c
+		 , [MachRep]    -- primitive arguments expected by stub function
+		 , Int		-- size of args to stub function
+		 )
+
+dsFExport fn_id ty ext_name cconv isDyn
+   = 
+     let
+        (_tvs,sans_foralls)		= tcSplitForAllTys ty
+        (fe_arg_tys', orig_res_ty)	= tcSplitFunTys sans_foralls
+	-- We must use tcSplits here, because we want to see 
+	-- the (IO t) in the corner of the type!
+        fe_arg_tys | isDyn     = tail fe_arg_tys'
+                   | otherwise = fe_arg_tys'
+     in
+	-- Look at the result type of the exported function, orig_res_ty
+	-- If it's IO t, return		(t, True)
+	-- If it's plain t, return	(t, False)
+     (case tcSplitTyConApp_maybe orig_res_ty of
+	-- We must use tcSplit here so that we see the (IO t) in
+	-- the type.  [IO t is transparent to plain splitTyConApp.]
+
+	Just (ioTyCon, [res_ty])
+	      -> ASSERT( ioTyCon `hasKey` ioTyConKey )
+		 -- The function already returns IO t
+		 returnDs (res_ty, True)
+
+	other -> -- The function returns t
+	         returnDs (orig_res_ty, False)
+     )
+					`thenDs` \ (res_ty,		-- t
+						    is_IO_res_ty) ->	-- Bool
+     returnDs $
+       mkFExportCBits ext_name 
+                      (if isDyn then Nothing else Just fn_id)
+                      fe_arg_tys res_ty is_IO_res_ty cconv
+\end{code}
+
+@foreign export dynamic@ lets you dress up Haskell IO actions
+of some fixed type behind an externally callable interface (i.e.,
+as a C function pointer). Useful for callbacks and stuff.
+
+\begin{verbatim}
+foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr
+
+-- Haskell-visible constructor, which is generated from the above:
+-- SUP: No check for NULL from createAdjustor anymore???
+
+f :: (Addr -> Int -> IO Int) -> IO Addr
+f cback =
+   bindIO (newStablePtr cback)
+          (\StablePtr sp# -> IO (\s1# ->
+              case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
+                 (# s2#, a# #) -> (# s2#, A# a# #)))
+
+foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int
+-- `special' foreign export that invokes the closure pointed to by the
+-- first argument.
+\end{verbatim}
+
+\begin{code}
+dsFExportDynamic :: Id
+		 -> CCallConv
+		 -> DsM ([Binding], SDoc, SDoc)
+dsFExportDynamic id cconv
+  =  newSysLocalDs ty				 `thenDs` \ fe_id ->
+     getModuleDs				`thenDs` \ mod_name -> 
+     let 
+        -- hack: need to get at the name of the C stub we're about to generate.
+       fe_nm	   = mkFastString (unpackFS (zEncodeFS (moduleFS mod_name)) ++ "_" ++ toCName fe_id)
+     in
+     newSysLocalDs arg_ty			`thenDs` \ cback ->
+     dsLookupGlobalId newStablePtrName		`thenDs` \ newStablePtrId ->
+     dsLookupTyCon stablePtrTyConName		`thenDs` \ stable_ptr_tycon ->
+     let
+	mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+	stable_ptr_ty	= mkTyConApp stable_ptr_tycon [arg_ty]
+	export_ty	= mkFunTy stable_ptr_ty arg_ty
+     in
+     dsLookupGlobalId bindIOName		`thenDs` \ bindIOId ->
+     newSysLocalDs stable_ptr_ty		`thenDs` \ stbl_value ->
+     dsFExport id export_ty fe_nm cconv True  	
+		`thenDs` \ (h_code, c_code, arg_reps, args_size) ->
+     let
+      stbl_app cont ret_ty = mkApps (Var bindIOId)
+				    [ Type stable_ptr_ty
+				    , Type ret_ty       
+				    , mk_stbl_ptr_app
+				    , cont
+				    ]
+       {-
+        The arguments to the external function which will
+	create a little bit of (template) code on the fly
+	for allowing the (stable pointed) Haskell closure
+	to be entered using an external calling convention
+	(stdcall, ccall).
+       -}
+      adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
+		      , Var stbl_value
+		      , mkLit (MachLabel fe_nm mb_sz_args)
+                      , mkLit (mkStringLit arg_type_info)
+		      ]
+        -- name of external entry point providing these services.
+	-- (probably in the RTS.) 
+      adjustor	 = FSLIT("createAdjustor")
+      
+      arg_type_info = map repCharCode arg_reps
+      repCharCode F32 = 'f'
+      repCharCode F64 = 'd'
+      repCharCode I64 = 'l'
+      repCharCode _   = 'i'
+
+	-- Determine the number of bytes of arguments to the stub function,
+	-- so that we can attach the '@N' suffix to its label if it is a
+	-- stdcall on Windows.
+      mb_sz_args = case cconv of
+		      StdCallConv -> Just args_size
+		      _ 	  -> Nothing
+
+     in
+     dsCCall adjustor adj_args PlayRisky io_res_ty	`thenDs` \ ccall_adj ->
+	-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
+     let ccall_adj_ty = exprType ccall_adj
+         ccall_io_adj = mkLams [stbl_value]		     $
+			Note (Coerce io_res_ty ccall_adj_ty)
+			     ccall_adj
+         io_app = mkLams tvs	 $
+		  mkLams [cback] $
+		  stbl_app ccall_io_adj res_ty
+	 fed = (id `setInlinePragma` NeverActive, io_app)
+		-- Never inline the f.e.d. function, because the litlit
+		-- might not be in scope in other modules.
+     in
+     returnDs ([fed], h_code, c_code)
+
+ where
+  ty			= idType id
+  (tvs,sans_foralls)	= tcSplitForAllTys ty
+  ([arg_ty], io_res_ty)	= tcSplitFunTys sans_foralls
+  [res_ty]		= tcTyConAppArgs io_res_ty
+	-- Must use tcSplit* to see the (IO t), which is a newtype
+
+toCName :: Id -> String
+toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
+\end{code}
+
+%*
+%
+\subsection{Generating @foreign export@ stubs}
+%
+%*
+
+For each @foreign export@ function, a C stub function is generated.
+The C stub constructs the application of the exported Haskell function 
+using the hugs/ghc rts invocation API.
+
+\begin{code}
+mkFExportCBits :: FastString
+	       -> Maybe Id 	-- Just==static, Nothing==dynamic
+	       -> [Type] 
+	       -> Type 
+               -> Bool		-- True <=> returns an IO type
+	       -> CCallConv 
+	       -> (SDoc, 
+		   SDoc,
+		   [MachRep], 	-- the argument reps
+		   Int		-- total size of arguments
+		  )
+mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 
+ = (header_bits, c_bits, 
+    [rep | (_,_,_,rep) <- arg_info],  -- just the real args
+    sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
+    )
+ where
+  -- list the arguments to the C function
+  arg_info :: [(SDoc, 		-- arg name
+		SDoc,		-- C type
+	        Type,		-- Haskell type
+		MachRep)]	-- the MachRep
+  arg_info  = [ (text ('a':show n), showStgType ty, ty, 
+		 typeMachRep (getPrimTyOf ty))
+	      | (ty,n) <- zip arg_htys [1..] ]
+
+  -- add some auxiliary args; the stable ptr in the wrapper case, and
+  -- a slot for the dummy return address in the wrapper + ccall case
+  aug_arg_info
+    | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
+    | otherwise              = arg_info
+
+  stable_ptr_arg = 
+	(text "the_stableptr", text "StgStablePtr", undefined,
+	 typeMachRep (mkStablePtrPrimTy alphaTy))
+
+  -- stuff to do with the return type of the C function
+  res_hty_is_unit = res_hty `coreEqType` unitTy	-- Look through any newtypes
+
+  cResType | res_hty_is_unit = text "void"
+	   | otherwise	     = showStgType res_hty
+
+  -- Now we can cook up the prototype for the exported function.
+  pprCconv = case cc of
+		CCallConv   -> empty
+		StdCallConv -> text (ccallConvAttribute cc)
+
+  header_bits = ptext SLIT("extern") <+> fun_proto <> semi
+
+  fun_proto = cResType <+> pprCconv <+> ftext c_nm <>
+	      parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm) 
+                                                 aug_arg_info)))
+
+  -- the target which will form the root of what we ask rts_evalIO to run
+  the_cfun
+     = case maybe_target of
+          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
+          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+
+  cap = text "cap" <> comma
+
+  -- the expression we give to rts_evalIO
+  expr_to_run
+     = foldl appArg the_cfun arg_info -- NOT aug_arg_info
+       where
+          appArg acc (arg_cname, _, arg_hty, _) 
+             = text "rts_apply" 
+               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
+
+  -- various other bits for inside the fn
+  declareResult = text "HaskellObj ret;"
+  declareCResult | res_hty_is_unit = empty
+                 | otherwise       = cResType <+> text "cret;"
+
+  assignCResult | res_hty_is_unit = empty
+	        | otherwise       =
+	        	text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
+
+  -- an extern decl for the fn being called
+  extern_decl
+     = case maybe_target of
+          Nothing -> empty
+          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+
+   
+   -- Initialise foreign exports by registering a stable pointer from an
+   -- __attribute__((constructor)) function.
+   -- The alternative is to do this from stginit functions generated in
+   -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
+   -- on binary sizes and link times because the static linker will think that
+   -- all modules that are imported directly or indirectly are actually used by
+   -- the program.
+   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
+
+  initialiser
+     = case maybe_target of
+          Nothing -> empty
+          Just hs_fn ->
+            vcat
+             [ text "static void stginit_export_" <> ppr hs_fn
+                  <> text "() __attribute__((constructor));"
+             , text "static void stginit_export_" <> ppr hs_fn <> text "()"
+             , braces (text "getStablePtr"
+                <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
+                <> semi)
+             ]
+
+  -- finally, the whole darn thing
+  c_bits =
+    space $$
+    extern_decl $$
+    fun_proto  $$
+    vcat 
+     [ lbrace
+     ,   text "Capability *cap;"
+     ,   declareResult
+     ,   declareCResult
+     ,   text "cap = rts_lock();"
+	  -- create the application + perform it.
+     ,   text "cap=rts_evalIO" <> parens (
+		cap <>
+		text "rts_apply" <> parens (
+		    cap <>
+		    text "(HaskellObj)"
+	         <> text (if is_IO_res_ty 
+				then "runIO_closure" 
+				else "runNonIO_closure")
+		 <> comma
+        	 <> expr_to_run
+		) <+> comma
+	       <> text "&ret"
+	     ) <> semi
+     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
+						<> comma <> text "cap") <> semi
+     ,   assignCResult
+     ,   text "rts_unlock(cap);"
+     ,   if res_hty_is_unit then empty
+            else text "return cret;"
+     , rbrace
+     ] $$
+    initialiser
+
+-- NB. the calculation here isn't strictly speaking correct.
+-- We have a primitive Haskell type (eg. Int#, Double#), and
+-- we want to know the size, when passed on the C stack, of
+-- the associated C type (eg. HsInt, HsDouble).  We don't have
+-- this information to hand, but we know what GHC's conventions
+-- are for passing around the primitive Haskell types, so we
+-- use that instead.  I hope the two coincide --SDM
+typeMachRep ty = argMachRep (typeCgRep ty)
+
+mkHObj :: Type -> SDoc
+mkHObj t = text "rts_mk" <> text (showFFIType t)
+
+unpackHObj :: Type -> SDoc
+unpackHObj t = text "rts_get" <> text (showFFIType t)
+
+showStgType :: Type -> SDoc
+showStgType t = text "Hs" <> text (showFFIType t)
+
+showFFIType :: Type -> String
+showFFIType t = getOccString (getName tc)
+ where
+  tc = case tcSplitTyConApp_maybe (repType t) of
+	    Just (tc,_) -> tc
+	    Nothing	-> pprPanic "showFFIType" (ppr t)
+
+#if !defined(x86_64_TARGET_ARCH)
+insertRetAddr CCallConv args = ret_addr_arg : args
+insertRetAddr _ args = args
+#else
+-- On x86_64 we insert the return address after the 6th
+-- integer argument, because this is the point at which we
+-- need to flush a register argument to the stack (See rts/Adjustor.c for
+-- details).
+insertRetAddr CCallConv args = go 0 args
+  where  go 6 args = ret_addr_arg : args
+	 go n (arg@(_,_,_,rep):args)
+	  | I64 <- rep = arg : go (n+1) args
+	  | otherwise  = arg : go n     args
+	 go n [] = []
+insertRetAddr _ args = args
+#endif
+
+ret_addr_arg = (text "original_return_addr", text "void*", undefined, 
+		typeMachRep addrPrimTy)
+
+-- This function returns the primitive type associated with the boxed
+-- type argument to a foreign export (eg. Int ==> Int#).  It assumes
+-- that all the types we are interested in have a single constructor
+-- with a single primitive-typed argument, which is true for all of the legal
+-- foreign export argument types (see TcType.legalFEArgTyCon).
+getPrimTyOf :: Type -> Type
+getPrimTyOf ty =
+  case splitProductType_maybe (repType ty) of
+     Just (_, _, data_con, [prim_ty]) ->
+	ASSERT(dataConSourceArity data_con == 1)
+	ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
+	prim_ty
+     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
+\end{code}
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}
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
new file mode 100644
index 0000000000..6bb41a92e4
--- /dev/null
+++ b/compiler/deSugar/DsListComp.lhs
@@ -0,0 +1,516 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsListComp]{Desugaring list comprehensions and array comprehensions}
+
+\begin{code}
+module DsListComp ( dsListComp, dsPArrComp ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
+
+import BasicTypes	( Boxity(..) )
+import HsSyn
+import TcHsSyn		( hsPatType, mkVanillaTuplePat )
+import CoreSyn
+
+import DsMonad		-- the monadery used in the desugarer
+import DsUtils
+
+import DynFlags		( DynFlag(..), dopt )
+import StaticFlags	( opt_RulesOff )
+import CoreUtils	( exprType, mkIfThenElse )
+import Id		( idType )
+import Var              ( Id )
+import Type		( mkTyVarTy, mkFunTys, mkFunTy, Type,
+			  splitTyConApp_maybe )
+import TysPrim		( alphaTyVar )
+import TysWiredIn	( nilDataCon, consDataCon, trueDataConId, falseDataConId, 
+			  unitDataConId, unitTy, mkListTy, parrTyCon )
+import Match		( matchSimply )
+import PrelNames	( foldrName, buildName, replicatePName, mapPName, 
+			  filterPName, zipPName, crossPName ) 
+import PrelInfo		( pAT_ERROR_ID )
+import SrcLoc		( noLoc, unLoc )
+import Panic		( panic )
+\end{code}
+
+List comprehensions may be desugared in one of two ways: ``ordinary''
+(as you would expect if you read SLPJ's book) and ``with foldr/build
+turned on'' (if you read Gill {\em et al.}'s paper on the subject).
+
+There will be at least one ``qualifier'' in the input.
+
+\begin{code}
+dsListComp :: [LStmt Id] 
+	   -> LHsExpr Id
+	   -> Type		-- Type of list elements
+	   -> DsM CoreExpr
+dsListComp lquals body elt_ty
+  = getDOptsDs  `thenDs` \dflags ->
+    let
+	quals = map unLoc lquals
+    in
+    if opt_RulesOff || dopt Opt_IgnoreInterfacePragmas dflags
+	-- Either rules are switched off, or we are ignoring what there are;
+	-- Either way foldr/build won't happen, so use the more efficient
+	-- Wadler-style desugaring
+  	|| isParallelComp quals
+		-- Foldr-style desugaring can't handle
+		-- parallel list comprehensions
+  	then deListComp quals body (mkNilExpr elt_ty)
+
+   else		-- Foldr/build should be enabled, so desugar 
+		-- into foldrs and builds
+    newTyVarsDs [alphaTyVar]    `thenDs` \ [n_tyvar] ->
+    let
+	n_ty = mkTyVarTy n_tyvar
+        c_ty = mkFunTys [elt_ty, n_ty] n_ty
+    in
+    newSysLocalsDs [c_ty,n_ty]		`thenDs` \ [c, n] ->
+    dfListComp c n quals body		`thenDs` \ result ->
+    dsLookupGlobalId buildName	`thenDs` \ build_id ->
+    returnDs (Var build_id `App` Type elt_ty 
+			   `App` mkLams [n_tyvar, c, n] result)
+
+  where isParallelComp (ParStmt bndrstmtss : _) = True
+	isParallelComp _                        = False
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
+%*									*
+%************************************************************************
+
+Just as in Phil's chapter~7 in SLPJ, using the rules for
+optimally-compiled list comprehensions.  This is what Kevin followed
+as well, and I quite happily do the same.  The TQ translation scheme
+transforms a list of qualifiers (either boolean expressions or
+generators) into a single expression which implements the list
+comprehension.  Because we are generating 2nd-order polymorphic
+lambda-calculus, calls to NIL and CONS must be applied to a type
+argument, as well as their usual value arguments.
+\begin{verbatim}
+TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
+
+(Rule C)
+TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
+
+(Rule B)
+TQ << [ e | b , qs ] ++ L >> =
+    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
+
+(Rule A')
+TQ << [ e | p <- L1, qs ]  ++  L2 >> =
+  letrec
+    h = \ u1 ->
+    	  case u1 of
+	    []        ->  TE << L2 >>
+	    (u2 : u3) ->
+		  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
+		    [] (h u3)
+  in
+    h ( TE << L1 >> )
+
+"h", "u1", "u2", and "u3" are new variables.
+\end{verbatim}
+
+@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
+is the TE translation scheme.  Note that we carry around the @L@ list
+already desugared.  @dsListComp@ does the top TE rule mentioned above.
+
+To the above, we add an additional rule to deal with parallel list
+comprehensions.  The translation goes roughly as follows:
+     [ e | p1 <- e11, let v1 = e12, p2 <- e13
+         | q1 <- e21, let v2 = e22, q2 <- e23]
+     =>
+     [ e | ((x1, .., xn), (y1, ..., ym)) <-
+               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
+                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
+where (x1, .., xn) are the variables bound in p1, v1, p2
+      (y1, .., ym) are the variables bound in q1, v2, q2
+
+In the translation below, the ParStmt branch translates each parallel branch
+into a sub-comprehension, and desugars each independently.  The resulting lists
+are fed to a zip function, we create a binding for all the variables bound in all
+the comprehensions, and then we hand things off the the desugarer for bindings.
+The zip function is generated here a) because it's small, and b) because then we
+don't have to deal with arbitrary limits on the number of zip functions in the
+prelude, nor which library the zip function came from.
+The introduced tuples are Boxed, but only because I couldn't get it to work
+with the Unboxed variety.
+
+\begin{code}
+deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
+
+deListComp (ParStmt stmtss_w_bndrs : quals) body list
+  = mappM do_list_comp stmtss_w_bndrs	`thenDs` \ exps ->
+    mkZipBind qual_tys			`thenDs` \ (zip_fn, zip_rhs) ->
+
+	-- Deal with [e | pat <- zip l1 .. ln] in example above
+    deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) 
+		   quals body list
+
+  where 
+	bndrs_s = map snd stmtss_w_bndrs
+
+	-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+	pat	 = mkTuplePat pats
+	pats	 = map mk_hs_tuple_pat bndrs_s
+
+	-- Types of (x1,..,xn), (y1,..,yn) etc
+	qual_tys = map mk_bndrs_tys bndrs_s
+
+	do_list_comp (stmts, bndrs)
+	  = dsListComp stmts (mk_hs_tuple_expr bndrs)
+		       (mk_bndrs_tys bndrs)
+
+	mk_bndrs_tys bndrs = mkCoreTupTy (map idType bndrs)
+
+	-- Last: the one to return
+deListComp [] body list		-- Figure 7.4, SLPJ, p 135, rule C above
+  = dsLExpr body		`thenDs` \ core_body ->
+    returnDs (mkConsExpr (exprType core_body) core_body list)
+
+	-- Non-last: must be a guard
+deListComp (ExprStmt guard _ _ : quals) body list	-- rule B above
+  = dsLExpr guard      		`thenDs` \ core_guard ->
+    deListComp quals body list	`thenDs` \ core_rest ->
+    returnDs (mkIfThenElse core_guard core_rest list)
+
+-- [e | let B, qs] = let B in [e | qs]
+deListComp (LetStmt binds : quals) body list
+  = deListComp quals body list	`thenDs` \ core_rest ->
+    dsLocalBinds binds core_rest
+
+deListComp (BindStmt pat list1 _ _ : quals) body core_list2 -- rule A' above
+  = dsLExpr list1		    `thenDs` \ core_list1 ->
+    deBindComp pat core_list1 quals body core_list2
+\end{code}
+
+
+\begin{code}
+deBindComp pat core_list1 quals body core_list2
+  = let
+	u3_ty@u1_ty = exprType core_list1	-- two names, same thing
+
+	-- u1_ty is a [alpha] type, and u2_ty = alpha
+	u2_ty = hsPatType pat
+
+	res_ty = exprType core_list2
+	h_ty   = u1_ty `mkFunTy` res_ty
+    in
+    newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]	`thenDs` \ [h, u1, u2, u3] ->
+
+    -- the "fail" value ...
+    let
+	core_fail   = App (Var h) (Var u3)
+	letrec_body = App (Var h) core_list1
+    in
+    deListComp quals body core_fail		`thenDs` \ rest_expr ->
+    matchSimply (Var u2) (StmtCtxt ListComp) pat
+		rest_expr core_fail		`thenDs` \ core_match ->
+    let
+	rhs = Lam u1 $
+	      Case (Var u1) u1 res_ty
+		   [(DataAlt nilDataCon,  [], 	    core_list2),
+		    (DataAlt consDataCon, [u2, u3], core_match)]
+			-- Increasing order of tag
+    in
+    returnDs (Let (Rec [(h, rhs)]) letrec_body)
+\end{code}
+
+
+\begin{code}
+mkZipBind :: [Type] -> DsM (Id, CoreExpr)
+-- mkZipBind [t1, t2] 
+-- = (zip, \as1:[t1] as2:[t2] 
+--	   -> case as1 of 
+--		[] -> []
+--		(a1:as'1) -> case as2 of
+--				[] -> []
+--				(a2:as'2) -> (a2,a2) : zip as'1 as'2)]
+
+mkZipBind elt_tys 
+  = mappM newSysLocalDs  list_tys	`thenDs` \ ass ->
+    mappM newSysLocalDs  elt_tys	`thenDs` \ as' ->
+    mappM newSysLocalDs  list_tys	`thenDs` \ as's ->
+    newSysLocalDs zip_fn_ty		`thenDs` \ zip_fn ->
+    let 
+	inner_rhs = mkConsExpr ret_elt_ty 
+			(mkCoreTup (map Var as'))
+			(mkVarApps (Var zip_fn) as's)
+	zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
+    in
+    returnDs (zip_fn, mkLams ass zip_body)
+  where
+    list_tys    = map mkListTy elt_tys
+    ret_elt_ty  = mkCoreTupTy elt_tys
+    list_ret_ty = mkListTy ret_elt_ty
+    zip_fn_ty   = mkFunTys list_tys list_ret_ty
+
+    mk_case (as, a', as') rest
+	  = Case (Var as) as list_ret_ty
+		  [(DataAlt nilDataCon,  [],        mkNilExpr ret_elt_ty),
+		   (DataAlt consDataCon, [a', as'], rest)]
+			-- Increasing order of tag
+-- Helper functions that makes an HsTuple only for non-1-sized tuples
+mk_hs_tuple_expr :: [Id] -> LHsExpr Id
+mk_hs_tuple_expr []   = nlHsVar unitDataConId
+mk_hs_tuple_expr [id] = nlHsVar id
+mk_hs_tuple_expr ids  = noLoc $ ExplicitTuple [ nlHsVar i | i <- ids ] Boxed
+
+mk_hs_tuple_pat :: [Id] -> LPat Id
+mk_hs_tuple_pat bs  = mkTuplePat (map nlVarPat bs)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
+%*									*
+%************************************************************************
+
+@dfListComp@ are the rules used with foldr/build turned on:
+
+\begin{verbatim}
+TE[ e | ]            c n = c e n
+TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n
+TE[ e | p <- l , q ] c n = let 
+				f = \ x b -> case x of
+						  p -> TE[ e | q ] c b
+						  _ -> b
+			   in
+			   foldr f n l
+\end{verbatim}
+
+\begin{code}
+dfListComp :: Id -> Id			-- 'c' and 'n'
+	   -> [Stmt Id] 	-- the rest of the qual's
+	   -> LHsExpr Id
+	   -> DsM CoreExpr
+
+	-- Last: the one to return
+dfListComp c_id n_id [] body
+  = dsLExpr body		`thenDs` \ core_body ->
+    returnDs (mkApps (Var c_id) [core_body, Var n_id])
+
+	-- Non-last: must be a guard
+dfListComp c_id n_id (ExprStmt guard _ _  : quals) body
+  = dsLExpr guard              		`thenDs` \ core_guard ->
+    dfListComp c_id n_id quals body	`thenDs` \ core_rest ->
+    returnDs (mkIfThenElse core_guard core_rest (Var n_id))
+
+dfListComp c_id n_id (LetStmt binds : quals) body
+  -- new in 1.3, local bindings
+  = dfListComp c_id n_id quals body	`thenDs` \ core_rest ->
+    dsLocalBinds binds core_rest
+
+dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body
+    -- evaluate the two lists
+  = dsLExpr list1			`thenDs` \ core_list1 ->
+
+    -- find the required type
+    let x_ty   = hsPatType pat
+	b_ty   = idType n_id
+    in
+
+    -- create some new local id's
+    newSysLocalsDs [b_ty,x_ty]			`thenDs` \ [b,x] ->
+
+    -- build rest of the comprehesion
+    dfListComp c_id b quals body		`thenDs` \ core_rest ->
+
+    -- build the pattern match
+    matchSimply (Var x) (StmtCtxt ListComp)
+		pat core_rest (Var b)		`thenDs` \ core_expr ->
+
+    -- now build the outermost foldr, and return
+    dsLookupGlobalId foldrName		`thenDs` \ foldr_id ->
+    returnDs (
+      Var foldr_id `App` Type x_ty 
+		   `App` Type b_ty
+		   `App` mkLams [x, b] core_expr
+		   `App` Var n_id
+		   `App` core_list1
+    )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[DsPArrComp]{Desugaring of array comprehensions}
+%*									*
+%************************************************************************
+
+\begin{code}
+
+-- entry point for desugaring a parallel array comprehension
+--
+--   [:e | qss:] = <<[:e | qss:]>> () [:():]
+--
+dsPArrComp      :: [Stmt Id] 
+		-> LHsExpr Id
+	        -> Type		    -- Don't use; called with `undefined' below
+	        -> DsM CoreExpr
+dsPArrComp qs body _  =
+  dsLookupGlobalId replicatePName			  `thenDs` \repP ->
+  let unitArray = mkApps (Var repP) [Type unitTy, 
+				     mkIntExpr 1, 
+				     mkCoreTup []]
+  in
+  dePArrComp qs body (mkTuplePat []) unitArray
+
+-- the work horse
+--
+dePArrComp :: [Stmt Id] 
+	   -> LHsExpr Id
+	   -> LPat Id		-- the current generator pattern
+	   -> CoreExpr		-- the current generator expression
+	   -> DsM CoreExpr
+--
+--  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
+--
+dePArrComp [] e' pa cea =
+  dsLookupGlobalId mapPName				  `thenDs` \mapP    ->
+  let ty = parrElemType cea
+  in
+  deLambda ty pa e'					  `thenDs` \(clam, 
+								     ty'e') ->
+  returnDs $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
+--
+--  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
+--
+dePArrComp (ExprStmt b _ _ : qs) body pa cea =
+  dsLookupGlobalId filterPName			  `thenDs` \filterP  ->
+  let ty = parrElemType cea
+  in
+  deLambda ty pa b				  `thenDs` \(clam,_) ->
+  dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
+--
+--  <<[:e' | p <- e, qs:]>> pa ea = 
+--    let ef = filterP (\x -> case x of {p -> True; _ -> False}) e
+--    in
+--    <<[:e' | qs:]>> (pa, p) (crossP ea ef)
+--
+dePArrComp (BindStmt p e _ _ : qs) body pa cea =
+  dsLookupGlobalId filterPName			  `thenDs` \filterP ->
+  dsLookupGlobalId crossPName			  `thenDs` \crossP  ->
+  dsLExpr e					  `thenDs` \ce      ->
+  let ty'cea = parrElemType cea
+      ty'ce  = parrElemType ce
+      false  = Var falseDataConId
+      true   = Var trueDataConId
+  in
+  newSysLocalDs ty'ce					  `thenDs` \v       ->
+  matchSimply (Var v) (StmtCtxt PArrComp) p true false    `thenDs` \pred    ->
+  let cef    = mkApps (Var filterP) [Type ty'ce, mkLams [v] pred, ce]
+      ty'cef = ty'ce				-- filterP preserves the type
+      pa'    = mkTuplePat [pa, p]
+  in
+  dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef])
+--
+--  <<[:e' | let ds, qs:]>> pa ea = 
+--    <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) 
+--		      (mapP (\v@pa -> (v, let ds in (x_1, ..., x_n))) ea)
+--  where
+--    {x_1, ..., x_n} = DV (ds)		-- Defined Variables
+--
+dePArrComp (LetStmt ds : qs) body pa cea =
+  dsLookupGlobalId mapPName				  `thenDs` \mapP    ->
+  let xs     = map unLoc (collectLocalBinders ds)
+      ty'cea = parrElemType cea
+  in
+  newSysLocalDs ty'cea					  `thenDs` \v       ->
+  dsLocalBinds ds (mkCoreTup (map Var xs))		  `thenDs` \clet    ->
+  newSysLocalDs (exprType clet)				  `thenDs` \let'v   ->
+  let projBody = mkDsLet (NonRec let'v clet) $ 
+		 mkCoreTup [Var v, Var let'v]
+      errTy    = exprType projBody
+      errMsg   = "DsListComp.dePArrComp: internal error!"
+  in
+  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
+  matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr`thenDs` \ccase   ->
+  let pa'    = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
+      proj   = mkLams [v] ccase
+  in
+  dePArrComp qs body pa' (mkApps (Var mapP) [Type ty'cea, proj, cea])
+--
+--  <<[:e' | qs | qss:]>> pa ea = 
+--    <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) 
+--		       (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
+--    where
+--      {x_1, ..., x_n} = DV (qs)
+--
+dePArrComp (ParStmt qss : qs) body pa cea = 
+  dsLookupGlobalId crossPName				`thenDs` \crossP  ->
+  deParStmt qss						`thenDs` \(pQss, 
+								   ceQss) ->
+  let ty'cea   = parrElemType cea
+      ty'ceQss = parrElemType ceQss
+      pa'      = mkTuplePat [pa, pQss]
+  in
+  dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'ceQss, 
+					       cea, ceQss])
+  where
+    deParStmt []             =
+      -- empty parallel statement lists have not source representation
+      panic "DsListComp.dePArrComp: Empty parallel list comprehension"
+    deParStmt ((qs, xs):qss) =          -- first statement
+      let res_expr = mkExplicitTuple (map nlHsVar xs)
+      in
+      dsPArrComp (map unLoc qs) res_expr undefined	  `thenDs` \cqs     ->
+      parStmts qss (mkTuplePat (map nlVarPat xs)) cqs
+    ---
+    parStmts []             pa cea = return (pa, cea)
+    parStmts ((qs, xs):qss) pa cea =    -- subsequent statements (zip'ed)
+      dsLookupGlobalId zipPName				  `thenDs` \zipP    ->
+      let pa'      = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
+	  ty'cea   = parrElemType cea
+	  res_expr = mkExplicitTuple (map nlHsVar xs)
+      in
+      dsPArrComp (map unLoc qs) res_expr undefined	  `thenDs` \cqs     ->
+      let ty'cqs = parrElemType cqs
+	  cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
+      in
+      parStmts qss pa' cea'
+
+-- generate Core corresponding to `\p -> e'
+--
+deLambda        :: Type			-- type of the argument
+		-> LPat Id		-- argument pattern
+		-> LHsExpr Id		-- body
+		-> DsM (CoreExpr, Type)
+deLambda ty p e  =
+  newSysLocalDs ty					  `thenDs` \v       ->
+  dsLExpr e						  `thenDs` \ce      ->
+  let errTy    = exprType ce
+      errMsg   = "DsListComp.deLambda: internal error!"
+  in
+  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    -> 
+  matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr	  `thenDs` \res	    ->
+  returnDs (mkLams [v] res, errTy)
+
+-- obtain the element type of the parallel array produced by the given Core
+-- expression
+--
+parrElemType   :: CoreExpr -> Type
+parrElemType e  = 
+  case splitTyConApp_maybe (exprType e) of
+    Just (tycon, [ty]) | tycon == parrTyCon -> ty
+    _							  -> panic
+      "DsListComp.parrElemType: not a parallel array type"
+
+-- Smart constructor for source tuple patterns
+--
+mkTuplePat :: [LPat Id] -> LPat Id
+mkTuplePat [lpat] = lpat
+mkTuplePat lpats  = noLoc $ mkVanillaTuplePat lpats Boxed
+
+-- Smart constructor for source tuple expressions
+--
+mkExplicitTuple :: [LHsExpr id] -> LHsExpr id
+mkExplicitTuple [lexp] = lexp
+mkExplicitTuple lexps  = noLoc $ ExplicitTuple lexps Boxed
+\end{code}
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
new file mode 100644
index 0000000000..88b0ba9c8e
--- /dev/null
+++ b/compiler/deSugar/DsMeta.hs
@@ -0,0 +1,1732 @@
+-----------------------------------------------------------------------------
+-- The purpose of this module is to transform an HsExpr into a CoreExpr which
+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
+-- input HsExpr. We do this in the DsM monad, which supplies access to
+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
+--
+-- It also defines a bunch of knownKeyNames, in the same way as is done
+-- in prelude/PrelNames.  It's much more convenient to do it here, becuase
+-- otherwise we have to recompile PrelNames whenever we add a Name, which is
+-- a Royal Pain (triggers other recompilation).
+-----------------------------------------------------------------------------
+
+
+module DsMeta( dsBracket, 
+	       templateHaskellNames, qTyConName, nameTyConName,
+	       liftName, expQTyConName, decQTyConName, typeQTyConName,
+	       decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
+	        ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-}	DsExpr ( dsExpr )
+
+import MatchLit	  ( dsLit )
+import DsUtils    ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
+import DsMonad
+
+import qualified Language.Haskell.TH as TH
+
+import HsSyn
+import Class (FunDep)
+import PrelNames  ( rationalTyConName, integerTyConName, negateName )
+import OccName	  ( isDataOcc, isTvOcc, occNameString )
+-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
+-- we do this by removing varName from the import of OccName above, making
+-- a qualified instance of OccName and using OccNameAlias.varName where varName
+-- ws previously used in this file.
+import qualified OccName
+
+import Module	  ( Module, mkModule, moduleString )
+import Id         ( Id, mkLocalId )
+import OccName	  ( mkOccNameFS )
+import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule, 
+		    isExternalName, getSrcLoc )
+import NameEnv
+import Type       ( Type, mkTyConApp )
+import TcType	  ( tcTyConAppArgs )
+import TyCon	  ( tyConName )
+import TysWiredIn ( parrTyCon )
+import CoreSyn
+import CoreUtils  ( exprType )
+import SrcLoc	  ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
+import Maybe	  ( catMaybes )
+import Unique	  ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
+import BasicTypes ( isBoxed ) 
+import Outputable
+import Bag	  ( bagToList, unionManyBags )
+import FastString ( unpackFS )
+import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
+
+import Monad ( zipWithM )
+import List ( sortBy )
+ 
+-----------------------------------------------------------------------------
+dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
+-- Returns a CoreExpr of type TH.ExpQ
+-- The quoted thing is parameterised over Name, even though it has
+-- been type checked.  We don't want all those type decorations!
+
+dsBracket brack splices
+  = dsExtendMetaEnv new_bit (do_brack brack)
+  where
+    new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
+
+    do_brack (VarBr n)  = do { MkC e1  <- lookupOcc n ; return e1 }
+    do_brack (ExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (PatBr p)  = do { MkC p1  <- repLP p     ; return p1 }
+    do_brack (TypBr t)  = do { MkC t1  <- repLTy t    ; return t1 }
+    do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
+
+{- -------------- Examples --------------------
+
+  [| \x -> x |]
+====>
+  gensym (unpackString "x"#) `bindQ` \ x1::String ->
+  lam (pvar x1) (var x1)
+
+
+  [| \x -> $(f [| x |]) |]
+====>
+  gensym (unpackString "x"#) `bindQ` \ x1::String ->
+  lam (pvar x1) (f (var x1))
+-}
+
+
+-------------------------------------------------------
+-- 			Declarations
+-------------------------------------------------------
+
+repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
+repTopDs group
+ = do { let { bndrs = map unLoc (groupBinders group) } ;
+	ss <- mkGenSyms bndrs ;
+
+	-- Bind all the names mainly to avoid repeated use of explicit strings.
+	-- Thus	we get
+	--	do { t :: String <- genSym "T" ;
+	--	     return (Data t [] ...more t's... }
+	-- The other important reason is that the output must mention
+	-- only "T", not "Foo:T" where Foo is the current module
+
+	
+	decls <- addBinds ss (do {
+			val_ds  <- rep_val_binds (hs_valds group) ;
+			tycl_ds <- mapM repTyClD (hs_tyclds group) ;
+			inst_ds <- mapM repInstD' (hs_instds group) ;
+			for_ds <- mapM repForD (hs_fords group) ;
+			-- more needed
+			return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
+
+	decl_ty <- lookupType decQTyConName ;
+	let { core_list = coreList' decl_ty decls } ;
+
+	dec_ty <- lookupType decTyConName ;
+	q_decs  <- repSequenceQ dec_ty core_list ;
+
+	wrapNongenSyms ss q_decs
+	-- Do *not* gensym top-level binders
+      }
+
+groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
+			hs_fords = foreign_decls })
+-- Collect the binders of a Group
+  = collectHsValBinders val_decls ++
+    [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
+    [n | L _ (ForeignImport n _ _ _) <- foreign_decls]
+
+
+{- 	Note [Binders and occurrences]
+	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we desugar [d| data T = MkT |]
+we want to get
+	Data "T" [] [Con "MkT" []] []
+and *not*
+	Data "Foo:T" [] [Con "Foo:MkT" []] []
+That is, the new data decl should fit into whatever new module it is
+asked to fit in.   We do *not* clone, though; no need for this:
+	Data "T79" ....
+
+But if we see this:
+	data T = MkT 
+	foo = reifyDecl T
+
+then we must desugar to
+	foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
+
+So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
+And we use lookupOcc, rather than lookupBinder
+in repTyClD and repC.
+
+-}
+
+repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
+
+repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, 
+		    tcdLName = tc, tcdTyVars = tvs, 
+		    tcdCons = cons, tcdDerivs = mb_derivs }))
+ = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
+        dec <- addTyVarBinds tvs $ \bndrs -> do {
+      	       cxt1    <- repLContext cxt ;
+               cons1   <- mapM repC cons ;
+      	       cons2   <- coreList conQTyConName cons1 ;
+      	       derivs1 <- repDerivs mb_derivs ;
+	       bndrs1  <- coreList nameTyConName bndrs ;
+      	       repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
+        return $ Just (loc, dec) }
+
+repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, 
+		    tcdLName = tc, tcdTyVars = tvs, 
+		    tcdCons = [con], tcdDerivs = mb_derivs }))
+ = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
+        dec <- addTyVarBinds tvs $ \bndrs -> do {
+      	       cxt1   <- repLContext cxt ;
+               con1   <- repC con ;
+      	       derivs1 <- repDerivs mb_derivs ;
+	       bndrs1  <- coreList nameTyConName bndrs ;
+      	       repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
+        return $ Just (loc, dec) }
+
+repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
+ = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
+        dec <- addTyVarBinds tvs $ \bndrs -> do {
+	       ty1     <- repLTy ty ;
+	       bndrs1  <- coreList nameTyConName bndrs ;
+	       repTySyn tc1 bndrs1 ty1 } ;
+ 	return (Just (loc, dec)) }
+
+repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, 
+		      tcdTyVars = tvs, 
+		      tcdFDs = fds,
+		      tcdSigs = sigs, tcdMeths = meth_binds }))
+ = do { cls1 <- lookupLOcc cls ;		-- See note [Binders and occurrences] 
+    	dec  <- addTyVarBinds tvs $ \bndrs -> do {
+ 		  cxt1   <- repLContext cxt ;
+ 		  sigs1  <- rep_sigs sigs ;
+ 		  binds1 <- rep_binds meth_binds ;
+	          fds1 <- repLFunDeps fds;
+ 		  decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
+	          bndrs1 <- coreList nameTyConName bndrs ;
+ 		  repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
+    	return $ Just (loc, dec) }
+
+-- Un-handled cases
+repTyClD (L loc d) = putSrcSpanDs loc $
+		     do { dsWarn (hang ds_msg 4 (ppr d))
+			; return Nothing }
+
+-- represent fundeps
+--
+repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
+repLFunDeps fds = do fds' <- mapM repLFunDep fds
+                     fdList <- coreList funDepTyConName fds'
+                     return fdList
+
+repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
+repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
+                               ys' <- mapM lookupBinder ys
+                               xs_list <- coreList nameTyConName xs'
+                               ys_list <- coreList nameTyConName ys'
+                               repFunDep xs_list ys_list
+
+repInstD' (L loc (InstDecl ty binds _))		-- Ignore user pragmas for now
+ = do	{ i <- addTyVarBinds tvs $ \tv_bndrs ->
+		-- We must bring the type variables into scope, so their occurrences
+		-- don't fail,  even though the binders don't appear in the resulting 
+		-- data structure
+		do {  cxt1 <- repContext cxt
+		   ; inst_ty1 <- repPred (HsClassP cls tys)
+		   ; ss <- mkGenSyms (collectHsBindBinders binds)
+		   ; binds1 <- addBinds ss (rep_binds binds)
+		   ; decls1 <- coreList decQTyConName binds1
+		   ; decls2 <- wrapNongenSyms ss decls1
+		   -- wrapNonGenSyms: do not clone the class op names!
+		   -- They must be called 'op' etc, not 'op34'
+		   ; repInst cxt1 inst_ty1 decls2 }
+
+	; return (loc, i)}
+ where
+   (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
+
+repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
+repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis) _))
+ = do MkC name' <- lookupLOcc name
+      MkC typ' <- repLTy typ
+      MkC cc' <- repCCallConv cc
+      MkC s' <- repSafety s
+      MkC str <- coreStringLit $ static
+                              ++ unpackFS ch ++ " "
+                              ++ unpackFS cn ++ " "
+                              ++ conv_cimportspec cis
+      dec <- rep2 forImpDName [cc', s', str, name', typ']
+      return (loc, dec)
+ where
+    conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
+    conv_cimportspec (CFunction DynamicTarget) = "dynamic"
+    conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
+    conv_cimportspec CWrapper = "wrapper"
+    static = case cis of
+                 CFunction (StaticTarget _) -> "static "
+                 _ -> ""
+
+repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
+repCCallConv CCallConv = rep2 cCallName []
+repCCallConv StdCallConv = rep2 stdCallName []
+
+repSafety :: Safety -> DsM (Core TH.Safety)
+repSafety PlayRisky = rep2 unsafeName []
+repSafety (PlaySafe False) = rep2 safeName []
+repSafety (PlaySafe True) = rep2 threadsafeName []
+
+ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
+
+-------------------------------------------------------
+-- 			Constructors
+-------------------------------------------------------
+
+repC :: LConDecl Name -> DsM (Core TH.ConQ)
+repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
+  = do { con1 <- lookupLOcc con ;		-- See note [Binders and occurrences] 
+	 repConstr con1 details }
+repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
+  = do { addTyVarBinds tvs $ \bndrs -> do {
+             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
+             ctxt' <- repContext ctxt;
+             bndrs' <- coreList nameTyConName bndrs;
+             rep2 forallCName [unC bndrs', unC ctxt', unC c']
+         }
+       }
+repC (L loc con_decl)		-- GADTs
+  = putSrcSpanDs loc $ 
+    do	{ dsWarn (hang ds_msg 4 (ppr con_decl))
+	; return (panic "DsMeta:repC") }
+
+repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
+repBangTy ty= do 
+  MkC s <- rep2 str []
+  MkC t <- repLTy ty'
+  rep2 strictTypeName [s, t]
+  where 
+    (str, ty') = case ty of
+		   L _ (HsBangTy _ ty) -> (isStrictName,  ty)
+		   other	       -> (notStrictName, ty)
+
+-------------------------------------------------------
+-- 			Deriving clause
+-------------------------------------------------------
+
+repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
+repDerivs Nothing = coreList nameTyConName []
+repDerivs (Just ctxt)
+  = do { strs <- mapM rep_deriv ctxt ; 
+	 coreList nameTyConName strs }
+  where
+    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
+	-- Deriving clauses must have the simple H98 form
+    rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
+    rep_deriv other		  		 = panic "rep_deriv"
+
+
+-------------------------------------------------------
+--   Signatures in a class decl, or a group of bindings
+-------------------------------------------------------
+
+rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
+rep_sigs sigs = do locs_cores <- rep_sigs' sigs
+                   return $ de_loc $ sort_by_loc locs_cores
+
+rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
+	-- We silently ignore ones we don't recognise
+rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
+		     return (concat sigs1) }
+
+rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
+	-- Singleton => Ok
+	-- Empty     => Too hard, signature ignored
+rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig other		        = return []
+
+rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; 
+		       ty1 <- repLTy ty ; 
+		       sig <- repProto nm1 ty1 ;
+		       return [(loc, sig)] }
+
+
+-------------------------------------------------------
+-- 			Types
+-------------------------------------------------------
+
+-- gensym a list of type variables and enter them into the meta environment;
+-- the computations passed as the second argument is executed in that extended
+-- meta environment and gets the *new* names on Core-level as an argument
+--
+addTyVarBinds :: [LHsTyVarBndr Name]	         -- the binders to be added
+	      -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
+	      -> DsM (Core (TH.Q a))
+addTyVarBinds tvs m =
+  do
+    let names = map (hsTyVarName.unLoc) tvs
+    freshNames <- mkGenSyms names
+    term       <- addBinds freshNames $ do
+		    bndrs <- mapM lookupBinder names 
+		    m bndrs
+    wrapGenSyns freshNames term
+
+-- represent a type context
+--
+repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
+repLContext (L _ ctxt) = repContext ctxt
+
+repContext :: HsContext Name -> DsM (Core TH.CxtQ)
+repContext ctxt = do 
+	            preds    <- mapM repLPred ctxt
+		    predList <- coreList typeQTyConName preds
+		    repCtxt predList
+
+-- represent a type predicate
+--
+repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
+repLPred (L _ p) = repPred p
+
+repPred :: HsPred Name -> DsM (Core TH.TypeQ)
+repPred (HsClassP cls tys) = do
+			       tcon <- repTy (HsTyVar cls)
+			       tys1 <- repLTys tys
+			       repTapps tcon tys1
+repPred (HsIParam _ _)     = 
+  panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
+
+-- yield the representation of a list of types
+--
+repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
+repLTys tys = mapM repLTy tys
+
+-- represent a type
+--
+repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
+repLTy (L _ ty) = repTy ty
+
+repTy :: HsType Name -> DsM (Core TH.TypeQ)
+repTy (HsForAllTy _ tvs ctxt ty)  = 
+  addTyVarBinds tvs $ \bndrs -> do
+    ctxt1  <- repLContext ctxt
+    ty1    <- repLTy ty
+    bndrs1 <- coreList nameTyConName bndrs
+    repTForall bndrs1 ctxt1 ty1
+
+repTy (HsTyVar n)
+  | isTvOcc (nameOccName n)       = do 
+				      tv1 <- lookupBinder n
+				      repTvar tv1
+  | otherwise		          = do 
+				      tc1 <- lookupOcc n
+				      repNamedTyCon tc1
+repTy (HsAppTy f a)               = do 
+				      f1 <- repLTy f
+				      a1 <- repLTy a
+				      repTapp f1 a1
+repTy (HsFunTy f a)               = do 
+				      f1   <- repLTy f
+				      a1   <- repLTy a
+				      tcon <- repArrowTyCon
+				      repTapps tcon [f1, a1]
+repTy (HsListTy t)		  = do
+				      t1   <- repLTy t
+				      tcon <- repListTyCon
+				      repTapp tcon t1
+repTy (HsPArrTy t)                = do
+				      t1   <- repLTy t
+				      tcon <- repTy (HsTyVar (tyConName parrTyCon))
+				      repTapp tcon t1
+repTy (HsTupleTy tc tys)	  = do
+				      tys1 <- repLTys tys 
+				      tcon <- repTupleTyCon (length tys)
+				      repTapps tcon tys1
+repTy (HsOpTy ty1 n ty2) 	  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) 
+					   `nlHsAppTy` ty2)
+repTy (HsParTy t)  	       	  = repLTy t
+repTy (HsNumTy i)                 =
+  panic "DsMeta.repTy: Can't represent number types (for generics)"
+repTy (HsPredTy pred)             = repPred pred
+repTy (HsKindSig ty kind)	  = 
+  panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
+
+
+-----------------------------------------------------------------------------
+-- 		Expressions
+-----------------------------------------------------------------------------
+
+repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
+repLEs es = do { es'  <- mapM repLE es ;
+		 coreList expQTyConName es' }
+
+-- FIXME: some of these panics should be converted into proper error messages
+--	  unless we can make sure that constructs, which are plainly not
+--	  supported in TH already lead to error messages at an earlier stage
+repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
+repLE (L _ e) = repE e
+
+repE :: HsExpr Name -> DsM (Core TH.ExpQ)
+repE (HsVar x)            =
+  do { mb_val <- dsLookupMetaEnv x 
+     ; case mb_val of
+	Nothing	         -> do { str <- globalVar x
+			       ; repVarOrCon x str }
+	Just (Bound y)   -> repVarOrCon x (coreVar y)
+	Just (Splice e)  -> do { e' <- dsExpr e
+			       ; return (MkC e') } }
+repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
+
+	-- Remember, we're desugaring renamer output here, so
+	-- HsOverlit can definitely occur
+repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
+repE (HsLam (MatchGroup [m] _)) = repLambda m
+repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
+
+repE (OpApp e1 op fix e2) =
+  do { arg1 <- repLE e1; 
+       arg2 <- repLE e2; 
+       the_op <- repLE op ;
+       repInfixApp arg1 the_op arg2 } 
+repE (NegApp x nm)        = do
+			      a         <- repLE x
+			      negateVar <- lookupOcc negateName >>= repVar
+			      negateVar `repApp` a
+repE (HsPar x)            = repLE x
+repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b } 
+repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b } 
+repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
+				       ; ms2 <- mapM repMatchTup ms
+				       ; repCaseE arg (nonEmptyCoreList ms2) }
+repE (HsIf x y z)         = do
+			      a <- repLE x
+			      b <- repLE y
+			      c <- repLE z
+			      repCond a b c
+repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
+			       ; e2 <- addBinds ss (repLE e)
+			       ; z <- repLetE ds e2
+			       ; wrapGenSyns ss z }
+-- FIXME: I haven't got the types here right yet
+repE (HsDo DoExpr sts body ty) 
+ = do { (ss,zs) <- repLSts sts; 
+	body'	<- addBinds ss $ repLE body;
+	ret	<- repNoBindSt body';	
+        e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
+        wrapGenSyns ss e }
+repE (HsDo ListComp sts body ty) 
+ = do { (ss,zs) <- repLSts sts; 
+	body'	<- addBinds ss $ repLE body;
+	ret	<- repNoBindSt body';	
+        e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
+        wrapGenSyns ss e }
+repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
+repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } 
+repE (ExplicitPArr ty es) = 
+  panic "DsMeta.repE: No explicit parallel arrays yet"
+repE (ExplicitTuple es boxed) 
+  | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
+  | otherwise		  = panic "DsMeta.repE: Can't represent unboxed tuples"
+repE (RecordCon c _ flds)
+ = do { x <- lookupLOcc c;
+        fs <- repFields flds;
+        repRecCon x fs }
+repE (RecordUpd e flds _ _)
+ = do { x <- repLE e;
+        fs <- repFields flds;
+        repRecUpd x fs }
+
+repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
+repE (ArithSeq _ aseq) =
+  case aseq of
+    From e              -> do { ds1 <- repLE e; repFrom ds1 }
+    FromThen e1 e2      -> do 
+		             ds1 <- repLE e1
+			     ds2 <- repLE e2
+			     repFromThen ds1 ds2
+    FromTo   e1 e2      -> do 
+			     ds1 <- repLE e1
+			     ds2 <- repLE e2
+			     repFromTo ds1 ds2
+    FromThenTo e1 e2 e3 -> do 
+			     ds1 <- repLE e1
+			     ds2 <- repLE e2
+			     ds3 <- repLE e3
+			     repFromThenTo ds1 ds2 ds3
+repE (PArrSeq _ aseq)     = panic "DsMeta.repE: parallel array seq.s missing"
+repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
+repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
+repE (HsBracketOut _ _)   = panic "DsMeta.repE: Can't represent Oxford brackets"
+repE (HsSpliceE (HsSplice n _)) 
+  = do { mb_val <- dsLookupMetaEnv n
+       ; case mb_val of
+		 Just (Splice e) -> do { e' <- dsExpr e
+				       ; return (MkC e') }
+		 other	     -> pprPanic "HsSplice" (ppr n) }
+
+repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
+
+-----------------------------------------------------------------------------
+-- Building representations of auxillary structures like Match, Clause, Stmt, 
+
+repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ) 
+repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
+  do { ss1 <- mkGenSyms (collectPatBinders p) 
+     ; addBinds ss1 $ do {
+     ; p1 <- repLP p
+     ; (ss2,ds) <- repBinds wheres
+     ; addBinds ss2 $ do {
+     ; gs    <- repGuards guards
+     ; match <- repMatch p1 gs ds
+     ; wrapGenSyns (ss1++ss2) match }}}
+
+repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
+repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
+  do { ss1 <- mkGenSyms (collectPatsBinders ps) 
+     ; addBinds ss1 $ do {
+       ps1 <- repLPs ps
+     ; (ss2,ds) <- repBinds wheres
+     ; addBinds ss2 $ do {
+       gs <- repGuards guards
+     ; clause <- repClause ps1 gs ds
+     ; wrapGenSyns (ss1++ss2) clause }}}
+
+repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
+repGuards [L _ (GRHS [] e)]
+  = do {a <- repLE e; repNormal a }
+repGuards other 
+  = do { zs <- mapM process other;
+     let {(xs, ys) = unzip zs};
+	 gd <- repGuarded (nonEmptyCoreList ys);
+     wrapGenSyns (concat xs) gd }
+  where 
+    process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+    process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
+           = do { x <- repLNormalGE e1 e2;
+                  return ([], x) }
+    process (L _ (GRHS ss rhs))
+           = do (gs, ss') <- repLSts ss
+		rhs' <- addBinds gs $ repLE rhs
+                g <- repPatGE (nonEmptyCoreList ss') rhs'
+                return (gs, g)
+
+repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
+repFields flds = do
+        fnames <- mapM lookupLOcc (map fst flds)
+        es <- mapM repLE (map snd flds)
+        fs <- zipWithM repFieldExp fnames es
+        coreList fieldExpQTyConName fs
+
+
+-----------------------------------------------------------------------------
+-- Representing Stmt's is tricky, especially if bound variables
+-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
+-- First gensym new names for every variable in any of the patterns.
+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
+-- if variables didn't shaddow, the static gensym wouldn't be necessary
+-- and we could reuse the original names (x and x).
+--
+-- do { x'1 <- gensym "x"
+--    ; x'2 <- gensym "x"   
+--    ; doE [ BindSt (pvar x'1) [| f 1 |]
+--          , BindSt (pvar x'2) [| f x |] 
+--          , NoBindSt [| g x |] 
+--          ]
+--    }
+
+-- The strategy is to translate a whole list of do-bindings by building a
+-- bigger environment, and a bigger set of meta bindings 
+-- (like:  x'1 <- gensym "x" ) and then combining these with the translations
+-- of the expressions within the Do
+      
+-----------------------------------------------------------------------------
+-- The helper function repSts computes the translation of each sub expression
+-- and a bunch of prefix bindings denoting the dynamic renaming.
+
+repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repLSts stmts = repSts (map unLoc stmts)
+
+repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repSts (BindStmt p e _ _ : ss) =
+   do { e2 <- repLE e 
+      ; ss1 <- mkGenSyms (collectPatBinders p) 
+      ; addBinds ss1 $ do {
+      ; p1 <- repLP p; 
+      ; (ss2,zs) <- repSts ss
+      ; z <- repBindSt p1 e2
+      ; return (ss1++ss2, z : zs) }}
+repSts (LetStmt bs : ss) =
+   do { (ss1,ds) <- repBinds bs
+      ; z <- repLetSt ds
+      ; (ss2,zs) <- addBinds ss1 (repSts ss)
+      ; return (ss1++ss2, z : zs) } 
+repSts (ExprStmt e _ _ : ss) =       
+   do { e2 <- repLE e
+      ; z <- repNoBindSt e2 
+      ; (ss2,zs) <- repSts ss
+      ; return (ss2, z : zs) }
+repSts [] = return ([],[])
+repSts other = panic "Exotic Stmt in meta brackets"      
+
+
+-----------------------------------------------------------
+--			Bindings
+-----------------------------------------------------------
+
+repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) 
+repBinds EmptyLocalBinds
+  = do	{ core_list <- coreList decQTyConName []
+	; return ([], core_list) }
+
+repBinds (HsIPBinds _)
+  = panic "DsMeta:repBinds: can't do implicit parameters"
+
+repBinds (HsValBinds decs)
+ = do	{ let { bndrs = map unLoc (collectHsValBinders decs) }
+		-- No need to worrry about detailed scopes within
+		-- the binding group, because we are talking Names
+		-- here, so we can safely treat it as a mutually 
+		-- recursive group
+	; ss        <- mkGenSyms bndrs
+	; prs       <- addBinds ss (rep_val_binds decs)
+	; core_list <- coreList decQTyConName 
+				(de_loc (sort_by_loc prs))
+	; return (ss, core_list) }
+
+rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
+-- Assumes: all the binders of the binding are alrady in the meta-env
+rep_val_binds (ValBindsOut binds sigs)
+ = do { core1 <- rep_binds' (unionManyBags (map snd binds))
+      ;	core2 <- rep_sigs' sigs
+      ;	return (core1 ++ core2) }
+
+rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
+rep_binds binds = do { binds_w_locs <- rep_binds' binds
+		     ; return (de_loc (sort_by_loc binds_w_locs)) }
+
+rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_binds' binds = mapM rep_bind (bagToList binds)
+
+rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
+-- Assumes: all the binders of the binding are alrady in the meta-env
+
+-- Note GHC treats declarations of a variable (not a pattern) 
+-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match 
+-- with an empty list of patterns
+rep_bind (L loc (FunBind { fun_id = fn, 
+			   fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
+ = do { (ss,wherecore) <- repBinds wheres
+	; guardcore <- addBinds ss (repGuards guards)
+	; fn'  <- lookupLBinder fn
+	; p    <- repPvar fn'
+	; ans  <- repVal p guardcore wherecore
+	; ans' <- wrapGenSyns ss ans
+	; return (loc, ans') }
+
+rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
+ =   do { ms1 <- mapM repClauseTup ms
+	; fn' <- lookupLBinder fn
+        ; ans <- repFun fn' (nonEmptyCoreList ms1)
+        ; return (loc, ans) }
+
+rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
+ =   do { patcore <- repLP pat 
+        ; (ss,wherecore) <- repBinds wheres
+	; guardcore <- addBinds ss (repGuards guards)
+        ; ans  <- repVal patcore guardcore wherecore
+	; ans' <- wrapGenSyns ss ans
+        ; return (loc, ans') }
+
+rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
+ =   do { v' <- lookupBinder v 
+	; e2 <- repLE e
+        ; x <- repNormal e2
+        ; patcore <- repPvar v'
+	; empty_decls <- coreList decQTyConName [] 
+        ; ans <- repVal patcore x empty_decls
+        ; return (srcLocSpan (getSrcLoc v), ans) }
+
+-----------------------------------------------------------------------------
+-- Since everything in a Bind is mutually recursive we need rename all
+-- all the variables simultaneously. For example: 
+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
+-- do { f'1 <- gensym "f"
+--    ; g'2 <- gensym "g"
+--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
+--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
+--      ]}
+-- This requires collecting the bindings (f'1 <- gensym "f"), and the 
+-- environment ( f |-> f'1 ) from each binding, and then unioning them 
+-- together. As we do this we collect GenSymBinds's which represent the renamed 
+-- variables bound by the Bindings. In order not to lose track of these 
+-- representations we build a shadow datatype MB with the same structure as 
+-- MonoBinds, but which has slots for the representations
+
+
+-----------------------------------------------------------------------------
+-- GHC allows a more general form of lambda abstraction than specified
+-- by Haskell 98. In particular it allows guarded lambda's like : 
+-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
+-- (\ p1 .. pn -> exp) by causing an error.  
+
+repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
+ = do { let bndrs = collectPatsBinders ps ;
+      ; ss  <- mkGenSyms bndrs
+      ; lam <- addBinds ss (
+		do { xs <- repLPs ps; body <- repLE e; repLam xs body })
+      ; wrapGenSyns ss lam }
+
+repLambda z = panic "Can't represent a guarded lambda in Template Haskell"  
+
+  
+-----------------------------------------------------------------------------
+--			Patterns
+-- repP deals with patterns.  It assumes that we have already
+-- walked over the pattern(s) once to collect the binders, and 
+-- have extended the environment.  So every pattern-bound 
+-- variable should already appear in the environment.
+
+-- Process a list of patterns
+repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
+repLPs ps = do { ps' <- mapM repLP ps ;
+		 coreList patQTyConName ps' }
+
+repLP :: LPat Name -> DsM (Core TH.PatQ)
+repLP (L _ p) = repP p
+
+repP :: Pat Name -> DsM (Core TH.PatQ)
+repP (WildPat _)       = repPwild 
+repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
+repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
+repP (ParPat p)        = repLP p 
+repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
+repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
+repP (ConPatIn dc details)
+ = do { con_str <- lookupLOcc dc
+      ; case details of
+         PrefixCon ps   -> do { qs <- repLPs ps; repPcon con_str qs }
+         RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
+                            ; ps <- sequence $ map repLP (map snd pairs)
+                            ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
+                            ; fps' <- coreList fieldPatQTyConName fps
+                            ; repPrec con_str fps' }
+         InfixCon p1 p2 -> do { p1' <- repLP p1;
+                                p2' <- repLP p2;
+                                repPinfix p1' con_str p2' }
+   }
+repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
+repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
+repP (SigPatIn p t)  = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
+repP other = panic "Exotic pattern inside meta brackets"
+
+----------------------------------------------------------
+-- Declaration ordering helpers
+
+sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
+sort_by_loc xs = sortBy comp xs
+    where comp x y = compare (fst x) (fst y)
+
+de_loc :: [(a, b)] -> [b]
+de_loc = map snd
+
+----------------------------------------------------------
+--	The meta-environment
+
+-- A name/identifier association for fresh names of locally bound entities
+type GenSymBind = (Name, Id)	-- Gensym the string and bind it to the Id
+				-- I.e.		(x, x_id) means
+				--	let x_id = gensym "x" in ...
+
+-- Generate a fresh name for a locally bound entity
+
+mkGenSyms :: [Name] -> DsM [GenSymBind]
+-- We can use the existing name.  For example:
+--	[| \x_77 -> x_77 + x_77 |]
+-- desugars to
+--	do { x_77 <- genSym "x"; .... }
+-- We use the same x_77 in the desugared program, but with the type Bndr
+-- instead of Int
+--
+-- We do make it an Internal name, though (hence localiseName)
+--
+-- Nevertheless, it's monadic because we have to generate nameTy
+mkGenSyms ns = do { var_ty <- lookupType nameTyConName
+		  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
+
+	     
+addBinds :: [GenSymBind] -> DsM a -> DsM a
+-- Add a list of fresh names for locally bound entities to the 
+-- meta environment (which is part of the state carried around 
+-- by the desugarer monad) 
+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
+
+-- Look up a locally bound name
+--
+lookupLBinder :: Located Name -> DsM (Core TH.Name)
+lookupLBinder (L _ n) = lookupBinder n
+
+lookupBinder :: Name -> DsM (Core TH.Name)
+lookupBinder n 
+  = do { mb_val <- dsLookupMetaEnv n;
+	 case mb_val of
+	    Just (Bound x) -> return (coreVar x)
+	    other	   -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
+
+-- Look up a name that is either locally bound or a global name
+--
+--  * If it is a global name, generate the "original name" representation (ie,
+--   the <module>:<name> form) for the associated entity
+--
+lookupLOcc :: Located Name -> DsM (Core TH.Name)
+-- Lookup an occurrence; it can't be a splice.
+-- Use the in-scope bindings if they exist
+lookupLOcc (L _ n) = lookupOcc n
+
+lookupOcc :: Name -> DsM (Core TH.Name)
+lookupOcc n
+  = do {  mb_val <- dsLookupMetaEnv n ;
+          case mb_val of
+		Nothing         -> globalVar n
+		Just (Bound x)  -> return (coreVar x)
+		Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) 
+    }
+
+globalVar :: Name -> DsM (Core TH.Name)
+-- Not bound by the meta-env
+-- Could be top-level; or could be local
+--	f x = $(g [| x |])
+-- Here the x will be local
+globalVar name
+  | isExternalName name
+  = do	{ MkC mod <- coreStringLit name_mod
+	; MkC occ <- occNameLit name
+	; rep2 mk_varg [mod,occ] }
+  | otherwise
+  = do 	{ MkC occ <- occNameLit name
+	; MkC uni <- coreIntLit (getKey (getUnique name))
+	; rep2 mkNameLName [occ,uni] }
+  where
+      name_mod = moduleString (nameModule name)
+      name_occ = nameOccName name
+      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
+	      | OccName.isVarOcc  name_occ = mkNameG_vName
+	      | OccName.isTcOcc   name_occ = mkNameG_tcName
+	      | otherwise 	           = pprPanic "DsMeta.globalVar" (ppr name)
+
+lookupType :: Name 	-- Name of type constructor (e.g. TH.ExpQ)
+	   -> DsM Type	-- The type
+lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
+		          return (mkTyConApp tc []) }
+
+wrapGenSyns :: [GenSymBind] 
+	    -> Core (TH.Q a) -> DsM (Core (TH.Q a))
+-- wrapGenSyns [(nm1,id1), (nm2,id2)] y 
+--	--> bindQ (gensym nm1) (\ id1 -> 
+--	    bindQ (gensym nm2 (\ id2 -> 
+--	    y))
+
+wrapGenSyns binds body@(MkC b)
+  = do  { var_ty <- lookupType nameTyConName
+	; go var_ty binds }
+  where
+    [elt_ty] = tcTyConAppArgs (exprType b) 
+	-- b :: Q a, so we can get the type 'a' by looking at the
+	-- argument type. NB: this relies on Q being a data/newtype,
+	-- not a type synonym
+
+    go var_ty [] = return body
+    go var_ty ((name,id) : binds)
+      = do { MkC body'  <- go var_ty binds
+	   ; lit_str    <- occNameLit name
+	   ; gensym_app <- repGensym lit_str
+	   ; repBindQ var_ty elt_ty 
+		      gensym_app (MkC (Lam id body')) }
+
+-- Just like wrapGenSym, but don't actually do the gensym
+-- Instead use the existing name:
+--	let x = "x" in ...
+-- Only used for [Decl], and for the class ops in class 
+-- and instance decls
+wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
+wrapNongenSyms binds (MkC body)
+  = do { binds' <- mapM do_one binds ;
+	 return (MkC (mkLets binds' body)) }
+  where
+    do_one (name,id) 
+	= do { MkC lit_str <- occNameLit name
+	     ; MkC var <- rep2 mkNameName [lit_str]
+	     ; return (NonRec id var) }
+
+occNameLit :: Name -> DsM (Core String)
+occNameLit n = coreStringLit (occNameString (nameOccName n))
+
+
+-- %*********************************************************************
+-- %*									*
+--		Constructing code
+-- %*									*
+-- %*********************************************************************
+
+-----------------------------------------------------------------------------
+-- PHANTOM TYPES for consistency. In order to make sure we do this correct 
+-- we invent a new datatype which uses phantom types.
+
+newtype Core a = MkC CoreExpr
+unC (MkC x) = x
+
+rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
+rep2 n xs = do { id <- dsLookupGlobalId n
+               ; return (MkC (foldl App (Var id) xs)) }
+
+-- Then we make "repConstructors" which use the phantom types for each of the
+-- smart constructors of the Meta.Meta datatypes.
+
+
+-- %*********************************************************************
+-- %*									*
+--		The 'smart constructors'
+-- %*									*
+-- %*********************************************************************
+
+--------------- Patterns -----------------
+repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ) 
+repPlit (MkC l) = rep2 litPName [l]
+
+repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
+repPvar (MkC s) = rep2 varPName [s]
+
+repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPtup (MkC ps) = rep2 tupPName [ps]
+
+repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
+
+repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
+
+repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
+
+repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPtilde (MkC p) = rep2 tildePName [p]
+
+repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
+
+repPwild  :: DsM (Core TH.PatQ)
+repPwild = rep2 wildPName []
+
+repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPlist (MkC ps) = rep2 listPName [ps]
+
+repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
+--------------- Expressions -----------------
+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
+	           | otherwise 		        = repVar str
+
+repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repVar (MkC s) = rep2 varEName [s] 
+
+repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
+repCon (MkC s) = rep2 conEName [s] 
+
+repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
+repLit (MkC c) = rep2 litEName [c] 
+
+repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repApp (MkC x) (MkC y) = rep2 appEName [x,y] 
+
+repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
+
+repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repTup (MkC es) = rep2 tupEName [es]
+
+repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z] 
+
+repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] 
+
+repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
+
+repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repDoE (MkC ss) = rep2 doEName [ss]
+
+repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repComp (MkC ss) = rep2 compEName [ss]
+
+repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repListExp (MkC es) = rep2 listEName [es]
+
+repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
+
+repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
+
+repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
+
+repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
+
+repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+
+repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
+
+repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
+
+------------ Right hand sides (guarded expressions) ----
+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
+repGuarded (MkC pairs) = rep2 guardedBName [pairs]
+
+repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
+repNormal (MkC e) = rep2 normalBName [e]
+
+------------ Guards ----
+repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repLNormalGE g e = do g' <- repLE g
+                      e' <- repLE e
+                      repNormalGE g' e'
+
+repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
+
+repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
+
+------------- Stmts -------------------
+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
+
+repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
+repLetSt (MkC ds) = rep2 letSName [ds]
+
+repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repNoBindSt (MkC e) = rep2 noBindSName [e]
+
+-------------- Range (Arithmetic sequences) -----------
+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFrom (MkC x) = rep2 fromEName [x]
+
+repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
+
+repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
+
+repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
+
+------------ Match and Clause Tuples -----------
+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
+
+repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
+
+-------------- Dec -----------------------------
+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
+
+repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)  
+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
+
+repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
+repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
+    = rep2 dataDName [cxt, nm, tvs, cons, derivs]
+
+repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
+repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
+    = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
+
+repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
+
+repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
+
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
+
+repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
+
+repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
+
+repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
+repCtxt (MkC tys) = rep2 cxtName [tys]
+
+repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
+          -> DsM (Core TH.ConQ)
+repConstr con (PrefixCon ps)
+    = do arg_tys  <- mapM repBangTy ps
+         arg_tys1 <- coreList strictTypeQTyConName arg_tys
+         rep2 normalCName [unC con, unC arg_tys1]
+repConstr con (RecCon ips)
+    = do arg_vs   <- mapM lookupLOcc (map fst ips)
+         arg_tys  <- mapM repBangTy (map snd ips)
+         arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
+                              arg_vs arg_tys
+         arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
+         rep2 recCName [unC con, unC arg_vtys']
+repConstr con (InfixCon st1 st2)
+    = do arg1 <- repBangTy st1
+         arg2 <- repBangTy st2
+         rep2 infixCName [unC arg1, unC con, unC arg2]
+
+------------ Types -------------------
+
+repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTForall (MkC tvars) (MkC ctxt) (MkC ty)
+    = rep2 forallTName [tvars, ctxt, ty]
+
+repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
+repTvar (MkC s) = rep2 varTName [s]
+
+repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
+
+repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTapps f []     = return f
+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
+
+--------- Type constructors --------------
+
+repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repNamedTyCon (MkC s) = rep2 conTName [s]
+
+repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+-- Note: not Core Int; it's easier to be direct here
+repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
+
+repArrowTyCon :: DsM (Core TH.TypeQ)
+repArrowTyCon = rep2 arrowTName []
+
+repListTyCon :: DsM (Core TH.TypeQ)
+repListTyCon = rep2 listTName []
+
+
+----------------------------------------------------------
+--		Literals
+
+repLiteral :: HsLit -> DsM (Core TH.Lit)
+repLiteral lit 
+  = do lit' <- case lit of
+                   HsIntPrim i    -> mk_integer i
+                   HsInt i        -> mk_integer i
+                   HsFloatPrim r  -> mk_rational r
+                   HsDoublePrim r -> mk_rational r
+                   _ -> return lit
+       lit_expr <- dsLit lit'
+       rep2 lit_name [lit_expr]
+  where
+    lit_name = case lit of
+		 HsInteger _ _  -> integerLName
+		 HsInt     _    -> integerLName
+		 HsIntPrim _    -> intPrimLName
+		 HsFloatPrim _  -> floatPrimLName
+		 HsDoublePrim _ -> doublePrimLName
+		 HsChar _       -> charLName
+		 HsString _     -> stringLName
+		 HsRat _ _      -> rationalLName
+		 other 	        -> uh_oh
+    uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
+		    (ppr lit)
+
+mk_integer  i = do integer_ty <- lookupType integerTyConName
+                   return $ HsInteger i integer_ty
+mk_rational r = do rat_ty <- lookupType rationalTyConName
+                   return $ HsRat r rat_ty
+
+repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
+repOverloadedLiteral (HsIntegral i _)   = do { lit <- mk_integer  i; repLiteral lit }
+repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
+	-- The type Rational will be in the environment, becuase 
+	-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
+	-- and rationalL is sucked in when any TH stuff is used
+              
+--------------- Miscellaneous -------------------
+
+repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
+repGensym (MkC lit_str) = rep2 newNameName [lit_str]
+
+repBindQ :: Type -> Type	-- a and b
+	 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
+repBindQ ty_a ty_b (MkC x) (MkC y) 
+  = rep2 bindQName [Type ty_a, Type ty_b, x, y] 
+
+repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
+repSequenceQ ty_a (MkC list)
+  = rep2 sequenceQName [Type ty_a, list]
+
+------------ Lists and Tuples -------------------
+-- turn a list of patterns into a single pattern matching a list
+
+coreList :: Name	-- Of the TyCon of the element type
+	 -> [Core a] -> DsM (Core [a])
+coreList tc_name es 
+  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
+
+coreList' :: Type 	-- The element type
+	  -> [Core a] -> Core [a]
+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
+
+nonEmptyCoreList :: [Core a] -> Core [a]
+  -- The list must be non-empty so we can get the element type
+  -- Otherwise use coreList
+nonEmptyCoreList [] 	      = panic "coreList: empty argument"
+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
+
+corePair :: (Core a, Core b) -> Core (a,b)
+corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
+
+coreStringLit :: String -> DsM (Core String)
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
+
+coreIntLit :: Int -> DsM (Core Int)
+coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
+
+coreVar :: Id -> Core TH.Name	-- The Id has type Name
+coreVar id = MkC (Var id)
+
+
+
+-- %************************************************************************
+-- %*									*
+--		The known-key names for Template Haskell
+-- %*									*
+-- %************************************************************************
+
+-- To add a name, do three things
+-- 
+--  1) Allocate a key
+--  2) Make a "Name"
+--  3) Add the name to knownKeyNames
+
+templateHaskellNames :: [Name]
+-- The names that are implicitly mentioned by ``bracket''
+-- Should stay in sync with the import list of DsMeta
+
+templateHaskellNames = [
+    returnQName, bindQName, sequenceQName, newNameName, liftName,
+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, 
+
+    -- Lit
+    charLName, stringLName, integerLName, intPrimLName,
+    floatPrimLName, doublePrimLName, rationalLName,
+    -- Pat
+    litPName, varPName, tupPName, conPName, tildePName, infixPName,
+    asPName, wildPName, recPName, listPName, sigPName,
+    -- FieldPat
+    fieldPatName,
+    -- Match
+    matchName,
+    -- Clause
+    clauseName,
+    -- Exp
+    varEName, conEName, litEName, appEName, infixEName,
+    infixAppName, sectionLName, sectionRName, lamEName, tupEName,
+    condEName, letEName, caseEName, doEName, compEName,
+    fromEName, fromThenEName, fromToEName, fromThenToEName,
+    listEName, sigEName, recConEName, recUpdEName,
+    -- FieldExp
+    fieldExpName,
+    -- Body
+    guardedBName, normalBName,
+    -- Guard
+    normalGEName, patGEName,
+    -- Stmt
+    bindSName, letSName, noBindSName, parSName,
+    -- Dec
+    funDName, valDName, dataDName, newtypeDName, tySynDName,
+    classDName, instanceDName, sigDName, forImpDName,
+    -- Cxt
+    cxtName,
+    -- Strict
+    isStrictName, notStrictName,
+    -- Con
+    normalCName, recCName, infixCName, forallCName,
+    -- StrictType
+    strictTypeName,
+    -- VarStrictType
+    varStrictTypeName,
+    -- Type
+    forallTName, varTName, conTName, appTName,
+    tupleTName, arrowTName, listTName,
+    -- Callconv
+    cCallName, stdCallName,
+    -- Safety
+    unsafeName,
+    safeName,
+    threadsafeName,
+    -- FunDep
+    funDepName,
+
+    -- And the tycons
+    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
+    clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
+    decQTyConName, conQTyConName, strictTypeQTyConName,
+    varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
+    typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
+    fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
+
+thSyn :: Module
+thSyn = mkModule "Language.Haskell.TH.Syntax"
+thLib = mkModule "Language.Haskell.TH.Lib"
+
+mk_known_key_name mod space str uniq 
+  = mkExternalName uniq mod (mkOccNameFS space str) 
+	           Nothing noSrcLoc
+
+libFun = mk_known_key_name thLib OccName.varName
+libTc  = mk_known_key_name thLib OccName.tcName
+thFun  = mk_known_key_name thSyn OccName.varName
+thTc   = mk_known_key_name thSyn OccName.tcName
+
+-------------------- TH.Syntax -----------------------
+qTyConName        = thTc FSLIT("Q")            qTyConKey
+nameTyConName     = thTc FSLIT("Name")         nameTyConKey
+fieldExpTyConName = thTc FSLIT("FieldExp")     fieldExpTyConKey
+patTyConName      = thTc FSLIT("Pat")          patTyConKey
+fieldPatTyConName = thTc FSLIT("FieldPat")     fieldPatTyConKey
+expTyConName      = thTc FSLIT("Exp")          expTyConKey
+decTyConName      = thTc FSLIT("Dec")          decTyConKey
+typeTyConName     = thTc FSLIT("Type")         typeTyConKey
+matchTyConName    = thTc FSLIT("Match")        matchTyConKey
+clauseTyConName   = thTc FSLIT("Clause")       clauseTyConKey
+funDepTyConName   = thTc FSLIT("FunDep")       funDepTyConKey
+
+returnQName   = thFun FSLIT("returnQ")   returnQIdKey
+bindQName     = thFun FSLIT("bindQ")     bindQIdKey
+sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
+newNameName    = thFun FSLIT("newName")   newNameIdKey
+liftName      = thFun FSLIT("lift")      liftIdKey
+mkNameName     = thFun FSLIT("mkName")     mkNameIdKey
+mkNameG_vName  = thFun FSLIT("mkNameG_v")  mkNameG_vIdKey
+mkNameG_dName  = thFun FSLIT("mkNameG_d")  mkNameG_dIdKey
+mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
+mkNameLName    = thFun FSLIT("mkNameL")    mkNameLIdKey
+
+
+-------------------- TH.Lib -----------------------
+-- data Lit = ...
+charLName       = libFun FSLIT("charL")       charLIdKey
+stringLName     = libFun FSLIT("stringL")     stringLIdKey
+integerLName    = libFun FSLIT("integerL")    integerLIdKey
+intPrimLName    = libFun FSLIT("intPrimL")    intPrimLIdKey
+floatPrimLName  = libFun FSLIT("floatPrimL")  floatPrimLIdKey
+doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
+rationalLName   = libFun FSLIT("rationalL")     rationalLIdKey
+
+-- data Pat = ...
+litPName   = libFun FSLIT("litP")   litPIdKey
+varPName   = libFun FSLIT("varP")   varPIdKey
+tupPName   = libFun FSLIT("tupP")   tupPIdKey
+conPName   = libFun FSLIT("conP")   conPIdKey
+infixPName = libFun FSLIT("infixP") infixPIdKey
+tildePName = libFun FSLIT("tildeP") tildePIdKey
+asPName    = libFun FSLIT("asP")    asPIdKey
+wildPName  = libFun FSLIT("wildP")  wildPIdKey
+recPName   = libFun FSLIT("recP")   recPIdKey
+listPName  = libFun FSLIT("listP")  listPIdKey
+sigPName   = libFun FSLIT("sigP")   sigPIdKey
+
+-- type FieldPat = ...
+fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
+
+-- data Match = ...
+matchName = libFun FSLIT("match") matchIdKey
+
+-- data Clause = ...	 
+clauseName = libFun FSLIT("clause") clauseIdKey
+
+-- data Exp = ...
+varEName        = libFun FSLIT("varE")        varEIdKey
+conEName        = libFun FSLIT("conE")        conEIdKey
+litEName        = libFun FSLIT("litE")        litEIdKey
+appEName        = libFun FSLIT("appE")        appEIdKey
+infixEName      = libFun FSLIT("infixE")      infixEIdKey
+infixAppName    = libFun FSLIT("infixApp")    infixAppIdKey
+sectionLName    = libFun FSLIT("sectionL")    sectionLIdKey
+sectionRName    = libFun FSLIT("sectionR")    sectionRIdKey
+lamEName        = libFun FSLIT("lamE")        lamEIdKey
+tupEName        = libFun FSLIT("tupE")        tupEIdKey
+condEName       = libFun FSLIT("condE")       condEIdKey
+letEName        = libFun FSLIT("letE")        letEIdKey
+caseEName       = libFun FSLIT("caseE")       caseEIdKey
+doEName         = libFun FSLIT("doE")         doEIdKey
+compEName       = libFun FSLIT("compE")       compEIdKey
+-- ArithSeq skips a level
+fromEName       = libFun FSLIT("fromE")       fromEIdKey
+fromThenEName   = libFun FSLIT("fromThenE")   fromThenEIdKey
+fromToEName     = libFun FSLIT("fromToE")     fromToEIdKey
+fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
+-- end ArithSeq
+listEName       = libFun FSLIT("listE")       listEIdKey
+sigEName        = libFun FSLIT("sigE")        sigEIdKey
+recConEName     = libFun FSLIT("recConE")     recConEIdKey
+recUpdEName     = libFun FSLIT("recUpdE")     recUpdEIdKey
+
+-- type FieldExp = ...
+fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
+
+-- data Body = ...
+guardedBName = libFun FSLIT("guardedB") guardedBIdKey
+normalBName  = libFun FSLIT("normalB")  normalBIdKey
+
+-- data Guard = ...
+normalGEName = libFun FSLIT("normalGE") normalGEIdKey
+patGEName    = libFun FSLIT("patGE")    patGEIdKey
+
+-- data Stmt = ...
+bindSName   = libFun FSLIT("bindS")   bindSIdKey
+letSName    = libFun FSLIT("letS")    letSIdKey
+noBindSName = libFun FSLIT("noBindS") noBindSIdKey
+parSName    = libFun FSLIT("parS")    parSIdKey
+
+-- data Dec = ...
+funDName      = libFun FSLIT("funD")      funDIdKey
+valDName      = libFun FSLIT("valD")      valDIdKey
+dataDName     = libFun FSLIT("dataD")     dataDIdKey
+newtypeDName  = libFun FSLIT("newtypeD")  newtypeDIdKey
+tySynDName    = libFun FSLIT("tySynD")    tySynDIdKey
+classDName    = libFun FSLIT("classD")    classDIdKey
+instanceDName = libFun FSLIT("instanceD") instanceDIdKey
+sigDName      = libFun FSLIT("sigD")      sigDIdKey
+forImpDName   = libFun FSLIT("forImpD")   forImpDIdKey
+
+-- type Ctxt = ...
+cxtName = libFun FSLIT("cxt") cxtIdKey
+
+-- data Strict = ...
+isStrictName      = libFun  FSLIT("isStrict")      isStrictKey
+notStrictName     = libFun  FSLIT("notStrict")     notStrictKey
+
+-- data Con = ...	 
+normalCName = libFun FSLIT("normalC") normalCIdKey
+recCName    = libFun FSLIT("recC")    recCIdKey
+infixCName  = libFun FSLIT("infixC")  infixCIdKey
+forallCName  = libFun FSLIT("forallC")  forallCIdKey
+			 
+-- type StrictType = ...
+strictTypeName    = libFun  FSLIT("strictType")    strictTKey
+
+-- type VarStrictType = ...
+varStrictTypeName = libFun  FSLIT("varStrictType") varStrictTKey
+
+-- data Type = ...
+forallTName = libFun FSLIT("forallT") forallTIdKey
+varTName    = libFun FSLIT("varT")    varTIdKey
+conTName    = libFun FSLIT("conT")    conTIdKey
+tupleTName  = libFun FSLIT("tupleT") tupleTIdKey
+arrowTName  = libFun FSLIT("arrowT") arrowTIdKey
+listTName   = libFun FSLIT("listT")  listTIdKey
+appTName    = libFun FSLIT("appT")    appTIdKey
+			 
+-- data Callconv = ...
+cCallName = libFun FSLIT("cCall") cCallIdKey
+stdCallName = libFun FSLIT("stdCall") stdCallIdKey
+
+-- data Safety = ...
+unsafeName     = libFun FSLIT("unsafe") unsafeIdKey
+safeName       = libFun FSLIT("safe") safeIdKey
+threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
+             
+-- data FunDep = ...
+funDepName     = libFun FSLIT("funDep") funDepIdKey
+
+matchQTyConName         = libTc FSLIT("MatchQ")        matchQTyConKey
+clauseQTyConName        = libTc FSLIT("ClauseQ")       clauseQTyConKey
+expQTyConName           = libTc FSLIT("ExpQ")          expQTyConKey
+stmtQTyConName          = libTc FSLIT("StmtQ")         stmtQTyConKey
+decQTyConName           = libTc FSLIT("DecQ")          decQTyConKey
+conQTyConName           = libTc FSLIT("ConQ")          conQTyConKey
+strictTypeQTyConName    = libTc FSLIT("StrictTypeQ")    strictTypeQTyConKey
+varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
+typeQTyConName          = libTc FSLIT("TypeQ")          typeQTyConKey
+fieldExpQTyConName      = libTc FSLIT("FieldExpQ")      fieldExpQTyConKey
+patQTyConName           = libTc FSLIT("PatQ")           patQTyConKey
+fieldPatQTyConName      = libTc FSLIT("FieldPatQ")      fieldPatQTyConKey
+
+--	TyConUniques available: 100-129
+-- 	Check in PrelNames if you want to change this
+
+expTyConKey             = mkPreludeTyConUnique 100
+matchTyConKey           = mkPreludeTyConUnique 101
+clauseTyConKey          = mkPreludeTyConUnique 102
+qTyConKey               = mkPreludeTyConUnique 103
+expQTyConKey            = mkPreludeTyConUnique 104
+decQTyConKey            = mkPreludeTyConUnique 105
+patTyConKey             = mkPreludeTyConUnique 106
+matchQTyConKey          = mkPreludeTyConUnique 107
+clauseQTyConKey         = mkPreludeTyConUnique 108
+stmtQTyConKey           = mkPreludeTyConUnique 109
+conQTyConKey            = mkPreludeTyConUnique 110
+typeQTyConKey           = mkPreludeTyConUnique 111
+typeTyConKey            = mkPreludeTyConUnique 112
+decTyConKey             = mkPreludeTyConUnique 113
+varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
+strictTypeQTyConKey     = mkPreludeTyConUnique 115
+fieldExpTyConKey        = mkPreludeTyConUnique 116
+fieldPatTyConKey        = mkPreludeTyConUnique 117
+nameTyConKey            = mkPreludeTyConUnique 118
+patQTyConKey            = mkPreludeTyConUnique 119
+fieldPatQTyConKey       = mkPreludeTyConUnique 120
+fieldExpQTyConKey       = mkPreludeTyConUnique 121
+funDepTyConKey          = mkPreludeTyConUnique 122
+
+-- 	IdUniques available: 200-399
+-- 	If you want to change this, make sure you check in PrelNames
+
+returnQIdKey        = mkPreludeMiscIdUnique 200
+bindQIdKey          = mkPreludeMiscIdUnique 201
+sequenceQIdKey      = mkPreludeMiscIdUnique 202
+liftIdKey           = mkPreludeMiscIdUnique 203
+newNameIdKey         = mkPreludeMiscIdUnique 204
+mkNameIdKey          = mkPreludeMiscIdUnique 205
+mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
+mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
+mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
+mkNameLIdKey         = mkPreludeMiscIdUnique 209
+
+
+-- data Lit = ...
+charLIdKey        = mkPreludeMiscIdUnique 210
+stringLIdKey      = mkPreludeMiscIdUnique 211
+integerLIdKey     = mkPreludeMiscIdUnique 212
+intPrimLIdKey     = mkPreludeMiscIdUnique 213
+floatPrimLIdKey   = mkPreludeMiscIdUnique 214
+doublePrimLIdKey  = mkPreludeMiscIdUnique 215
+rationalLIdKey    = mkPreludeMiscIdUnique 216
+
+-- data Pat = ...
+litPIdKey         = mkPreludeMiscIdUnique 220
+varPIdKey         = mkPreludeMiscIdUnique 221
+tupPIdKey         = mkPreludeMiscIdUnique 222
+conPIdKey         = mkPreludeMiscIdUnique 223
+infixPIdKey       = mkPreludeMiscIdUnique 312
+tildePIdKey       = mkPreludeMiscIdUnique 224
+asPIdKey          = mkPreludeMiscIdUnique 225
+wildPIdKey        = mkPreludeMiscIdUnique 226
+recPIdKey         = mkPreludeMiscIdUnique 227
+listPIdKey        = mkPreludeMiscIdUnique 228
+sigPIdKey         = mkPreludeMiscIdUnique 229
+
+-- type FieldPat = ...
+fieldPatIdKey       = mkPreludeMiscIdUnique 230
+
+-- data Match = ...
+matchIdKey          = mkPreludeMiscIdUnique 231
+
+-- data Clause = ...
+clauseIdKey         = mkPreludeMiscIdUnique 232
+
+-- data Exp = ...
+varEIdKey         = mkPreludeMiscIdUnique 240
+conEIdKey         = mkPreludeMiscIdUnique 241
+litEIdKey         = mkPreludeMiscIdUnique 242
+appEIdKey         = mkPreludeMiscIdUnique 243
+infixEIdKey       = mkPreludeMiscIdUnique 244
+infixAppIdKey       = mkPreludeMiscIdUnique 245
+sectionLIdKey       = mkPreludeMiscIdUnique 246
+sectionRIdKey       = mkPreludeMiscIdUnique 247
+lamEIdKey         = mkPreludeMiscIdUnique 248
+tupEIdKey         = mkPreludeMiscIdUnique 249
+condEIdKey        = mkPreludeMiscIdUnique 250
+letEIdKey         = mkPreludeMiscIdUnique 251
+caseEIdKey        = mkPreludeMiscIdUnique 252
+doEIdKey          = mkPreludeMiscIdUnique 253
+compEIdKey        = mkPreludeMiscIdUnique 254
+fromEIdKey        = mkPreludeMiscIdUnique 255
+fromThenEIdKey    = mkPreludeMiscIdUnique 256
+fromToEIdKey      = mkPreludeMiscIdUnique 257
+fromThenToEIdKey  = mkPreludeMiscIdUnique 258
+listEIdKey        = mkPreludeMiscIdUnique 259
+sigEIdKey         = mkPreludeMiscIdUnique 260
+recConEIdKey      = mkPreludeMiscIdUnique 261
+recUpdEIdKey      = mkPreludeMiscIdUnique 262
+
+-- type FieldExp = ...
+fieldExpIdKey       = mkPreludeMiscIdUnique 265
+
+-- data Body = ...
+guardedBIdKey     = mkPreludeMiscIdUnique 266
+normalBIdKey      = mkPreludeMiscIdUnique 267
+
+-- data Guard = ...
+normalGEIdKey     = mkPreludeMiscIdUnique 310
+patGEIdKey        = mkPreludeMiscIdUnique 311
+
+-- data Stmt = ...
+bindSIdKey       = mkPreludeMiscIdUnique 268
+letSIdKey        = mkPreludeMiscIdUnique 269
+noBindSIdKey     = mkPreludeMiscIdUnique 270
+parSIdKey        = mkPreludeMiscIdUnique 271
+
+-- data Dec = ...
+funDIdKey         = mkPreludeMiscIdUnique 272
+valDIdKey         = mkPreludeMiscIdUnique 273
+dataDIdKey        = mkPreludeMiscIdUnique 274
+newtypeDIdKey     = mkPreludeMiscIdUnique 275
+tySynDIdKey       = mkPreludeMiscIdUnique 276
+classDIdKey       = mkPreludeMiscIdUnique 277
+instanceDIdKey    = mkPreludeMiscIdUnique 278
+sigDIdKey         = mkPreludeMiscIdUnique 279
+forImpDIdKey      = mkPreludeMiscIdUnique 297
+
+-- type Cxt = ...
+cxtIdKey            = mkPreludeMiscIdUnique 280
+
+-- data Strict = ...
+isStrictKey         = mkPreludeMiscIdUnique 281
+notStrictKey        = mkPreludeMiscIdUnique 282
+
+-- data Con = ...
+normalCIdKey      = mkPreludeMiscIdUnique 283
+recCIdKey         = mkPreludeMiscIdUnique 284
+infixCIdKey       = mkPreludeMiscIdUnique 285
+forallCIdKey      = mkPreludeMiscIdUnique 288
+
+-- type StrictType = ...
+strictTKey        = mkPreludeMiscIdUnique 286
+
+-- type VarStrictType = ...
+varStrictTKey     = mkPreludeMiscIdUnique 287
+
+-- data Type = ...
+forallTIdKey      = mkPreludeMiscIdUnique 290
+varTIdKey         = mkPreludeMiscIdUnique 291
+conTIdKey         = mkPreludeMiscIdUnique 292
+tupleTIdKey       = mkPreludeMiscIdUnique 294
+arrowTIdKey       = mkPreludeMiscIdUnique 295
+listTIdKey        = mkPreludeMiscIdUnique 296
+appTIdKey         = mkPreludeMiscIdUnique 293
+
+-- data Callconv = ...
+cCallIdKey      = mkPreludeMiscIdUnique 300
+stdCallIdKey    = mkPreludeMiscIdUnique 301
+
+-- data Safety = ...
+unsafeIdKey     = mkPreludeMiscIdUnique 305
+safeIdKey       = mkPreludeMiscIdUnique 306
+threadsafeIdKey = mkPreludeMiscIdUnique 307
+
+-- data FunDep = ...
+funDepIdKey = mkPreludeMiscIdUnique 320
+
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
new file mode 100644
index 0000000000..f24dee4905
--- /dev/null
+++ b/compiler/deSugar/DsMonad.lhs
@@ -0,0 +1,285 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsMonad]{@DsMonad@: monadery used in desugaring}
+
+\begin{code}
+module DsMonad (
+	DsM, mappM, mapAndUnzipM,
+	initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, 
+	foldlDs, foldrDs,
+
+	newTyVarsDs, newLocalName,
+	duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
+	newFailLocalDs,
+	getSrcSpanDs, putSrcSpanDs,
+	getModuleDs,
+	newUnique, 
+	UniqSupply, newUniqueSupply,
+	getDOptsDs,
+	dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
+
+	DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
+
+	-- Warnings
+	DsWarning, dsWarn, 
+
+	-- Data types
+	DsMatchContext(..),
+	EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
+	CanItFail(..), orFail
+    ) where
+
+#include "HsVersions.h"
+
+import TcRnMonad
+import CoreSyn		( CoreExpr )
+import HsSyn		( HsExpr, HsMatchContext, Pat )
+import TcIface		( tcIfaceGlobal )
+import RdrName		( GlobalRdrEnv )
+import HscTypes		( TyThing(..), TypeEnv, HscEnv, 
+			  tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope )
+import Bag		( emptyBag, snocBag, Bag )
+import DataCon		( DataCon )
+import TyCon		( TyCon )
+import Id		( mkSysLocal, setIdUnique, Id )
+import Module		( Module )
+import Var		( TyVar, setTyVarUnique )
+import Outputable
+import SrcLoc		( noSrcSpan, SrcSpan )
+import Type             ( Type )
+import UniqSupply	( UniqSupply, uniqsFromSupply )
+import Name		( Name, nameOccName )
+import NameEnv
+import OccName          ( occNameFS )
+import DynFlags	( DynFlags )
+import ErrUtils		( WarnMsg, mkWarnMsg )
+import Bag		( mapBag )
+
+import DATA_IOREF	( newIORef, readIORef )
+
+infixr 9 `thenDs`
+\end{code}
+
+%************************************************************************
+%*									*
+		Data types for the desugarer
+%*									*
+%************************************************************************
+
+\begin{code}
+data DsMatchContext
+  = DsMatchContext (HsMatchContext Name) SrcSpan
+  | NoMatchContext
+  deriving ()
+
+data EquationInfo
+  = EqnInfo { eqn_wrap :: DsWrapper,	-- Bindings
+	      eqn_pats :: [Pat Id],    	-- The patterns for an eqn
+	      eqn_rhs  :: MatchResult }	-- What to do after match
+
+type DsWrapper = CoreExpr -> CoreExpr
+idWrapper e = e
+
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+--	\fail. wrap (case vs of { pats -> rhs fail })
+-- where vs are not bound by wrap
+
+
+-- A MatchResult is an expression with a hole in it
+data MatchResult
+  = MatchResult
+	CanItFail	-- Tells whether the failure expression is used
+	(CoreExpr -> DsM CoreExpr)
+			-- Takes a expression to plug in at the
+			-- failure point(s). The expression should
+			-- be duplicatable!
+
+data CanItFail = CanFail | CantFail
+
+orFail CantFail CantFail = CantFail
+orFail _        _	 = CanFail
+\end{code}
+
+
+%************************************************************************
+%*									*
+		Monad stuff
+%*									*
+%************************************************************************
+
+Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
+a @UniqueSupply@ and some annotations, which
+presumably include source-file location information:
+\begin{code}
+type DsM result = TcRnIf DsGblEnv DsLclEnv result
+
+-- Compatibility functions
+fixDs    = fixM
+thenDs   = thenM
+returnDs = returnM
+listDs   = sequenceM
+foldlDs  = foldlM
+foldrDs  = foldrM
+mapAndUnzipDs = mapAndUnzipM
+
+
+type DsWarning = (SrcSpan, SDoc)
+	-- Not quite the same as a WarnMsg, we have an SDoc here 
+	-- and we'll do the print_unqual stuff later on to turn it
+	-- into a Doc.
+
+data DsGblEnv = DsGblEnv {
+	ds_mod	   :: Module,       		-- For SCC profiling
+	ds_warns   :: IORef (Bag DsWarning),	-- Warning messages
+	ds_if_env  :: (IfGblEnv, IfLclEnv)	-- Used for looking up global, 
+						-- possibly-imported things
+    }
+
+data DsLclEnv = DsLclEnv {
+	ds_meta	   :: DsMetaEnv,	-- Template Haskell bindings
+	ds_loc	   :: SrcSpan		-- to put in pattern-matching error msgs
+     }
+
+-- Inside [| |] brackets, the desugarer looks 
+-- up variables in the DsMetaEnv
+type DsMetaEnv = NameEnv DsMetaVal
+
+data DsMetaVal
+   = Bound Id		-- Bound by a pattern inside the [| |]. 
+			-- Will be dynamically alpha renamed.
+			-- The Id has type THSyntax.Var
+
+   | Splice (HsExpr Id)	-- These bindings are introduced by
+			-- the PendingSplices on a HsBracketOut
+
+-- initDs returns the UniqSupply out the end (not just the result)
+
+initDs  :: HscEnv
+	-> Module -> GlobalRdrEnv -> TypeEnv
+	-> DsM a
+	-> IO (a, Bag WarnMsg)
+
+initDs hsc_env mod rdr_env type_env thing_inside
+  = do 	{ warn_var <- newIORef emptyBag
+	; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+	      ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
+	      ; gbl_env = DsGblEnv { ds_mod = mod, 
+				     ds_if_env = (if_genv, if_lenv),
+				     ds_warns = warn_var }
+	      ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, 
+				     ds_loc = noSrcSpan } }
+
+	; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
+
+	; warns <- readIORef warn_var
+	; return (res, mapBag mk_warn warns)
+	}
+   where
+    print_unqual = unQualInScope rdr_env
+
+    mk_warn :: (SrcSpan,SDoc) -> WarnMsg
+    mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
+\end{code}
+
+%************************************************************************
+%*									*
+		Operations in the monad
+%*									*
+%************************************************************************
+
+And all this mysterious stuff is so we can occasionally reach out and
+grab one or more names.  @newLocalDs@ isn't exported---exported
+functions are defined with it.  The difference in name-strings makes
+it easier to read debugging output.
+
+\begin{code}
+-- Make a new Id with the same print name, but different type, and new unique
+newUniqueId :: Name -> Type -> DsM Id
+newUniqueId id ty
+  = newUnique 	`thenDs` \ uniq ->
+    returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
+
+duplicateLocalDs :: Id -> DsM Id
+duplicateLocalDs old_local 
+  = newUnique 	`thenDs` \ uniq ->
+    returnDs (setIdUnique old_local uniq)
+
+newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDs ty
+  = newUnique 	`thenDs` \ uniq ->
+    returnDs (mkSysLocal FSLIT("ds") uniq ty)
+
+newSysLocalsDs tys = mappM newSysLocalDs tys
+
+newFailLocalDs ty 
+  = newUnique 	`thenDs` \ uniq ->
+    returnDs (mkSysLocal FSLIT("fail") uniq ty)
+	-- The UserLocal bit just helps make the code a little clearer
+\end{code}
+
+\begin{code}
+newTyVarsDs :: [TyVar] -> DsM [TyVar]
+newTyVarsDs tyvar_tmpls 
+  = newUniqueSupply	`thenDs` \ uniqs ->
+    returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
+\end{code}
+
+We can also reach out and either set/grab location information from
+the @SrcSpan@ being carried around.
+
+\begin{code}
+getDOptsDs :: DsM DynFlags
+getDOptsDs = getDOpts
+
+getModuleDs :: DsM Module
+getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
+
+getSrcSpanDs :: DsM SrcSpan
+getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
+
+putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
+putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
+
+dsWarn :: SDoc -> DsM ()
+dsWarn warn = do { env <- getGblEnv 
+		 ; loc <- getSrcSpanDs
+		 ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
+	    where
+	      msg = ptext SLIT("Warning:") <+> warn
+\end{code}
+
+\begin{code}
+dsLookupGlobal :: Name -> DsM TyThing
+-- Very like TcEnv.tcLookupGlobal
+dsLookupGlobal name 
+  = do	{ env <- getGblEnv
+	; setEnvs (ds_if_env env)
+		  (tcIfaceGlobal name) }
+
+dsLookupGlobalId :: Name -> DsM Id
+dsLookupGlobalId name 
+  = dsLookupGlobal name		`thenDs` \ thing ->
+    returnDs (tyThingId thing)
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name
+  = dsLookupGlobal name		`thenDs` \ thing ->
+    returnDs (tyThingTyCon thing)
+
+dsLookupDataCon :: Name -> DsM DataCon
+dsLookupDataCon name
+  = dsLookupGlobal name		`thenDs` \ thing ->
+    returnDs (tyThingDataCon thing)
+\end{code}
+
+\begin{code}
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
+
+dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
+dsExtendMetaEnv menv thing_inside
+  = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
+\end{code}
+
+
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
new file mode 100644
index 0000000000..29e7773bb8
--- /dev/null
+++ b/compiler/deSugar/DsUtils.lhs
@@ -0,0 +1,884 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsUtils]{Utilities for desugaring}
+
+This module exports some utility functions of no great interest.
+
+\begin{code}
+module DsUtils (
+	EquationInfo(..), 
+	firstPat, shiftEqns,
+	
+	mkDsLet, mkDsLets,
+
+	MatchResult(..), CanItFail(..), 
+	cantFailMatchResult, alwaysFailMatchResult,
+	extractMatchResult, combineMatchResults, 
+	adjustMatchResult,  adjustMatchResultDs,
+	mkCoLetMatchResult, mkGuardedMatchResult, 
+	matchCanFail,
+	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
+	wrapBind, wrapBinds,
+
+	mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
+	mkIntExpr, mkCharExpr,
+	mkStringExpr, mkStringExprFS, mkIntegerExpr, 
+
+	mkSelectorBinds, mkTupleExpr, mkTupleSelector, 
+	mkTupleType, mkTupleCase, mkBigCoreTup,
+	mkCoreTup, mkCoreTupTy, seqVar,
+	
+	dsSyntaxTable, lookupEvidence,
+
+	selectSimpleMatchVarL, selectMatchVars, selectMatchVar
+    ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-}	Match ( matchSimply )
+import {-# SOURCE #-}	DsExpr( dsExpr )
+
+import HsSyn
+import TcHsSyn		( hsPatType )
+import CoreSyn
+import Constants	( mAX_TUPLE_SIZE )
+import DsMonad
+
+import CoreUtils	( exprType, mkIfThenElse, mkCoerce, bindNonRec )
+import MkId		( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
+import Id		( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal )
+import Var		( Var )
+import Name		( Name )
+import Literal		( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT )
+import TyCon		( isNewTyCon, tyConDataCons )
+import DataCon		( DataCon, dataConSourceArity, dataConTyCon, dataConTag )
+import Type		( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy )
+import TcType		( tcEqType )
+import TysPrim		( intPrimTy )
+import TysWiredIn	( nilDataCon, consDataCon, 
+                          tupleCon, mkTupleTy,
+			  unitDataConId, unitTy,
+                          charTy, charDataCon, 
+                          intTy, intDataCon, 
+			  isPArrFakeCon )
+import BasicTypes	( Boxity(..) )
+import UniqSet		( mkUniqSet, minusUniqSet, isEmptyUniqSet )
+import UniqSupply	( splitUniqSupply, uniqFromSupply, uniqsFromSupply )
+import PrelNames	( unpackCStringName, unpackCStringUtf8Name, 
+			  plusIntegerName, timesIntegerName, smallIntegerDataConName, 
+			  lengthPName, indexPName )
+import Outputable
+import SrcLoc		( Located(..), unLoc )
+import Util             ( isSingleton, zipEqual, sortWith )
+import ListSetOps	( assocDefault )
+import FastString
+import Data.Char	( ord )
+
+#ifdef DEBUG
+import Util		( notNull )	-- Used in an assertion
+#endif
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+		Rebindable syntax
+%*									*
+%************************************************************************
+
+\begin{code}
+dsSyntaxTable :: SyntaxTable Id 
+	       -> DsM ([CoreBind], 	-- Auxiliary bindings
+		       [(Name,Id)])	-- Maps the standard name to its value
+
+dsSyntaxTable rebound_ids
+  = mapAndUnzipDs mk_bind rebound_ids	`thenDs` \ (binds_s, prs) ->
+    return (concat binds_s, prs)
+  where
+	-- The cheapo special case can happen when we 
+	-- make an intermediate HsDo when desugaring a RecStmt
+    mk_bind (std_name, HsVar id) = return ([], (std_name, id))
+    mk_bind (std_name, expr)
+ 	 = dsExpr expr				`thenDs` \ rhs ->
+     	   newSysLocalDs (exprType rhs)		`thenDs` \ id ->
+     	   return ([NonRec id rhs], (std_name, id))
+
+lookupEvidence :: [(Name, Id)] -> Name -> Id
+lookupEvidence prs std_name
+  = assocDefault (mk_panic std_name) prs std_name
+  where
+    mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Building lets}
+%*									*
+%************************************************************************
+
+Use case, not let for unlifted types.  The simplifier will turn some
+back again.
+
+\begin{code}
+mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
+mkDsLet (NonRec bndr rhs) body
+  | isUnLiftedType (idType bndr) 
+  = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
+mkDsLet bind body
+  = Let bind body
+
+mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
+mkDsLets binds body = foldr mkDsLet body binds
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{ Selecting match variables}
+%*									*
+%************************************************************************
+
+We're about to match against some patterns.  We want to make some
+@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
+hand, which should indeed be bound to the pattern as a whole, then use it;
+otherwise, make one up.
+
+\begin{code}
+selectSimpleMatchVarL :: LPat Id -> DsM Id
+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) (hsPatType pat)
+
+-- (selectMatchVars ps tys) chooses variables of type tys
+-- to use for matching ps against.  If the pattern is a variable,
+-- we try to use that, to save inventing lots of fresh variables.
+-- But even if it is a variable, its type might not match.  Consider
+--	data T a where
+--	  T1 :: Int -> T Int
+--	  T2 :: a   -> T a
+--
+--	f :: T a -> a -> Int
+--	f (T1 i) (x::Int) = x
+--	f (T2 i) (y::a)   = 0
+-- Then we must not choose (x::Int) as the matching variable!
+
+selectMatchVars :: [Pat Id] -> [Type] -> DsM [Id]
+selectMatchVars []     [] 	= return []
+selectMatchVars (p:ps) (ty:tys) = do { v  <- selectMatchVar  p  ty
+				     ; vs <- selectMatchVars ps tys
+				     ; return (v:vs) }
+
+selectMatchVar (BangPat pat)   pat_ty  = selectMatchVar (unLoc pat) pat_ty
+selectMatchVar (LazyPat pat)   pat_ty  = selectMatchVar (unLoc pat) pat_ty
+selectMatchVar (VarPat var)    pat_ty  = try_for var 	     pat_ty
+selectMatchVar (AsPat var pat) pat_ty  = try_for (unLoc var) pat_ty
+selectMatchVar other_pat       pat_ty  = newSysLocalDs pat_ty   -- OK, better make up one...
+
+try_for var pat_ty 
+  | idType var `tcEqType` pat_ty = returnDs var
+  | otherwise			 = newSysLocalDs pat_ty
+\end{code}
+
+
+%************************************************************************
+%*									*
+%* type synonym EquationInfo and access functions for its pieces	*
+%*									*
+%************************************************************************
+\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
+
+The ``equation info'' used by @match@ is relatively complicated and
+worthy of a type synonym and a few handy functions.
+
+\begin{code}
+firstPat :: EquationInfo -> Pat Id
+firstPat eqn = head (eqn_pats eqn)
+
+shiftEqns :: [EquationInfo] -> [EquationInfo]
+-- Drop the first pattern in each equation
+shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
+\end{code}
+
+Functions on MatchResults
+
+\begin{code}
+matchCanFail :: MatchResult -> Bool
+matchCanFail (MatchResult CanFail _)  = True
+matchCanFail (MatchResult CantFail _) = False
+
+alwaysFailMatchResult :: MatchResult
+alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
+
+cantFailMatchResult :: CoreExpr -> MatchResult
+cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
+
+extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
+extractMatchResult (MatchResult CantFail match_fn) fail_expr
+  = match_fn (error "It can't fail!")
+
+extractMatchResult (MatchResult CanFail match_fn) fail_expr
+  = mkFailurePair fail_expr	 	`thenDs` \ (fail_bind, if_it_fails) ->
+    match_fn if_it_fails		`thenDs` \ body ->
+    returnDs (mkDsLet fail_bind body)
+
+
+combineMatchResults :: MatchResult -> MatchResult -> MatchResult
+combineMatchResults (MatchResult CanFail      body_fn1)
+		    (MatchResult can_it_fail2 body_fn2)
+  = MatchResult can_it_fail2 body_fn
+  where
+    body_fn fail = body_fn2 fail			`thenDs` \ body2 ->
+		   mkFailurePair body2	 		`thenDs` \ (fail_bind, duplicatable_expr) ->
+		   body_fn1 duplicatable_expr		`thenDs` \ body1 ->
+		   returnDs (Let fail_bind body1)
+
+combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
+  = match_result1
+
+adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
+  = MatchResult can_it_fail (\fail -> body_fn fail	`thenDs` \ body ->
+				      returnDs (encl_fn body))
+
+adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
+  = MatchResult can_it_fail (\fail -> body_fn fail	`thenDs` \ body ->
+				      encl_fn body)
+
+wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
+wrapBinds [] e = e
+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
+
+wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
+wrapBind new old body
+  | new==old    = body
+  | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
+  | otherwise   = Let (NonRec new (Var old)) body
+
+seqVar :: Var -> CoreExpr -> CoreExpr
+seqVar var body = Case (Var var) var (exprType body)
+			[(DEFAULT, [], body)]
+
+mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
+mkCoLetMatchResult bind match_result
+  = adjustMatchResult (mkDsLet bind) match_result
+
+mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
+mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
+  = MatchResult CanFail (\fail -> body_fn fail	`thenDs` \ body ->
+				  returnDs (mkIfThenElse pred_expr body fail))
+
+mkCoPrimCaseMatchResult :: Id				-- Scrutinee
+                    -> Type                             -- Type of the case
+		    -> [(Literal, MatchResult)]		-- Alternatives
+		    -> MatchResult
+mkCoPrimCaseMatchResult var ty match_alts
+  = MatchResult CanFail mk_case
+  where
+    mk_case fail
+      = mappM (mk_alt fail) sorted_alts		`thenDs` \ alts ->
+	returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
+
+    sorted_alts = sortWith fst match_alts	-- Right order for a Case
+    mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail	`thenDs` \ body ->
+					       returnDs (LitAlt lit, [], body)
+
+
+mkCoAlgCaseMatchResult :: Id					-- Scrutinee
+                    -> Type                                     -- Type of exp
+		    -> [(DataCon, [CoreBndr], MatchResult)]	-- Alternatives
+		    -> MatchResult
+mkCoAlgCaseMatchResult var ty match_alts 
+  | isNewTyCon tycon		-- Newtype case; use a let
+  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
+    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
+
+  | isPArrFakeAlts match_alts	-- Sugared parallel array; use a literal case 
+  = MatchResult CanFail mk_parrCase
+
+  | otherwise			-- Datatype case; use a case
+  = MatchResult fail_flag mk_case
+  where
+    tycon = dataConTyCon con1
+	-- [Interesting: becuase of GADTs, we can't rely on the type of 
+	--  the scrutinised Id to be sufficiently refined to have a TyCon in it]
+
+	-- Stuff for newtype
+    (con1, arg_ids1, match_result1) = head match_alts
+    arg_id1 	= head arg_ids1
+    newtype_rhs = mkNewTypeBody tycon (idType arg_id1) (Var var)
+		
+	-- Stuff for data types
+    data_cons      = tyConDataCons tycon
+    match_results  = [match_result | (_,_,match_result) <- match_alts]
+
+    fail_flag | exhaustive_case
+	      = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
+	      | otherwise
+	      = CanFail
+
+    wild_var = mkWildId (idType var)
+    sorted_alts  = sortWith get_tag match_alts
+    get_tag (con, _, _) = dataConTag con
+    mk_case fail = mappM (mk_alt fail) sorted_alts	`thenDs` \ alts ->
+		   returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))
+
+    mk_alt fail (con, args, MatchResult _ body_fn)
+	= body_fn fail				`thenDs` \ body ->
+	  newUniqueSupply			`thenDs` \ us ->
+	  returnDs (mkReboxingAlt (uniqsFromSupply us) con args body)
+
+    mk_default fail | exhaustive_case = []
+		    | otherwise       = [(DEFAULT, [], fail)]
+
+    un_mentioned_constructors
+        = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
+    exhaustive_case = isEmptyUniqSet un_mentioned_constructors
+
+	-- Stuff for parallel arrays
+	-- 
+	--  * the following is to desugar cases over fake constructors for
+	--   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
+	--   case
+	--
+	-- Concerning `isPArrFakeAlts':
+	--
+	--  * it is *not* sufficient to just check the type of the type
+	--   constructor, as we have to be careful not to confuse the real
+	--   representation of parallel arrays with the fake constructors;
+	--   moreover, a list of alternatives must not mix fake and real
+	--   constructors (this is checked earlier on)
+	--
+	-- FIXME: We actually go through the whole list and make sure that
+	--	  either all or none of the constructors are fake parallel
+	--	  array constructors.  This is to spot equations that mix fake
+	--	  constructors with the real representation defined in
+	--	  `PrelPArr'.  It would be nicer to spot this situation
+	--	  earlier and raise a proper error message, but it can really
+	--	  only happen in `PrelPArr' anyway.
+	--
+    isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
+    isPArrFakeAlts ((dcon, _, _):alts) = 
+      case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
+        (True , True ) -> True
+        (False, False) -> False
+	_	       -> 
+	  panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
+    --
+    mk_parrCase fail = 		   
+      dsLookupGlobalId lengthPName			`thenDs` \lengthP  ->
+      unboxAlt						`thenDs` \alt      ->
+      returnDs (Case (len lengthP) (mkWildId intTy) ty [alt])
+      where
+	elemTy      = case splitTyConApp (idType var) of
+		        (_, [elemTy]) -> elemTy
+		        _	        -> panic panicMsg
+        panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
+	len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
+	--
+	unboxAlt = 
+	  newSysLocalDs intPrimTy			`thenDs` \l	   ->
+	  dsLookupGlobalId indexPName			`thenDs` \indexP   ->
+	  mappM (mkAlt indexP) sorted_alts              `thenDs` \alts     ->
+	  returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
+          where
+	    wild = mkWildId intPrimTy
+	    dft  = (DEFAULT, [], fail)
+	--
+	-- each alternative matches one array length (corresponding to one
+	-- fake array constructor), so the match is on a literal; each
+	-- alternative's body is extended by a local binding for each
+	-- constructor argument, which are bound to array elements starting
+	-- with the first
+	--
+	mkAlt indexP (con, args, MatchResult _ bodyFun) = 
+	  bodyFun fail					`thenDs` \body     ->
+	  returnDs (LitAlt lit, [], mkDsLets binds body)
+	  where
+	    lit   = MachInt $ toInteger (dataConSourceArity con)
+	    binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
+	    --
+	    indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Desugarer's versions of some Core functions}
+%*									*
+%************************************************************************
+
+\begin{code}
+mkErrorAppDs :: Id 		-- The error function
+	     -> Type		-- Type to which it should be applied
+	     -> String		-- The error message string to pass
+	     -> DsM CoreExpr
+
+mkErrorAppDs err_id ty msg
+  = getSrcSpanDs		`thenDs` \ src_loc ->
+    let
+	full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
+	core_msg = Lit (mkStringLit full_msg)
+	-- mkStringLit returns a result of type String#
+    in
+    returnDs (mkApps (Var err_id) [Type ty, core_msg])
+\end{code}
+
+
+*************************************************************
+%*									*
+\subsection{Making literals}
+%*									*
+%************************************************************************
+
+\begin{code}
+mkCharExpr     :: Char	     -> CoreExpr      -- Returns	C# c :: Int
+mkIntExpr      :: Integer    -> CoreExpr      -- Returns	I# i :: Int
+mkIntegerExpr  :: Integer    -> DsM CoreExpr  -- Result :: Integer
+mkStringExpr   :: String     -> DsM CoreExpr  -- Result :: String
+mkStringExprFS :: FastString -> DsM CoreExpr  -- Result :: String
+
+mkIntExpr  i = mkConApp intDataCon  [mkIntLit i]
+mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
+
+mkIntegerExpr i
+  | inIntRange i  	-- Small enough, so start from an Int
+  = dsLookupDataCon  smallIntegerDataConName	`thenDs` \ integer_dc ->
+    returnDs (mkSmallIntegerLit integer_dc i)
+
+-- Special case for integral literals with a large magnitude:
+-- They are transformed into an expression involving only smaller
+-- integral literals. This improves constant folding.
+
+  | otherwise 		-- Big, so start from a string
+  = dsLookupGlobalId plusIntegerName		`thenDs` \ plus_id ->
+    dsLookupGlobalId timesIntegerName		`thenDs` \ times_id ->
+    dsLookupDataCon  smallIntegerDataConName	`thenDs` \ integer_dc ->
+    let 
+	lit i = mkSmallIntegerLit integer_dc i
+        plus a b  = Var plus_id  `App` a `App` b
+        times a b = Var times_id `App` a `App` b
+
+	-- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
+	horner :: Integer -> Integer -> CoreExpr
+	horner b i | abs q <= 1 = if r == 0 || r == i 
+				  then lit i 
+				  else lit r `plus` lit (i-r)
+	           | r == 0     =               horner b q `times` lit b
+	           | otherwise  = lit r `plus` (horner b q `times` lit b)
+  		   where
+		     (q,r) = i `quotRem` b
+
+    in
+    returnDs (horner tARGET_MAX_INT i)
+
+mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
+
+mkStringExpr str = mkStringExprFS (mkFastString str)
+
+mkStringExprFS str
+  | nullFS str
+  = returnDs (mkNilExpr charTy)
+
+  | lengthFS str == 1
+  = let
+	the_char = mkCharExpr (headFS str)
+    in
+    returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
+
+  | all safeChar chars
+  = dsLookupGlobalId unpackCStringName	`thenDs` \ unpack_id ->
+    returnDs (App (Var unpack_id) (Lit (MachStr str)))
+
+  | otherwise
+  = dsLookupGlobalId unpackCStringUtf8Name	`thenDs` \ unpack_id ->
+    returnDs (App (Var unpack_id) (Lit (MachStr str)))
+
+  where
+    chars = unpackFS str
+    safeChar c = ord c >= 1 && ord c <= 0x7F
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[mkSelectorBind]{Make a selector bind}
+%*									*
+%************************************************************************
+
+This is used in various places to do with lazy patterns.
+For each binder $b$ in the pattern, we create a binding:
+\begin{verbatim}
+    b = case v of pat' -> b'
+\end{verbatim}
+where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
+
+ToDo: making these bindings should really depend on whether there's
+much work to be done per binding.  If the pattern is complex, it
+should be de-mangled once, into a tuple (and then selected from).
+Otherwise the demangling can be in-line in the bindings (as here).
+
+Boring!  Boring!  One error message per binder.  The above ToDo is
+even more helpful.  Something very similar happens for pattern-bound
+expressions.
+
+\begin{code}
+mkSelectorBinds :: LPat Id	-- The pattern
+		-> CoreExpr	-- Expression to which the pattern is bound
+		-> DsM [(Id,CoreExpr)]
+
+mkSelectorBinds (L _ (VarPat v)) val_expr
+  = returnDs [(v, val_expr)]
+
+mkSelectorBinds pat val_expr
+  | isSingleton binders || is_simple_lpat pat
+  = 	-- Given   p = e, where p binds x,y
+	-- we are going to make
+	--	v = p	(where v is fresh)
+	--	x = case v of p -> x
+	--	y = case v of p -> x
+
+	-- Make up 'v'
+	-- NB: give it the type of *pattern* p, not the type of the *rhs* e.
+	-- This does not matter after desugaring, but there's a subtle 
+	-- issue with implicit parameters. Consider
+	--	(x,y) = ?i
+	-- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
+	-- to the desugarer.  (Why opaque?  Because newtypes have to be.  Why
+	-- does it get that type?  So that when we abstract over it we get the
+	-- right top-level type  (?i::Int) => ...)
+	--
+	-- So to get the type of 'v', use the pattern not the rhs.  Often more
+	-- efficient too.
+    newSysLocalDs (hsPatType pat)	`thenDs` \ val_var ->
+
+	-- For the error message we make one error-app, to avoid duplication.
+	-- But we need it at different types... so we use coerce for that
+    mkErrorAppDs iRREFUT_PAT_ERROR_ID 
+		 unitTy (showSDoc (ppr pat))	`thenDs` \ err_expr ->
+    newSysLocalDs unitTy			`thenDs` \ err_var ->
+    mappM (mk_bind val_var err_var) binders	`thenDs` \ binds ->
+    returnDs ( (val_var, val_expr) : 
+	       (err_var, err_expr) :
+	       binds )
+
+
+  | otherwise
+  = mkErrorAppDs iRREFUT_PAT_ERROR_ID 
+		 tuple_ty (showSDoc (ppr pat))			`thenDs` \ error_expr ->
+    matchSimply val_expr PatBindRhs pat local_tuple error_expr	`thenDs` \ tuple_expr ->
+    newSysLocalDs tuple_ty					`thenDs` \ tuple_var ->
+    let
+	mk_tup_bind binder
+	  = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
+    in
+    returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
+  where
+    binders	= collectPatBinders pat
+    local_tuple = mkTupleExpr binders
+    tuple_ty    = exprType local_tuple
+
+    mk_bind scrut_var err_var bndr_var
+    -- (mk_bind sv err_var) generates
+    --		bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
+    -- Remember, pat binds bv
+      = matchSimply (Var scrut_var) PatBindRhs pat
+		    (Var bndr_var) error_expr			`thenDs` \ rhs_expr ->
+        returnDs (bndr_var, rhs_expr)
+      where
+        error_expr = mkCoerce (idType bndr_var) (Var err_var)
+
+    is_simple_lpat p = is_simple_pat (unLoc p)
+
+    is_simple_pat (TuplePat ps Boxed _)    = all is_triv_lpat ps
+    is_simple_pat (ConPatOut _ _ _ _ ps _) = all is_triv_lpat (hsConArgs ps)
+    is_simple_pat (VarPat _)	       	   = True
+    is_simple_pat (ParPat p)		   = is_simple_lpat p
+    is_simple_pat other		       	   = False
+
+    is_triv_lpat p = is_triv_pat (unLoc p)
+
+    is_triv_pat (VarPat v)  = True
+    is_triv_pat (WildPat _) = True
+    is_triv_pat (ParPat p)  = is_triv_lpat p
+    is_triv_pat other       = False
+\end{code}
+
+
+%************************************************************************
+%*									*
+		Tuples
+%*									*
+%************************************************************************
+
+@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  
+
+* If it has only one element, it is the identity function.
+
+* If there are more elements than a big tuple can have, it nests 
+  the tuples.  
+
+Nesting policy.  Better a 2-tuple of 10-tuples (3 objects) than
+a 10-tuple of 2-tuples (11 objects).  So we want the leaves to be big.
+
+\begin{code}
+mkTupleExpr :: [Id] -> CoreExpr
+mkTupleExpr ids = mkBigCoreTup (map Var ids)
+
+-- corresponding type
+mkTupleType :: [Id] -> Type
+mkTupleType ids = mkBigTuple mkCoreTupTy (map idType ids)
+
+mkBigCoreTup :: [CoreExpr] -> CoreExpr
+mkBigCoreTup = mkBigTuple mkCoreTup
+
+mkBigTuple :: ([a] -> a) -> [a] -> a
+mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
+  where
+	-- Each sub-list is short enough to fit in a tuple
+    mk_big_tuple [as] = small_tuple as
+    mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
+
+chunkify :: [a] -> [[a]]
+-- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
+-- But there may be more than mAX_TUPLE_SIZE sub-lists
+chunkify xs
+  | n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs] 
+  | otherwise		   = {- pprTrace "Big"   (ppr n_xs) -} (split xs)
+  where
+    n_xs     = length xs
+    split [] = []
+    split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
+\end{code}
+
+
+@mkTupleSelector@ builds a selector which scrutises the given
+expression and extracts the one name from the list given.
+If you want the no-shadowing rule to apply, the caller
+is responsible for making sure that none of these names
+are in scope.
+
+If there is just one id in the ``tuple'', then the selector is
+just the identity.
+
+If it's big, it does nesting
+	mkTupleSelector [a,b,c,d] b v e
+	  = case e of v { 
+		(p,q) -> case p of p {
+			   (a,b) -> b }}
+We use 'tpl' vars for the p,q, since shadowing does not matter.
+
+In fact, it's more convenient to generate it innermost first, getting
+
+	case (case e of v 
+		(p,q) -> p) of p
+	  (a,b) -> b
+
+\begin{code}
+mkTupleSelector :: [Id]		-- The tuple args
+		-> Id		-- The selected one
+		-> Id		-- A variable of the same type as the scrutinee
+		-> CoreExpr	-- Scrutinee
+		-> CoreExpr
+
+mkTupleSelector vars the_var scrut_var scrut
+  = mk_tup_sel (chunkify vars) the_var
+  where
+    mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
+    mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
+				mk_tup_sel (chunkify tpl_vs) tpl_v
+	where
+	  tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
+	  tpl_vs  = mkTemplateLocals tpl_tys
+	  [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
+					 the_var `elem` gp ]
+\end{code}
+
+A generalization of @mkTupleSelector@, allowing the body
+of the case to be an arbitrary expression.
+
+If the tuple is big, it is nested:
+
+	mkTupleCase uniqs [a,b,c,d] body v e
+	  = case e of v { (p,q) ->
+	    case p of p { (a,b) ->
+	    case q of q { (c,d) ->
+	    body }}}
+
+To avoid shadowing, we use uniqs to invent new variables p,q.
+
+ToDo: eliminate cases where none of the variables are needed.
+
+\begin{code}
+mkTupleCase
+	:: UniqSupply	-- for inventing names of intermediate variables
+	-> [Id]		-- the tuple args
+	-> CoreExpr	-- body of the case
+	-> Id		-- a variable of the same type as the scrutinee
+	-> CoreExpr	-- scrutinee
+	-> CoreExpr
+
+mkTupleCase uniqs vars body scrut_var scrut
+  = mk_tuple_case uniqs (chunkify vars) body
+  where
+    mk_tuple_case us [vars] body
+      = mkSmallTupleCase vars body scrut_var scrut
+    mk_tuple_case us vars_s body
+      = let
+	    (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
+	in
+	mk_tuple_case us' (chunkify vars') body'
+    one_tuple_case chunk_vars (us, vs, body)
+      = let
+	    (us1, us2) = splitUniqSupply us
+	    scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
+			(mkCoreTupTy (map idType chunk_vars))
+	    body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
+	in (us2, scrut_var:vs, body')
+\end{code}
+
+The same, but with a tuple small enough not to need nesting.
+
+\begin{code}
+mkSmallTupleCase
+	:: [Id]		-- the tuple args
+	-> CoreExpr	-- body of the case
+	-> Id		-- a variable of the same type as the scrutinee
+	-> CoreExpr	-- scrutinee
+	-> CoreExpr
+
+mkSmallTupleCase [var] body _scrut_var scrut
+  = bindNonRec var scrut body
+mkSmallTupleCase vars body scrut_var scrut
+-- One branch no refinement?
+  = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%*									*
+%************************************************************************
+
+Call the constructor Ids when building explicit lists, so that they
+interact well with rules.
+
+\begin{code}
+mkNilExpr :: Type -> CoreExpr
+mkNilExpr ty = mkConApp nilDataCon [Type ty]
+
+mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
+mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
+
+mkListExpr :: Type -> [CoreExpr] -> CoreExpr
+mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
+			    
+
+-- The next three functions make tuple types, constructors and selectors,
+-- with the rule that a 1-tuple is represented by the thing itselg
+mkCoreTupTy :: [Type] -> Type
+mkCoreTupTy [ty] = ty
+mkCoreTupTy tys  = mkTupleTy Boxed (length tys) tys
+
+mkCoreTup :: [CoreExpr] -> CoreExpr			    
+-- Builds exactly the specified tuple.
+-- No fancy business for big tuples
+mkCoreTup []  = Var unitDataConId
+mkCoreTup [c] = c
+mkCoreTup cs  = mkConApp (tupleCon Boxed (length cs))
+			 (map (Type . exprType) cs ++ cs)
+
+mkCoreSel :: [Id]	-- The tuple args
+	  -> Id		-- The selected one
+	  -> Id		-- A variable of the same type as the scrutinee
+	  -> CoreExpr	-- Scrutinee
+	  -> CoreExpr
+-- mkCoreSel [x,y,z] x v e
+-- ===>  case e of v { (x,y,z) -> x
+mkCoreSel [var] should_be_the_same_var scrut_var scrut
+  = ASSERT(var == should_be_the_same_var)
+    scrut
+
+mkCoreSel vars the_var scrut_var scrut
+  = ASSERT( notNull vars )
+    Case scrut scrut_var (idType the_var)
+	 [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%*									*
+%************************************************************************
+
+Generally, we handle pattern matching failure like this: let-bind a
+fail-variable, and use that variable if the thing fails:
+\begin{verbatim}
+	let fail.33 = error "Help"
+	in
+	case x of
+		p1 -> ...
+		p2 -> fail.33
+		p3 -> fail.33
+		p4 -> ...
+\end{verbatim}
+Then
+\begin{itemize}
+\item
+If the case can't fail, then there'll be no mention of @fail.33@, and the
+simplifier will later discard it.
+
+\item
+If it can fail in only one way, then the simplifier will inline it.
+
+\item
+Only if it is used more than once will the let-binding remain.
+\end{itemize}
+
+There's a problem when the result of the case expression is of
+unboxed type.  Then the type of @fail.33@ is unboxed too, and
+there is every chance that someone will change the let into a case:
+\begin{verbatim}
+	case error "Help" of
+	  fail.33 -> case ....
+\end{verbatim}
+
+which is of course utterly wrong.  Rather than drop the condition that
+only boxed types can be let-bound, we just turn the fail into a function
+for the primitive case:
+\begin{verbatim}
+	let fail.33 :: Void -> Int#
+	    fail.33 = \_ -> error "Help"
+	in
+	case x of
+		p1 -> ...
+		p2 -> fail.33 void
+		p3 -> fail.33 void
+		p4 -> ...
+\end{verbatim}
+
+Now @fail.33@ is a function, so it can be let-bound.
+
+\begin{code}
+mkFailurePair :: CoreExpr	-- Result type of the whole case expression
+	      -> DsM (CoreBind,	-- Binds the newly-created fail variable
+				-- to either the expression or \ _ -> expression
+		      CoreExpr)	-- Either the fail variable, or fail variable
+				-- applied to unit tuple
+mkFailurePair expr
+  | isUnLiftedType ty
+  = newFailLocalDs (unitTy `mkFunTy` ty)	`thenDs` \ fail_fun_var ->
+    newSysLocalDs unitTy			`thenDs` \ fail_fun_arg ->
+    returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
+	      App (Var fail_fun_var) (Var unitDataConId))
+
+  | otherwise
+  = newFailLocalDs ty 		`thenDs` \ fail_var ->
+    returnDs (NonRec fail_var expr, Var fail_var)
+  where
+    ty = exprType expr
+\end{code}
+
+
diff --git a/compiler/deSugar/Match.hi-boot-5 b/compiler/deSugar/Match.hi-boot-5
new file mode 100644
index 0000000000..42c200fbff
--- /dev/null
+++ b/compiler/deSugar/Match.hi-boot-5
@@ -0,0 +1,6 @@
+__interface Match 1 0 where
+__export Match match matchExport matchSimply matchSinglePat;
+1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
+1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
+1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Name.Name -> HsPat.LPat Var.Id -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
+1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> HsPat.LPat Var.Id -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;
diff --git a/compiler/deSugar/Match.hi-boot-6 b/compiler/deSugar/Match.hi-boot-6
new file mode 100644
index 0000000000..df806ec644
--- /dev/null
+++ b/compiler/deSugar/Match.hi-boot-6
@@ -0,0 +1,27 @@
+module Match where
+
+match 	:: [Var.Id]
+        -> TcType.TcType
+	-> [DsMonad.EquationInfo]
+	-> DsMonad.DsM DsMonad.MatchResult
+
+matchWrapper
+	:: HsExpr.HsMatchContext Name.Name
+        -> HsExpr.MatchGroup Var.Id
+	-> DsMonad.DsM ([Var.Id], CoreSyn.CoreExpr)
+
+matchSimply
+	:: CoreSyn.CoreExpr
+	-> HsExpr.HsMatchContext Name.Name
+	-> HsPat.LPat Var.Id
+	-> CoreSyn.CoreExpr
+	-> CoreSyn.CoreExpr
+	-> DsMonad.DsM CoreSyn.CoreExpr
+
+matchSinglePat
+	:: CoreSyn.CoreExpr
+	-> HsExpr.HsMatchContext Name.Name
+	-> HsPat.LPat Var.Id
+        -> TcType.TcType
+	-> DsMonad.MatchResult
+	-> DsMonad.DsM DsMonad.MatchResult
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
new file mode 100644
index 0000000000..d72d6adf17
--- /dev/null
+++ b/compiler/deSugar/Match.lhs
@@ -0,0 +1,740 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Main_match]{The @match@ function}
+
+\begin{code}
+module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
+
+#include "HsVersions.h"
+
+import DynFlags	( DynFlag(..), dopt )
+import HsSyn		
+import TcHsSyn		( mkVanillaTuplePat )
+import Check            ( check, ExhaustivePat )
+import CoreSyn
+import CoreUtils	( bindNonRec, exprType )
+import DsMonad
+import DsBinds		( dsLHsBinds )
+import DsGRHSs		( dsGRHSs )
+import DsUtils
+import Id		( idName, idType, Id )
+import DataCon		( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon )
+import MatchCon		( matchConFamily )
+import MatchLit		( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
+import PrelInfo		( pAT_ERROR_ID )
+import TcType		( Type, tcTyConAppArgs )
+import Type		( splitFunTysN, mkTyVarTys )
+import TysWiredIn	( consDataCon, mkListTy, unitTy,
+			  tupleCon, parrFakeCon, mkPArrTy )
+import BasicTypes	( Boxity(..) )
+import ListSetOps	( runs )
+import SrcLoc		( noLoc, unLoc, Located(..) )
+import Util             ( lengthExceeds, notNull )
+import Name		( Name )
+import Outputable
+\end{code}
+
+This function is a wrapper of @match@, it must be called from all the parts where 
+it was called match, but only substitutes the firs call, ....
+if the associated flags are declared, warnings will be issued.
+It can not be called matchWrapper because this name already exists :-(
+
+JJCQ 30-Nov-1997
+
+\begin{code}
+matchCheck ::  DsMatchContext
+	    -> [Id]	        -- Vars rep'ing the exprs we're matching with
+            -> Type             -- Type of the case expression
+            -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
+            -> DsM MatchResult  -- Desugared result!
+
+matchCheck ctx vars ty qs
+   = getDOptsDs 				`thenDs` \ dflags ->
+     matchCheck_really dflags ctx vars ty qs
+
+matchCheck_really dflags ctx vars ty qs
+  | incomplete && shadow = 
+      dsShadowWarn ctx eqns_shadow		`thenDs`   \ () ->
+      dsIncompleteWarn ctx pats			`thenDs`   \ () ->
+      match vars ty qs
+  | incomplete            = 
+      dsIncompleteWarn ctx pats			`thenDs`   \ () ->
+      match vars ty qs
+  | shadow                = 
+      dsShadowWarn ctx eqns_shadow		`thenDs`   \ () ->
+      match vars ty qs
+  | otherwise             =
+      match vars ty qs
+  where (pats, eqns_shadow) = check qs
+        incomplete    = want_incomplete && (notNull pats)
+        want_incomplete = case ctx of
+                              DsMatchContext RecUpd _ ->
+                                  dopt Opt_WarnIncompletePatternsRecUpd dflags
+                              _ ->
+                                  dopt Opt_WarnIncompletePatterns       dflags
+        shadow        = dopt Opt_WarnOverlappingPatterns dflags
+			&& not (null eqns_shadow)
+\end{code}
+
+This variable shows the maximum number of lines of output generated for warnings.
+It will limit the number of patterns/equations displayed to@ maximum_output@.
+
+(ToDo: add command-line option?)
+
+\begin{code}
+maximum_output = 4
+\end{code}
+
+The next two functions create the warning message.
+
+\begin{code}
+dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
+dsShadowWarn ctx@(DsMatchContext kind loc) qs
+  = putSrcSpanDs loc (dsWarn warn)
+  where
+    warn | qs `lengthExceeds` maximum_output
+         = pp_context ctx (ptext SLIT("are overlapped"))
+		      (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
+		      ptext SLIT("..."))
+	 | otherwise
+         = pp_context ctx (ptext SLIT("are overlapped"))
+	              (\ f -> vcat $ map (ppr_eqn f kind) qs)
+
+
+dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
+dsIncompleteWarn ctx@(DsMatchContext kind loc) pats 
+  = putSrcSpanDs loc (dsWarn warn)
+	where
+	  warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
+                    	    (\f -> hang (ptext SLIT("Patterns not matched:"))
+		                   4 ((vcat $ map (ppr_incomplete_pats kind)
+						  (take maximum_output pats))
+		                      $$ dots))
+
+	  dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
+	       | otherwise                           = empty
+
+pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
+  = vcat [ptext SLIT("Pattern match(es)") <+> msg,
+	  sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
+  where
+    (ppr_match, pref)
+	= case kind of
+	     FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+	     other	-> (pprMatchContext kind, \ pp -> pp)
+
+ppr_pats pats = sep (map ppr pats)
+
+ppr_shadow_pats kind pats
+  = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]
+    
+ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
+ppr_incomplete_pats kind (pats,constraints) = 
+	                 sep [ppr_pats pats, ptext SLIT("with"), 
+	                      sep (map ppr_constraint constraints)]
+    
+
+ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
+
+ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
+\end{code}
+
+
+The function @match@ is basically the same as in the Wadler chapter,
+except it is monadised, to carry around the name supply, info about
+annotations, etc.
+
+Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
+\begin{enumerate}
+\item
+A list of $n$ variable names, those variables presumably bound to the
+$n$ expressions being matched against the $n$ patterns.  Using the
+list of $n$ expressions as the first argument showed no benefit and
+some inelegance.
+
+\item
+The second argument, a list giving the ``equation info'' for each of
+the $m$ equations:
+\begin{itemize}
+\item
+the $n$ patterns for that equation, and
+\item
+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
+the front'' of the matching code, as in:
+\begin{verbatim}
+let <binds>
+in  <matching-code>
+\end{verbatim}
+\item
+and finally: (ToDo: fill in)
+
+The right way to think about the ``after-match function'' is that it
+is an embryonic @CoreExpr@ with a ``hole'' at the end for the
+final ``else expression''.
+\end{itemize}
+
+There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
+
+An experiment with re-ordering this information about equations (in
+particular, having the patterns available in column-major order)
+showed no benefit.
+
+\item
+A default expression---what to evaluate if the overall pattern-match
+fails.  This expression will (almost?) always be
+a measly expression @Var@, unless we know it will only be used once
+(as we do in @glue_success_exprs@).
+
+Leaving out this third argument to @match@ (and slamming in lots of
+@Var "fail"@s) is a positively {\em bad} idea, because it makes it
+impossible to share the default expressions.  (Also, it stands no
+chance of working in our post-upheaval world of @Locals@.)
+\end{enumerate}
+So, the full type signature:
+\begin{code}
+match :: [Id]		  -- Variables rep'ing the exprs we're matching with
+      -> Type             -- Type of the case expression
+      -> [EquationInfo]	  -- Info about patterns, etc. (type synonym below)
+      -> DsM MatchResult  -- Desugared result!
+\end{code}
+
+Note: @match@ is often called via @matchWrapper@ (end of this module),
+a function that does much of the house-keeping that goes with a call
+to @match@.
+
+It is also worth mentioning the {\em typical} way a block of equations
+is desugared with @match@.  At each stage, it is the first column of
+patterns that is examined.  The steps carried out are roughly:
+\begin{enumerate}
+\item
+Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
+bindings to the second component of the equation-info):
+\begin{itemize}
+\item
+Remove the `as' patterns from column~1.
+\item
+Make all constructor patterns in column~1 into @ConPats@, notably
+@ListPats@ and @TuplePats@.
+\item
+Handle any irrefutable (or ``twiddle'') @LazyPats@.
+\end{itemize}
+\item
+Now {\em unmix} the equations into {\em blocks} [w/ local function
+@unmix_eqns@], in which the equations in a block all have variable
+patterns in column~1, or they all have constructor patterns in ...
+(see ``the mixture rule'' in SLPJ).
+\item
+Call @matchEqnBlock@ on each block of equations; it will do the
+appropriate thing for each kind of column-1 pattern, usually ending up
+in a recursive call to @match@.
+\end{enumerate}
+
+%************************************************************************
+%*									*
+%*  match: empty rule							*
+%*									*
+%************************************************************************
+\subsection[Match-empty-rule]{The ``empty rule''}
+
+We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
+than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
+And gluing the ``success expressions'' together isn't quite so pretty.
+
+\begin{code}
+match [] ty eqns_info
+  = ASSERT( not (null eqns_info) )
+    returnDs (foldr1 combineMatchResults match_results)
+  where
+    match_results = [ ASSERT( null (eqn_pats eqn) ) 
+		      adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn)
+		    | eqn <- eqns_info ]
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*  match: non-empty rule						*
+%*									*
+%************************************************************************
+\subsection[Match-nonempty]{@match@ when non-empty: unmixing}
+
+This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
+(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
+(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
+un}mixes the equations], producing a list of equation-info
+blocks, each block having as its first column of patterns either all
+constructors, or all variables (or similar beasts), etc.
+
+@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
+Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
+corresponds roughly to @matchVarCon@.
+
+\begin{code}
+match vars@(v:_) ty eqns_info
+  = do	{ tidy_eqns <- mappM (tidyEqnInfo v) eqns_info
+	; let eqns_blks = runs same_family tidy_eqns
+	; match_results <- mappM match_block eqns_blks
+	; ASSERT( not (null match_results) )
+	  return (foldr1 combineMatchResults match_results) }
+  where
+    same_family eqn1 eqn2 
+      = samePatFamily (firstPat eqn1) (firstPat eqn2)
+ 
+    match_block eqns
+      = case firstPat (head eqns) of
+	  WildPat {}   -> matchVariables  vars ty eqns
+	  ConPatOut {} -> matchConFamily  vars ty eqns
+	  NPlusKPat {} -> matchNPlusKPats vars ty eqns
+	  NPat {}      -> matchNPats	  vars ty eqns
+	  LitPat {}    -> matchLiterals   vars ty eqns
+
+-- After tidying, there are only five kinds of patterns
+samePatFamily (WildPat {})   (WildPat {})   = True
+samePatFamily (ConPatOut {}) (ConPatOut {}) = True
+samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True
+samePatFamily (NPat {})	     (NPat {}) 	    = True
+samePatFamily (LitPat {})    (LitPat {})    = True
+samePatFamily _		     _		    = False
+
+matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Real true variables, just like in matchVar, SLPJ p 94
+-- No binding to do: they'll all be wildcards by now (done in tidy)
+matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns)
+\end{code}
+
+
+\end{code}
+
+Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
+which will be scrutinised.  This means:
+\begin{itemize}
+\item
+Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
+together with the binding @x = v@.
+\item
+Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
+\item
+Removing lazy (irrefutable) patterns (you don't want to know...).
+\item
+Converting explicit tuple-, list-, and parallel-array-pats into ordinary
+@ConPats@. 
+\item
+Convert the literal pat "" to [].
+\end{itemize}
+
+The result of this tidying is that the column of patterns will include
+{\em only}:
+\begin{description}
+\item[@WildPats@:]
+The @VarPat@ information isn't needed any more after this.
+
+\item[@ConPats@:]
+@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
+
+\item[@LitPats@ and @NPats@:]
+@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
+Float, 	Double, at least) are converted to unboxed form; e.g.,
+\tr{(NPat (HsInt i) _ _)} is converted to:
+\begin{verbatim}
+(ConPat I# _ _ [LitPat (HsIntPrim i)])
+\end{verbatim}
+\end{description}
+
+\begin{code}
+tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
+	-- DsM'd because of internal call to dsLHsBinds
+	-- 	and mkSelectorBinds.
+	-- "tidy1" does the interesting stuff, looking at
+	-- one pattern and fiddling the list of bindings.
+	--
+	-- POST CONDITION: head pattern in the EqnInfo is
+	--	WildPat
+	--	ConPat
+	--	NPat
+	--	LitPat
+	--	NPlusKPat
+	-- but no other
+
+tidyEqnInfo v eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = pat : pats })
+  = tidy1 v wrap pat 	`thenDs` \ (wrap', pat') ->
+    returnDs (eqn { eqn_wrap = wrap', eqn_pats = pat' : pats })
+
+tidy1 :: Id 			-- The Id being scrutinised
+      -> DsWrapper		-- Previous wrapping bindings
+      -> Pat Id 		-- The pattern against which it is to be matched
+      -> DsM (DsWrapper,	-- Extra bindings around what to do afterwards
+	      Pat Id) 		-- Equivalent pattern
+
+-- The extra bindings etc are all wrapped around the RHS of the match
+-- so they are only available when matching is complete.  But that's ok
+-- becuase, for example, in the pattern x@(...), the x can only be
+-- used in the RHS, not in the nested pattern, nor subsquent patterns
+--
+-- However this does have an awkward consequence.  The bindings in 
+-- a VarPatOut get wrapped around the result in right to left order,
+-- rather than left to right.  This only matters if one set of 
+-- bindings can mention things used in another, and that can happen
+-- if we allow equality dictionary bindings of form d1=d2.  
+-- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart.
+-- (Without this care in bindInstsOfLocalFuns, compiling 
+-- Data.Generics.Schemes.hs fails in function everywhereBut.)
+
+-------------------------------------------------------
+--	(pat', mr') = tidy1 v pat mr
+-- tidies the *outer level only* of pat, giving pat'
+-- It eliminates many pattern forms (as-patterns, variable patterns,
+-- list patterns, etc) yielding one of:
+--	WildPat
+--	ConPatOut
+--	LitPat
+--	NPat
+--	NPlusKPat
+
+tidy1 v wrap (ParPat pat)      = tidy1 v wrap (unLoc pat) 
+tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat) 
+tidy1 v wrap (WildPat ty)      = returnDs (wrap, WildPat ty)
+
+	-- case v of { x -> mr[] }
+	-- = case v of { _ -> let x=v in mr[] }
+tidy1 v wrap (VarPat var)
+  = returnDs (wrap . wrapBind var v, WildPat (idType var)) 
+
+tidy1 v wrap (VarPatOut var binds)
+  = do	{ prs <- dsLHsBinds binds
+	; return (wrap . wrapBind var v . mkDsLet (Rec prs),
+		  WildPat (idType var)) }
+
+	-- case v of { x@p -> mr[] }
+	-- = case v of { p -> let x=v in mr[] }
+tidy1 v wrap (AsPat (L _ var) pat)
+  = tidy1 v (wrap . wrapBind var v) (unLoc pat)
+
+tidy1 v wrap (BangPat pat)
+  = tidy1 v (wrap . seqVar v) (unLoc pat)
+
+{- now, here we handle lazy patterns:
+    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
+			v2 = case v of p -> v2 : ... : bs )
+
+    where the v_i's are the binders in the pattern.
+
+    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
+
+    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
+-}
+
+tidy1 v wrap (LazyPat pat)
+  = do	{ v' <- newSysLocalDs (idType v)
+	; sel_prs <- mkSelectorBinds pat (Var v)
+	; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
+	; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds,
+		    WildPat (idType v)) }
+
+-- re-express <con-something> as (ConPat ...) [directly]
+
+tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty)
+  = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty)
+  where
+    tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps)
+
+tidy1 v wrap (ListPat pats ty)
+  = returnDs (wrap, unLoc list_ConPat)
+  where
+    list_ty     = mkListTy ty
+    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
+	      	  	(mkNilPat list_ty)
+	      	  	pats
+
+-- Introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+tidy1 v wrap (PArrPat pats ty)
+  = returnDs (wrap, unLoc parrConPat)
+  where
+    arity      = length pats
+    parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
+
+tidy1 v wrap (TuplePat pats boxity ty)
+  = returnDs (wrap, unLoc tuple_ConPat)
+  where
+    arity = length pats
+    tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
+
+tidy1 v wrap (DictPat dicts methods)
+  = case num_of_d_and_ms of
+	0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) 
+	1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
+	_ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed)
+  where
+    num_of_d_and_ms	 = length dicts + length methods
+    dict_and_method_pats = map nlVarPat (dicts ++ methods)
+
+-- LitPats: we *might* be able to replace these w/ a simpler form
+tidy1 v wrap pat@(LitPat lit)
+  = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat)))
+
+-- NPats: we *might* be able to replace these w/ a simpler form
+tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty)
+  = returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat)))
+
+-- and everything else goes through unchanged...
+
+tidy1 v wrap non_interesting_pat
+  = returnDs (wrap, non_interesting_pat)
+
+
+tidy_con data_con ex_tvs pat_ty (PrefixCon ps)   = ps
+tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con ex_tvs pat_ty (RecCon rpats)
+  | null rpats
+  =	-- Special case for C {}, which can be used for 
+	-- a constructor that isn't declared to have
+	-- fields at all
+    map (noLoc . WildPat) con_arg_tys'
+
+  | otherwise
+  = map mk_pat tagged_arg_tys
+  where
+	-- Boring stuff to find the arg-tys of the constructor
+	
+    inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty	-- Newtypes must be opaque
+	     | otherwise		 = mkTyVarTys ex_tvs
+
+    con_arg_tys'     = dataConInstOrigArgTys data_con inst_tys
+    tagged_arg_tys   = con_arg_tys' `zip` dataConFieldLabels data_con
+
+	-- mk_pat picks a WildPat of the appropriate type for absent fields,
+	-- and the specified pattern for present fields
+    mk_pat (arg_ty, lbl) = 
+	case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of
+	  (pat:pats) -> ASSERT( null pats ) pat
+	  []	     -> noLoc (WildPat arg_ty)
+\end{code}
+
+\noindent
+{\bf Previous @matchTwiddled@ stuff:}
+
+Now we get to the only interesting part; note: there are choices for
+translation [from Simon's notes]; translation~1:
+\begin{verbatim}
+deTwiddle [s,t] e
+\end{verbatim}
+returns
+\begin{verbatim}
+[ w = e,
+  s = case w of [s,t] -> s
+  t = case w of [s,t] -> t
+]
+\end{verbatim}
+
+Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
+evaluation of \tr{e}.  An alternative translation (No.~2):
+\begin{verbatim}
+[ w = case e of [s,t] -> (s,t)
+  s = case w of (s,t) -> s
+  t = case w of (s,t) -> t
+]
+\end{verbatim}
+
+%************************************************************************
+%*									*
+\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
+%*									*
+%************************************************************************
+
+We might be able to optimise unmixing when confronted by
+only-one-constructor-possible, of which tuples are the most notable
+examples.  Consider:
+\begin{verbatim}
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+f j ...       = ...
+\end{verbatim}
+This definition would normally be unmixed into four equation blocks,
+one per equation.  But it could be unmixed into just one equation
+block, because if the one equation matches (on the first column),
+the others certainly will.
+
+You have to be careful, though; the example
+\begin{verbatim}
+f j ...       = ...
+-------------------
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+\end{verbatim}
+{\em must} be broken into two blocks at the line shown; otherwise, you
+are forcing unnecessary evaluation.  In any case, the top-left pattern
+always gives the cue.  You could then unmix blocks into groups of...
+\begin{description}
+\item[all variables:]
+As it is now.
+\item[constructors or variables (mixed):]
+Need to make sure the right names get bound for the variable patterns.
+\item[literals or variables (mixed):]
+Presumably just a variant on the constructor case (as it is now).
+\end{description}
+
+%************************************************************************
+%*									*
+%*  matchWrapper: a convenient way to call @match@			*
+%*									*
+%************************************************************************
+\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
+
+Calls to @match@ often involve similar (non-trivial) work; that work
+is collected here, in @matchWrapper@.  This function takes as
+arguments:
+\begin{itemize}
+\item
+Typchecked @Matches@ (of a function definition, or a case or lambda
+expression)---the main input;
+\item
+An error message to be inserted into any (runtime) pattern-matching
+failure messages.
+\end{itemize}
+
+As results, @matchWrapper@ produces:
+\begin{itemize}
+\item
+A list of variables (@Locals@) that the caller must ``promise'' to
+bind to appropriate values; and
+\item
+a @CoreExpr@, the desugared output (main result).
+\end{itemize}
+
+The main actions of @matchWrapper@ include:
+\begin{enumerate}
+\item
+Flatten the @[TypecheckedMatch]@ into a suitable list of
+@EquationInfo@s.
+\item
+Create as many new variables as there are patterns in a pattern-list
+(in any one of the @EquationInfo@s).
+\item
+Create a suitable ``if it fails'' expression---a call to @error@ using
+the error-string input; the {\em type} of this fail value can be found
+by examining one of the RHS expressions in one of the @EquationInfo@s.
+\item
+Call @match@ with all of this information!
+\end{enumerate}
+
+\begin{code}
+matchWrapper :: HsMatchContext Name	-- For shadowing warning messages
+	     -> MatchGroup Id		-- Matches being desugared
+	     -> DsM ([Id], CoreExpr) 	-- Results
+\end{code}
+
+ There is one small problem with the Lambda Patterns, when somebody
+ writes something similar to:
+\begin{verbatim}
+    (\ (x:xs) -> ...)
+\end{verbatim}
+ he/she don't want a warning about incomplete patterns, that is done with 
+ the flag @opt_WarnSimplePatterns@.
+ This problem also appears in the:
+\begin{itemize}
+\item @do@ patterns, but if the @do@ can fail
+      it creates another equation if the match can fail
+      (see @DsExpr.doDo@ function)
+\item @let@ patterns, are treated by @matchSimply@
+   List Comprension Patterns, are treated by @matchSimply@ also
+\end{itemize}
+
+We can't call @matchSimply@ with Lambda patterns,
+due to the fact that lambda patterns can have more than
+one pattern, and match simply only accepts one pattern.
+
+JJQC 30-Nov-1997
+
+\begin{code}
+matchWrapper ctxt (MatchGroup matches match_ty)
+  = do	{ eqns_info   <- mapM mk_eqn_info matches
+	; new_vars    <- selectMatchVars arg_pats pat_tys
+	; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
+	; return (new_vars, result_expr) }
+  where
+    arg_pats          = map unLoc (hsLMatchPats (head matches))
+    n_pats	      = length arg_pats
+    (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty
+
+    mk_eqn_info (L _ (Match pats _ grhss))
+      = do { let upats = map unLoc pats
+	   ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
+	   ; return (EqnInfo { eqn_wrap = idWrapper,
+			       eqn_pats = upats, 
+			       eqn_rhs  = match_result}) }
+
+
+matchEquations  :: HsMatchContext Name
+		-> [Id]	-> [EquationInfo] -> Type
+		-> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+  = do	{ dflags <- getDOptsDs
+	; locn   <- getSrcSpanDs
+	; let   ds_ctxt      = DsMatchContext ctxt locn
+		error_string = matchContextErrString ctxt
+
+	; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+
+	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+	; extractMatchResult match_result fail_expr }
+  where 
+    match_fun dflags ds_ctxt
+       = case ctxt of 
+           LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
+                      | otherwise                          -> match
+           _                                               -> matchCheck ds_ctxt
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
+%*									*
+%************************************************************************
+
+@mkSimpleMatch@ is a wrapper for @match@ which deals with the
+situation where we want to match a single expression against a single
+pattern. It returns an expression.
+
+\begin{code}
+matchSimply :: CoreExpr			-- Scrutinee
+	    -> HsMatchContext Name	-- Match kind
+	    -> LPat Id			-- Pattern it should match
+	    -> CoreExpr			-- Return this if it matches
+	    -> CoreExpr			-- Return this if it doesn't
+	    -> DsM CoreExpr
+
+matchSimply scrut hs_ctx pat result_expr fail_expr
+  = let
+      match_result = cantFailMatchResult result_expr
+      rhs_ty	   = exprType fail_expr
+	-- Use exprType of fail_expr, because won't refine in the case of failure!
+    in 
+    matchSinglePat scrut hs_ctx pat rhs_ty match_result	`thenDs` \ match_result' ->
+    extractMatchResult match_result' fail_expr
+
+
+matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
+	       -> Type -> MatchResult -> DsM MatchResult
+matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result
+  = getDOptsDs				`thenDs` \ dflags ->
+    getSrcSpanDs			`thenDs` \ locn ->
+    let
+	match_fn dflags
+           | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
+  	   | otherwise	       		        = match
+	   where
+	     ds_ctx = DsMatchContext hs_ctx locn
+    in
+    match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
+					eqn_pats = [pat],
+					eqn_rhs  = match_result }]
+
+matchSinglePat scrut hs_ctx pat ty match_result
+  = selectSimpleMatchVarL pat 		 		`thenDs` \ var ->
+    matchSinglePat (Var var) hs_ctx pat ty match_result	`thenDs` \ match_result' ->
+    returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
+\end{code}
+
diff --git a/compiler/deSugar/Match.lhs-boot b/compiler/deSugar/Match.lhs-boot
new file mode 100644
index 0000000000..5f99f5cc1a
--- /dev/null
+++ b/compiler/deSugar/Match.lhs-boot
@@ -0,0 +1,35 @@
+\begin{code}
+module Match where
+import Var	( Id )
+import TcType	( TcType )
+import DsMonad	( DsM, EquationInfo, MatchResult )
+import CoreSyn	( CoreExpr )
+import HsSyn	( LPat, HsMatchContext, MatchGroup )
+import Name	( Name )
+
+match 	:: [Id]
+        -> TcType
+	-> [EquationInfo]
+	-> DsM MatchResult
+
+matchWrapper
+	:: HsMatchContext Name
+        -> MatchGroup Id
+	-> DsM ([Id], CoreExpr)
+
+matchSimply
+	:: CoreExpr
+	-> HsMatchContext Name
+	-> LPat Id
+	-> CoreExpr
+	-> CoreExpr
+	-> DsM CoreExpr
+
+matchSinglePat
+	:: CoreExpr
+	-> HsMatchContext Name
+	-> LPat Id
+        -> TcType
+	-> MatchResult
+	-> DsM MatchResult
+\end{code}
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
new file mode 100644
index 0000000000..6ff502a8ae
--- /dev/null
+++ b/compiler/deSugar/MatchCon.lhs
@@ -0,0 +1,174 @@
+
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[MatchCon]{Pattern-matching constructors}
+
+\begin{code}
+module MatchCon ( matchConFamily ) where
+
+#include "HsVersions.h"
+
+import Id( idType )
+
+import {-# SOURCE #-} Match	( match )
+
+import HsSyn		( Pat(..), HsConDetails(..) )
+import DsBinds		( dsLHsBinds )
+import DataCon		( isVanillaDataCon, dataConInstOrigArgTys )
+import TcType		( tcTyConAppArgs )
+import Type		( mkTyVarTys )
+import CoreSyn
+import DsMonad
+import DsUtils
+
+import Id		( Id )
+import Type             ( Type )
+import ListSetOps	( equivClassesByUniq )
+import SrcLoc		( unLoc, Located(..) )
+import Unique		( Uniquable(..) )
+import Outputable
+\end{code}
+
+We are confronted with the first column of patterns in a set of
+equations, all beginning with constructors from one ``family'' (e.g.,
+@[]@ and @:@ make up the @List@ ``family'').  We want to generate the
+alternatives for a @Case@ expression.  There are several choices:
+\begin{enumerate}
+\item
+Generate an alternative for every constructor in the family, whether
+they are used in this set of equations or not; this is what the Wadler
+chapter does.
+\begin{description}
+\item[Advantages:]
+(a)~Simple.  (b)~It may also be that large sparsely-used constructor
+families are mainly handled by the code for literals.
+\item[Disadvantages:]
+(a)~Not practical for large sparsely-used constructor families, e.g.,
+the ASCII character set.  (b)~Have to look up a list of what
+constructors make up the whole family.
+\end{description}
+
+\item
+Generate an alternative for each constructor used, then add a default
+alternative in case some constructors in the family weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~Alternatives aren't generated for unused constructors.  (b)~The
+STG is quite happy with defaults.  (c)~No lookup in an environment needed.
+\item[Disadvantages:]
+(a)~A spurious default alternative may be generated.
+\end{description}
+
+\item
+``Do it right:'' generate an alternative for each constructor used,
+and add a default alternative if all constructors in the family
+weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~You will get cases with only one alternative (and no default),
+which should be amenable to optimisation.  Tuples are a common example.
+\item[Disadvantages:]
+(b)~Have to look up constructor families in TDE (as above).
+\end{description}
+\end{enumerate}
+
+We are implementing the ``do-it-right'' option for now.  The arguments
+to @matchConFamily@ are the same as to @match@; the extra @Int@
+returned is the number of constructors in the family.
+
+The function @matchConFamily@ is concerned with this
+have-we-used-all-the-constructors? question; the local function
+@match_cons_used@ does all the real work.
+\begin{code}
+matchConFamily :: [Id]
+               -> Type
+	       -> [EquationInfo]
+	       -> DsM MatchResult
+matchConFamily (var:vars) ty eqns_info
+  = let
+	-- Sort into equivalence classes by the unique on the constructor
+	-- All the EqnInfos should start with a ConPat
+	groups = equivClassesByUniq get_uniq eqns_info
+	get_uniq (EqnInfo { eqn_pats = ConPatOut (L _ data_con) _ _ _ _ _ : _}) = getUnique data_con
+
+	-- Get the wrapper from the head of each group.  We're going to
+	-- use it as the pattern in this case expression, so we need to 
+	-- ensure that any type variables it mentions in the pattern are
+	-- in scope.  So we put its wrappers outside the case, and
+	-- zap the wrapper for it. 
+	wraps :: [CoreExpr -> CoreExpr]
+	wraps = map (eqn_wrap . head) groups
+
+	groups' = [ eqn { eqn_wrap = idWrapper } : eqns | eqn:eqns <- groups ]
+    in
+	-- Now make a case alternative out of each group
+    mappM (match_con vars ty) groups'	`thenDs` \ alts ->
+    returnDs (adjustMatchResult (foldr (.) idWrapper wraps) $
+	      mkCoAlgCaseMatchResult var ty alts)
+\end{code}
+
+And here is the local function that does all the work.  It is
+more-or-less the @matchCon@/@matchClause@ functions on page~94 in
+Wadler's chapter in SLPJ.  The function @shift_con_pats@ does what the
+list comprehension in @matchClause@ (SLPJ, p.~94) does, except things
+are trickier in real life.  Works for @ConPats@, and we want it to
+fail catastrophically for anything else (which a list comprehension
+wouldn't).  Cf.~@shift_lit_pats@ in @MatchLits@.
+
+\begin{code}
+match_con vars ty eqns
+  = do	{ -- Make new vars for the con arguments; avoid new locals where possible
+	  arg_vars     <- selectMatchVars (map unLoc arg_pats1) arg_tys
+	; eqns'        <- mapM shift eqns 
+	; match_result <- match (arg_vars ++ vars) ty eqns'
+	; return (con, tvs1 ++ dicts1 ++ arg_vars, match_result) }
+  where
+    ConPatOut (L _ con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = firstPat (head eqns)
+
+    shift eqn@(EqnInfo { eqn_wrap = wrap, 
+		         eqn_pats = ConPatOut _ tvs ds bind (PrefixCon arg_pats) _ : pats })
+	= do { prs <- dsLHsBinds bind
+	     ; return (eqn { eqn_wrap = wrap . wrapBinds (tvs `zip` tvs1) 
+					     . wrapBinds (ds  `zip` dicts1)
+					     . mkDsLet (Rec prs),
+			     eqn_pats = map unLoc arg_pats ++ pats }) }
+
+     	-- Get the arg types, which we use to type the new vars
+	-- to match on, from the "outside"; the types of pats1 may 
+	-- be more refined, and hence won't do
+    arg_tys = dataConInstOrigArgTys con inst_tys
+    inst_tys | isVanillaDataCon con = tcTyConAppArgs pat_ty	-- Newtypes opaque!
+	     | otherwise	    = mkTyVarTys tvs1
+\end{code}
+
+Note [Existentials in shift_con_pat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+	data T = forall a. Ord a => T a (a->Int)
+
+	f (T x f) True  = ...expr1...
+	f (T y g) False = ...expr2..
+
+When we put in the tyvars etc we get
+
+	f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...
+	f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...
+
+After desugaring etc we'll get a single case:
+
+	f = \t::T b::Bool -> 
+	    case t of
+	       T a (d::Ord a) (x::a) (f::a->Int)) ->
+	    case b of
+		True  -> ...expr1...
+		False -> ...expr2...
+
+*** We have to substitute [a/b, d/e] in expr2! **
+Hence
+		False -> ....((/\b\(e:Ord b).expr2) a d)....
+
+Originally I tried to use 
+	(\b -> let e = d in expr2) a 
+to do this substitution.  While this is "correct" in a way, it fails
+Lint, because e::Ord b but d::Ord a.  
+
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
new file mode 100644
index 0000000000..0b7907b22e
--- /dev/null
+++ b/compiler/deSugar/MatchLit.lhs
@@ -0,0 +1,329 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[MatchLit]{Pattern-matching literal patterns}
+
+\begin{code}
+module MatchLit ( dsLit, dsOverLit,
+		  tidyLitPat, tidyNPat,
+		  matchLiterals, matchNPlusKPats, matchNPats ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} Match  ( match )
+import {-# SOURCE #-} DsExpr ( dsExpr )
+
+import DsMonad
+import DsUtils
+
+import HsSyn
+import Id		( Id, idType )
+import CoreSyn
+import TyCon		( tyConDataCons )
+import TcType		( tcSplitTyConApp, isIntegerTy, isIntTy, 
+			  isFloatTy, isDoubleTy, isStringTy )
+import Type		( Type )
+import PrelNames	( ratioTyConKey )
+import TysWiredIn	( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
+import PrelNames	( eqStringName )
+import Unique		( hasKey )
+import Literal		( mkMachInt, Literal(..) )
+import SrcLoc		( noLoc )
+import ListSetOps	( equivClasses, runs )
+import Ratio 		( numerator, denominator )
+import SrcLoc		( Located(..) )
+import Outputable
+import FastString	( lengthFS, unpackFS )
+\end{code}
+
+%************************************************************************
+%*									*
+		Desugaring literals
+	[used to be in DsExpr, but DsMeta needs it,
+	 and it's nice to avoid a loop]
+%*									*
+%************************************************************************
+
+We give int/float literals type @Integer@ and @Rational@, respectively.
+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
+around them.
+
+ToDo: put in range checks for when converting ``@i@''
+(or should that be in the typechecker?)
+
+For numeric literals, we try to detect there use at a standard type
+(@Int@, @Float@, etc.) are directly put in the right constructor.
+[NB: down with the @App@ conversion.]
+
+See also below where we look for @DictApps@ for \tr{plusInt}, etc.
+
+\begin{code}
+dsLit :: HsLit -> DsM CoreExpr
+dsLit (HsChar c)       = returnDs (mkCharExpr c)
+dsLit (HsCharPrim c)   = returnDs (mkLit (MachChar c))
+dsLit (HsString str)   = mkStringExprFS str
+dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
+dsLit (HsInteger i _)  = mkIntegerExpr i
+dsLit (HsInt i)	       = returnDs (mkIntExpr i)
+dsLit (HsIntPrim i)    = returnDs (mkIntLit i)
+dsLit (HsFloatPrim f)  = returnDs (mkLit (MachFloat f))
+dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
+
+dsLit (HsRat r ty)
+  = mkIntegerExpr (numerator r)		`thenDs` \ num ->
+    mkIntegerExpr (denominator r)	`thenDs` \ denom ->
+    returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
+  where
+    (ratio_data_con, integer_ty) 
+	= case tcSplitTyConApp ty of
+		(tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+				   (head (tyConDataCons tycon), i_ty)
+
+dsOverLit :: HsOverLit Id -> DsM CoreExpr
+-- Post-typechecker, the SyntaxExpr field of an OverLit contains 
+-- (an expression for) the literal value itself
+dsOverLit (HsIntegral   _ lit) = dsExpr lit
+dsOverLit (HsFractional _ lit) = dsExpr lit
+\end{code}
+
+%************************************************************************
+%*									*
+	Tidying lit pats
+%*									*
+%************************************************************************
+
+\begin{code}
+tidyLitPat :: HsLit -> LPat Id -> LPat Id
+-- Result has only the following HsLits:
+--	HsIntPrim, HsCharPrim, HsFloatPrim
+--	HsDoublePrim, HsStringPrim, HsString
+--  * HsInteger, HsRat, HsInt can't show up in LitPats
+--  * We get rid of HsChar right here
+tidyLitPat (HsChar c) pat = mkCharLitPat c
+tidyLitPat (HsString s) pat
+  | lengthFS s <= 1	-- Short string literals only
+  = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
+	  (mkNilPat stringTy) (unpackFS s)
+	-- The stringTy is the type of the whole pattern, not 
+	-- the type to instantiate (:) or [] with!
+tidyLitPat lit	      pat = pat
+
+----------------
+tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> LPat Id -> LPat Id
+tidyNPat over_lit mb_neg lit_ty default_pat
+  | isIntTy    lit_ty = mk_con_pat intDataCon    (HsIntPrim int_val)
+  | isFloatTy  lit_ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
+  | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
+  | otherwise	      = default_pat
+  where
+    mk_con_pat con lit = mkPrefixConPat con [noLoc $ LitPat lit] lit_ty 
+    neg_lit = case (mb_neg, over_lit) of
+		(Nothing, 	       _)   -> over_lit
+		(Just _,  HsIntegral i s)   -> HsIntegral   (-i) s
+		(Just _,  HsFractional f s) -> HsFractional (-f) s
+			     
+    int_val :: Integer
+    int_val = case neg_lit of
+		HsIntegral   i _ -> i
+		HsFractional f _ -> panic "tidyNPat"
+	
+    rat_val :: Rational
+    rat_val = case neg_lit of
+		HsIntegral   i _ -> fromInteger i
+		HsFractional f _ -> f
+\end{code}
+
+
+%************************************************************************
+%*									*
+		Pattern matching on LitPat
+%*									*
+%************************************************************************
+
+\begin{code}
+matchLiterals :: [Id]
+	      -> Type	-- Type of the whole case expression
+	      -> [EquationInfo]
+	      -> DsM MatchResult
+-- All the EquationInfos have LitPats at the front
+
+matchLiterals (var:vars) ty eqns
+  = do	{	-- Group by literal
+	  let groups :: [[(Literal, EquationInfo)]]
+	      groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
+
+		-- Deal with each group
+	; alts <- mapM match_group groups
+
+	 	-- Combine results.  For everything except String
+		-- we can use a case expression; for String we need
+		-- a chain of if-then-else
+	; if isStringTy (idType var) then
+	    do	{ mrs <- mapM wrap_str_guard alts
+		; return (foldr1 combineMatchResults mrs) }
+	  else 
+	    return (mkCoPrimCaseMatchResult var ty alts)
+	}
+  where
+    match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
+    match_group group
+	= do { let (lits, eqns) = unzip group
+	     ; match_result <- match vars ty (shiftEqns eqns)
+	     ; return (head lits, match_result) }
+
+    wrap_str_guard :: (Literal,MatchResult) -> DsM MatchResult
+	-- Equality check for string literals
+    wrap_str_guard (MachStr s, mr)
+	= do { eq_str <- dsLookupGlobalId eqStringName
+	     ; lit    <- mkStringExprFS s
+	     ; let pred = mkApps (Var eq_str) [Var var, lit]
+	     ; return (mkGuardedMatchResult pred mr) }
+\end{code}
+
+%************************************************************************
+%*									*
+		Pattern matching on NPat
+%*									*
+%************************************************************************
+
+\begin{code}
+matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- All the EquationInfos have NPat at the front
+
+matchNPats (var:vars) ty eqns
+  = do {  let groups :: [[(Literal, EquationInfo)]]
+	      groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
+
+	; match_results <- mapM (match_group . map snd) groups
+
+	; ASSERT( not (null match_results) )
+	  return (foldr1 combineMatchResults match_results) }
+  where
+    match_group :: [EquationInfo] -> DsM MatchResult
+    match_group (eqn1:eqns)
+	= do { lit_expr <- dsOverLit lit
+	     ; neg_lit <- case mb_neg of
+			    Nothing -> return lit_expr
+			    Just neg -> do { neg_expr <- dsExpr neg
+					   ; return (App neg_expr lit_expr) }
+	     ; eq_expr <- dsExpr eq_chk
+	     ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
+	     ; match_result <- match vars ty (eqn1' : shiftEqns eqns)
+	     ; return (adjustMatchResult (eqn_wrap eqn1) $
+			-- Bring the eqn1 wrapper stuff into scope because
+			-- it may be used in pred_expr
+		       mkGuardedMatchResult pred_expr match_result) }
+	where
+	  NPat lit mb_neg eq_chk _ : pats1 = eqn_pats eqn1
+	  eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
+\end{code}
+
+
+%************************************************************************
+%*									*
+		Pattern matching on n+k patterns
+%*									*
+%************************************************************************
+
+For an n+k pattern, we use the various magic expressions we've been given.
+We generate:
+\begin{verbatim}
+    if ge var lit then
+	let n = sub var lit
+	in  <expr-for-a-successful-match>
+    else
+	<try-next-pattern-or-whatever>
+\end{verbatim}
+
+WATCH OUT!  Consider
+
+	f (n+1) = ...
+	f (n+2) = ...
+	f (n+1) = ...
+
+We can't group the first and third together, because the second may match 
+the same thing as the first.  Contrast
+	f 1 = ...
+	f 2 = ...
+	f 1 = ...
+where we can group the first and third.  Hence 'runs' rather than 'equivClasses'
+
+\begin{code}
+matchNPlusKPats all_vars@(var:vars) ty eqns
+  = do {  let groups :: [[(Literal, EquationInfo)]]
+	      groups = runs eqTaggedEqn (tagLitEqns eqns)
+
+	; match_results <- mapM (match_group . map snd) groups
+
+	; ASSERT( not (null match_results) )
+	  return (foldr1 combineMatchResults match_results) }
+  where
+    match_group :: [EquationInfo] -> DsM MatchResult
+    match_group (eqn1:eqns)
+	= do { ge_expr     <- dsExpr ge
+	     ; minus_expr  <- dsExpr minus
+	     ; lit_expr    <- dsOverLit lit
+	     ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
+		   minusk_expr = mkApps minus_expr [Var var, lit_expr]
+	     ; match_result <- match vars ty (eqn1' : map shift eqns)
+	     ; return  (adjustMatchResult (eqn_wrap eqn1) 	     $
+			-- Bring the eqn1 wrapper stuff into scope because
+			-- it may be used in ge_expr, minusk_expr
+		        mkGuardedMatchResult pred_expr 		    $
+			mkCoLetMatchResult (NonRec n1 minusk_expr)  $
+			match_result) }
+	where
+	  NPlusKPat (L _ n1) lit ge minus : pats1 = eqn_pats eqn1
+	  eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
+
+	  shift eqn@(EqnInfo { eqn_wrap = wrap,
+			       eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
+	    = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }  
+\end{code}
+
+
+%************************************************************************
+%*									*
+		Grouping functions
+%*									*
+%************************************************************************
+
+Given a blob of @LitPat@s/@NPat@s, we want to split them into those
+that are ``same''/different as one we are looking at.  We need to know
+whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
+
+\begin{code}
+-- Tag equations by the leading literal
+-- NB: we have ordering on Core Literals, but not on HsLits
+cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
+cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
+
+eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
+eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
+
+tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
+tagLitEqns eqns = [(get_lit (firstPat eqn), eqn) | eqn <- eqns]
+
+get_lit :: Pat Id -> Literal
+-- Get a Core literal to use (only) a grouping key
+-- Hence its type doesn't need to match the type of the original literal
+get_lit (LitPat (HsIntPrim     i)) = mkMachInt  i
+get_lit (LitPat (HsCharPrim    c)) = MachChar   c
+get_lit (LitPat (HsStringPrim  s)) = MachStr    s
+get_lit (LitPat (HsFloatPrim   f)) = MachFloat  f
+get_lit (LitPat (HsDoublePrim  d)) = MachDouble d
+get_lit (LitPat (HsString s))	   = MachStr    s
+
+get_lit (NPat (HsIntegral i _) Nothing  _ _)   = MachInt i
+get_lit (NPat (HsIntegral i _) (Just _) _ _)   = MachInt (-i)
+get_lit (NPat (HsFractional r _) Nothing  _ _) = MachFloat r
+get_lit (NPat (HsFractional r _) (Just _) _ _) = MachFloat (-r)
+
+get_lit (NPlusKPat _ (HsIntegral i _) _ _) = MachInt i
+
+-- These ones can't happen
+-- get_lit (LitPat (HsChar c))
+-- get_lit (LitPat (HsInt i))	
+get_lit other = pprPanic "get_lit:bad pattern" (ppr other)
+\end{code}
+
diff --git a/compiler/deSugar/deSugar.tex b/compiler/deSugar/deSugar.tex
new file mode 100644
index 0000000000..02cb285742
--- /dev/null
+++ b/compiler/deSugar/deSugar.tex
@@ -0,0 +1,23 @@
+\documentstyle{report}
+\input{lit-style}
+
+\begin{document}
+\centerline{{\Large{deSugar}}}
+\tableofcontents
+
+\input{Desugar}    % {@deSugar@: the main function}
+\input{DsBinds}    % {Pattern-matching bindings (HsBinds and MonoBinds)}
+\input{DsGRHSs}    % {Matching guarded right-hand-sides (GRHSs)}
+\input{DsExpr}     % {Matching expressions (Exprs)}
+\input{DsHsSyn}    % {Haskell abstract syntax---added things for desugarer}
+\input{DsListComp} % {Desugaring list comprehensions}
+\input{DsMonad}    % {@DsMonad@: monadery used in desugaring}
+\input{DsUtils}    % {Utilities for desugaring}
+\input{Check}      % {Module @Check@ in @deSugar@}
+\input{Match}      % {The @match@ function}
+\input{MatchCon}   % {Pattern-matching constructors}
+\input{MatchLit}   % {Pattern-matching literal patterns}
+\input{DsForeign}  % {Desugaring \tr{foreign} declarations}
+\input{DsCCall}    % {Desugaring \tr{_ccall_}s and \tr{_casm_}s}
+
+\end{document}