X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=b51c2d5a9b592770205de16a82a6df28aace1ae8;hb=1b9841866c2b49484a3af10ab2d8f5bb6d68ab84;hp=8b5953c46fb5e35356c18168e03aac957fdc94c7;hpb=40888e1d6141c919254f93545ae0d795e20ae4bf;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 8b5953c..b51c2d5 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -61,13 +61,12 @@ import Kind		( liftedTypeKind )
 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 BasicTypes	( initialVersion, StrictnessMark(..) )
 import Module		( ModuleName )
 import SrcLoc
-import CStrings		( CLabelString )
 import CmdLineOpts	( opt_InPackage )
 import OrdList		( OrdList, fromOL )
 import Bag		( Bag, emptyBag, snocBag, consBag, foldrBag )
@@ -113,7 +112,7 @@ 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
@@ -273,17 +272,17 @@ hsIfaceCons NewType [con]	-- newtype
 
 hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
 hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
-  = IfaceConDecl (get_occ lname)
+  = IfaceConDecl (get_occ lname) is_infix
 		 (hsIfaceTvs ex_tvs)
 		 (hsIfaceCtxt (unLoc ex_ctxt))
 		 (map (hsIfaceLType . getBangType       . unLoc) args)
 		 (map (hsStrictMark . getBangStrictness . unLoc) args)
 		 flds
   where
-    (args, flds) = case details of
-			PrefixCon args -> (args, [])
-			InfixCon a1 a2 -> ([a1,a2], [])
-			RecCon fs      -> (map snd fs, map (get_occ . fst) fs)
+    (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)
 
 hsStrictMark :: HsBang -> StrictnessMark
@@ -319,7 +318,7 @@ 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 (HsPredTy p)       = IfacePredTy (hsIfaceLPred p)
+hsIfaceType (HsPredTy p)       = IfacePredTy (hsIfacePred p)
 hsIfaceType (HsKindSig t _)    = hsIfaceLType t
 hsIfaceType (HsNumTy n)	       = panic "hsIfaceType:HsNum"
 hsIfaceType (HsSpliceTy _)     = panic "hsIfaceType:HsSpliceTy"
@@ -620,7 +619,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.
-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 []
@@ -637,7 +636,7 @@ 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))))
+  	= 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"
@@ -763,20 +762,23 @@ patFail loc = parseError loc "Parse error in pattern"
 checkValDef 
 	:: LHsExpr RdrName
 	-> Maybe (LHsType RdrName)
-	-> GRHSs RdrName
+	-> Located (GRHSs 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
-		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 [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
 	return (PatBind lhs grhss)
+	
 
 checkValSig
 	:: LHsExpr RdrName