X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=79721cfdacdb2e911177a0cb0f5f3684c1a3f6bb;hb=6493f9d3305d5af08ad92c8f32b8b6410404eb46;hp=93014802fc77198f1e0915ec24ae806d7daa91f7;hpb=a883f6ba301651e1c8a1636f0ff74ad6c078fd12;p=ghc-hetmet.git

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 9301480..79721cf 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -20,7 +20,7 @@ import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
 import RdrHsSyn		( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
-import RnBinds		( rnTopBinds, rnMethodBinds, renameSigs )
+import RnBinds		( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
 import RnEnv		( lookupLocalDataTcNames,
 			  lookupLocatedTopBndrRn, lookupLocatedOccRn,
 			  lookupOccRn, newLocalsRn, 
@@ -38,7 +38,7 @@ import NameSet
 import NameEnv
 import OccName		( occEnvElts )
 import Outputable
-import SrcLoc		( Located(..), unLoc, getLoc, noLoc )
+import SrcLoc		( Located(..), unLoc, noLoc )
 import DynFlags	( DynFlag(..) )
 import Maybes		( seqMaybe )
 import Maybe            ( isNothing )
@@ -286,7 +286,8 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
     extendTyVarEnvForMethodBinds inst_tyvars (		
 	-- (Slightly strangely) the forall-d tyvars scope over
 	-- the method bindings too
-	rnMethodBinds cls [] mbinds
+	rnMethodBinds cls (\n->[]) 	-- No scoped tyvars
+		      [] mbinds
     )						`thenM` \ (mbinds', meth_fvs) ->
 	-- Rename the prags and signatures.
 	-- Note that the type variables are not in scope here,
@@ -538,7 +539,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
    	 in
    	 checkDupNames meth_doc meth_rdr_names_w_locs	`thenM_`
    	 newLocalsRn gen_rdr_tyvars_w_locs	`thenM` \ gen_tyvars ->
-   	 rnMethodBinds (unLoc cname') gen_tyvars mbinds
+   	 rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
     ) `thenM` \ (mbinds', meth_fvs) ->
 
     returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
@@ -592,18 +593,22 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty)
 	; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 	{ new_context <- rnContext doc cxt
         ; new_details <- rnConDetails doc details
-        ; new_res_ty  <- rnConResult doc res_ty
-        ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
-        ; traceRn (text "****** - autrijus" <> ppr rv)
-        ; return rv } }
+        ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
+        ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
   where
     doc = text "In the definition of data constructor" <+> quotes (ppr name)
     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 
-rnConResult _ ResTyH98 = return ResTyH98
-rnConResult doc (ResTyGADT ty) = do
+rnConResult _ details ResTyH98 = return (details, ResTyH98)
+
+rnConResult doc details (ResTyGADT ty) = do
     ty' <- rnHsSigType doc ty
-    return $ ResTyGADT ty'
+    let (arg_tys, res_ty) = splitHsFunType ty'
+	-- We can split it up, now the renamer has dealt with fixities
+    case details of
+	PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
+	RecCon fields -> return (details, ResTyGADT ty')
+	InfixCon {}   -> panic "rnConResult"
 
 rnConDetails doc (PrefixCon tys)
   = mappM (rnLHsType doc) tys	`thenM` \ new_tys  ->