[project @ 2004-11-26 16:19:45 by simonmar]

[ghc-hetmet.git] / ghc / compiler / parser / RdrHsSyn.lhs

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 3761f74..236d538 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -1,23 +1,16 @@
 %
 %

-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
+% (c) The University of Glasgow, 1996-2003

 
 

-(Well, really, for specialisations involving @RdrName@s, even if
-they are used somewhat later on in the compiler...)
+Functions over HsSyn specialised to RdrName.

 
 \begin{code}
 module RdrHsSyn (
 
 \begin{code}
 module RdrHsSyn (

-       RdrBinding(..),
-
-       main_RDR_Unqual,
-

        extractHsTyRdrTyVars, 
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
        mkHsOpApp, mkClassDecl, 
        mkHsNegApp, mkHsIntegral, mkHsFractional,
        extractHsTyRdrTyVars, 
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
        mkHsOpApp, mkClassDecl, 
        mkHsNegApp, mkHsIntegral, mkHsFractional,

-       mkHsDo, mkHsSplice, mkSigDecls,
+       mkHsDo, mkHsSplice,

         mkTyData, mkPrefixCon, mkRecCon,
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
        mkBootIface,
         mkTyData, mkPrefixCon, mkRecCon,
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
        mkBootIface,

@@ -57,25 +50,25 @@ module RdrHsSyn (
 
 import HsSyn           -- Lots of it
 import IfaceType
 
 import HsSyn           -- Lots of it
 import IfaceType

-import HscTypes                ( ModIface(..), emptyModIface, mkIfaceVerCache )
-import IfaceSyn                ( IfaceDecl(..), IfaceIdInfo(..) )
+import HscTypes                ( ModIface(..), emptyModIface, mkIfaceVerCache,
+                         IfacePackage(..) )
+import IfaceSyn                ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )

 import RdrName         ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, 
                          isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
                          setRdrNameSpace, rdrNameModule )
 import BasicTypes      ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
 import Lexer           ( P, failSpanMsgP )
 import RdrName         ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, 
                          isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
                          setRdrNameSpace, rdrNameModule )
 import BasicTypes      ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
 import Lexer           ( P, failSpanMsgP )

+import Kind            ( liftedTypeKind )

 import HscTypes                ( GenAvailInfo(..) )
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall     ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
 import HscTypes                ( GenAvailInfo(..) )
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall     ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),

-                         DNCallSpec(..), DNKind(..))
+                         DNCallSpec(..), DNKind(..), CLabelString )

 import OccName         ( OccName, srcDataName, varName, isDataOcc, isTcOcc, 
                          occNameUserString, isValOcc )
 import OccName         ( OccName, srcDataName, varName, isDataOcc, isTcOcc, 
                          occNameUserString, isValOcc )

-import BasicTypes      ( initialVersion )
-import TyCon           ( DataConDetails(..) )
-import Module          ( ModuleName )
+import BasicTypes      ( initialVersion, StrictnessMark(..) )
+import Module          ( Module )

 import SrcLoc
 import SrcLoc

-import CStrings                ( CLabelString )
-import CmdLineOpts     ( opt_InPackage )
+import OrdList         ( OrdList, fromOL )

 import Bag             ( Bag, emptyBag, snocBag, consBag, foldrBag )
 import Outputable
 import FastString
 import Bag             ( Bag, emptyBag, snocBag, consBag, foldrBag )
 import Outputable
 import FastString

@@ -84,19 +77,6 @@ import Panic
 import List            ( isSuffixOf, nubBy )
 \end{code}
 
 import List            ( isSuffixOf, nubBy )
 \end{code}
 

- 
-%************************************************************************
-%*                                                                     *
-\subsection{Type synonyms}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-main_RDR_Unqual :: RdrName
-main_RDR_Unqual = mkUnqual varName FSLIT("main")
-       -- We definitely don't want an Orig RdrName, because
-       -- main might, in principle, be imported into module Main
-\end{code}

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -104,7 +84,7 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main")
 %*                                                                    *
 %************************************************************************
 
 %*                                                                    *
 %************************************************************************
 

-@extractHsTyRdrNames@ finds the free variables of a HsType
+extractHsTyRdrNames finds the free variables of a HsType

 It's used when making the for-alls explicit.
 
 \begin{code}
 It's used when making the for-alls explicit.
 
 \begin{code}

