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,
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 )
-- Deal with top-level fixity decls
-- (returns the total new fixity env)
- fix_env <- rnSrcFixityDeclsEnv fix_decls ;
rn_fix_decls <- rnSrcFixityDecls fix_decls ;
+ fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ;
updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
$ do {
rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
- = do names <- lookupLocalDataTcNames rdr_name
+ = setSrcSpan nameLoc $
+ -- GHC extension: look up both the tycon and data con
+ -- for con-like things
+ -- If neither are in scope, report an error; otherwise
+ -- add both to the fixity env
+ do names <- lookupLocalDataTcNames rdr_name
return [ L loc (FixitySig (L nameLoc name) fixity)
| name <- names ]
-rnSrcFixityDeclsEnv :: [LFixitySig RdrName] -> RnM FixityEnv
+rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
rnSrcFixityDeclsEnv fix_decls
= getGblEnv `thenM` \ gbl_env ->
foldlM rnFixityDeclEnv (tcg_fix_env gbl_env)
traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_`
returnM fix_env
-rnFixityDeclEnv :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
-rnFixityDeclEnv fix_env (L loc (FixitySig rdr_name fixity))
- = setSrcSpan loc $
- -- GHC extension: look up both the tycon and data con
- -- for con-like things
- -- If neither are in scope, report an error; otherwise
- -- add both to the fixity env
- addLocM lookupLocalDataTcNames rdr_name `thenM` \ names ->
- foldlM add fix_env names
- where
- add fix_env name
- = case lookupNameEnv fix_env name of
- Just (FixItem _ _ loc')
- -> addLocErr rdr_name (dupFixityDecl loc') `thenM_`
- returnM fix_env
- Nothing -> returnM (extendNameEnv fix_env name fix_item)
- where
- fix_item = FixItem (nameOccName name) fixity (getLoc rdr_name)
+rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
+rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
+ = case lookupNameEnv fix_env name of
+ Just (FixItem _ _ loc')
+ -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
+ return fix_env
+ Nothing
+ -> return (extendNameEnv fix_env name fix_item)
+ where fix_item = FixItem (nameOccName name) fixity nameLoc
pprFixEnv :: FixityEnv -> SDoc
pprFixEnv env
%*********************************************************
\begin{code}
-rnHsForeignDecl (ForeignImport name ty spec isDeprec)
+rnHsForeignDecl (ForeignImport name ty spec)
= lookupLocatedTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignImport name' ty' spec isDeprec, fvs)
+ returnM (ForeignImport name' ty' spec, fvs)
-rnHsForeignDecl (ForeignExport name ty spec isDeprec)
+rnHsForeignDecl (ForeignExport name ty spec)
= lookupLocatedOccRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignExport name' ty' spec isDeprec, fvs )
+ returnM (ForeignExport name' ty' spec, fvs )
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
-- be imported from another module
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,
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',
; 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 ->