From 096b95b76ac1947049a6c396e21e6c82baa681f7 Mon Sep 17 00:00:00 2001 From: sof Date: Mon, 26 May 1997 04:22:55 +0000 Subject: [PATCH] [project @ 1997-05-26 04:22:55 by sof] Support for (non-)?greedy slurping added --- ghc/compiler/rename/RnSource.lhs | 56 +++++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 25 deletions(-) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 63aa9a5..875dccc 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -23,7 +23,7 @@ import CmdLineOpts ( opt_IgnoreIfacePragmas ) import RnBinds ( rnTopBinds, rnMethodBinds ) import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn, - lookupOptionalOccRn, newSysName, newDfunName, checkDupOrQualNames, checkDupNames, + newSysName, newDfunName, checkDupOrQualNames, checkDupNames, listType_RDR, tupleType_RDR ) import RnMonad @@ -46,11 +46,9 @@ import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NA import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) -import Outputable ( Outputable(..){-instances-} ) -import PprStyle +import Outputable ( PprStyle(..), Outputable(..){-instances-} ) import Pretty import SrcLoc ( SrcLoc ) --- import TyCon ( TyCon{-instance NamedThing-} ) import Unique ( Unique ) import UniqSet ( SYN_IE(UniqSet) ) import UniqFM ( UniqFM, lookupUFM ) @@ -94,6 +92,9 @@ rnDecl (SigD (IfaceSig name ty id_infos loc)) (if opt_IgnoreIfacePragmas then returnRn [] else + setModeRn (InterfaceMode Optional) $ + -- In all the rest of the signature we read in optional mode, + -- so that (a) we don't die mapRn rnIdInfo id_infos ) `thenRn` \ id_infos' -> @@ -191,11 +192,12 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) -- Call up interface info for default method, if such info exists let - dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op) + dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op) in - newSysName dm_occ Exported locn `thenRn` \ dm_name -> - addOccurrenceName Optional dm_name `thenRn_` - + newSysName dm_occ Exported locn `thenRn` \ dm_name -> + setModeRn (InterfaceMode Optional) ( + addOccurrenceName dm_name + ) `thenRn_` -- Checks..... let @@ -239,7 +241,7 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) mapRn rn_uprag uprags `thenRn` \ new_uprags -> newDfunName maybe_dfun src_loc `thenRn` \ dfun_name -> - addOccurrenceName Compulsory dfun_name `thenRn_` + addOccurrenceName dfun_name `thenRn_` -- The dfun is not optional, because we use its version number -- to identify the version of the instance declaration @@ -410,8 +412,8 @@ rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kind not (tv `elem` forall_tyvars) ] in --- checkRn (null non_foralld_constrained) --- (ctxtErr sig_doc non_foralld_constrained) `thenRn_` + checkRn (null non_foralld_constrained) + (ctxtErr sig_doc non_foralld_constrained) `thenRn_` (bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars -> rnContext ctxt `thenRn` \ new_ctxt -> @@ -507,7 +509,7 @@ rnContext ctxt -- Easiest thing is simply not to put it in the occurrence set. lookupBndrRn clas `thenRn` \ clas_name -> (if clas_name /= allClass_NAME then - addOccurrenceName Compulsory clas_name + addOccurrenceName clas_name else returnRn clas_name ) `thenRn_` @@ -533,17 +535,21 @@ rnIdInfo (HsStrictness strict) = rnStrict strict `thenRn` \ strict' -> returnRn (HsStrictness strict') -rnIdInfo (HsUnfold expr) = rnCoreExpr expr `thenRn` \ expr' -> - returnRn (HsUnfold expr') +rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' -> + returnRn (HsUnfold inline expr') rnIdInfo (HsArity arity) = returnRn (HsArity arity) rnIdInfo (HsUpdate update) = returnRn (HsUpdate update) rnIdInfo (HsFBType fb) = returnRn (HsFBType fb) rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au) rnIdInfo (HsDeforest df) = returnRn (HsDeforest df) -rnStrict (StrictnessInfo demands (Just worker)) - = lookupOptionalOccRn worker `thenRn` \ worker' -> - returnRn (StrictnessInfo demands (Just worker')) +rnStrict (StrictnessInfo demands (Just (worker,cons))) + -- The sole purpose of the "cons" field is so that we can mark the constructors + -- needed to build the wrapper as "needed", so that their data type decl will be + -- slurped in. After that their usefulness is o'er, so we just put in the empty list. + = lookupOccRn worker `thenRn` \ worker' -> + mapRn lookupOccRn cons `thenRn_` + returnRn (StrictnessInfo demands (Just (worker',[]))) -- Boring, but necessary for the type checker. rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing) @@ -555,13 +561,13 @@ UfCore expressions. \begin{code} rnCoreExpr (UfVar v) - = lookupOptionalOccRn v `thenRn` \ v' -> + = lookupOccRn v `thenRn` \ v' -> returnRn (UfVar v') rnCoreExpr (UfLit lit) = returnRn (UfLit lit) rnCoreExpr (UfCon con args) - = lookupOptionalOccRn con `thenRn` \ con' -> + = lookupOccRn con `thenRn` \ con' -> mapRn rnCoreArg args `thenRn` \ args' -> returnRn (UfCon con' args') @@ -638,8 +644,8 @@ rnCoreBndrNamess names thing_inside \end{code} \begin{code} -rnCoreArg (UfVarArg v) = lookupOptionalOccRn v `thenRn` \ v' -> returnRn (UfVarArg v') -rnCoreArg (UfUsageArg u) = lookupOptionalOccRn u `thenRn` \ u' -> returnRn (UfUsageArg u') +rnCoreArg (UfVarArg v) = lookupOccRn v `thenRn` \ v' -> returnRn (UfVarArg v') +rnCoreArg (UfUsageArg u) = lookupOccRn u `thenRn` \ u' -> returnRn (UfUsageArg u') rnCoreArg (UfTyArg ty) = rnHsType ty `thenRn` \ ty' -> returnRn (UfTyArg ty') rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit) @@ -648,7 +654,7 @@ rnCoreAlts (UfAlgAlts alts deflt) rnCoreDefault deflt `thenRn` \ deflt' -> returnRn (UfAlgAlts alts' deflt') where - rn_alt (con, bndrs, rhs) = lookupOptionalOccRn con `thenRn` \ con' -> + rn_alt (con, bndrs, rhs) = lookupOccRn con `thenRn` \ con' -> bindLocalsRn "unfolding alt" bndrs $ \ bndrs' -> rnCoreExpr rhs `thenRn` \ rhs' -> returnRn (con', bndrs', rhs') @@ -666,11 +672,11 @@ rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr] rnCoreExpr rhs `thenRn` \ rhs' -> returnRn (UfBindDefault bndr' rhs') -rnCoercion (UfIn n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfIn n') -rnCoercion (UfOut n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfOut n') +rnCoercion (UfIn n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfIn n') +rnCoercion (UfOut n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfOut n') rnCorePrim (UfOtherOp op) - = lookupOptionalOccRn op `thenRn` \ op' -> + = lookupOccRn op `thenRn` \ op' -> returnRn (UfOtherOp op') rnCorePrim (UfCCallOp str casm gc arg_tys res_ty) -- 1.7.10.4