@@ -127,15 +107,17 @@ extract_lty (L loc (HsTyVar tv)) acc
   | otherwise = acc
 extract_lty ty acc = extract_ty (unLoc ty) acc
 
   | otherwise = acc
 extract_lty ty acc = extract_ty (unLoc ty) acc
 

+extract_ty (HsBangTy _ ty)           acc = extract_lty ty acc

 extract_ty (HsAppTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)
 extract_ty (HsListTy ty)             acc = extract_lty ty acc
 extract_ty (HsPArrTy ty)             acc = extract_lty ty acc
 extract_ty (HsTupleTy _ tys)         acc = foldr extract_lty acc tys
 extract_ty (HsFunTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)
 extract_ty (HsAppTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)
 extract_ty (HsListTy ty)             acc = extract_lty ty acc
 extract_ty (HsPArrTy ty)             acc = extract_lty ty acc
 extract_ty (HsTupleTy _ tys)         acc = foldr extract_lty acc tys
 extract_ty (HsFunTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)

-extract_ty (HsPredTy p)                     acc = extract_pred (unLoc p) acc
+extract_ty (HsPredTy p)                     acc = extract_pred p acc

 extract_ty (HsOpTy ty1 nam ty2)      acc = extract_lty ty1 (extract_lty ty2 acc)
 extract_ty (HsParTy ty)              acc = extract_lty ty acc
 extract_ty (HsNumTy num)             acc = acc
 extract_ty (HsOpTy ty1 nam ty2)      acc = extract_lty ty1 (extract_lty ty2 acc)
 extract_ty (HsParTy ty)              acc = extract_lty ty acc
 extract_ty (HsNumTy num)             acc = acc

+extract_ty (HsSpliceTy _)            acc = acc -- Type splices mention no type variables

 extract_ty (HsKindSig ty k)         acc = extract_lty ty acc
 extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
 extract_ty (HsForAllTy exp tvs cx ty) 
 extract_ty (HsKindSig ty k)         acc = extract_lty ty acc
 extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
 extract_ty (HsForAllTy exp tvs cx ty) 

@@ -150,8 +132,8 @@ extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
 extractGenericPatTyVars binds
   = nubBy eqLocated (foldrBag get [] binds)
   where
 extractGenericPatTyVars binds
   = nubBy eqLocated (foldrBag get [] binds)
   where

-    get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms
-    get other                 acc = acc
+    get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms
+    get other                                acc = acc

 
     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
     get_m other                                           acc = acc
 
     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
     get_m other                                           acc = acc

@@ -179,13 +161,13 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
                tcdFDs = fds,  
                tcdSigs = sigs,
   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
                tcdFDs = fds,  
                tcdSigs = sigs,

-               tcdMeths = mbinds,
+               tcdMeths = mbinds

                }
 
                }
 

-mkTyData new_or_data (context, tname, tyvars) data_cons maybe
+mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv

   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
             tcdTyVars = tyvars,  tcdCons = data_cons, 
   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
             tcdTyVars = tyvars,  tcdCons = data_cons, 

-            tcdDerivs = maybe }
+            tcdKindSig = ksig, tcdDerivs = maybe_deriv }

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -206,9 +188,11 @@ mkHsNegApp (L loc e) = f e
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-mkBootIface, and its boring helper functions, have two purposes:
+mkBootIface, and its deeply boring helper functions, have two purposes:
+

 a) HsSyn to IfaceSyn.  The parser parses the former, but we're reading
        an hi-boot file, and interfaces consist of the latter
 a) HsSyn to IfaceSyn.  The parser parses the former, but we're reading
        an hi-boot file, and interfaces consist of the latter

+

 b) Convert unqualifed names from the "current module" to qualified Orig
    names.  E.g.
        module This where
 b) Convert unqualifed names from the "current module" to qualified Orig
    names.  E.g.
        module This where

@@ -216,14 +200,18 @@ b) Convert unqualifed names from the "current module" to qualified Orig
    becomes
         This.foo :: GHC.Base.Int -> GHC.Base.Int
 
    becomes
         This.foo :: GHC.Base.Int -> GHC.Base.Int
 

-It assumes that everything is well kinded, of course.
+It assumes that everything is well kinded, of course.  Failure causes a
+fatal error using pgmError, rather than a monadic error.  You're supposed
+to get hi-boot files right!
+

 
 \begin{code}
 
 \begin{code}

-mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
+mkBootIface :: Module -> [HsDecl RdrName] -> ModIface

 -- Make the ModIface for a hi-boot file
 -- The decls are of very limited form
 -- Make the ModIface for a hi-boot file
 -- The decls are of very limited form

+-- The package will be filled in later (see LoadIface.readIface)

 mkBootIface mod decls
 mkBootIface mod decls

-  = (emptyModIface opt_InPackage mod) {
+  = (emptyModIface ThisPackage{-fill in later-} mod) {

        mi_boot     = True,
        mi_exports  = [(mod, map mk_export decls')],
        mi_decls    = decls_w_vers,
        mi_boot     = True,
        mi_exports  = [(mod, map mk_export decls')],
        mi_decls    = decls_w_vers,

@@ -252,6 +240,14 @@ hsIfaceDecl (SigD (Sig name ty))
              ifType = hsIfaceLType ty,
              ifIdInfo = NoInfo }
 
              ifType = hsIfaceLType ty,
              ifIdInfo = NoInfo }
 

+hsIfaceDecl (TyClD decl@(ClassDecl {}))
+  = IfaceClass { ifName = rdrNameOcc (tcdName decl), 
+                ifTyVars = hsIfaceTvs (tcdTyVars decl), 
+                ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
+                ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
+                ifSigs = [],   -- Is this right??
+                ifRec = NonRecursive, ifVrcs = [] }
+

 hsIfaceDecl (TyClD decl@(TySynonym {}))
   = IfaceSyn { ifName = rdrNameOcc (tcdName decl), 
               ifTyVars = hsIfaceTvs (tcdTyVars decl), 
 hsIfaceDecl (TyClD decl@(TySynonym {}))
   = IfaceSyn { ifName = rdrNameOcc (tcdName decl), 
               ifTyVars = hsIfaceTvs (tcdTyVars decl), 

@@ -259,24 +255,69 @@ hsIfaceDecl (TyClD decl@(TySynonym {}))
               ifVrcs = [] } 
 
 hsIfaceDecl (TyClD decl@(TyData {}))
               ifVrcs = [] } 
 
 hsIfaceDecl (TyClD decl@(TyData {}))

-  = IfaceData { ifND = tcdND decl, 
-               ifName = rdrNameOcc (tcdName decl), 
-               ifTyVars = hsIfaceTvs (tcdTyVars decl), 
-               ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
-               ifCons = Unknown, ifRec = NonRecursive,
+  = IfaceData { ifName = rdrNameOcc (tcdName decl), 
+               ifTyVars = tvs,
+               ifCons = hsIfaceCons tvs decl,
+               ifRec = Recursive,      -- Hi-boot decls are always loop-breakers

                ifVrcs = [], ifGeneric = False }
        -- I'm not sure that [] is right for ifVrcs, but
        -- since we don't use them I'm not going to fiddle
                ifVrcs = [], ifGeneric = False }
        -- I'm not sure that [] is right for ifVrcs, but
        -- since we don't use them I'm not going to fiddle

-
-hsIfaceDecl (TyClD decl@(ClassDecl {}))
-  = IfaceClass { ifName = rdrNameOcc (tcdName decl), 
-                ifTyVars = hsIfaceTvs (tcdTyVars decl), 
-                ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
-                ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
-                ifSigs = [],   -- Is this right??
-                ifRec = NonRecursive, ifVrcs = [] }
-
-hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
+  where
+    tvs = hsIfaceTvs (tcdTyVars decl)
+
+hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
+
+hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls
+hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt})
+  | not (null stupid_ctxt)     -- Keep it simple: no data type contexts
+                               -- Else we'll have to do "thinning"; sigh
+  = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl)
+
+hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []})
+  =    -- data T a, meaning "constructors unspecified", 
+    IfAbstractTyCon            -- not "no constructors"
+
+hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons})
+  = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons)
+
+hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]})
+  = IfNewTyCon (hsIfaceCon tvs (unLoc con))
+
+hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
+
+
+hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl
+hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details)
+  | null ex_tvs && null (unLoc ex_ctxt)
+  = IfVanillaCon { ifConOcc = get_occ lname,
+                  ifConInfix = is_infix,
+                  ifConArgTys = map hsIfaceLType args,
+                  ifConStricts = map (hsStrictMark . getBangStrictness) args,
+                  ifConFields = flds }
+  | null flds
+  = IfGadtCon    { ifConOcc = get_occ lname,
+                  ifConTyVars = tvs ++ hsIfaceTvs ex_tvs,
+                  ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt),
+                  ifConArgTys = map hsIfaceLType args,
+                  ifConResTys = map (IfaceTyVar . fst) tvs,
+                  ifConStricts = map (hsStrictMark . getBangStrictness) args }
+  | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname))
+  where
+    (is_infix, args, flds) = case details of
+                               PrefixCon args -> (False, args, [])
+                               InfixCon a1 a2 -> (True, [a1,a2], [])
+                               RecCon fs      -> (False, map snd fs, map (get_occ . fst) fs)
+    get_occ lname = rdrNameOcc (unLoc lname)
+
+hsIfaceCon _tvs (GadtDecl lname con_ty)        -- Not yet
+  = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname))
+
+hsStrictMark :: HsBang -> StrictnessMark
+-- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
+--         but in an hi-boot file it's interpreted as the Truth!
+hsStrictMark HsNoBang = NotMarkedStrict
+hsStrictMark HsStrict = MarkedStrict
+hsStrictMark HsUnbox  = MarkedUnboxed

 
 hsIfaceName rdr_name   -- Qualify unqualifed occurrences
                                -- with the module name
 
 hsIfaceName rdr_name   -- Qualify unqualifed occurrences
                                -- with the module name

@@ -304,9 +345,11 @@ hsIfaceType (HsPArrTy t)       = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
 hsIfaceType (HsTupleTy bx ts)  = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
 hsIfaceType (HsOpTy t1 tc t2)  = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
 hsIfaceType (HsParTy t)               = hsIfaceLType t
 hsIfaceType (HsTupleTy bx ts)  = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
 hsIfaceType (HsOpTy t1 tc t2)  = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
 hsIfaceType (HsParTy t)               = hsIfaceLType t

-hsIfaceType (HsNumTy n)               = panic "hsIfaceType:HsNum"
-hsIfaceType (HsPredTy p)       = IfacePredTy (hsIfaceLPred p)
+hsIfaceType (HsBangTy _ t)     = hsIfaceLType t
+hsIfaceType (HsPredTy p)       = IfacePredTy (hsIfacePred p)

 hsIfaceType (HsKindSig t _)    = hsIfaceLType t
 hsIfaceType (HsKindSig t _)    = hsIfaceLType t

+hsIfaceType ty                = pprPanic "hsIfaceType" (ppr ty)
+                               -- HsNumTy, HsSpliceTy

 
 -----------
 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
 
 -----------
 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys

@@ -332,11 +375,12 @@ hs_tc_app (HsTyVar n) args
 hs_tc_app ty args         = foldl IfaceAppTy (hsIfaceType ty) args
 
 -----------
 hs_tc_app ty args         = foldl IfaceAppTy (hsIfaceType ty) args
 
 -----------

+hsIfaceTvs :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr]

 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
 
 -----------
 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
 
 -----------

-hsIfaceTv (UserTyVar n)     = (rdrNameOcc n, IfaceLiftedTypeKind)
-hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)
+hsIfaceTv (UserTyVar n)     = (rdrNameOcc n, liftedTypeKind)
+hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)

 
 -----------
 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
 
 -----------
 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]

@@ -344,25 +388,6 @@ hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
                 | (xs,ys) <- fds ]
 \end{code}
 
                 | (xs,ys) <- fds ]
 \end{code}
 

-
-%************************************************************************
-%*                                                                     *
-\subsection[rdrBinding]{Bindings straight out of the parser}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-data RdrBinding
-  =   -- Value bindings havn't been united with their
-      -- signatures yet
-    RdrBindings [RdrBinding]   -- Convenience for parsing
-
-  | RdrValBinding     (LHsBind RdrName)
-
-      -- The remainder all fit into the main HsDecl form
-  | RdrHsDecl         (LHsDecl RdrName)
-\end{code}
-

 %************************************************************************
 %*                                                                     *
 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
 %************************************************************************
 %*                                                                     *
 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}

@@ -375,44 +400,39 @@ analyser.
 
 
 \begin{code}
 
 
 \begin{code}

-cvTopDecls :: [RdrBinding] -> [LHsDecl RdrName]
--- Incoming bindings are in reverse order; result is in ordinary order
--- (a) flatten RdrBindings
--- (b) Group together bindings for a single function
-cvTopDecls decls
-  = go [] decls
+-- | Groups together bindings for a single function
+cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
+cvTopDecls decls = go (fromOL decls)

   where
   where

-    go :: [LHsDecl RdrName] -> [RdrBinding] -> [LHsDecl RdrName]
-    go acc []                     = acc
-    go acc (RdrBindings ds1 : ds2) = go (go acc ds1)    ds2
-    go acc (RdrHsDecl d : ds)      = go (d       : acc) ds
-    go acc (RdrValBinding b : ds)  = go (L l (ValD b') : acc) ds'
-                                  where
-                                    (L l b', ds') = getMonoBind b ds
-
-cvBindGroup :: [RdrBinding] -> HsBindGroup RdrName
+    go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
+    go []                  = []
+    go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
+                           where (L l' b', ds') = getMonoBind (L l b) ds
+    go (d : ds)            = d : go ds
+
+cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName

 cvBindGroup binding
   = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
     HsBindGroup mbs sigs Recursive -- just one big group for now
     }
 
 cvBindGroup binding
   = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
     HsBindGroup mbs sigs Recursive -- just one big group for now
     }
 

-cvBindsAndSigs :: [RdrBinding] -> (Bag (LHsBind RdrName), [LSig RdrName])
--- Input bindings are in *reverse* order, 
--- and contain just value bindings and signatures
-cvBindsAndSigs  fb
-  = go (emptyBag, []) fb
+cvBindsAndSigs :: OrdList (LHsDecl RdrName)
+  -> (Bag (LHsBind RdrName), [LSig RdrName])
+-- Input decls contain just value bindings and signatures
+cvBindsAndSigs  fb = go (fromOL fb)

   where
   where

-    go acc     []                        = acc
-    go acc     (RdrBindings ds1 : ds2)   = go (go acc ds1) ds2
-    go (bs, ss) (RdrHsDecl (L l (SigD s)) : ds) = go (bs, L l s : ss) ds
-    go (bs, ss) (RdrValBinding b : ds)    = go (b' `consBag` bs, ss) ds'
-                                         where
-                                           (b',ds') = getMonoBind b ds
+    go []                 = (emptyBag, [])
+    go (L l (SigD s) : ds) = (bs, L l s : ss)
+                           where (bs,ss) = go ds
+    go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
+                           where (b',ds') = getMonoBind (L l b) ds
+                                 (bs,ss)  = go ds'

 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups
 
 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups
 

-getMonoBind :: LHsBind RdrName -> [RdrBinding] -> (LHsBind RdrName, [RdrBinding])
+getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
+  -> (LHsBind RdrName, [LHsDecl RdrName])

 -- Suppose     (b',ds') = getMonoBind b ds
 --     ds is a *reversed* list of parsed bindings
 --     b is a MonoBinds that has just been read off the front
 -- Suppose     (b',ds') = getMonoBind b ds
 --     ds is a *reversed* list of parsed bindings
 --     b is a MonoBinds that has just been read off the front

@@ -423,16 +443,17 @@ getMonoBind :: LHsBind RdrName -> [RdrBinding] -> (LHsBind RdrName, [RdrBinding]
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 

-getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
+-- gaw 2004
+getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds

   | has_args mtchs
   = go mtchs loc binds
   where
   | has_args mtchs
   = go mtchs loc binds
   where

-    go mtchs1 loc1 (RdrValBinding (L loc2 (FunBind f2 inf2 mtchs2)) : binds)
-       | f == unLoc f2 = go (mtchs2 ++ mtchs1) loc binds
-       -- Remember binds is reversed, so glue mtchs2 on the front
-       -- and use loc2 as the final location
+    go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds)
+       | f == unLoc f2 = go (mtchs2++mtchs1) loc binds

        where loc = combineSrcSpans loc1 loc2
        where loc = combineSrcSpans loc1 loc2

-    go mtchs1 loc binds = (L loc (FunBind lf inf mtchs1), binds)
+    go mtchs1 loc binds
+       = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds)
+       -- reverse the final matches, to get it back in the right order

 
 getMonoBind bind binds = (bind, binds)
 
 
 getMonoBind bind binds = (bind, binds)
 

@@ -465,7 +486,7 @@ addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]
        -- This stuff reverses the declarations (again) but it doesn't matter
 
 -- Base cases
        -- This stuff reverses the declarations (again) but it doesn't matter
 
 -- Base cases

-addl gp []                = (gp, Nothing)
+addl gp []          = (gp, Nothing)

 addl gp (L l d : ds) = add gp l d ds
 
 
 addl gp (L l d : ds) = add gp l d ds
 
 

@@ -529,7 +550,7 @@ mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 mkPrefixCon ty tys
  = split ty tys
  where
 mkPrefixCon ty tys
  = split ty tys
  where

-   split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
+   split (L _ (HsAppTy t u)) ts = split t (u : ts)

    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
                                     return (data_con, PrefixCon ts)
    split (L l _) _             = parseError l "parse error in data/newtype declaration"
    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
                                     return (data_con, PrefixCon ts)
    split (L l _) _             = parseError l "parse error in data/newtype declaration"

@@ -628,7 +649,7 @@ checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 -- Watch out.. in ...deriving( Show )... we use checkPred on 
 -- the list of partially applied predicates in the deriving,
 -- so there can be zero args.
 -- Watch out.. in ...deriving( Show )... we use checkPred on 
 -- the list of partially applied predicates in the deriving,
 -- so there can be zero args.

-checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) )
+checkPred (L spn (HsPredTy (HsIParam n ty)))

   = return (L spn (HsIParam n ty))
 checkPred (L spn ty)
   = check spn ty []
   = return (L spn (HsIParam n ty))
 checkPred (L spn ty)
   = check spn ty []

@@ -644,8 +665,8 @@ checkPred (L spn ty)
 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 checkDictTy (L spn ty) = check ty []
   where
 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 checkDictTy (L spn ty) = check ty []
   where

-  check (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
-       = return (L spn (HsPredTy (L spn (HsClassP t args))))
+  check (HsTyVar t) args | not (isRdrTyVar t) 
+       = return (L spn (HsPredTy (HsClassP t args)))

   check (HsAppTy l r) args = check (unLoc l) (r:args)
   check (HsParTy t)   args = check (unLoc t) args
   check _ _ = parseError spn "Malformed context in instance header"
   check (HsAppTy l r) args = check (unLoc l) (r:args)
   check (HsParTy t)   args = check (unLoc t) args
   check _ _ = parseError spn "Malformed context in instance header"

@@ -757,8 +778,6 @@ checkAPat loc e = case e of
    HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc
 
    HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc
 

-checkAPat loc _ = patFail loc
-

 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 checkPatField (n,e) = do
   p <- checkLPat e
 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 checkPatField (n,e) = do
   p <- checkLPat e

@@ -773,20 +792,22 @@ patFail loc = parseError loc "Parse error in pattern"
 checkValDef 
        :: LHsExpr RdrName
        -> Maybe (LHsType RdrName)
 checkValDef 
        :: LHsExpr RdrName
        -> Maybe (LHsType RdrName)

-       -> GRHSs RdrName
+       -> Located (GRHSs RdrName)

        -> P (HsBind RdrName)
 
        -> P (HsBind RdrName)
 

-checkValDef lhs opt_sig grhss
+checkValDef lhs opt_sig (L rhs_span grhss)

   | Just (f,inf,es)  <- isFunLhs lhs []
   = if isQual (unLoc f)
        then parseError (getLoc f) ("Qualified name in function definition: "  ++ 
                                        showRdrName (unLoc f))
        else do ps <- checkPatterns es
   | Just (f,inf,es)  <- isFunLhs lhs []
   = if isQual (unLoc f)
        then parseError (getLoc f) ("Qualified name in function definition: "  ++ 
                                        showRdrName (unLoc f))
        else do ps <- checkPatterns es

-               return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
-                       -- TODO: span is wrong
+               let match_span = combineSrcSpans (getLoc lhs) rhs_span
+               return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)]))
+       -- The span of the match covers the entire equation.  
+       -- That isn't quite right, but it'll do for now.

   | otherwise = do
        lhs <- checkPattern lhs
   | otherwise = do
        lhs <- checkPattern lhs

-       return (PatBind lhs grhss)
+       return (PatBind lhs grhss placeHolderType)

 
 checkValSig
        :: LHsExpr RdrName
 
 checkValSig
        :: LHsExpr RdrName

@@ -796,10 +817,6 @@ checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
 checkValSig (L l other)     ty
   = parseError l "Type signature given for an expression"
 
 checkValSig (L l other)     ty
   = parseError l "Type signature given for an expression"
 

-mkSigDecls :: [LSig RdrName] -> RdrBinding
-mkSigDecls sigs = RdrBindings [RdrHsDecl (L l (SigD sig)) | L l sig <- sigs]
-
-

 -- A variable binding is parsed as a FunBind.
 
 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
 -- A variable binding is parsed as a FunBind.
 
 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]