diff options
Diffstat (limited to 'compiler')
48 files changed, 2337 insertions, 1164 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 851bf661da..0c6e3c5720 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -87,15 +87,20 @@ differently, as follows. Note [Data Constructor Naming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each data constructor C has two, and possibly three, Names associated with it: +Each data constructor C has two, and possibly up to four, Names associated with it: - OccName Name space Used for + OccName Name space Name of --------------------------------------------------------------------------- - * The "source data con" C DataName The DataCon itself - * The "real data con" C VarName Its worker Id - * The "wrapper data con" $WC VarName Wrapper Id (optional) - -Each of these three has a distinct Unique. The "source data con" name + * The "data con itself" C DataName DataCon + * The "worker data con" C VarName Id (the worker) + * The "wrapper data con" $WC VarName Id (the wrapper) + * The "newtype coercion" :CoT TcClsName TyCon + +EVERY data constructor (incl for newtypes) has the former two (the +data con itself, and its worker. But only some data constructors have a +wrapper (see Note [The need for a wrapper]). + +Each of these three has a distinct Unique. The "data con itself" name appears in the output of the renamer, and names the Haskell-source data constructor. The type checker translates it into either the wrapper Id (if it exists) or worker Id (otherwise). @@ -129,6 +134,8 @@ The "wrapper Id", $WC, goes as follows nothing for the wrapper to do. That is, if its defn would be $wC = C +Note [The need for a wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Why might the wrapper have anything to do? Two reasons: * Unboxing strict fields (with -funbox-strict-fields) @@ -152,6 +159,8 @@ Why might the wrapper have anything to do? Two reasons: The third argument is a coerion [a] :: [a]:=:[a] +INVARIANT: the dictionary constructor for a class + never has a wrapper. A note about the stupid context diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index f07def0609..32b4ecfed0 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -1,4 +1,4 @@ -% +\% % (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1998 % @@ -498,20 +498,37 @@ gotten by appying the eq_spec to the univ_tvs of the data con. mkRecordSelId :: TyCon -> FieldLabel -> Id mkRecordSelId tycon field_label -- Assumes that all fields with the same field label have the same type - | is_naughty = naughty_id - | otherwise = sel_id + = sel_id where - is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set) + -- Because this function gets called by implicitTyThings, we need to + -- produce the OccName of the Id without doing any suspend type checks. + -- (see the note [Tricky iface loop]). + -- A suspended type-check is sometimes necessary to compute field_ty, + -- so we need to make sure that we suspend anything that depends on field_ty. + + -- the overall result + sel_id = mkGlobalId sel_id_details field_label theType theInfo + + -- check whether the type is naughty: this thunk does not get forced + -- until the type is actually needed + field_ty = dataConFieldType con1 field_label + is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set) + + -- it's important that this doesn't force the if + (theType, theInfo) = if is_naughty + -- Escapist case here for naughty constructors + -- We give it no IdInfo, and a type of forall a.a (never looked at) + then (forall_a_a, noCafIdInfo) + -- otherwise do the real case + else (selector_ty, info) + sel_id_details = RecordSelId { sel_tycon = tycon, sel_label = field_label, sel_naughty = is_naughty } - -- For a data type family, the tycon is the *instance* TyCon + -- For a data type family, the tycon is the *instance* TyCon - -- Escapist case here for naughty constructors - -- We give it no IdInfo, and a type of forall a.a (never looked at) - naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo + -- for naughty case forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) - -- Normal case starts here - sel_id = mkGlobalId sel_id_details field_label selector_ty info + -- real case starts here: data_cons = tyConDataCons tycon data_cons_w_field = filter has_field data_cons -- Can't be empty! has_field con = field_label `elem` dataConFieldLabels con @@ -522,7 +539,6 @@ mkRecordSelId tycon field_label -- only the family TyCon, not the instance TyCon data_tv_set = tyVarsOfType data_ty data_tvs = varSetElems data_tv_set - field_ty = dataConFieldType con1 field_label -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over -- just the dictionaries in the types of the constructors that contain diff --git a/compiler/basicTypes/NameEnv.lhs b/compiler/basicTypes/NameEnv.lhs index 7eee4c6f8b..b6a7ec8e08 100644 --- a/compiler/basicTypes/NameEnv.lhs +++ b/compiler/basicTypes/NameEnv.lhs @@ -29,6 +29,7 @@ import Name import Unique(Unique) import UniqFM import Maybes +import Outputable \end{code} %************************************************************************ @@ -38,7 +39,7 @@ import Maybes %************************************************************************ \begin{code} -type NameEnv a = UniqFM a -- Domain is Name +newtype NameEnv a = A (UniqFM a) -- Domain is Name emptyNameEnv :: NameEnv a mkNameEnv :: [(Name,a)] -> NameEnv a @@ -61,26 +62,31 @@ foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 -emptyNameEnv = emptyUFM -foldNameEnv = foldUFM -mkNameEnv = listToUFM -nameEnvElts = eltsUFM -nameEnvUniqueElts = ufmToList -extendNameEnv_C = addToUFM_C -extendNameEnv_Acc = addToUFM_Acc -extendNameEnv = addToUFM -plusNameEnv = plusUFM -plusNameEnv_C = plusUFM_C -extendNameEnvList = addListToUFM -extendNameEnvList_C = addListToUFM_C -delFromNameEnv = delFromUFM -delListFromNameEnv = delListFromUFM -elemNameEnv = elemUFM -unitNameEnv = unitUFM -filterNameEnv = filterUFM -mapNameEnv = mapUFM +nameEnvElts (A x) = eltsUFM x +emptyNameEnv = A emptyUFM +unitNameEnv x y = A $ unitUFM x y +extendNameEnv (A x) y z = A $ addToUFM x y z +extendNameEnvList (A x) l = A $ addListToUFM x l +lookupNameEnv (A x) y = lookupUFM x y +mkNameEnv l = A $ listToUFM l +elemNameEnv x (A y) = elemUFM x y +foldNameEnv a b (A c) = foldUFM a b c +occEnvElts (A x) = eltsUFM x +plusNameEnv (A x) (A y) = A $ plusUFM x y +plusNameEnv_C f (A x) (A y) = A $ plusUFM_C f x y +extendNameEnv_C f (A x) y z = A $ addToUFM_C f x y z +mapNameEnv f (A x) = A $ mapUFM f x +mkNameEnv_C comb l = A $ addListToUFM_C comb emptyUFM l +nameEnvUniqueElts (A x) = ufmToList x +extendNameEnv_Acc x y (A z) a b = A $ addToUFM_Acc x y z a b +extendNameEnvList_C x (A y) z = A $ addListToUFM_C x y z +delFromNameEnv (A x) y = A $ delFromUFM x y +delListFromNameEnv (A x) y = A $ delListFromUFM x y +filterNameEnv x (A y) = A $ filterUFM x y -lookupNameEnv = lookupUFM -lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n) +lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) + +instance Outputable a => Outputable (NameEnv a) where + ppr (A x) = ppr x \end{code} diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 13978e28f0..d597a46f34 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -56,13 +56,14 @@ module OccName ( OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + filterOccEnv, delListFromOccEnv, delFromOccEnv, -- The OccSet type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, extendOccSetList, unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, - + -- Tidying up TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, @@ -262,7 +263,7 @@ instance Uniquable OccName where TvName -> 'v' TcClsName -> 't' -type OccEnv a = UniqFM a +newtype OccEnv a = A (UniqFM a) emptyOccEnv :: OccEnv a unitOccEnv :: OccName -> a -> OccEnv a @@ -278,22 +279,30 @@ extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b - -emptyOccEnv = emptyUFM -unitOccEnv = unitUFM -extendOccEnv = addToUFM -extendOccEnvList = addListToUFM -lookupOccEnv = lookupUFM -mkOccEnv = listToUFM -elemOccEnv = elemUFM -foldOccEnv = foldUFM -occEnvElts = eltsUFM -plusOccEnv = plusUFM -plusOccEnv_C = plusUFM_C -extendOccEnv_C = addToUFM_C -mapOccEnv = mapUFM - -mkOccEnv_C comb l = addListToUFM_C comb emptyOccEnv l +delFromOccEnv :: OccEnv a -> OccName -> OccEnv a +delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a +filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt + +emptyOccEnv = A emptyUFM +unitOccEnv x y = A $ unitUFM x y +extendOccEnv (A x) y z = A $ addToUFM x y z +extendOccEnvList (A x) l = A $ addListToUFM x l +lookupOccEnv (A x) y = lookupUFM x y +mkOccEnv l = A $ listToUFM l +elemOccEnv x (A y) = elemUFM x y +foldOccEnv a b (A c) = foldUFM a b c +occEnvElts (A x) = eltsUFM x +plusOccEnv (A x) (A y) = A $ plusUFM x y +plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y +extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +mapOccEnv f (A x) = A $ mapUFM f x +mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l +delFromOccEnv (A x) y = A $ delFromUFM x y +delListFromOccEnv (A x) y = A $ delListFromUFM x y +filterOccEnv x (A y) = A $ filterUFM x y + +instance Outputable a => Outputable (OccEnv a) where + ppr (A x) = ppr x type OccSet = UniqFM OccName diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 4713d202bb..3996678b4e 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -216,7 +216,9 @@ check' qs | literals = split_by_literals qs | constructors = split_by_constructor qs | only_vars = first_column_only_vars qs - | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats) +-- FIXME: hack to get view patterns through for now + | otherwise = ([([],[])],emptyUniqSet) +-- pprPanic "Check.check': Not implemented :-(" (ppr first_pats) where -- Note: RecPats will have been simplified to ConPats -- at this stage. @@ -430,9 +432,9 @@ get_lit :: Pat id -> Maybe HsLit -- It doesn't matter which one, because they will only be compared -- with other HsLits gotten in the same way get_lit (LitPat lit) = Just lit -get_lit (NPat (HsIntegral i _) mb _ _) = Just (HsIntPrim (mb_neg mb i)) -get_lit (NPat (HsFractional f _) mb _ _) = Just (HsFloatPrim (mb_neg mb f)) -get_lit (NPat (HsIsString s _) _ _ _) = Just (HsStringPrim s) +get_lit (NPat (HsIntegral i _ _) mb _) = Just (HsIntPrim (mb_neg mb i)) +get_lit (NPat (HsFractional f _ _) mb _) = Just (HsFloatPrim (mb_neg mb f)) +get_lit (NPat (HsIsString s _ _) _ _) = Just (HsStringPrim s) get_lit other_pat = Nothing mb_neg :: Num a => Maybe b -> a -> a @@ -484,7 +486,7 @@ is_con _ = False is_lit :: Pat Id -> Bool is_lit (LitPat _) = True -is_lit (NPat _ _ _ _) = True +is_lit (NPat _ _ _) = True is_lit _ = False is_var :: Pat Id -> Bool @@ -610,6 +612,7 @@ has_nplusk_pat :: Pat Id -> Bool has_nplusk_pat (NPlusKPat _ _ _ _) = True has_nplusk_pat (ParPat p) = has_nplusk_lpat p has_nplusk_pat (AsPat _ p) = has_nplusk_lpat p +has_nplusk_pat (ViewPat _ p _) = has_nplusk_lpat p has_nplusk_pat (SigPatOut p _ ) = has_nplusk_lpat p has_nplusk_pat (ListPat ps _) = any has_nplusk_lpat ps has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps @@ -631,6 +634,9 @@ simplify_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaus -- purposes, a ~pat is like a wildcard simplify_pat (BangPat p) = unLoc (simplify_lpat p) simplify_pat (AsPat id p) = unLoc (simplify_lpat p) + +simplify_pat (ViewPat expr p ty) = ViewPat expr (simplify_lpat p) ty + simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right simplify_pat pat@(ConPatOut { pat_con = L loc id, pat_args = ps }) @@ -665,7 +671,7 @@ simplify_pat pat@(LitPat (HsString s)) = mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy simplify_pat (LitPat lit) = tidyLitPat lit -simplify_pat (NPat lit mb_neg eq lit_ty) = tidyNPat lit mb_neg eq lit_ty +simplify_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2) = WildPat (idType (unLoc id)) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 02e5e27955..976b47f72e 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -637,7 +637,7 @@ bindLocals :: [Id] -> TM a -> TM a bindLocals new_ids (TM m) = TM $ \ env st -> case m env{ inScope = inScope env `extendVarSetList` new_ids } st of - (r, fv, st') -> (r, fv `delListFromUFM` occs, st') + (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') where occs = [ nameOccName (idName id) | id <- new_ids ] isBlackListed :: SrcSpan -> TM Bool diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 0ef7fa5f8c..7500111f4c 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -1115,7 +1115,7 @@ collectl (L l pat) bndrs collectHsBindLocatedBinders ds ++ foldr collectl bndrs (hsConPatArgs ps) go (LitPat _) = bndrs - go (NPat _ _ _ _) = bndrs + go (NPat _ _ _) = bndrs go (NPlusKPat n _ _ _) = n : bndrs go (SigPatIn pat _) = collectl pat bndrs diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 457bb09aef..3317ffaa72 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -790,7 +790,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyns ss lam } -repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m) +repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) ----------------------------------------------------------------------------- @@ -831,8 +831,8 @@ repP (ConPatIn dc details) p2' <- repLP p2; repPinfix p1' con_str p2' } } -repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a } -repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p) +repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP p@(NPat l (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) -- The problem is to do with scoped type variables. -- To implement them, we have to implement the scoping rules @@ -1277,9 +1277,9 @@ mk_string s = do string_ty <- lookupType stringTyConName return $ HsString s repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) -repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit } -repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit } -repOverloadedLiteral (HsIsString s _) = do { lit <- mk_string s; repLiteral lit } +repOverloadedLiteral (HsIntegral i _ _) = do { lit <- mk_integer i; repLiteral lit } +repOverloadedLiteral (HsFractional f _ _) = do { lit <- mk_rational f; repLiteral lit } +repOverloadedLiteral (HsIsString s _ _) = do { lit <- mk_string s; repLiteral lit } -- The type Rational will be in the environment, becuase -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index e47cd57df2..279416d8cc 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -16,7 +16,7 @@ module DsMonad ( DsM, mappM, mapAndUnzipM, initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, - foldlDs, foldrDs, + foldlDs, foldrDs, ifOptDs, newTyVarsDs, newLocalName, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, @@ -130,7 +130,7 @@ listDs = sequenceM foldlDs = foldlM foldrDs = foldrM mapAndUnzipDs = mapAndUnzipM - +ifOptDs = ifOptM type DsWarning = (SrcSpan, SDoc) -- Not quite the same as a WarnMsg, we have an SDoc here diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 6e2973f685..9d787add26 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -25,7 +25,7 @@ module DsUtils ( cantFailMatchResult, alwaysFailMatchResult, extractMatchResult, combineMatchResults, adjustMatchResult, adjustMatchResultDs, - mkCoLetMatchResult, mkGuardedMatchResult, + mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, matchCanFail, mkEvalMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, wrapBind, wrapBinds, @@ -319,6 +319,12 @@ seqVar var body = Case (Var var) var (exprType body) mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind) +-- (mkViewMatchResult var' viewExpr var mr) makes the expression +-- let var' = viewExpr var in mr +mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult +mkViewMatchResult var' viewExpr var = + adjustMatchResult (mkDsLet (NonRec var' (mkDsApp viewExpr (Var var)))) + mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult mkEvalMatchResult var ty = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index de45c66dbc..3f3a1272bb 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -17,6 +17,8 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat #include "HsVersions.h" +import {-#SOURCE#-} DsExpr (dsLExpr) + import DynFlags import HsSyn import TcHsSyn @@ -274,8 +276,13 @@ match vars@(v:_) ty eqns (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns -- Group the equations and match each group in turn - ; match_results <- mapM match_group (groupEquations tidy_eqns) + ; let grouped = (groupEquations tidy_eqns) + + -- print the view patterns that are commoned up to help debug + ; ifOptDs Opt_D_dump_view_pattern_commoning (debug grouped) + + ; match_results <- mapM match_group grouped ; return (adjustMatchResult (foldr1 (.) aux_binds) $ foldr1 combineMatchResults match_results) } where @@ -284,14 +291,30 @@ match vars@(v:_) ty eqns match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult match_group eqns@((group,_) : _) - = case group of - PgAny -> matchVariables vars ty (dropGroup eqns) - PgCon _ -> matchConFamily vars ty (subGroups eqns) - PgLit _ -> matchLiterals vars ty (subGroups eqns) - PgN lit -> matchNPats vars ty (subGroups eqns) - PgNpK lit -> matchNPlusKPats vars ty (dropGroup eqns) - PgBang -> matchBangs vars ty (dropGroup eqns) - PgCo _ -> matchCoercion vars ty (dropGroup eqns) + = case group of + PgAny -> matchVariables vars ty (dropGroup eqns) + PgCon _ -> matchConFamily vars ty (subGroups eqns) + PgLit _ -> matchLiterals vars ty (subGroups eqns) + PgN lit -> matchNPats vars ty (subGroups eqns) + PgNpK lit -> matchNPlusKPats vars ty (dropGroup eqns) + PgBang -> matchBangs vars ty (dropGroup eqns) + PgCo _ -> matchCoercion vars ty (dropGroup eqns) + PgView _ _ -> matchView vars ty (dropGroup eqns) + + -- FIXME: we should also warn about view patterns that should be + -- commoned up but are not + + -- print some stuff to see what's getting grouped + -- use -dppr-debug to see the resolution of overloaded lits + debug eqns = + let gs = map (\group -> foldr (\ (p,_) -> \acc -> + case p of PgView e _ -> e:acc + _ -> acc) [] group) eqns + maybeWarn [] = return () + maybeWarn l = warnDs (vcat l) + in + maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) + (filter (not . null) gs)) matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Real true variables, just like in matchVar, SLPJ p 94 @@ -300,23 +323,40 @@ matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns) matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchBangs (var:vars) ty eqns - = do { match_result <- match (var:vars) ty (map shift eqns) + = do { match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns) ; return (mkEvalMatchResult var ty match_result) } - where - shift eqn@(EqnInfo { eqn_pats = BangPat pat : pats }) - = eqn { eqn_pats = unLoc pat : pats } matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that -matchCoercion (var:vars) ty (eqn1:eqns) +matchCoercion (var:vars) ty (eqns@(eqn1:_)) = do { let CoPat co pat _ = firstPat eqn1 ; var' <- newUniqueId (idName var) (hsPatType pat) - ; match_result <- match (var':vars) ty (map shift (eqn1:eqns)) + ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns) ; rhs <- dsCoercion co (return (Var var)) ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) } - where - shift eqn@(EqnInfo { eqn_pats = CoPat _ pat _ : pats }) - = eqn { eqn_pats = pat : pats } + +matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Apply the view function to the match variable and then match that +matchView (var:vars) ty (eqns@(eqn1:_)) + = do { -- we could pass in the expr from the PgView, + -- but this needs to extract the pat anyway + -- to figure out the type of the fresh variable + let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 + -- do the rest of the compilation + ; var' <- newUniqueId (idName var) (hsPatType pat) + ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns) + -- compile the view expressions + ; viewExpr' <- dsLExpr viewExpr + ; return (mkViewMatchResult var' viewExpr' var match_result) } + +-- decompose the first pattern and leave the rest alone +decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) + = eqn { eqn_pats = extractpat pat : pats} + +decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat) +decomposeFirst_Bang = decomposeFirstPat (\ (BangPat pat ) -> unLoc pat) +decomposeFirst_View = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat) + \end{code} %************************************************************************ @@ -459,8 +499,8 @@ tidy1 v (LitPat lit) = returnDs (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 v (NPat lit mb_neg eq lit_ty) - = returnDs (idDsWrapper, tidyNPat lit mb_neg eq lit_ty) +tidy1 v (NPat lit mb_neg eq) + = returnDs (idDsWrapper, tidyNPat lit mb_neg eq) -- Everything else goes through unchanged... @@ -710,7 +750,9 @@ data PatGroup | PgBang -- Bang patterns | PgCo Type -- Coercion patterns; the type is the type -- of the pattern *inside* - + | PgView (LHsExpr Id) -- view pattern (e -> p): + -- the LHsExpr is the expression e + Type -- the Type is the type of p (equivalently, the result type of e) groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] -- If the result is of form [g1, g2, g3], @@ -750,16 +792,102 @@ sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2 -- enclosed pattern is the same. The patterns outside the CoPat -- always have the same type, so this boils down to saying that -- the two coercions are identical. +sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) + -- ViewPats are in the same gorup iff the expressions + -- are "equal"---conservatively, we use syntactic equality sameGroup _ _ = False - + +-- an approximation of syntactic equality used for determining when view +-- exprs are in the same group. +-- this function can always safely return false; +-- but doing so will result in the application of the view function being repeated. +-- +-- currently: compare applications of literals and variables +-- and anything else that we can do without involving other +-- HsSyn types in the recursion +-- +-- NB we can't assume that the two view expressions have the same type. Consider +-- f (e1 -> True) = ... +-- f (e2 -> "hi") = ... +viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool +viewLExprEq (e1,t1) (e2,t2) = + let + -- short name for recursive call on unLoc + lexp e e' = exp (unLoc e) (unLoc e') + + -- check that two lists have the same length + -- and that they match up pairwise + lexps [] [] = True + lexps [] (_:_) = False + lexps (_:_) [] = False + lexps (x:xs) (y:ys) = lexp x y && lexps xs ys + + -- conservative, in that it demands that wrappers be + -- syntactically identical and doesn't look under binders + -- + -- coarser notions of equality are possible + -- (e.g., reassociating compositions, + -- equating different ways of writing a coercion) + wrap WpHole WpHole = True + wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' + wrap (WpCo c) (WpCo c') = tcEqType c c' + wrap (WpApp d) (WpApp d') = d == d' + wrap (WpTyApp t) (WpTyApp t') = tcEqType t t' + -- Enhancement: could implement equality for more wrappers + -- if it seems useful (lams and lets) + wrap _ _ = False + + -- real comparison is on HsExpr's + -- strip parens + exp (HsPar (L _ e)) e' = exp e e' + exp e (HsPar (L _ e')) = exp e e' + -- because the expressions do not necessarily have the same type, + -- we have to compare the wrappers + exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' + exp (HsVar i) (HsVar i') = i == i' + -- the instance for IPName derives using the id, so this works if the + -- above does + exp (HsIPVar i) (HsIPVar i') = i == i' + exp (HsOverLit l) (HsOverLit l') = + -- overloaded lits are equal if they have the same type + -- and the data is the same. + -- this is coarser than comparing the SyntaxExpr's in l and l', + -- which resolve the overloading (e.g., fromInteger 1), + -- because these expressions get written as a bunch of different variables + -- (presumably to improve sharing) + tcEqType (overLitType l) (overLitType l') && l == l' + -- comparing the constants seems right + exp (HsLit l) (HsLit l') = l == l' + exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' + -- the fixities have been straightened out by now, so it's safe + -- to ignore them? + exp (OpApp l o _ ri) (OpApp l' o' _ ri') = + lexp l l' && lexp o o' && lexp ri ri' + exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n' + exp (SectionL e1 e2) (SectionL e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (SectionR e1 e2) (SectionR e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (HsIf e e1 e2) (HsIf e' e1' e2') = + lexp e e' && lexp e1 e1' && lexp e2 e2' + exp (ExplicitList _ ls) (ExplicitList _ ls') = lexps ls ls' + exp (ExplicitPArr _ ls) (ExplicitPArr _ ls') = lexps ls ls' + exp (ExplicitTuple ls _) (ExplicitTuple ls' _) = lexps ls ls' + -- Enhancement: could implement equality for more expressions + -- if it seems useful + exp _ _ = False + in + lexp e1 e2 + patGroup :: Pat Id -> PatGroup patGroup (WildPat {}) = PgAny patGroup (BangPat {}) = PgBang patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) patGroup (LitPat lit) = PgLit (hsLitKey lit) -patGroup (NPat olit mb_neg _ _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) -patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of inner pattern +patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern +patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) patGroup pat = pprPanic "patGroup" (ppr pat) \end{code} diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 610a423b1d..1cf87ce505 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -90,9 +90,9 @@ dsLit (HsRat r ty) dsOverLit :: HsOverLit Id -> DsM CoreExpr -- Post-typechecker, the SyntaxExpr field of an OverLit contains -- (an expression for) the literal value itself -dsOverLit (HsIntegral _ lit) = dsExpr lit -dsOverLit (HsFractional _ lit) = dsExpr lit -dsOverLit (HsIsString _ lit) = dsExpr lit +dsOverLit (HsIntegral _ lit _) = dsExpr lit +dsOverLit (HsFractional _ lit _) = dsExpr lit +dsOverLit (HsIsString _ lit _) = dsExpr lit \end{code} \begin{code} @@ -111,11 +111,11 @@ hsLitKey (HsString s) = MachStr s hsOverLitKey :: HsOverLit a -> Bool -> Literal -- Ditto for HsOverLit; the boolean indicates to negate -hsOverLitKey (HsIntegral i _) False = MachInt i -hsOverLitKey (HsIntegral i _) True = MachInt (-i) -hsOverLitKey (HsFractional r _) False = MachFloat r -hsOverLitKey (HsFractional r _) True = MachFloat (-r) -hsOverLitKey (HsIsString s _) False = MachStr s +hsOverLitKey (HsIntegral i _ _) False = MachInt i +hsOverLitKey (HsIntegral i _ _) True = MachInt (-i) +hsOverLitKey (HsFractional r _ _) False = MachFloat r +hsOverLitKey (HsFractional r _ _) True = MachFloat (-r) +hsOverLitKey (HsIsString s _ _) False = MachStr s -- negated string should never happen \end{code} @@ -142,36 +142,36 @@ tidyLitPat (HsString s) tidyLitPat lit = LitPat lit ---------------- -tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id - -> Type -> Pat Id -tidyNPat over_lit mb_neg eq lit_ty - | isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val) - | isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val) - | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val) +tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id +tidyNPat over_lit mb_neg eq + | isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val) + | isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val) + | isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val) -- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val) - | otherwise = NPat over_lit mb_neg eq lit_ty + | otherwise = NPat over_lit mb_neg eq where mk_con_pat :: DataCon -> HsLit -> Pat Id - mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty) + mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] (overLitType over_lit)) + neg_lit = case (mb_neg, over_lit) of (Nothing, _) -> over_lit - (Just _, HsIntegral i s) -> HsIntegral (-i) s - (Just _, HsFractional f s) -> HsFractional (-f) s + (Just _, HsIntegral i s ty) -> HsIntegral (-i) s ty + (Just _, HsFractional f s ty) -> HsFractional (-f) s ty int_val :: Integer int_val = case neg_lit of - HsIntegral i _ -> i - HsFractional f _ -> panic "tidyNPat" + HsIntegral i _ _ -> i + HsFractional f _ _ -> panic "tidyNPat" rat_val :: Rational rat_val = case neg_lit of - HsIntegral i _ -> fromInteger i - HsFractional f _ -> f + HsIntegral i _ _ -> fromInteger i + HsFractional f _ _ -> f str_val :: FastString str_val = case neg_lit of - HsIsString s _ -> s - _ -> error "tidyNPat" + HsIsString s _ _ -> s + _ -> error "tidyNPat" \end{code} @@ -232,7 +232,7 @@ matchNPats vars ty groups ; return (foldr1 combineMatchResults match_results) } matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat lit mb_neg eq_chk _ = firstPat eqn1 + = do { let NPat lit mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index f2e7015dab..2848c5566e 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -426,9 +426,9 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs ; returnL $ GRHS gs' rhs' } cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) -cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i } -cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r } -cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' } +cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i placeHolderType} +cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType} +cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType } -- An Integer is like an an (overloaded) '3' in a Haskell source program -- Similarly 3.5 for fractionals diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e40272e28b..8e10667643 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -46,20 +46,29 @@ import Bag Global bindings (where clauses) \begin{code} -data HsLocalBinds id -- Bindings in a 'let' expression - -- or a 'where' clause - = HsValBinds (HsValBinds id) - | HsIPBinds (HsIPBinds id) - +-- During renaming, we need bindings where the left-hand sides +-- have been renamed but the the right-hand sides have not. +-- the ...LR datatypes are parametrized by two id types, +-- one for the left and one for the right. +-- Other than during renaming, these will be the same. + +type HsLocalBinds id = HsLocalBindsLR id id + +data HsLocalBindsLR idL idR -- Bindings in a 'let' expression + -- or a 'where' clause + = HsValBinds (HsValBindsLR idL idR) + | HsIPBinds (HsIPBinds idR) | EmptyLocalBinds -data HsValBinds id -- Value bindings (not implicit parameters) - = ValBindsIn -- Before typechecking - (LHsBinds id) [LSig id] -- Not dependency analysed +type HsValBinds id = HsValBindsLR id id + +data HsValBindsLR idL idR -- Value bindings (not implicit parameters) + = ValBindsIn -- Before typechecking + (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed -- Recursive by default - | ValBindsOut -- After renaming - [(RecFlag, LHsBinds id)] -- Dependency analysed, later bindings + | ValBindsOut -- After renaming + [(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings -- in the list may depend on earlier -- ones. [LSig Name] @@ -67,8 +76,12 @@ data HsValBinds id -- Value bindings (not implicit parameters) type LHsBinds id = Bag (LHsBind id) type DictBinds id = LHsBinds id -- Used for dictionary or method bindings type LHsBind id = Located (HsBind id) +type HsBind id = HsBindLR id id + +type LHsBindLR idL idR = Located (HsBindLR idL idR) +type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) -data HsBind id +data HsBindLR idL idR = FunBind { -- FunBind is used for both functions f x = e -- and variables f = \x -> e -- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds @@ -80,11 +93,11 @@ data HsBind id -- parses as a pattern binding, just like -- (f :: a -> a) = ... - fun_id :: Located id, + fun_id :: Located idL, fun_infix :: Bool, -- True => infix declaration - fun_matches :: MatchGroup id, -- The payload + fun_matches :: MatchGroup idR, -- The payload fun_co_fn :: HsWrapper, -- Coercion from the type of the MatchGroup to the type of -- the Id. Example: @@ -102,27 +115,30 @@ data HsBind id -- Before renaming, and after typechecking, -- the field is unused; it's just an error thunk - fun_tick :: Maybe (Int,[id]) -- This is the (optional) module-local tick number. + fun_tick :: Maybe (Int,[idR]) -- This is the (optional) module-local tick number. } | PatBind { -- The pattern is never a simple variable; -- That case is done by FunBind - pat_lhs :: LPat id, - pat_rhs :: GRHSs id, + pat_lhs :: LPat idL, + pat_rhs :: GRHSs idR, pat_rhs_ty :: PostTcType, -- Type of the GRHSs bind_fvs :: NameSet -- Same as for FunBind } | VarBind { -- Dictionary binding and suchlike - var_id :: id, -- All VarBinds are introduced by the type checker - var_rhs :: LHsExpr id -- Located only for consistency + var_id :: idL, -- All VarBinds are introduced by the type checker + var_rhs :: LHsExpr idR -- Located only for consistency } | AbsBinds { -- Binds abstraction; TRANSLATION - abs_tvs :: [TyVar], + abs_tvs :: [TyVar], abs_dicts :: [DictId], - abs_exports :: [([TyVar], id, id, [LPrag])], -- (tvs, poly_id, mono_id, prags) - abs_binds :: LHsBinds id -- The dictionary bindings and typechecked user bindings + -- AbsBinds only gets used when idL = idR after renaming, + -- but these need to be idL's for the collect... code in HsUtil to have + -- the right type + abs_exports :: [([TyVar], idL, idL, [LPrag])], -- (tvs, poly_id, mono_id, prags) + abs_binds :: LHsBinds idL -- The dictionary bindings and typechecked user bindings -- mixed up together; you can tell the dict bindings because -- they are all VarBinds } @@ -145,12 +161,12 @@ placeHolderNames :: NameSet placeHolderNames = panic "placeHolderNames" ------------ -instance OutputableBndr id => Outputable (HsLocalBinds id) where +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where ppr (HsValBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs ppr EmptyLocalBinds = empty -instance OutputableBndr id => Outputable (HsValBinds id) where +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where ppr (ValBindsIn binds sigs) = pprValBindsForUser binds sigs @@ -169,44 +185,44 @@ instance OutputableBndr id => Outputable (HsValBinds id) where -- 'where' include a list of HsBindGroups and we don't want -- several groups of bindings each with braces around. -- Sort by location before printing -pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2) - => LHsBinds id1 -> [LSig id2] -> SDoc +pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) + => LHsBindsLR idL idR -> [LSig id2] -> SDoc pprValBindsForUser binds sigs = pprDeeperList vcat (map snd (sort_by_loc decls)) where decls :: [(SrcSpan, SDoc)] decls = [(loc, ppr sig) | L loc sig <- sigs] ++ - [(loc, ppr bind) | L loc bind <- bagToList binds] + [(loc, ppr bind) | L loc bind <- bagToList binds] sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls -pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc +pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace ------------ -emptyLocalBinds :: HsLocalBinds a +emptyLocalBinds :: HsLocalBindsLR a b emptyLocalBinds = EmptyLocalBinds -isEmptyLocalBinds :: HsLocalBinds a -> Bool +isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds isEmptyLocalBinds EmptyLocalBinds = True -isEmptyValBinds :: HsValBinds a -> Bool +isEmptyValBinds :: HsValBindsLR a b -> Bool isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs -emptyValBindsIn, emptyValBindsOut :: HsValBinds a +emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b emptyValBindsIn = ValBindsIn emptyBag [] emptyValBindsOut = ValBindsOut [] [] -emptyLHsBinds :: LHsBinds id +emptyLHsBinds :: LHsBindsLR idL idR emptyLHsBinds = emptyBag -isEmptyLHsBinds :: LHsBinds id -> Bool +isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool isEmptyLHsBinds = isEmptyBag ------------ @@ -242,10 +258,10 @@ So the desugarer tries to do a better job: in (fm,gm) \begin{code} -instance OutputableBndr id => Outputable (HsBind id) where +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where ppr mbind = ppr_monobind mbind -ppr_monobind :: OutputableBndr id => HsBind id -> SDoc +ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs) @@ -339,14 +355,20 @@ instance Outputable HsWrapper where ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn pprHsWrapper :: SDoc -> HsWrapper -> SDoc -pprHsWrapper it WpHole = it -pprHsWrapper it (WpCompose f1 f2) = pprHsWrapper (pprHsWrapper it f2) f1 -pprHsWrapper it (WpCo co) = sep [it, nest 2 (ptext SLIT("`cast`") <+> pprParendType co)] -pprHsWrapper it (WpApp id) = sep [it, nest 2 (ppr id)] -pprHsWrapper it (WpTyApp ty) = sep [it, ptext SLIT("@") <+> pprParendType ty] -pprHsWrapper it (WpLam id) = sep [ptext SLIT("\\") <> pprBndr LambdaBind id <> dot, it] -pprHsWrapper it (WpTyLam tv) = sep [ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot, it] -pprHsWrapper it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it] +pprHsWrapper it wrap = + let + help it WpHole = it + help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpCo co) = sep [it, nest 2 (ptext SLIT("`cast`") <+> pprParendType co)] + help it (WpApp id) = sep [it, nest 2 (ppr id)] + help it (WpTyApp ty) = sep [it, ptext SLIT("@") <+> pprParendType ty] + help it (WpLam id) = sep [ptext SLIT("\\") <> pprBndr LambdaBind id <> dot, it] + help it (WpTyLam tv) = sep [ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot, it] + help it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it] + in + -- in debug mode, print the wrapper + -- otherwise just print what's inside + getPprStyle (\ s -> if debugStyle s then (help it wrap) else it) (<.>) :: HsWrapper -> HsWrapper -> HsWrapper WpHole <.> c = c diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 5b552c6385..c2e4c8adbd 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -94,7 +94,8 @@ noSyntaxTable = [] data HsExpr id = HsVar id -- variable | HsIPVar (IPName id) -- implicit parameter - | HsOverLit (HsOverLit id) -- Overloaded literals + | HsOverLit (HsOverLit id) -- Overloaded literals + | HsLit HsLit -- Simple (non-overloaded) literals | HsLam (MatchGroup id) -- Currently always a single match @@ -259,6 +260,9 @@ data HsExpr id | EAsPat (Located id) -- as pattern (LHsExpr id) + | EViewPat (LHsExpr id) -- view pattern + (LHsExpr id) + | ELazyPat (LHsExpr id) -- ~ pattern | HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y @@ -305,13 +309,14 @@ isQuietHsExpr (HsApp _ _) = True isQuietHsExpr (OpApp _ _ _ _) = True isQuietHsExpr _ = False -pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc +pprBinds :: (OutputableBndr idL, OutputableBndr idR) => HsLocalBindsLR idL idR -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) +ppr_expr :: OutputableBndr id => HsExpr id -> SDoc ppr_expr (HsVar v) = pprHsVar v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit @@ -353,7 +358,7 @@ ppr_expr (SectionL expr op) pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, ptext SLIT("x_ )")]) - pp_infixly v = parens (sep [pp_expr, pprInfix v]) + pp_infixly v = (sep [pp_expr, pprInfix v]) ppr_expr (SectionR op expr) = case unLoc op of @@ -365,14 +370,14 @@ ppr_expr (SectionR op expr) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")]) 4 ((<>) pp_expr rparen) pp_infixly v - = parens (sep [pprInfix v, pp_expr]) + = (sep [pprInfix v, pp_expr]) -ppr_expr (HsLam matches) - = pprMatches LambdaExpr matches +ppr_expr (HsLam matches :: HsExpr id) + = pprMatches (LambdaExpr :: HsMatchContext id) matches -ppr_expr (HsCase expr matches) +ppr_expr (HsCase expr matches :: HsExpr id) = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")], - nest 2 (pprMatches CaseAlt matches) ] + nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches) ] ppr_expr (HsIf e1 e2 e3) = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")], @@ -675,22 +680,22 @@ data GRHS id = GRHS [LStmt id] -- Guards We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc +pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc matches)) -- Don't print the type; it's only -- a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndr id) => id -> Bool -> MatchGroup id -> SDoc +pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext pprPatBind :: (OutputableBndr bndr, OutputableBndr id) => LPat bndr -> GRHSs id -> SDoc -pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] +pprPatBind pat (grhss :: GRHSs id) = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] -pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc +pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) = herald <+> sep [sep (map ppr other_pats), ppr_maybe_ty, @@ -721,13 +726,13 @@ pprMatch ctxt (Match pats maybe_ty grhss) Nothing -> empty -pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc +pprGRHSs :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHSs idR -> SDoc pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ if isEmptyLocalBinds binds then empty else text "where" $$ nest 4 (pprBinds binds) -pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc +pprGRHS :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHS idR -> SDoc pprGRHS ctxt (GRHS [] expr) = pp_rhs ctxt expr @@ -745,35 +750,38 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) %************************************************************************ \begin{code} -type LStmt id = Located (Stmt id) +type LStmt id = Located (StmtLR id id) +type LStmtLR idL idR = Located (StmtLR idL idR) + +type Stmt id = StmtLR id id -- The SyntaxExprs in here are used *only* for do-notation, which -- has rebindable syntax. Otherwise they are unused. -data Stmt id - = BindStmt (LPat id) - (LHsExpr id) - (SyntaxExpr id) -- The (>>=) operator - (SyntaxExpr id) -- The fail operator +data StmtLR idL idR + = BindStmt (LPat idL) + (LHsExpr idR) + (SyntaxExpr idR) -- The (>>=) operator + (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail - | ExprStmt (LHsExpr id) - (SyntaxExpr id) -- The (>>) operator + | ExprStmt (LHsExpr idR) + (SyntaxExpr idR) -- The (>>) operator PostTcType -- Element type of the RHS (used for arrows) - | LetStmt (HsLocalBinds id) + | LetStmt (HsLocalBindsLR idL idR) -- ParStmts only occur in a list comprehension - | ParStmt [([LStmt id], [id])] -- After renaming, the ids are the binders - -- bound by the stmts and used subsequently + | ParStmt [([LStmt idL], [idR])] -- After renaming, the ids are the binders + -- bound by the stmts and used subsequently -- Recursive statement (see Note [RecStmt] below) - | RecStmt [LStmt id] + | RecStmt [LStmtLR idL idR] --- The next two fields are only valid after renaming - [id] -- The ids are a subset of the variables bound by the stmts + [idR] -- The ids are a subset of the variables bound by the stmts -- that are used in stmts that follow the RecStmt - [id] -- Ditto, but these variables are the "recursive" ones, that + [idR] -- Ditto, but these variables are the "recursive" ones, that -- are used before they are bound in the stmts of the RecStmt -- From a type-checking point of view, these ones have to be monomorphic @@ -783,7 +791,7 @@ data Stmt id -- should be returned by the recursion. They may not quite be the -- Ids themselves, because the Id may be *polymorphic*, but -- the returned thing has to be *monomorphic*. - (DictBinds id) -- Method bindings of Ids bound by the RecStmt, + (DictBinds idR) -- Method bindings of Ids bound by the RecStmt, -- and used afterwards \end{code} @@ -837,9 +845,10 @@ have the same Name. \begin{code} -instance OutputableBndr id => Outputable (Stmt id) where +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where ppr stmt = pprStmt stmt +pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds] pprStmt (ExprStmt expr _ _) = ppr expr diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index b56ef47231..e0b4d047e7 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -13,6 +13,9 @@ data GRHSs a type LHsExpr a = Located (HsExpr a) type SyntaxExpr a = HsExpr a +pprLExpr :: (OutputableBndr i) => + LHsExpr i -> SDoc + pprExpr :: (OutputableBndr i) => HsExpr i -> SDoc @@ -22,6 +25,6 @@ pprSplice :: (OutputableBndr i) => pprPatBind :: (OutputableBndr b, OutputableBndr i) => LPat b -> GRHSs i -> SDoc -pprFunBind :: (OutputableBndr i) => - i -> Bool -> MatchGroup i -> SDoc +pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => + idL -> Bool -> MatchGroup idR -> SDoc \end{code} diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index c110ba4c68..3c18102191 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -16,7 +16,8 @@ module HsLit where #include "HsVersions.h" -import {-# SOURCE #-} HsExpr( SyntaxExpr ) +import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr ) +import HsTypes (PostTcType) import Type ( Type ) import Outputable import FastString @@ -61,34 +62,48 @@ instance Eq HsLit where lit1 == lit2 = False data HsOverLit id -- An overloaded literal - = HsIntegral Integer (SyntaxExpr id) -- Integer-looking literals; - | HsFractional Rational (SyntaxExpr id) -- Frac-looking literals - | HsIsString FastString (SyntaxExpr id) -- String-looking literals + = HsIntegral Integer (SyntaxExpr id) PostTcType -- Integer-looking literals; + | HsFractional Rational (SyntaxExpr id) PostTcType -- Frac-looking literals + | HsIsString FastString (SyntaxExpr id) PostTcType -- String-looking literals -- Before type checking, the SyntaxExpr is 'fromInteger' or 'fromRational' -- After type checking, it is (fromInteger 3) or lit_78; that is, -- the expression that should replace the literal. -- This is unusual, because we're replacing 'fromInteger' with a call -- to fromInteger. Reason: it allows commoning up of the fromInteger -- calls, which wouldn't be possible if the desguarar made the application + -- + -- The PostTcType in each branch records the type the overload literal is + -- found to have. + +overLitExpr :: HsOverLit id -> SyntaxExpr id +overLitExpr (HsIntegral _ e _) = e +overLitExpr (HsFractional _ e _) = e +overLitExpr (HsIsString _ e _) = e + +overLitType :: HsOverLit id -> PostTcType +overLitType (HsIntegral _ _ t) = t +overLitType (HsFractional _ _ t) = t +overLitType (HsIsString _ _ t) = t + -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) instance Eq (HsOverLit id) where - (HsIntegral i1 _) == (HsIntegral i2 _) = i1 == i2 - (HsFractional f1 _) == (HsFractional f2 _) = f1 == f2 - (HsIsString s1 _) == (HsIsString s2 _) = s1 == s2 + (HsIntegral i1 _ _) == (HsIntegral i2 _ _) = i1 == i2 + (HsFractional f1 _ _) == (HsFractional f2 _ _) = f1 == f2 + (HsIsString s1 _ _) == (HsIsString s2 _ _) = s1 == s2 l1 == l2 = False instance Ord (HsOverLit id) where - compare (HsIntegral i1 _) (HsIntegral i2 _) = i1 `compare` i2 - compare (HsIntegral _ _) (HsFractional _ _) = LT - compare (HsIntegral _ _) (HsIsString _ _) = LT - compare (HsFractional f1 _) (HsFractional f2 _) = f1 `compare` f2 - compare (HsFractional f1 _) (HsIntegral _ _) = GT - compare (HsFractional f1 _) (HsIsString _ _) = LT - compare (HsIsString s1 _) (HsIsString s2 _) = s1 `compare` s2 - compare (HsIsString s1 _) (HsIntegral _ _) = GT - compare (HsIsString s1 _) (HsFractional _ _) = GT + compare (HsIntegral i1 _ _) (HsIntegral i2 _ _) = i1 `compare` i2 + compare (HsIntegral _ _ _) (HsFractional _ _ _) = LT + compare (HsIntegral _ _ _) (HsIsString _ _ _) = LT + compare (HsFractional f1 _ _) (HsFractional f2 _ _) = f1 `compare` f2 + compare (HsFractional f1 _ _) (HsIntegral _ _ _) = GT + compare (HsFractional f1 _ _) (HsIsString _ _ _) = LT + compare (HsIsString s1 _ _) (HsIsString s2 _ _) = s1 `compare` s2 + compare (HsIsString s1 _ _) (HsIntegral _ _ _) = GT + compare (HsIsString s1 _ _) (HsFractional _ _ _) = GT \end{code} \begin{code} @@ -105,8 +120,9 @@ instance Outputable HsLit where ppr (HsDoublePrim d) = rational d <> text "##" ppr (HsIntPrim i) = integer i <> char '#' -instance Outputable (HsOverLit id) where - ppr (HsIntegral i _) = integer i - ppr (HsFractional f _) = rational f - ppr (HsIsString s _) = pprHsString s +-- in debug mode, print the expression that it's resolved to, too +instance OutputableBndr id => Outputable (HsOverLit id) where + ppr (HsIntegral i e _) = integer i <+> (ifPprDebug (parens (pprExpr e))) + ppr (HsFractional f e _) = rational f <+> (ifPprDebug (parens (pprExpr e))) + ppr (HsIsString s e _) = pprHsString s <+> (ifPprDebug (parens (pprExpr e))) \end{code} diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index ddd6ec2694..a524ab8732 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -28,13 +28,13 @@ module HsPat ( #include "HsVersions.h" - -import {-# SOURCE #-} HsExpr ( SyntaxExpr ) +import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, pprLExpr) -- friends: import HsBinds import HsLit import HsTypes +import HsDoc import BasicTypes -- others: import Coercion @@ -67,7 +67,7 @@ data Pat id | LazyPat (LPat id) -- Lazy pattern | AsPat (Located id) (LPat id) -- As pattern | ParPat (LPat id) -- Parenthesised pattern - | BangPat (LPat id) -- Bang patterng + | BangPat (LPat id) -- Bang pattern ------------ Lists, tuples, arrays --------------- | ListPat [LPat id] -- Syntactic list @@ -105,6 +105,13 @@ data Pat id pat_ty :: Type -- The type of the pattern } + ------------ View patterns --------------- + | ViewPat (LHsExpr id) + (LPat id) + PostTcType -- The overall type of the pattern + -- (= the argument type of the view function) + -- for hsPatType. + ------------ Literal and n+k patterns --------------- | LitPat HsLit -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. @@ -113,7 +120,6 @@ data Pat id (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative -- patterns, Nothing otherwise (SyntaxExpr id) -- Equality checker, of type t->t->Bool - PostTcType -- Type of the pattern | NPlusKPat (Located id) -- n+k pattern (HsOverLit id) -- It'll always be an HsIntegral @@ -220,6 +226,7 @@ pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> ppr pat pprPat (BangPat pat) = char '!' <> ppr pat pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) +pprPat (ViewPat expr pat _) = parens (hcat [pprLExpr expr, text " -> ", ppr pat]) pprPat (ParPat pat) = parens (ppr pat) pprPat (ListPat pats _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) @@ -236,8 +243,8 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, else pprUserCon con details pprPat (LitPat s) = ppr s -pprPat (NPat l Nothing _ _) = ppr l -pprPat (NPat l (Just _) _ _) = char '-' <> ppr l +pprPat (NPat l Nothing _) = ppr l +pprPat (NPat l (Just _) _) = char '-' <> ppr l pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") pprPat (CoPat co pat _) = parens (pprHsWrapper (ppr pat) co) @@ -357,7 +364,7 @@ patsAreAllLits pat_list = all isLitPat pat_list isLitPat (AsPat _ pat) = isLitPat (unLoc pat) isLitPat (LitPat _) = True -isLitPat (NPat _ _ _ _) = True +isLitPat (NPat _ _ _) = True isLitPat (NPlusKPat _ _ _ _) = True isLitPat other = False @@ -367,7 +374,12 @@ isBangHsBind (PatBind { pat_lhs = L _ (BangPat p) }) = True isBangHsBind bind = False isIrrefutableHsPat :: LPat id -> Bool --- This function returns False if it's in doubt; specifically +-- (isIrrefutableHsPat p) is true if matching against p cannot fail, +-- in the sense of falling through to the next pattern. +-- (NB: this is not quite the same as the (silly) defn +-- in 3.17.2 of the Haskell 98 report.) +-- +-- isIrrefutableHsPat returns False if it's in doubt; specifically -- on a ConPatIn it doesn't know the size of the constructor family -- But if it returns True, the pattern is definitely irrefutable isIrrefutableHsPat pat @@ -383,6 +395,7 @@ isIrrefutableHsPat pat go1 (CoPat _ pat _) = go1 pat go1 (ParPat pat) = go pat go1 (AsPat _ pat) = go pat + go1 (ViewPat _ pat _) = go pat go1 (SigPatIn pat _) = go pat go1 (SigPatOut pat _) = go pat go1 (TuplePat pats _ _) = all go pats @@ -395,7 +408,7 @@ isIrrefutableHsPat pat && all go (hsConPatArgs details) go1 (LitPat _) = False - go1 (NPat _ _ _ _) = False + go1 (NPat _ _ _) = False go1 (NPlusKPat _ _ _ _) = False go1 (TypePat _) = panic "isIrrefutableHsPat: type pattern" diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 0f75769ba3..e9d80c0471 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -132,7 +132,7 @@ mkHsFractional f = HsFractional f noSyntaxExpr mkHsIsString s = HsIsString s noSyntaxExpr mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType -mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType +mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType @@ -294,18 +294,18 @@ where it should return [x, y, f, a, b] (remember, order important). \begin{code} -collectLocalBinders :: HsLocalBinds name -> [Located name] +collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL] collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds collectLocalBinders (HsIPBinds _) = [] collectLocalBinders EmptyLocalBinds = [] -collectHsValBinders :: HsValBinds name -> [Located name] +collectHsValBinders :: HsValBindsLR idL idR -> [Located idL] collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds where collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds -collectAcc :: HsBind name -> [Located name] -> [Located name] +collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL] collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc collectAcc (FunBind { fun_id = f }) acc = f : acc collectAcc (VarBind { var_id = f }) acc = noLoc f : acc @@ -316,10 +316,10 @@ collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collectHsBindBinders :: LHsBinds name -> [name] +collectHsBindBinders :: LHsBindsLR idL idR -> [idL] collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) -collectHsBindLocatedBinders :: LHsBinds name -> [Located name] +collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL] collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds \end{code} @@ -331,16 +331,16 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds %************************************************************************ \begin{code} -collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id] +collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id] +collectStmtsBinders :: [StmtLR idL idR] -> [Located idL] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id] +collectLStmtBinders :: LStmtLR idL idR -> [Located idL] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: OutputableBndr id => Stmt id -> [Located id] +collectStmtBinders :: StmtLR idL idR -> [Located idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds @@ -348,7 +348,6 @@ collectStmtBinders (ExprStmt _ _ _) = [] collectStmtBinders (ParStmt xs) = collectLStmtsBinders $ concatMap fst xs collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss -collectStmtBinders s = pprPanic "collectStmtBinders" (ppr s) \end{code} @@ -389,6 +388,7 @@ collectl (L l pat) bndrs go (LazyPat pat) = collectl pat bndrs go (BangPat pat) = collectl pat bndrs go (AsPat a pat) = a : collectl pat bndrs + go (ViewPat exp pat _) = collectl pat bndrs go (ParPat pat) = collectl pat bndrs go (ListPat pats _) = foldr collectl bndrs pats @@ -399,7 +399,7 @@ collectl (L l pat) bndrs go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] go (LitPat _) = bndrs - go (NPat _ _ _ _) = bndrs + go (NPat _ _ _) = bndrs go (NPlusKPat n _ _ _) = n : bndrs go (SigPatIn pat _) = collectl pat bndrs diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index aab8d26636..4f2457c341 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -428,7 +428,7 @@ instance Binary Usage where usg_exports = exps, usg_entities = ents, usg_rules = rules }) -instance Binary a => Binary (Deprecs a) where +instance Binary Deprecations where put_ bh NoDeprecs = putByte bh 0 put_ bh (DeprecAll t) = do putByte bh 1 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index a9afa99d06..44ce2359fe 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -338,56 +338,80 @@ ifaceDeclSubBndrs :: IfaceDecl -> [OccName] -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, - ifSigs = sigs, ifATs = ats }) - = co_occs ++ - [tc_occ, dc_occ, dcww_occ] ++ - [op | IfaceClassOp op _ _ <- sigs] ++ - [ifName at | at <- ats ] ++ - [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] - where - n_ctxt = length sc_ctxt - n_sigs = length sigs - tc_occ = mkClassTyConOcc cls_occ - dc_occ = mkClassDataConOcc cls_occ - co_occs | is_newtype = [mkNewTyCoOcc tc_occ] - | otherwise = [] - dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker - | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper - is_newtype = n_sigs + n_ctxt == 1 -- Sigh +-- N.B. the set of names returned here *must* match the set of +-- TyThings returned by HscTypes.implicitTyThings, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. +ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] -ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} - = [] -- Newtype ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, - ifCons = IfNewTyCon ( - IfCon { ifConOcc = con_occ, - ifConFields = fields - }), - ifFamInst = famInst}) - = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ] - ++ famInstCo famInst tc_occ + ifCons = IfNewTyCon ( + IfCon { ifConOcc = con_occ, + ifConFields = fields + }), + ifFamInst = famInst}) + = -- fields (names of selectors) + fields ++ + -- implicit coerion and (possibly) family instance coercion + (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ + -- data constructor and worker (newtypes don't have a wrapper) + [con_occ, mkDataConWorkerOcc con_occ] + ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfDataTyCon cons, ifFamInst = famInst}) - = nub (concatMap ifConFields cons) -- Eliminate duplicate fields - ++ concatMap dc_occs cons + = -- fields (names of selectors) + nub (concatMap ifConFields cons) -- Eliminate duplicate fields + -- (possibly) family instance coercion; + -- there is no implicit coercion for non-newtypes ++ famInstCo famInst tc_occ + -- for each data constructor in order, + -- data constructor, worker, and (possibly) wrapper + ++ concatMap dc_occs cons where dc_occs con_decl | has_wrapper = [con_occ, work_occ, wrap_occ] | otherwise = [con_occ, work_occ] where - con_occ = ifConOcc con_decl - strs = ifConStricts con_decl - wrap_occ = mkDataConWrapperOcc con_occ - work_occ = mkDataConWorkerOcc con_occ + con_occ = ifConOcc con_decl -- DataCon namespace + wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + strs = ifConStricts con_decl has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) || not (null . ifConEqSpec $ con_decl) || isJust famInst -- ToDo: may miss strictness in existential dicts +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) + = -- dictionary datatype: + -- type constructor + tc_occ : + -- (possibly) newtype coercion + co_occs ++ + -- data constructor (DataCon namespace) + -- data worker (Id namespace) + -- no wrapper (class dictionaries never have a wrapper) + [dc_occ, dcww_occ] ++ + -- associated types + [ifName at | at <- ats ] ++ + -- superclass selectors + [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++ + -- operation selectors + [op | IfaceClassOp op _ _ <- sigs] + where + n_ctxt = length sc_ctxt + n_sigs = length sigs + tc_occ = mkClassTyConOcc cls_occ + dc_occ = mkClassDataConOcc cls_occ + co_occs | is_newtype = [mkNewTyCoOcc tc_occ] + | otherwise = [] + dcww_occ = mkDataConWorkerOcc dc_occ + is_newtype = n_sigs + n_ctxt == 1 -- Sigh + ifaceDeclSubBndrs _other = [] -- coercion for data/newtype family instances diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index e4ac07506a..34026a6bf6 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -357,38 +357,72 @@ loadDecl ignore_prags mod (_version, decl) ; thing <- forkM doc $ do { bumpDeclStats main_name ; tcIfaceDecl ignore_prags decl } - -- Populate the type environment with the implicitTyThings too. - -- - -- Note [Tricky iface loop] - -- ~~~~~~~~~~~~~~~~~~~~~~~~ - -- The delicate point here is that 'mini-env' should be - -- buildable from 'thing' without demanding any of the things 'forkM'd - -- by tcIfaceDecl. For example - -- class C a where { data T a; op :: T a -> Int } - -- We return the bindings - -- [("C", <cls>), ("T", lookup env "T"), ("op", lookup env "op")] - -- The call (lookup env "T") must return the tycon T without first demanding - -- op; because getting the latter will look up T, hence loop. - -- - -- Of course, there is no reason in principle why (lookup env "T") should demand - -- anything do to with op, but take care: - -- (a) implicitTyThings, and - -- (b) getOccName of all the things returned by implicitThings, - -- must not depend on any of the nested type-checks - -- - -- All a bit too finely-balanced for my liking. - + -- Populate the type environment with the implicitTyThings too. + -- + -- Note [Tricky iface loop] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + -- Summary: The delicate point here is that 'mini-env' must be + -- buildable from 'thing' without demanding any of the things + -- 'forkM'd by tcIfaceDecl. + -- + -- In more detail: Consider the example + -- data T a = MkT { x :: T a } + -- The implicitTyThings of T are: [ <datacon MkT>, <selector x>] + -- (plus their workers, wrappers, coercions etc etc) + -- + -- We want to return an environment + -- [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ] + -- (where the "MkT" is the *Name* associated with MkT, etc.) + -- + -- We do this by mapping the implict_names to the associated + -- TyThings. By the invariant on ifaceDeclSubBndrs and + -- implicitTyThings, we can use getOccName on the implicit + -- TyThings to make this association: each Name's OccName should + -- be the OccName of exactly one implictTyThing. So the key is + -- to define a "mini-env" + -- + -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ] + -- where the 'MkT' here is the *OccName* associated with MkT. + -- + -- However, there is a subtlety: due to how type checking needs + -- to be staged, we can't poke on the forkM'd thunks inside the + -- implictTyThings while building this mini-env. + -- If we poke these thunks too early, two problems could happen: + -- (1) When processing mutually recursive modules across + -- hs-boot boundaries, poking too early will do the + -- type-checking before the recursive knot has been tied, + -- so things will be type-checked in the wrong + -- environment, and necessary variables won't be in + -- scope. + -- + -- (2) Looking up one OccName in the mini_env will cause + -- others to be looked up, which might cause that + -- original one to be looked up again, and hence loop. + -- + -- The code below works because of the following invariant: + -- getOccName on a TyThing does not force the suspended type + -- checks in order to extract the name. For example, we don't + -- poke on the "T a" type of <selector x> on the way to + -- extracting <selector x>'s OccName. Of course, there is no + -- reason in principle why getting the OccName should force the + -- thunks, but this means we need to be careful in + -- implicitTyThings and its helper functions. + -- + -- All a bit too finely-balanced for my liking. + + -- This mini-env and lookup function mediates between the + -- *Name*s n and the map from *OccName*s to the implicit TyThings ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] lookup n = case lookupOccEnv mini_env (getOccName n) of Just thing -> thing Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) - ; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names] + ; returnM $ (main_name, thing) : + -- uses the invariant that implicit_names and + -- implictTyThings are bijective + [(n, lookup n) | n <- implicit_names] } - -- We build a list from the *known* names, with (lookup n) thunks - -- as the TyThings. That way we can extend the PTE without poking the - -- thunks where doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index d2cef9d518..407f3ea3d9 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -265,7 +265,7 @@ mkIface hsc_env maybe_old_iface -- put exactly the info into the TypeEnv that we want -- to expose in the interface - = do { eps <- hscEPS hsc_env + = do {eps <- hscEPS hsc_env ; let { entities = typeEnvElts type_env ; decls = [ tyThingToIfaceDecl entity | entity <- entities, @@ -277,8 +277,8 @@ mkIface hsc_env maybe_old_iface nameIsLocalOrFrom this_mod name ] -- Sigh: see Note [Root-main Id] in TcRnDriver - ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] - ; deprecs = mkIfaceDeprec src_deprecs + ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] + ; deprecs = src_deprecs ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts @@ -319,7 +319,7 @@ mkIface hsc_env maybe_old_iface mi_fix_fn = mkIfaceFixCache fixities } -- Add version information - ; ext_ver_fn = mkParentVerFun hsc_env eps + ; ext_ver_fn = mkParentVerFun hsc_env eps ; (new_iface, no_change_at_all, pp_diffs, pp_orphs) = {-# SCC "versioninfo" #-} addVersionInfo ext_ver_fn maybe_old_iface @@ -691,12 +691,6 @@ mkOrphMap get_key decls | otherwise = (non_orphs, d:orphs) ---------------------- -mkIfaceDeprec :: Deprecations -> IfaceDeprecs -mkIfaceDeprec NoDeprecs = NoDeprecs -mkIfaceDeprec (DeprecAll t) = DeprecAll t -mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLe (<=) (nameEnvElts env)) - ----------------------- bump_unless :: Bool -> Version -> Version bump_unless True v = v -- True <=> no change bump_unless False v = bumpVersion v diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 25dddeb8d9..bf456c97af 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -151,6 +151,7 @@ data DynFlag | Opt_D_dump_hi_diffs | Opt_D_dump_minimal_imports | Opt_D_dump_mod_cycles + | Opt_D_dump_view_pattern_commoning | Opt_D_faststring_stats | Opt_DumpToFile -- ^ Append dump output to files instead of stdout. | Opt_DoCoreLinting @@ -203,6 +204,7 @@ data DynFlag | Opt_DisambiguateRecordFields | Opt_RecordWildCards | Opt_RecordPuns + | Opt_ViewPatterns | Opt_GADTs | Opt_RelaxedPolyRec | Opt_StandaloneDeriving @@ -1087,6 +1089,7 @@ dynamic_flags = [ , ( "ddump-vect", setDumpFlag Opt_D_dump_vect) , ( "ddump-hpc", setDumpFlag Opt_D_dump_hpc) , ( "ddump-mod-cycles", setDumpFlag Opt_D_dump_mod_cycles) + , ( "ddump-view-pattern-commoning", setDumpFlag Opt_D_dump_view_pattern_commoning) , ( "ddump-to-file", setDumpFlag Opt_DumpToFile) , ( "ddump-hi-diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs)) , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) @@ -1275,6 +1278,7 @@ xFlags = [ ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields ), ( "OverloadedStrings", Opt_OverloadedStrings ), ( "GADTs", Opt_GADTs ), + ( "ViewPatterns", Opt_ViewPatterns), ( "TypeFamilies", Opt_TypeFamilies ), ( "BangPatterns", Opt_BangPatterns ), -- On by default: diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index c223bad91c..9a7a255395 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -25,7 +25,7 @@ module HscMain #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..), LStmt, LHsType ) +import HsSyn ( StmtLR(..), LStmt, LHsType ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index d0c2f1332e..abebd14b6b 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -34,8 +34,6 @@ module HscTypes ( ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, emptyIfaceDepCache, - Deprecs(..), IfaceDeprecs, - FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, implicitTyThings, isImplicitTyThing, @@ -53,7 +51,7 @@ module HscTypes ( GenAvailInfo(..), AvailInfo, RdrAvailInfo, IfaceExport, - Deprecations, DeprecTxt, plusDeprecs, + Deprecations(..), DeprecTxt, plusDeprecs, PackageInstEnv, PackageRuleBase, @@ -434,7 +432,7 @@ data ModIface -- NOT STRICT! we read this field lazily from the interface file -- Deprecations - mi_deprecs :: IfaceDeprecs, + mi_deprecs :: Deprecations, -- NOT STRICT! we read this field lazily from the interface file -- Type, class and variable declarations @@ -801,31 +799,62 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) %************************************************************************ \begin{code} +-- N.B. the set of TyThings returned here *must* match the set of +-- names returned by LoadIface.ifaceDeclSubBndrs, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. implicitTyThings :: TyThing -> [TyThing] --- If you change this, make sure you change LoadIface.ifaceDeclSubBndrs in sync - -implicitTyThings (AnId _) = [] - -- For type constructors, add the data cons (and their extras), - -- and the selectors and generic-programming Ids too - -- - -- Newtypes don't have a worker Id, so don't generate that? -implicitTyThings (ATyCon tc) = implicitCoTyCon tc ++ - map AnId (tyConSelIds tc) ++ - concatMap (extras_plus . ADataCon) - (tyConDataCons tc) +-- For data and newtype declarations: +implicitTyThings (ATyCon tc) = + -- fields (names of selectors) + map AnId (tyConSelIds tc) ++ + -- (possibly) implicit coercion and family coercion + -- depending on whether it's a newtype or a family instance or both + implicitCoTyCon tc ++ + -- for each data constructor in order, + -- the contructor, worker, and (possibly) wrapper + concatMap (extras_plus . ADataCon) (tyConDataCons tc) - -- For classes, add the class selector Ids, and assoicated TyCons - -- and the class TyCon too (and its extras) implicitTyThings (AClass cl) - = map AnId (classSelIds cl) ++ + = -- dictionary datatype: + -- [extras_plus:] + -- type constructor + -- [recursive call:] + -- (possibly) newtype coercion; definitely no family coercion here + -- data constructor + -- worker + -- (no wrapper by invariant) + extras_plus (ATyCon (classTyCon cl)) ++ + -- associated types + -- No extras_plus (recursive call) for the classATs, because they + -- are only the family decls; they have no implicit things map ATyCon (classATs cl) ++ - -- No extras_plus for the classATs, because they - -- are only the family decls; they have no implicit things - extras_plus (ATyCon (classTyCon cl)) + -- superclass and operation selectors + map AnId (classSelIds cl) + +implicitTyThings (ADataCon dc) = + -- For data cons add the worker and (possibly) wrapper + map AnId (dataConImplicitIds dc) + +implicitTyThings (AnId _) = [] + +-- add a thing and recursive call +extras_plus :: TyThing -> [TyThing] +extras_plus thing = thing : implicitTyThings thing + +-- For newtypes and indexed data types (and both), +-- add the implicit coercion tycon +implicitCoTyCon :: TyCon -> [TyThing] +implicitCoTyCon tc + = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not + newTyConCo_maybe tc, + -- Just if family instance, Nothing if not + tyConFamilyCoercion_maybe tc] + +-- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y) - -- For data cons add the worker and wrapper (if any) -implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) -- | returns 'True' if there should be no interface-file declaration -- for this thing on its own: either it is built-in, or it is part @@ -837,15 +866,6 @@ isImplicitTyThing (AnId id) = isImplicitId id isImplicitTyThing (AClass _) = False isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc - -- For newtypes and indexed data types, add the implicit coercion tycon -implicitCoTyCon :: TyCon -> [TyThing] -implicitCoTyCon tc - = map ATyCon . catMaybes $ [newTyConCo_maybe tc, - tyConFamilyCoercion_maybe tc] - -extras_plus :: TyThing -> [TyThing] -extras_plus thing = thing : implicitTyThings thing - extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids = extendNameEnvList env [(getName id, AnId id) | id <- ids] @@ -950,21 +970,33 @@ emptyIfaceVerCache :: OccName -> Maybe (OccName, Version) emptyIfaceVerCache _occ = Nothing ------------------ Deprecations ------------------------- -data Deprecs a +data Deprecations = NoDeprecs - | DeprecAll DeprecTxt -- Whole module deprecated - | DeprecSome a -- Some specific things deprecated + | DeprecAll DeprecTxt -- Whole module deprecated + | DeprecSome [(OccName,DeprecTxt)] -- Some specific things deprecated + -- Only an OccName is needed because + -- (1) a deprecation always applies to a binding + -- defined in the module in which the deprecation appears. + -- (2) deprecations are only reported outside the defining module. + -- this is important because, otherwise, if we saw something like + -- + -- {-# DEPRECATED f "" #-} + -- f = ... + -- h = f + -- g = let f = undefined in f + -- + -- we'd need more information than an OccName to know to say something + -- about the use of f in h but not the use of the locally bound f in g + -- + -- however, because we only report about deprecations from the outside, + -- and a module can only export one value called f, + -- an OccName suffices. + -- + -- this is in contrast with fixity declarations, where we need to map + -- a Name to its fixity declaration. deriving( Eq ) -type IfaceDeprecs = Deprecs [(OccName,DeprecTxt)] -type Deprecations = Deprecs (NameEnv (OccName,DeprecTxt)) - -- Keep the OccName so we can flatten the NameEnv to - -- get an IfaceDeprecs from a Deprecations - -- Only an OccName is needed, because a deprecation always - -- applies to things defined in the module in which the - -- deprecation appears. - -mkIfaceDepCache:: IfaceDeprecs -> Name -> Maybe DeprecTxt +mkIfaceDepCache :: Deprecations -> Name -> Maybe DeprecTxt mkIfaceDepCache NoDeprecs = \_ -> Nothing mkIfaceDepCache (DeprecAll t) = \_ -> Just t mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName @@ -977,7 +1009,7 @@ plusDeprecs d NoDeprecs = d plusDeprecs NoDeprecs d = d plusDeprecs _ (DeprecAll t) = DeprecAll t plusDeprecs (DeprecAll t) _ = DeprecAll t -plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2) +plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 ++ v2) \end{code} @@ -1036,18 +1068,18 @@ emptyIfaceFixCache _ = defaultFixity type FixityEnv = NameEnv FixItem -- We keep the OccName in the range so that we can generate an interface from it -data FixItem = FixItem OccName Fixity SrcSpan +data FixItem = FixItem OccName Fixity instance Outputable FixItem where - ppr (FixItem occ fix loc) = ppr fix <+> ppr occ <+> parens (ppr loc) + ppr (FixItem occ fix) = ppr fix <+> ppr occ emptyFixityEnv :: FixityEnv emptyFixityEnv = emptyNameEnv lookupFixity :: FixityEnv -> Name -> Fixity lookupFixity env n = case lookupNameEnv env n of - Just (FixItem _ fix _) -> fix - Nothing -> defaultFixity + Just (FixItem _ fix) -> fix + Nothing -> defaultFixity \end{code} diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index bfcf5f6631..9187f1a4f9 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -441,7 +441,6 @@ resume (Session ref) step handleRunStatus expr ref bindings final_ids breakMVar statusMVar status hist' - back :: Session -> IO ([Name], Int, SrcSpan) back = moveHist (+1) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index d91143f333..109fd8be47 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1327,7 +1327,7 @@ fexp :: { LHsExpr RdrName } aexp :: { LHsExpr RdrName } : qvar '@' aexp { LL $ EAsPat $1 $3 } | '~' aexp { LL $ ELazyPat $2 } - | aexp1 { $1 } + | aexp1 { $1 } aexp1 :: { LHsExpr RdrName } : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3 @@ -1348,16 +1348,18 @@ aexp2 :: { LHsExpr RdrName } | literal { L1 (HsLit $! unLoc $1) } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. --- | STRING { L1 (HsOverLit $! mkHsIsString (getSTRING $1)) } - | INTEGER { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) } - | RATIONAL { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) } - | '(' exp ')' { LL (HsPar $2) } +-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRING $1) placeHolderType) } + | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGER $1) placeHolderType) } + | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) } + -- N.B.: sections get parsed by these next two productions. + -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't correct Haskell98 + -- (you'd have to write '((+ 3), (4 -))') + -- but the less cluttered version fell out of having texps. + | '(' texp ')' { LL (HsPar $2) } | '(' texp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed } | '(#' texps '#)' { LL $ ExplicitTuple (reverse $2) Unboxed } | '[' list ']' { LL (unLoc $2) } | '[:' parr ':]' { LL (unLoc $2) } - | '(' infixexp qop ')' { LL $ SectionL $2 $3 } - | '(' qopm infixexp ')' { LL $ SectionR $2 $3 } | '_' { L1 EWildPat } -- Template Haskell Extension @@ -1395,11 +1397,17 @@ cvtopdecls0 :: { [LHsDecl RdrName] } : {- empty -} { [] } | cvtopdecls { $1 } +-- tuple expressions: things that can appear unparenthesized as long as they're +-- inside parens or delimitted by commas texp :: { LHsExpr RdrName } : exp { $1 } - | qopm infixexp { LL $ SectionR $1 $2 } - -- The second production is really here only for bang patterns - -- but + -- Technically, this should only be used for bang patterns, + -- but we can be a little more liberal here and avoid parens + -- inside tuples + | infixexp qop { LL $ SectionL $1 $2 } + | qopm infixexp { LL $ SectionR $1 $2 } + -- view patterns get parenthesized above + | exp '->' exp { LL $ EViewPat $1 $3 } texps :: { [LHsExpr RdrName] } : texps ',' texp { $3 : $1 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index ce02da0863..6e77dee417 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -653,7 +653,7 @@ checkAPat loc e = case e of -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - HsOverLit pos_lit -> return (mkNPat pos_lit Nothing) + HsOverLit pos_lit -> return (mkNPat pos_lit Nothing) NegApp (L _ (HsOverLit pos_lit)) _ -> return (mkNPat pos_lit (Just noSyntaxExpr)) @@ -665,6 +665,8 @@ checkAPat loc e = case e of ELazyPat e -> checkLPat e >>= (return . LazyPat) EAsPat n e -> checkLPat e >>= (return . AsPat n) + -- view pattern is well-formed if the pattern is + EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType)) ExprWithTySig e t -> checkLPat e >>= \e -> -- Pattern signatures are parsed as sigtypes, -- but they aren't explicit forall points. Hence @@ -677,7 +679,7 @@ checkAPat loc e = case e of -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ - (L _ (HsOverLit lit@(HsIntegral _ _))) + (L _ (HsOverLit lit@(HsIntegral _ _ _))) | plus == plus_RDR -> return (mkNPlusKPat (L nloc n) lit) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 6b98ca95a5..cae7ef0236 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -16,11 +16,11 @@ they may be affected by renaming (which isn't fully worked out yet). -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module RnBinds ( - rnTopBinds, - rnLocalBindsAndThen, rnValBindsAndThen, rnValBinds, trimWith, - rnMethodBinds, renameSigs, mkSigTvFn, - rnMatchGroup, rnGRHSs +module RnBinds (rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, -- use these for top-level bindings + rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, -- or these for local bindings + rnMethodBinds, renameSigs, mkSigTvFn, + rnMatchGroup, rnGRHSs, + makeMiniFixityEnv ) where #include "HsVersions.h" @@ -31,21 +31,30 @@ import HsSyn import RdrHsSyn import RnHsSyn import TcRnMonad -import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs, - rnLPat, rnPatsAndThen, patSigErr, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn, - lookupInstDeclBndr, newIPNameRn, - lookupLocatedSigOccRn, bindPatSigTyVarsFV, - bindLocalFixities, bindSigTyVarsFV, - warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, +import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch) +import RnPat (rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec, + NameMaker, localNameMaker, topNameMaker, applyNameMaker, + patSigErr) + +import RnEnv ( lookupLocatedBndrRn, + lookupInstDeclBndr, newIPNameRn, + lookupLocatedSigOccRn, bindPatSigTyVarsFV, + bindLocalFixities, bindSigTyVarsFV, + warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, + bindLocatedLocalsFV, bindLocalNames, bindLocalNamesFV, + bindLocalNamesFV_WithFixities, + bindLocatedLocalsRn, + checkDupNames, checkShadowing ) import DynFlags ( DynFlag(..) ) +import HscTypes (FixItem(..)) import Name import NameEnv +import UniqFM import NameSet import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) -import SrcLoc ( Located(..), unLoc ) +import SrcLoc ( Located(..), unLoc, noLoc ) import ListSetOps ( findDupsEq ) import BasicTypes ( RecFlag(..) ) import Digraph ( SCC(..), stronglyConnComp ) @@ -162,30 +171,46 @@ it expects the global environment to contain bindings for the binders %* * %************************************************************************ -@rnTopMonoBinds@ assumes that the environment already -contains bindings for the binders of this particular binding. - \begin{code} -rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) - --- The binders of the binding are in scope already; --- the top level scope resolution does that - -rnTopBinds binds - = do { is_boot <- tcIsHsBoot - ; if is_boot then rnTopBindsBoot binds - else rnTopBindsSrc binds } - -rnTopBindsBoot :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) +-- for top-level bindings, we need to make top-level names, +-- so we have a different entry point than for local bindings +rnTopBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind + -- these fixities need to be brought into scope with the names + -> HsValBinds RdrName + -> RnM (HsValBindsLR Name RdrName) +rnTopBindsLHS fix_env binds = + (uncurry $ rnValBindsLHSFromDoc True) (bindersAndDoc binds) fix_env binds + +rnTopBindsRHS :: [Name] -- the names bound by these binds + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) +rnTopBindsRHS bound_names binds = + do { is_boot <- tcIsHsBoot + ; if is_boot + then rnTopBindsBoot binds + else rnValBindsRHSGen (\x -> x) -- don't trim free vars + bound_names binds } + + +-- wrapper if we don't need to do anything in between the left and right, +-- or anything else in the scope of the left +-- +-- never used when there are fixity declarations +rnTopBinds :: HsValBinds RdrName + -> RnM (HsValBinds Name, DefUses) +rnTopBinds b = + do nl <- rnTopBindsLHS emptyUFM b + let bound_names = map unLoc (collectHsValBinders nl) + bindLocalNames bound_names $ rnTopBindsRHS bound_names nl + + +rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) ; sigs' <- renameSigs okHsBootSig sigs ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } - -rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) -rnTopBindsSrc binds = rnValBinds noTrim binds \end{code} @@ -197,26 +222,25 @@ rnTopBindsSrc binds = rnValBinds noTrim binds %********************************************************* \begin{code} -rnLocalBindsAndThen - :: HsLocalBinds RdrName - -> (HsLocalBinds Name -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) --- This version (a) assumes that the binding vars are not already in scope --- (b) removes the binders from the free vars of the thing inside +rnLocalBindsAndThen :: HsLocalBinds RdrName + -> (HsLocalBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +-- This version (a) assumes that the binding vars are *not* already in scope +-- (b) removes the binders from the free vars of the thing inside -- The parser doesn't produce ThenBinds rnLocalBindsAndThen EmptyLocalBinds thing_inside = thing_inside EmptyLocalBinds rnLocalBindsAndThen (HsValBinds val_binds) thing_inside = rnValBindsAndThen val_binds $ \ val_binds' -> - thing_inside (HsValBinds val_binds') + thing_inside (HsValBinds val_binds') rnLocalBindsAndThen (HsIPBinds binds) thing_inside = rnIPBinds binds `thenM` \ (binds',fv_binds) -> thing_inside (HsIPBinds binds') `thenM` \ (thing, fvs_thing) -> returnM (thing, fvs_thing `plusFV` fv_binds) -------------- + rnIPBinds (IPBinds ip_binds _no_dict_binds) = do { (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds ; return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s) } @@ -235,68 +259,299 @@ rnIPBind (IPBind n expr) %************************************************************************ \begin{code} -rnValBindsAndThen :: HsValBinds RdrName - -> (HsValBinds Name -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) - -rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside - = -- Extract all the binders in this group, and extend the - -- current scope, inventing new names for the new binders - -- This also checks that the names form a set - bindLocatedLocalsRn doc mbinders_w_srclocs $ \ bndrs -> - - -- Then install local fixity declarations - -- Notice that they scope over thing_inside too - bindLocalFixities [sig | L _ (FixSig sig) <- sigs ] $ - - -- Do the business - rnValBinds (trimWith bndrs) binds `thenM` \ (binds, bind_dus) -> - - -- Now do the "thing inside" - thing_inside binds `thenM` \ (result,result_fvs) -> - - -- Final error checking +-- wrapper for local binds +-- creates the documentation info and calls the helper below +rnValBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind + -- these fixities need to be brought into scope with the names + -> HsValBinds RdrName + -> RnM (HsValBindsLR Name RdrName) +rnValBindsLHS fix_env binds = + let (boundNames,doc) = bindersAndDoc binds + in rnValBindsLHSFromDoc_Local boundNames doc fix_env binds + +-- a helper used for local binds that does the duplicates check, +-- just so we don't forget to do it somewhere +rnValBindsLHSFromDoc_Local :: [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice) + -> SDoc -- doc string for dup names and shadowing + -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind + -- these fixities need to be brought into scope with the names + -> HsValBinds RdrName + -> RnM (HsValBindsLR Name RdrName) + +rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do + -- Do error checking: we need to check for dups here because we + -- don't don't bind all of the variables from the ValBinds at once + -- with bindLocatedLocals any more. + -- + checkDupNames doc boundNames + -- Warn about shadowing, but only in source modules + ifOptM Opt_WarnNameShadowing (checkShadowing doc boundNames) + + -- (Note that we don't want to do this at the top level, since + -- sorting out duplicates and shadowing there happens elsewhere. + -- The behavior is even different. For example, + -- import A(f) + -- f = ... + -- should not produce a shadowing warning (but it will produce + -- an ambiguity warning if you use f), but + -- import A(f) + -- g = let f = ... in f + -- should. + rnValBindsLHSFromDoc False boundNames doc fix_env binds + +bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc) +bindersAndDoc binds = let - all_uses = duUses bind_dus `plusFV` result_fvs - -- duUses: It's important to return all the uses, not the 'real uses' - -- used for warning about unused bindings. Otherwise consider: - -- x = 3 - -- y = let p = x in 'x' -- NB: p not used - -- If we don't "see" the dependency of 'y' on 'x', we may put the - -- bindings in the wrong order, and the type checker will complain - -- that x isn't in scope - - unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)] + -- the unrenamed bndrs for error checking and reporting + orig = collectHsValBinders binds + doc = text "In the binding group for:" <+> pprWithCommas ppr (map unLoc orig) in - warnUnusedLocalBinds unused_bndrs `thenM_` + (orig, doc) + +-- renames the left-hand sides +-- generic version used both at the top level and for local binds +-- does some error checking, but not what gets done elsewhere at the top level +rnValBindsLHSFromDoc :: Bool -- top or not + -> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice) + -> SDoc -- doc string for dup names and shadowing + -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind + -- these fixities need to be brought into scope with the names + -> HsValBinds RdrName + -> RnM (HsValBindsLR Name RdrName) +rnValBindsLHSFromDoc topP original_bndrs doc fix_env binds@(ValBindsIn mbinds sigs) + = do + -- rename the LHSes + mbinds' <- mapBagM (rnBindLHS topP doc fix_env) mbinds + return $ ValBindsIn mbinds' sigs + +-- assumes the LHS vars are in scope +-- general version used both from the top-level and for local things +-- +-- does not bind the local fixity declarations +rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets + -- The trimming function trims the free vars we attach to a + -- binding so that it stays reasonably small + -> [Name] -- names bound by the LHSes + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) + +rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) + = do -- rename the sigs + sigs' <- rename_sigs sigs + -- rename the RHSes + binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds + let (anal_binds, anal_dus) = depAnalBinds binds_w_dus + (valbind', valbind'_dus) = (ValBindsOut anal_binds sigs', + usesOnly (hsSigsFVs sigs') `plusDU` anal_dus) + -- We do the check-sigs after renaming the bindings, + -- so that we have convenient access to the binders + check_sigs (okBindSig (duDefs anal_dus)) sigs' + returnM (valbind', valbind'_dus) + +-- wrapper for local binds +-- +-- the *client* of this function is responsible for checking for unused binders; +-- it doesn't (and can't: we don't have the thing inside the binds) happen here +-- +-- the client is also responsible for bringing the fixities into scope +rnValBindsRHS :: [Name] -- names bound by the LHSes + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) +rnValBindsRHS bound_names binds = + rnValBindsRHSGen (\ fvs -> -- only keep the names the names from this group + intersectNameSet (mkNameSet bound_names) fvs) bound_names binds - returnM (result, delListFromNameSet all_uses bndrs) - where - mbinders_w_srclocs = collectHsBindLocatedBinders mbinds - doc = text "In the binding group for:" - <+> pprWithCommas ppr (map unLoc mbinders_w_srclocs) + +-- for local binds +-- wrapper that does both the left- and right-hand sides +-- +-- here there are no local fixity decls passed in; +-- the local fixity decls come from the ValBinds sigs +rnValBindsAndThen :: HsValBinds RdrName + -> (HsValBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside = + let + (original_bndrs, doc) = bindersAndDoc binds + + in do + -- (A) create the local fixity environment + new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] + + -- (B) rename the LHSes + new_lhs <- rnValBindsLHSFromDoc_Local original_bndrs doc new_fixities binds + let bound_names = map unLoc $ collectHsValBinders new_lhs + + -- and bring them (and their fixities) into scope + bindLocalNamesFV_WithFixities bound_names new_fixities $ do + + -- (C) do the RHS and thing inside + (binds', dus) <- rnValBindsRHS bound_names new_lhs + (result, result_fvs) <- thing_inside binds' + + let + -- the variables used in the val binds are: + -- (1) the uses of the binds + -- (2) the FVs of the thing-inside + all_uses = (duUses dus) `plusFV` result_fvs + -- duUses: It's important to return all the uses. Otherwise consider: + -- x = 3 + -- y = let p = x in 'x' -- NB: p not used + -- If we don't "see" the dependency of 'y' on 'x', we may put the + -- bindings in the wrong order, and the type checker will complain + -- that x isn't in scope + + -- check for unused binders. note that we only want to do + -- this for local ValBinds; it gets done elsewhere for + -- top-level binds (where the scoping is different) + unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` all_uses)] + + warnUnusedLocalBinds unused_bndrs + + return (result, + -- the bound names are pruned out of all_uses + -- by the bindLocalNamesFV call above + all_uses) + + +-- Process the fixity declarations, making a FastString -> (Located Fixity) map +-- (We keep the location around for reporting duplicate fixity declarations.) +-- +-- Checks for duplicates, but not that only locally defined things are fixed. +-- Note: for local fixity declarations, duplicates would also be checked in +-- check_sigs below. But we also use this function at the top level. +makeMiniFixityEnv :: [LFixitySig RdrName] + -> RnM (UniqFM (Located Fixity)) -- key is the FastString of the OccName + -- of the fixity declaration it came from + +makeMiniFixityEnv decls = foldlM add_one emptyUFM decls + where + add_one env (L loc (FixitySig (L name_loc name) fixity)) = do + { -- this fixity decl is a duplicate iff + -- the ReaderName's OccName's FastString is already in the env + -- (we only need to check the local fix_env because + -- definitions of non-local will be caught elsewhere) + let {occ = rdrNameOcc name; + curKey = occNameFS occ; + fix_item = L loc fixity}; + + case lookupUFM env curKey of + Nothing -> return $ addToUFM env curKey fix_item + Just (L loc' _) -> do + { setSrcSpan loc $ + addLocErr (L name_loc name) (dupFixityDecl loc') + ; return env} + } + +pprFixEnv :: NameEnv FixItem -> SDoc +pprFixEnv env + = pprWithCommas (\ (FixItem n f) -> ppr f <+> ppr n) + (nameEnvElts env) + +dupFixityDecl loc rdr_name + = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), + ptext SLIT("also at ") <+> ppr loc] --------------------- -rnValBinds :: (FreeVars -> FreeVars) - -> HsValBinds RdrName - -> RnM (HsValBinds Name, DefUses) --- Assumes the binders of the binding are in scope already -rnValBinds trim (ValBindsIn mbinds sigs) - = do { sigs' <- rename_sigs sigs +-- renaming a single bind + +rnBindLHS :: Bool -- top if true; local if false + -> SDoc + -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind + -- these fixities need to be brought into scope with the names + -> LHsBind RdrName + -- returns the renamed left-hand side, + -- and the FreeVars *of the LHS* + -- (i.e., any free variables of the pattern) + -> RnM (LHsBindLR Name RdrName) + +rnBindLHS topP doc fix_env (L loc (PatBind { pat_lhs = pat, + pat_rhs = grhss, + bind_fvs=bind_fvs, + pat_rhs_ty=pat_rhs_ty + })) + = setSrcSpan loc $ do + -- we don't actually use the FV processing of rnPatsAndThen here + (pat',pat'_fvs) <- (if topP then rnPat_TopRec else rnPat_LocalRec) fix_env pat + return (L loc (PatBind { pat_lhs = pat', + pat_rhs = grhss, + -- we temporarily store the pat's FVs here; + -- gets updated to the FVs of the whole bind + -- when doing the RHS below + bind_fvs = pat'_fvs, + -- these will get ignored in the next pass, + -- when we rename the RHS + pat_rhs_ty = pat_rhs_ty })) + +rnBindLHS topP doc fix_env (L loc (FunBind { fun_id = name@(L nameLoc _), + fun_infix = inf, + fun_matches = matches, + fun_co_fn = fun_co_fn, + bind_fvs = bind_fvs, + fun_tick = fun_tick + })) + = setSrcSpan loc $ do + newname <- applyNameMaker (if topP then topNameMaker else localNameMaker) name + return (L loc (FunBind { fun_id = L nameLoc newname, + fun_infix = inf, + fun_matches = matches, + -- we temporatily store the LHS's FVs (empty in this case) here + -- gets updated when doing the RHS below + bind_fvs = emptyFVs, + -- everything else will get ignored in the next pass + fun_co_fn = fun_co_fn, + fun_tick = fun_tick + })) + +-- assumes the left-hands-side vars are in scope +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars + -> LHsBindLR Name RdrName + -> RnM (LHsBind Name, [Name], Uses) +rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat, + pat_rhs = grhss, + -- pat fvs were stored here while processing the LHS + bind_fvs=pat_fvs })) + = setSrcSpan loc $ + do {let bndrs = collectPatBinders pat - ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds + ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss + -- No scoped type variables for pattern bindings - ; let (binds', bind_dus) = depAnalBinds binds_w_dus + ; return (L loc (PatBind { pat_lhs = pat, + pat_rhs = grhss', + pat_rhs_ty = placeHolderType, + bind_fvs = trim fvs }), + bndrs, pat_fvs `plusFV` fvs) } - -- We do the check-sigs after renaming the bindings, - -- so that we have convenient access to the binders - ; check_sigs (okBindSig (duDefs bind_dus)) sigs' +rnBind sig_fn + trim + (L loc (FunBind { fun_id = name, + fun_infix = inf, + fun_matches = matches, + -- no pattern FVs + bind_fvs = _ + })) + -- invariant: no free vars here when it's a FunBind + = setSrcSpan loc $ + do { let plain_name = unLoc name - ; return (ValBindsOut binds' sigs', - usesOnly (hsSigsFVs sigs') `plusDU` bind_dus) } + ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + -- bindSigTyVars tests for Opt_ScopedTyVars + rnMatchGroup (FunRhs plain_name inf) matches + ; checkPrecMatch inf plain_name matches' + ; return (L loc (FunBind { fun_id = name, + fun_infix = inf, + fun_matches = matches', + bind_fvs = trim fvs, + fun_co_fn = idHsWrapper, + fun_tick = Nothing }), + [plain_name], fvs) + } + --------------------- depAnalBinds :: Bag (LHsBind Name, [Name], Uses) -> ([(RecFlag, LHsBinds Name)], DefUses) @@ -352,49 +607,6 @@ mkSigTvFn sigs (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all - --- The trimming function trims the free vars we attach to a --- binding so that it stays reasonably small -noTrim :: FreeVars -> FreeVars -noTrim fvs = fvs -- Used at top level - -trimWith :: [Name] -> FreeVars -> FreeVars --- Nested bindings; trim by intersection with the names bound here -trimWith bndrs = intersectNameSet (mkNameSet bndrs) - ---------------------- -rnBind :: (Name -> [Name]) -- Signature tyvar function - -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars - -> LHsBind RdrName - -> RnM (LHsBind Name, [Name], Uses) -rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss })) - = setSrcSpan loc $ - do { (pat', pat_fvs) <- rnLPat pat - - ; let bndrs = collectPatBinders pat' - - ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss - -- No scoped type variables for pattern bindings - - ; return (L loc (PatBind { pat_lhs = pat', pat_rhs = grhss', - pat_rhs_ty = placeHolderType, bind_fvs = trim fvs }), - bndrs, pat_fvs `plusFV` fvs) } - -rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = matches })) - = setSrcSpan loc $ - do { new_name <- lookupLocatedBndrRn name - ; let plain_name = unLoc new_name - - ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - -- bindSigTyVars tests for Opt_ScopedTyVars - rnMatchGroup (FunRhs plain_name inf) matches - - ; checkPrecMatch inf plain_name matches' - - ; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches', - bind_fvs = trim fvs, fun_co_fn = idHsWrapper, fun_tick = Nothing }), - [plain_name], fvs) - } \end{code} @@ -493,9 +705,7 @@ renameSigs ok_sig sigs ---------------------- rename_sigs :: [LSig RdrName] -> RnM [LSig Name] -rename_sigs sigs = mappM (wrapLocM renameSig) - (filter (not . isFixityLSig) sigs) - -- Remove fixity sigs which have been dealt with already +rename_sigs sigs = mappM (wrapLocM renameSig) sigs ---------------------- check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM () @@ -503,7 +713,9 @@ check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM () check_sigs ok_sig sigs -- Check for (a) duplicate signatures -- (b) signatures for things not in this group - = do { mappM_ unknownSigErr (filter (not . ok_sig) sigs') + = do { + traceRn (text "SIGS" <+> ppr sigs) + ; mappM_ unknownSigErr (filter (not . ok_sig) sigs') ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs') } where -- Don't complain about an unbound name again @@ -540,6 +752,10 @@ renameSig (SpecSig v ty inl) renameSig (InlineSig v s) = lookupLocatedSigOccRn v `thenM` \ new_v -> returnM (InlineSig new_v s) + +renameSig (FixSig (FixitySig v f)) + = lookupLocatedSigOccRn v `thenM` \ new_v -> + returnM (FixSig (FixitySig new_v f)) \end{code} @@ -572,7 +788,8 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) ) `thenM` \ (maybe_rhs_sig', ty_fvs) -> -- Now the main event - rnPatsAndThen ctxt pats $ \ pats' -> + -- note that there are no local ficity decls for matches + rnPatsAndThen_LocalRightwards ctxt pats $ \ (pats',_) -> rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 933de84ff0..86f3d67fd4 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1,4 +1,4 @@ -% +\% % (c) The GRASP/AQUA Project, Glasgow University, 1992-2006 % \section[RnEnv]{Environment manipulation for the renamer monad} @@ -13,25 +13,25 @@ module RnEnv ( newTopSrcBinder, lookupFamInstDeclBndr, - lookupLocatedBndrRn, lookupBndrRn, - lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedBndrRn, lookupBndrRn, lookupBndrRn_maybe, + lookupLocatedTopBndrRn, lookupTopBndrRn, lookupBndrRn_maybe, lookupLocatedOccRn, lookupOccRn, lookupLocatedGlobalOccRn, lookupGlobalOccRn, lookupLocalDataTcNames, lookupSrcOcc_maybe, lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, - lookupGreRn, lookupGreRn_maybe, + lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, newLocalsRn, newIPNameRn, - bindLocalNames, bindLocalNamesFV, + bindLocalNames, bindLocalNamesFV, bindLocalNamesFV_WithFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalFixities, - checkDupNames, mapFvRn, + checkDupNames, checkShadowing, mapFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, @@ -56,20 +56,21 @@ import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, Provenance(..), pprNameProvenance, importSpecLoc, importSpecModule ) -import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity) import TcEnv ( tcLookupDataCon ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, nameSrcLoc, nameOccName, nameModule, isExternalName ) import NameSet import NameEnv +import UniqFM import DataCon ( dataConFieldLabels ) import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, - reportIfUnused ) + reportIfUnused, occNameFS ) import Module ( Module, ModuleName ) import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply -import BasicTypes ( IPName, mapIPName ) +import BasicTypes ( IPName, mapIPName, Fixity ) import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan ) import Outputable @@ -79,6 +80,7 @@ import ListSetOps ( removeDups ) import List ( nubBy ) import Monad ( when ) import DynFlags +import FastString \end{code} %********************************************************* @@ -150,17 +152,31 @@ lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedBndrRn = wrapLocM lookupBndrRn lookupBndrRn :: RdrName -> RnM Name +lookupBndrRn n = do nopt <- lookupBndrRn_maybe n + case nopt of + Just n' -> return n' + Nothing -> do traceRn $ text "lookupTopBndrRn" + unboundName n + +lookupTopBndrRn :: RdrName -> RnM Name +lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n + case nopt of + Just n' -> return n' + Nothing -> do traceRn $ text "lookupTopBndrRn" + unboundName n + +lookupBndrRn_maybe :: RdrName -> RnM (Maybe Name) -- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd -lookupBndrRn rdr_name +lookupBndrRn_maybe rdr_name = getLocalRdrEnv `thenM` \ local_env -> case lookupLocalRdrEnv local_env rdr_name of - Just name -> returnM name - Nothing -> lookupTopBndrRn rdr_name + Just name -> returnM (Just name) + Nothing -> lookupTopBndrRn_maybe rdr_name lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn -lookupTopBndrRn :: RdrName -> RnM Name +lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name) -- Look up a top-level source-code binder. We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. -- For example, this is OK: @@ -177,24 +193,23 @@ lookupTopBndrRn :: RdrName -> RnM Name -- The Haskell parser checks for the illegal qualified name in Haskell -- source files, so we don't need to do so here. -lookupTopBndrRn rdr_name +lookupTopBndrRn_maybe rdr_name | Just name <- isExact_maybe rdr_name - = returnM name + = returnM (Just name) | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name -- This deals with the case of derived bindings, where -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name = do { loc <- getSrcSpanM - ; newGlobalBinder rdr_mod rdr_occ loc } + ; n <- newGlobalBinder rdr_mod rdr_occ loc + ; return (Just n)} | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name ; case mb_gre of - Nothing -> do - traceRn $ text "lookupTopBndrRn" - unboundName rdr_name - Just gre -> returnM (gre_name gre) } + Nothing -> returnM Nothing + Just gre -> returnM (Just $ gre_name gre) } -- lookupLocatedSigOccRn is used for type signatures and pragmas -- Is this valid? @@ -281,7 +296,7 @@ lookupConstructorFields con_name ; if nameIsLocalOrFrom this_mod con_name then do { field_env <- getRecFieldEnv ; return (lookupNameEnv field_env con_name `orElse` []) } - else + else do { con <- tcLookupDataCon con_name ; return (dataConFieldLabels con) } } @@ -510,24 +525,54 @@ lookupLocalDataTcNames rdr_name | otherwise = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) ; case [gre_name gre | Just gre <- mb_gres] of - [] -> do { addErr (unknownNameErr rdr_name) - ; return [] } + [] -> do { + -- run for error reporting + ; unboundName rdr_name + ; return [] } names -> return names } -------------------------------- -bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a --- Used for nested fixity decls +bindLocalFixities :: [FixitySig RdrName] -> (UniqFM (Located Fixity) -> RnM a) -> RnM a +-- Used for nested fixity decls: +-- bind the names that are in scope already; +-- pass the rest to the continuation for later +-- as a FastString->(Located Fixity) map +-- -- No need to worry about type constructors here, --- Should check for duplicates but we don't +-- Should check for duplicates? bindLocalFixities fixes thing_inside - | null fixes = thing_inside - | otherwise = mappM rn_sig fixes `thenM` \ new_bit -> - extendFixityEnv new_bit thing_inside + | null fixes = thing_inside emptyUFM + | otherwise = do ls <- mappM rn_sig fixes + let (now, later) = nowAndLater ls + extendFixityEnv now $ thing_inside later where - rn_sig (FixitySig lv@(L loc v) fix) - = addLocM lookupBndrRn lv `thenM` \ new_v -> - returnM (new_v, (FixItem (rdrNameOcc v) fix loc)) + rn_sig (FixitySig lv@(L loc v) fix) = do + vopt <- lookupBndrRn_maybe v + case vopt of + Just new_v -> returnM (Left (new_v, (FixItem (rdrNameOcc v) fix))) + Nothing -> returnM (Right (occNameFS $ rdrNameOcc v, (L loc fix))) + + nowAndLater (ls :: [Either (Name, FixItem) (FastString, Located Fixity)]) = + foldr (\ cur -> \ (now, later) -> + case cur of + Left (n, f) -> ((n, f) : now, later) + Right (fs, f) -> (now, addToUFM later fs f)) + ([], emptyUFM) ls + +-- Used for nested fixity decls to bind names along with their fixities. +-- the fixities are given as a UFM from an OccName's FastString to a fixity decl +bindLocalNamesFV_WithFixities :: [Name] -> UniqFM (Located Fixity) -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV_WithFixities names fixities cont = + -- find the names that have fixity decls + let boundFixities = foldr + (\ name -> \ acc -> + -- check whether this name has a fixity decl + case lookupUFM fixities (occNameFS (nameOccName name)) of + Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc + Nothing -> acc) [] names in + -- bind the names; extend the fixity env; do the thing inside + bindLocalNamesFV names (extendFixityEnv boundFixities cont) \end{code} -------------------------------- @@ -547,13 +592,13 @@ lookupFixity is a bit strange. \begin{code} lookupFixityRn :: Name -> RnM Fixity lookupFixityRn name - = getModule `thenM` \ this_mod -> + = getModule `thenM` \ this_mod -> if nameIsLocalOrFrom this_mod name - then -- It's defined in this module - getFixityEnv `thenM` \ local_fix_env -> - traceRn (text "lookupFixityRn" <+> (ppr name $$ ppr local_fix_env)) `thenM_` - returnM (lookupFixity local_fix_env name) - + then do -- It's defined in this module + local_fix_env <- getFixityEnv + traceRn (text "lookupFixityRn: looking up name in local environment:" <+> + vcat [ppr name, ppr local_fix_env]) + return $ lookupFixity local_fix_env name else -- It's imported -- For imported names, we have to get their fixities by doing a -- loadInterfaceForName, and consulting the Ifaces that comes back @@ -571,8 +616,11 @@ lookupFixityRn name -- -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. - loadInterfaceForName doc name `thenM` \ iface -> - returnM (mi_fix_fn iface (nameOccName name)) + loadInterfaceForName doc name `thenM` \ iface -> do { + traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> + vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]); + returnM (mi_fix_fn iface (nameOccName name)) + } where doc = ptext SLIT("Checking fixity for") <+> ppr name @@ -708,7 +756,6 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope setLocalRdrEnv (extendLocalRdrEnv local_env names) (enclosed_scope names) - bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names enclosed_scope = getLocalRdrEnv `thenM` \ name_env -> @@ -724,8 +771,8 @@ bindLocalNamesFV names enclosed_scope ------------------------------------- -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocatedLocalsFV :: SDoc -> [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) - -> RnM (a, FreeVars) +bindLocatedLocalsFV :: SDoc -> [Located RdrName] + -> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars) bindLocatedLocalsFV doc rdr_names enclosed_scope = bindLocatedLocalsRn doc rdr_names $ \ names -> enclosed_scope names `thenM` \ (thing, fvs) -> @@ -826,6 +873,20 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> (ys, fvs_s) = unzip stuff in returnM (ys, plusFVs fvs_s) + +-- because some of the rename functions are CPSed: +-- maps the function across the list from left to right; +-- collects all the free vars into one set +mapFvRnCPS :: (a -> ((b,FreeVars) -> RnM (c, FreeVars)) -> RnM(c, FreeVars)) + -> [a] + -> (([b],FreeVars) -> RnM (c, FreeVars)) + -> RnM (c, FreeVars) + +mapFvRnCPS _ [] cont = cont ([], emptyFVs) + +mapFvRnCPS f (h:t) cont = f h $ \ (h',hfv) -> + mapFvRnCPS f t $ \ (t',tfv) -> + cont (h':t', hfv `plusFV` tfv) \end{code} diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index fd4017fe20..d9b229dd34 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -24,16 +24,18 @@ module RnExpr ( #include "HsVersions.h" import RnSource ( rnSrcDecls, rnSplice, checkTH ) -import RnBinds ( rnLocalBindsAndThen, rnValBinds, - rnMatchGroup, trimWith ) +import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, + rnMatchGroup, makeMiniFixityEnv) import HsSyn import TcRnMonad import RnEnv import HscTypes ( availNames ) import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) -import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, - mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, - rnHsRecFields, checkTupSize ) +import RnTypes ( rnHsTypeFVs, + mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) +import RnPat (rnOverLit, rnPatsAndThen_LocalRightwards, rnPat_LocalRec, localNameMaker, + rnLit, + rnHsRecFields_Con, rnHsRecFields_Update, checkTupSize) import DynFlags ( DynFlag(..) ) import BasicTypes ( FixityDirection(..) ) import SrcLoc ( SrcSpan ) @@ -43,6 +45,7 @@ import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, import Name ( Name, nameOccName, nameIsLocalOrFrom ) import NameSet +import UniqFM import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals ) import LoadIface ( loadInterfaceForName ) import UniqFM ( isNullUFM ) @@ -114,7 +117,7 @@ rnExpr (HsLit lit@(HsString s)) = do { opt_OverloadedStrings <- doptM Opt_OverloadedStrings ; if opt_OverloadedStrings then - rnExpr (HsOverLit (mkHsIsString s)) + rnExpr (HsOverLit (mkHsIsString s placeHolderType)) else -- Same as below rnLit lit `thenM_` returnM (HsLit lit, emptyFVs) @@ -228,14 +231,13 @@ rnExpr e@(ExplicitTuple exps boxity) rnExpr (RecordCon con_id _ rbinds) = do { conname <- lookupLocatedOccRn con_id - ; (rbinds', fvRbinds) <- rnHsRecFields "construction" (Just conname) - rnLExpr HsVar rbinds + ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds ; return (RecordCon conname noPostTcExpr rbinds', fvRbinds `addOneFV` unLoc conname) } rnExpr (RecordUpd expr rbinds _ _ _) = do { (expr', fvExpr) <- rnLExpr expr - ; (rbinds', fvRbinds) <- rnHsRecFields "update" Nothing rnLExpr HsVar rbinds + ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds ; return (RecordUpd expr' rbinds' [] [] [], fvExpr `plusFV` fvRbinds) } @@ -287,7 +289,7 @@ rnExpr e@(ELazyPat {}) = patSynErr e \begin{code} rnExpr (HsProc pat body) = newArrowScope $ - rnPatsAndThen ProcExpr [pat] $ \ [pat'] -> + rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ ([pat'],_) -> rnCmdTop body `thenM` \ (body',fvBody) -> returnM (HsProc pat' body', fvBody) @@ -527,46 +529,41 @@ rnBracket (VarBr n) = do { name <- lookupOccRn n rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr e', fvs) } -rnBracket (PatBr p) = do { (p', fvs) <- rnLPat p - ; return (PatBr p', fvs) } + +rnBracket (PatBr p) = do { addErr (ptext SLIT("Tempate Haskell pattern brackets are not supported yet")); + failM } + rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t ; return (TypBr t', fvs) } where doc = ptext SLIT("In a Template-Haskell quoted type") rnBracket (DecBr group) - = do { gbl_env <- getGblEnv - - ; let gbl_env1 = gbl_env { tcg_mod = thFAKE } - -- Note the thFAKE. The top-level names from the bracketed - -- declarations will go into the name cache, and we don't want them to - -- confuse the Names for the current module. - -- By using a pretend module, thFAKE, we keep them safely out of the way. - - ; avails <- getLocalDeclBinders gbl_env1 group - ; let names = concatMap availNames avails + = do { gbl_env <- getGblEnv + + ; let new_gbl_env = gbl_env { -- Set the module to thFAKE. The top-level names from the bracketed + -- declarations will go into the name cache, and we don't want them to + -- confuse the Names for the current module. + -- By using a pretend module, thFAKE, we keep them safely out of the way. + tcg_mod = thFAKE, + + -- The emptyDUs is so that we just collect uses for this group alone + -- in the call to rnSrcDecls below + tcg_dus = emptyDUs } + ; setGblEnv new_gbl_env $ do { - ; let new_occs = map nameOccName names - trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs - - ; rdr_env' <- extendRdrEnvRn trimmed_rdr_env avails -- In this situation we want to *shadow* top-level bindings. -- foo = 1 - -- bar = [d| foo = 1|] + -- bar = [d| foo = 1 |] -- If we don't shadow, we'll get an ambiguity complaint when we do -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo' -- -- Furthermore, arguably if the splice does define foo, that should hide -- any foo's further out -- - -- The shadowing is acheived by the call to hideSomeUnquals, which removes - -- the unqualified bindings of things defined by the bracket - - ; setGblEnv (gbl_env { tcg_rdr_env = rdr_env', - tcg_dus = emptyDUs }) $ do - -- The emptyDUs is so that we just collect uses for this group alone + -- The shadowing is acheived by calling rnSrcDecls with True as the shadowing flag + ; (tcg_env, group') <- rnSrcDecls True group - { (tcg_env, group') <- rnSrcDecls group - -- Discard the tcg_env; it contains only extra info about fixity + -- Discard the tcg_env; it contains only extra info about fixity ; return (DecBr group', allUses (tcg_dus tcg_env)) } } \end{code} @@ -599,7 +596,8 @@ rnNormalStmts ctxt (L loc stmt : stmts) thing_inside <- rnStmt ctxt stmt $ rnNormalStmts ctxt stmts thing_inside ; return (((L loc stmt' : stmts'), thing), fvs) } - + + rnStmt :: HsStmtContext Name -> Stmt RdrName -> RnM (thing, FreeVars) -> RnM ((Stmt Name, thing), FreeVars) @@ -616,11 +614,11 @@ rnStmt ctxt (BindStmt pat expr _ _) thing_inside -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupSyntaxName bindMName ; (fail_op, fvs2) <- lookupSyntaxName failMName - ; rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] -> do + ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ ([pat'],_) -> do { (thing, fvs3) <- thing_inside ; return ((BindStmt pat' expr' bind_op fail_op, thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} - -- fv_expr shouldn't really be filtered by the rnPatsAndThen + -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique rnStmt ctxt (LetStmt binds) thing_inside @@ -636,8 +634,8 @@ rnStmt ctxt (LetStmt binds) thing_inside ok _ _ = True rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside - = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ bndrs -> - rn_rec_stmts bndrs rec_stmts `thenM` \ segs -> + = + rn_rec_stmts_and_then rec_stmts $ \ segs -> thing_inside `thenM` \ (thing, fvs) -> let segs_w_fwd_refs = addFwdRefs segs @@ -723,38 +721,37 @@ type Segment stmts = (Defs, ---------------------------------------------------- + rnMDoStmts :: [LStmt RdrName] -> RnM (thing, FreeVars) -> RnM (([LStmt Name], thing), FreeVars) rnMDoStmts stmts thing_inside - = -- Step1: bring all the binders of the mdo into scope - -- Remember that this also removes the binders from the - -- finally-returned free-vars - bindLocatedLocalsRn doc (collectLStmtsBinders stmts) $ \ bndrs -> - do { - -- Step 2: Rename each individual stmt, making a - -- singleton segment. At this stage the FwdRefs field - -- isn't finished: it's empty for all except a BindStmt - -- for which it's the fwd refs within the bind itself - -- (This set may not be empty, because we're in a recursive - -- context.) - segs <- rn_rec_stmts bndrs stmts + = -- Step1: Bring all the binders of the mdo into scope + -- (Remember that this also removes the binders from the + -- finally-returned free-vars.) + -- And rename each individual stmt, making a + -- singleton segment. At this stage the FwdRefs field + -- isn't finished: it's empty for all except a BindStmt + -- for which it's the fwd refs within the bind itself + -- (This set may not be empty, because we're in a recursive + -- context.) + rn_rec_stmts_and_then stmts $ \ segs -> do { ; (thing, fvs_later) <- thing_inside ; let - -- Step 3: Fill in the fwd refs. + -- Step 2: Fill in the fwd refs. -- The segments are all singletons, but their fwd-ref -- field mentions all the things used by the segment -- that are bound after their use segs_w_fwd_refs = addFwdRefs segs - -- Step 4: Group together the segments to make bigger segments + -- Step 3: Group together the segments to make bigger segments -- Invariant: in the result, no segment uses a variable -- bound in a later segment grouped_segs = glomSegments segs_w_fwd_refs - -- Step 5: Turn the segments into Stmts + -- Step 4: Turn the segments into Stmts -- Use RecStmt when and only when there are fwd refs -- Also gather up the uses from the end towards the -- start, so we can tell the RecStmt which things are @@ -766,25 +763,112 @@ rnMDoStmts stmts thing_inside doc = text "In a recursive mdo-expression" --------------------------------------------- -rn_rec_stmts :: [Name] -> [LStmt RdrName] -> RnM [Segment (LStmt Name)] -rn_rec_stmts bndrs stmts = mappM (rn_rec_stmt bndrs) stmts `thenM` \ segs_s -> - returnM (concat segs_s) ----------------------------------------------------- -rn_rec_stmt :: [Name] -> LStmt RdrName -> RnM [Segment (LStmt Name)] +-- wrapper that does both the left- and right-hand sides +rn_rec_stmts_and_then :: [LStmt RdrName] + -- assumes that the FreeVars returned includes + -- the FreeVars of the Segments + -> ([Segment (LStmt Name)] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rn_rec_stmts_and_then s cont = do + -- (A) make the mini fixity env for all of the stmts + fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) + + -- (B) do the LHSes + new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s + + -- bring them and their fixities into scope + let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv) + bindLocalNamesFV_WithFixities bound_names fix_env $ do + + -- (C) do the right-hand-sides and thing-inside + segs <- rn_rec_stmts bound_names new_lhs_and_fv + (result, result_fvs) <- cont segs + + -- (D) warn about unusued binders + let unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` result_fvs)] + warnUnusedLocalBinds unused_bndrs + + -- (E) return + return (result, result_fvs) + + +-- get all the fixity decls in any Let stmt +collectRecStmtsFixities l = + foldr (\ s -> \acc -> case s of + (L loc (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> + foldr (\ sig -> \ acc -> case sig of + (L loc (FixSig s)) -> (L loc s) : acc + _ -> acc) acc sigs + _ -> acc) [] l + +-- left-hand sides + +rn_rec_stmt_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind + -- these fixities need to be brought into scope with the names + -> LStmt RdrName + -- rename LHS, and return its FVs + -- Warning: we will only need the FreeVars below in the case of a BindStmt, + -- so we don't bother to compute it accurately in the other cases + -> RnM [(LStmtLR Name RdrName, FreeVars)] + +rn_rec_stmt_lhs fix_env (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b), + -- this is actually correct + emptyFVs)] + +rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) + = do + -- should the ctxt be MDo instead? + (pat', fv_pat) <- rnPat_LocalRec fix_env pat + return [(L loc (BindStmt pat' expr a b), + fv_pat)] + +rn_rec_stmt_lhs fix_env (L loc (LetStmt binds@(HsIPBinds _))) + = do { addErr (badIpBinds (ptext SLIT("an mdo expression")) binds) + ; failM } + +rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) + = do binds' <- rnValBindsLHS fix_env binds + return [(L loc (LetStmt (HsValBinds binds')), + -- Warning: this is bogus; see function invariant + emptyFVs + )] + +rn_rec_stmt_lhs fix_env (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec + = rn_rec_stmts_lhs fix_env stmts + +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmts_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind + -- these fixities need to be brought into scope with the names + -> [LStmt RdrName] + -> RnM [(LStmtLR Name RdrName, FreeVars)] +rn_rec_stmts_lhs fix_env stmts = + let boundNames = collectLStmtsBinders stmts + doc = text "In a recursive mdo-expression" + in do + -- First do error checking: we need to check for dups here because we + -- don't bind all of the variables from the Stmt at once + -- with bindLocatedLocals. + checkDupNames doc boundNames + mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls) + + +-- right-hand-sides + +rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt - -rn_rec_stmt all_bndrs (L loc (ExprStmt expr _ _)) - = rnLExpr expr `thenM` \ (expr', fvs) -> +rn_rec_stmt all_bndrs (L loc (ExprStmt expr _ _)) _ + = rnLExpr expr `thenM` \ (expr', fvs) -> lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, L loc (ExprStmt expr' then_op placeHolderType))] -rn_rec_stmt all_bndrs (L loc (BindStmt pat expr _ _)) +rn_rec_stmt all_bndrs (L loc (BindStmt pat' expr _ _)) fv_pat = rnLExpr expr `thenM` \ (expr', fv_expr) -> - rnLPat pat `thenM` \ (pat', fv_pat) -> lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> let @@ -794,20 +878,27 @@ rn_rec_stmt all_bndrs (L loc (BindStmt pat expr _ _)) returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs, L loc (BindStmt pat' expr' bind_op fail_op))] -rn_rec_stmt all_bndrs (L loc (LetStmt binds@(HsIPBinds _))) +rn_rec_stmt all_bndrs (L loc (LetStmt binds@(HsIPBinds _))) _ = do { addErr (badIpBinds (ptext SLIT("an mdo expression")) binds) ; failM } -rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds))) - = rnValBinds (trimWith all_bndrs) binds `thenM` \ (binds', du_binds) -> - returnM [(duDefs du_binds, duUses du_binds, - emptyNameSet, L loc (LetStmt (HsValBinds binds')))] +rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do + (binds', du_binds) <- + -- fixities and unused are handled above in rn_rec_stmts_and_then + rnValBindsRHS all_bndrs binds' + returnM [(duDefs du_binds, duUses du_binds, + emptyNameSet, L loc (LetStmt (HsValBinds binds')))] -rn_rec_stmt all_bndrs (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec - = rn_rec_stmts all_bndrs stmts +-- no RecStmt case becuase they get flattened above when doing the LHSes +rn_rec_stmt all_bndrs stmt@(L loc (RecStmt stmts _ _ _ _)) _ + = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) -rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt" (ppr stmt) +rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) + +rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)] +rn_rec_stmts bndrs stmts = mappM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s -> + returnM (concat segs_s) --------------------------------------------- addFwdRefs :: [Segment a] -> [Segment a] diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 8f24141c97..bc7146b062 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -15,14 +15,14 @@ module RnNames ( rnImports, importsFromLocalDecls, rnExports, getLocalDeclBinders, extendRdrEnvRn, - reportUnusedNames, finishDeprecations + reportUnusedNames, finishDeprecations, ) where #include "HsVersions.h" import DynFlags import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, - ForeignDecl(..), HsGroup(..), HsValBinds(..), + ForeignDecl(..), HsGroup(..), HsValBindsLR(..), Sig(..), collectHsBindLocatedBinders, tyClDeclNames, instDeclATs, isFamInstDecl, LIE ) @@ -36,6 +36,7 @@ import PrelNames import Module import Name import NameEnv +import UniqFM import NameSet import OccName import HscTypes @@ -45,7 +46,7 @@ import Maybes import SrcLoc import FiniteMap import ErrUtils -import BasicTypes ( DeprecTxt ) +import BasicTypes ( DeprecTxt, Fixity ) import DriverPhases ( isHsBoot ) import Util import ListSetOps @@ -273,36 +274,82 @@ From the top-level declarations of this module produce * the ImportAvails created by its bindings. -Complain about duplicate bindings - \begin{code} -importsFromLocalDecls :: HsGroup RdrName -> RnM TcGblEnv -importsFromLocalDecls group +-- Bool determines shadowing: +-- true: names in the group should shadow other UnQuals +-- with the same OccName (used in Template Haskell) +-- false: duplicates should be reported as an error +-- +-- The UniqFM (OccName -> FixItem) associates a Name's OccName's +-- FastString with a fixity declaration (that needs the actual OccName +-- to be plugged in). This fixity must be brought into scope when such +-- a Name is. +importsFromLocalDecls :: Bool -> HsGroup RdrName -> UniqFM (Located Fixity) -> RnM TcGblEnv +importsFromLocalDecls shadowP group fixities = do { gbl_env <- getGblEnv ; avails <- getLocalDeclBinders gbl_env group - ; rdr_env' <- extendRdrEnvRn (tcg_rdr_env gbl_env) avails + ; (rdr_env', fix_env') <- extendRdrEnvRn shadowP (tcg_rdr_env gbl_env, + tcg_fix_env gbl_env) + avails fixities ; traceRn (text "local avails: " <> ppr avails) - ; returnM (gbl_env { tcg_rdr_env = rdr_env' }) + ; returnM (gbl_env { tcg_rdr_env = rdr_env', + tcg_fix_env = fix_env'}) } -extendRdrEnvRn :: GlobalRdrEnv -> [AvailInfo] -> RnM GlobalRdrEnv +-- Bool determines shadowing as in importsFromLocalDecls. +-- UniqFM FixItem is the same as in importsFromLocalDecls. +-- -- Add the new locally-bound names one by one, checking for duplicates as -- we do so. Remember that in Template Haskell the duplicates --- might *already be* in the GlobalRdrEnv from higher up the module -extendRdrEnvRn rdr_env avails - = foldlM add_local rdr_env (gresFromAvails LocalDef avails) - where - add_local rdr_env gre - | gres <- lookupGlobalRdrEnv rdr_env (nameOccName (gre_name gre)) - , (dup_gre:_) <- filter isLocalGRE gres -- Check for existing *local* defns - = do { addDupDeclErr (gre_name dup_gre) (gre_name gre) - ; return rdr_env } - | otherwise - = return (extendGlobalRdrEnv rdr_env gre) +-- might *already be* in the GlobalRdrEnv from higher up the module. +-- +-- Also update the FixityEnv with the fixities for the names brought into scope. +-- +-- Note that the return values are the extensions of the two inputs, +-- not the extras relative to them. +extendRdrEnvRn :: Bool -> (GlobalRdrEnv, NameEnv FixItem) + -> [AvailInfo] -> UniqFM (Located Fixity) -> RnM (GlobalRdrEnv, NameEnv FixItem) +extendRdrEnvRn shadowP (rdr_env, fix_env) avails fixities = + let -- if there is a fixity decl for the gre, + -- add it to the fixity env + extendFixEnv env gre = + let name = gre_name gre + occ = nameOccName name + curKey = occNameFS occ in + case lookupUFM fixities curKey of + Nothing -> env + Just (L _ fi) -> extendNameEnv env name (FixItem occ fi) + + (rdr_env_to_extend, extender) = + if shadowP + then -- when shadowing is on, + -- (1) we need to remove the existing Unquals for the + -- names we're extending the env with + -- (2) but extending the env is simple + let names = concatMap availNames avails + new_occs = map nameOccName names + trimmed_rdr_env = hideSomeUnquals rdr_env new_occs + in + (trimmed_rdr_env, + \(cur_rdr_env, cur_fix_env) -> \gre -> + return (extendGlobalRdrEnv cur_rdr_env gre, + extendFixEnv cur_fix_env gre)) + else -- when shadowing is off, + -- (1) we don't munge the incoming env + -- (2) but we need to check for dups when extending + (rdr_env, + \(cur_rdr_env, cur_fix_env) -> \gre -> + let gres = lookupGlobalRdrEnv cur_rdr_env (nameOccName (gre_name gre)) + in case filter isLocalGRE gres of -- Check for existing *local* defns + dup_gre:_ -> do { addDupDeclErr (gre_name dup_gre) (gre_name gre) + ; return (cur_rdr_env, cur_fix_env) } + [] -> return (extendGlobalRdrEnv cur_rdr_env gre, + extendFixEnv cur_fix_env gre)) + in foldlM extender (rdr_env_to_extend, fix_env) (gresFromAvails LocalDef avails) \end{code} @getLocalDeclBinders@ returns the names for an @HsDecl@. It's @@ -322,11 +369,13 @@ raising a duplicate declaration error. So, we make a new name for it, but don't return it in the 'AvailInfo'. \begin{code} +-- Note: this function does NOT get the binders of the ValBinds that +-- will be bound during renaming getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [AvailInfo] getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_fords = foreign_decls }) + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fords = foreign_decls }) = do { tc_names_s <- mappM new_tc tycl_decls ; at_names_s <- mappM inst_ats inst_decls ; val_names <- mappM new_simple val_bndrs @@ -334,19 +383,18 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, where mod = tcg_mod gbl_env is_hs_boot = isHsBoot (tcg_src gbl_env) ; - val_bndrs | is_hs_boot = sig_hs_bndrs - | otherwise = for_hs_bndrs ++ val_hs_bndrs - -- In a hs-boot file, the value binders come from the - -- *signatures*, and there should be no foreign binders + + for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls] + + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + val_bndrs | is_hs_boot = [nm | L _ (TypeSig nm _) <- val_sigs] + | otherwise = for_hs_bndrs new_simple rdr_name = do nm <- newTopSrcBinder mod rdr_name return (Avail nm) - sig_hs_bndrs = [nm | L _ (TypeSig nm _) <- val_sigs] - val_hs_bndrs = collectHsBindLocatedBinders val_decls - for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls] - new_tc tc_decl | isFamInstDecl (unLoc tc_decl) = do { main_name <- lookupFamInstDeclBndr mod main_rdr diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs new file mode 100644 index 0000000000..56e84d7a63 --- /dev/null +++ b/compiler/rename/RnPat.lhs @@ -0,0 +1,609 @@ +%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[RnPat]{Renaming of patterns}
+
+Basically dependency analysis.
+
+Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
+general, all of these functions return a renamed thing, and a set of
+free variables.
+
+\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+module RnPat (-- main entry points
+ rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec,
+
+ NameMaker, applyNameMaker, -- a utility for making names:
+ localNameMaker, topNameMaker, -- sometimes we want to make local names,
+ -- sometimes we want to make top (qualified) names.
+
+ rnHsRecFields_Con, rnHsRecFields_Update, --rename record fields in a constructor
+ --and in an update
+
+ -- Literals
+ rnLit, rnOverLit,
+
+ -- Pattern Error messages that are also used elsewhere
+ checkTupSize, patSigErr
+ ) where
+
+-- ENH: thin imports to only what is necessary for patterns
+
+import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts)
+
+#include "HsVersions.h"
+
+import HsSyn
+import TcRnMonad
+import RnEnv
+import HscTypes ( availNames )
+import RnNames ( getLocalDeclBinders, extendRdrEnvRn )
+import RnTypes ( rnHsTypeFVs,
+ mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, mkConOpPatRn
+ )
+import DynFlags ( DynFlag(..) )
+import BasicTypes ( FixityDirection(..) )
+import SrcLoc ( SrcSpan )
+import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
+ loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
+ negateName, thenMName, bindMName, failMName,
+ eqClassName, integralClassName, geName, eqName,
+ negateName, minusName, lengthPName, indexPName,
+ plusIntegerName, fromIntegerName, timesIntegerName,
+ ratioDataConName, fromRationalName, fromStringName )
+import Constants ( mAX_TUPLE_SIZE )
+import Name ( Name, nameOccName, nameIsLocalOrFrom, getOccName, nameSrcSpan )
+import NameSet
+import UniqFM
+import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, mkRdrUnqual, nameRdrName )
+import LoadIface ( loadInterfaceForName )
+import UniqFM ( isNullUFM )
+import UniqSet ( emptyUniqSet )
+import List ( nub )
+import Util ( isSingleton )
+import ListSetOps ( removeDups, minusList )
+import Maybes ( expectJust )
+import Outputable
+import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated, noLoc )
+import FastString
+import Literal ( inIntRange, inCharRange )
+import List ( unzip4 )
+import Bag (foldrBag)
+
+import ErrUtils (Message)
+\end{code}
+
+
+*********************************************************
+* *
+\subsection{Patterns}
+* *
+*********************************************************
+
+\begin{code}
+-- externally abstract type of name makers,
+-- which is how you go from a RdrName to a Name
+data NameMaker = NM (Located RdrName -> RnM Name)
+localNameMaker = NM (\name -> do [newname] <- newLocalsRn [name]
+ return newname)
+
+topNameMaker = NM (\name -> do mod <- getModule
+ newTopSrcBinder mod name)
+
+applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
+applyNameMaker (NM f) x = f x
+
+
+-- There are various entry points to renaming patterns, depending on
+-- (1) whether the names created should be top-level names or local names
+-- (2) whether the scope of the names is entirely given in a continuation
+-- (e.g., in a case or lambda, but not in a let or at the top-level,
+-- because of the way mutually recursive bindings are handled)
+-- (3) whether the type signatures can bind variables
+-- (for unpacking existential type vars in data constructors)
+-- (4) whether we do duplicate and unused variable checking
+-- (5) whether there are fixity declarations associated with the names
+-- bound by the patterns that need to be brought into scope with them.
+--
+-- Rather than burdening the clients of this module with all of these choices,
+-- we export the three points in this design space that we actually need:
+
+-- entry point 1:
+-- binds local names; the scope of the bindings is entirely in the thing_inside
+-- allows type sigs to bind vars
+-- local namemaker
+-- unused and duplicate checking
+-- no fixities
+rnPatsAndThen_LocalRightwards :: HsMatchContext Name -- for error messages
+ -> [LPat RdrName]
+ -- the continuation gets:
+ -- the list of renamed patterns
+ -- the (overall) free vars of all of them
+ -> (([LPat Name], FreeVars) -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+
+rnPatsAndThen_LocalRightwards ctxt pats thing_inside =
+ -- (0) bring into scope all of the type variables bound by the patterns
+ bindPatSigTyVarsFV (collectSigTysFromPats pats) $
+ -- (1) rename the patterns, bringing into scope all of the term variables
+ rnLPatsAndThen localNameMaker emptyUFM pats $ \ (pats', pat_fvs) ->
+ -- (2) then do the thing inside.
+ thing_inside (pats', pat_fvs) `thenM` \ (res, res_fvs) ->
+ let
+ -- walk again to collect the names bound by the pattern
+ new_bndrs = collectPatsBinders pats'
+
+ -- uses now include both pattern uses and thing_inside uses
+ used = res_fvs `plusFV` pat_fvs
+ unused_binders = filter (not . (`elemNameSet` used)) new_bndrs
+
+ -- restore the locations and rdrnames of the new_bndrs
+ -- lets us use the existing checkDupNames, rather than reimplementing
+ -- the error reporting for names
+ new_bndrs_rdr = map (\ n -> (L (nameSrcSpan n)
+ (mkRdrUnqual (getOccName n)))) new_bndrs
+ in
+ -- (3) check for duplicates explicitly
+ -- (because we don't bind the vars all at once, it doesn't happen
+ -- for free in the binding)
+ checkDupNames doc_pat new_bndrs_rdr `thenM_`
+ -- (4) warn about unused binders
+ warnUnusedMatches unused_binders `thenM_`
+ -- (5) return; note that the fvs are pruned by the rnLPatsAndThen
+ returnM (res, res_fvs `plusFV` pat_fvs)
+ where
+ doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt
+
+
+-- entry point 2:
+-- binds local names; in a recursive scope that involves other bound vars
+-- allows type sigs to bind vars
+-- local namemaker
+-- no unused and duplicate checking
+-- fixities might be coming in
+rnPat_LocalRec :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> LPat RdrName
+ -> RnM (LPat Name,
+ -- free variables of the pattern,
+ -- but not including variables bound by this pattern
+ FreeVars)
+
+rnPat_LocalRec fix_env pat =
+ bindPatSigTyVarsFV (collectSigTysFromPats [pat]) $
+ rnLPatsAndThen localNameMaker fix_env [pat] $ \ ([pat'], pat_fvs) ->
+ return (pat', pat_fvs)
+
+
+-- entry point 3:
+-- binds top names; in a recursive scope that involves other bound vars
+-- does NOT allow type sigs to bind vars
+-- top namemaker
+-- no unused and duplicate checking
+-- fixities might be coming in
+rnPat_TopRec :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> LPat RdrName
+ -> RnM (LPat Name,
+ -- free variables of the pattern,
+ -- but not including variables bound by this pattern
+ FreeVars)
+
+rnPat_TopRec fix_env pat =
+ rnLPatsAndThen topNameMaker fix_env [pat] $ \ ([pat'], pat_fvs) ->
+ return (pat', pat_fvs)
+
+
+-- general version: parametrized by how you make new names
+-- invariant: what-to-do continuation only gets called with a list whose length is the same as
+-- the part of the pattern we're currently renaming
+rnLPatsAndThen :: NameMaker -- how to make a new variable
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> [LPat RdrName] -- part of pattern we're currently renaming
+ -> (([LPat Name],FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards
+ -> RnM (a, FreeVars) -- renaming of the whole thing
+
+rnLPatsAndThen var fix_env = mapFvRnCPS (rnLPatAndThen var fix_env)
+
+
+-- the workhorse
+rnLPatAndThen :: NameMaker
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> LPat RdrName -- part of pattern we're currently renaming
+ -> ((LPat Name, FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards
+ -> RnM (a, FreeVars) -- renaming of the whole thing
+rnLPatAndThen var@(NM varf) fix_env (L loc p) cont =
+ setSrcSpan loc $
+ let reloc = L loc
+ lcont = \ (unlocated, fv) -> cont (reloc unlocated, fv)
+
+ -- Note: this is somewhat suspicious because it sometimes
+ -- binds a top-level name as a local name (when the NameMaker
+ -- returns a top-level name).
+ -- however, this binding seems to work, and it only exists for
+ -- the duration of the patterns and the continuation;
+ -- then the top-level name is added to the global env
+ -- before going on to the RHSes (see RnSource.lhs).
+ --
+ -- and doing things this way saves us from having to parametrize
+ -- by the environment extender, repeating the FreeVar handling,
+ -- etc.
+ bind n = bindLocalNamesFV_WithFixities [n] fix_env
+ in
+ case p of
+ WildPat _ -> lcont (WildPat placeHolderType, emptyFVs)
+
+ VarPat name -> do
+ newBoundName <- varf (reloc name)
+ -- we need to bind pattern variables for view pattern expressions
+ -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
+ bind newBoundName $
+ (lcont (VarPat newBoundName, emptyFVs))
+
+ SigPatIn pat ty ->
+ doptM Opt_PatternSignatures `thenM` \ patsigs ->
+ if patsigs
+ then rnLPatAndThen var fix_env pat
+ (\ (pat', fvs1) ->
+ rnHsTypeFVs tvdoc ty `thenM` \ (ty', fvs2) ->
+ lcont (SigPatIn pat' ty', fvs1 `plusFV` fvs2))
+ else addErr (patSigErr ty) `thenM_`
+ rnLPatAndThen var fix_env pat cont
+ where
+ tvdoc = text "In a pattern type-signature"
+
+ LitPat lit@(HsString s) ->
+ do ovlStr <- doptM Opt_OverloadedStrings
+ if ovlStr
+ then rnLPatAndThen var fix_env (reloc $ mkNPat (mkHsIsString s placeHolderType) Nothing) cont
+ else do
+ rnLit lit
+ lcont (LitPat lit, emptyFVs) -- Same as below
+
+ LitPat lit -> do
+ rnLit lit
+ lcont (LitPat lit, emptyFVs)
+
+ NPat lit mb_neg eq ->
+ rnOverLit lit `thenM` \ (lit', fvs1) ->
+ (case mb_neg of
+ Nothing -> returnM (Nothing, emptyFVs)
+ Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) ->
+ returnM (Just neg, fvs)
+ ) `thenM` \ (mb_neg', fvs2) ->
+ lookupSyntaxName eqName `thenM` \ (eq', fvs3) ->
+ lcont (NPat lit' mb_neg' eq',
+ fvs1 `plusFV` fvs2 `plusFV` fvs3)
+ -- Needed to find equality on pattern
+
+ NPlusKPat name lit _ _ -> do
+ new_name <- varf name
+ bind new_name $
+ rnOverLit lit `thenM` \ (lit', fvs1) ->
+ lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->
+ lookupSyntaxName geName `thenM` \ (ge, fvs3) ->
+ lcont (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus,
+ fvs1 `plusFV` fvs2 `plusFV` fvs3)
+ -- The Report says that n+k patterns must be in Integral
+
+ LazyPat pat ->
+ rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> lcont (LazyPat pat', fvs)
+
+ BangPat pat ->
+ rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> lcont (BangPat pat', fvs)
+
+ AsPat name pat -> do
+ new_name <- varf name
+ bind new_name $
+ rnLPatAndThen var fix_env pat $ \ (pat', fvs) ->
+ lcont (AsPat (L (nameSrcSpan new_name) new_name) pat', fvs)
+
+ ViewPat expr pat ty ->
+ do vp_flag <- doptM Opt_ViewPatterns
+ checkErr vp_flag (badViewPat p)
+ -- because of the way we're arranging the recursive calls,
+ -- this will be in the right context
+ (expr', fvExpr) <- rnLExpr expr
+ rnLPatAndThen var fix_env pat $ \ (pat', fvPat) ->
+ lcont (ViewPat expr' pat' ty, fvPat `plusFV` fvExpr)
+
+ ConPatIn con stuff ->
+ -- rnConPatAndThen takes care of reconstructing the pattern
+ rnConPatAndThen var fix_env con stuff cont
+
+ ParPat pat -> rnLPatAndThen var fix_env pat $
+ \ (pat', fv') -> lcont (ParPat pat', fv')
+
+ ListPat pats _ ->
+ rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->
+ lcont (ListPat patslist placeHolderType, fvs)
+
+ PArrPat pats _ ->
+ rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->
+ lcont (PArrPat patslist placeHolderType,
+ fvs `plusFV` implicit_fvs)
+ where
+ implicit_fvs = mkFVs [lengthPName, indexPName]
+
+ TuplePat pats boxed _ ->
+ checkTupSize (length pats) `thenM_`
+ (rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->
+ lcont (TuplePat patslist boxed placeHolderType, fvs))
+
+ TypePat name ->
+ rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
+ lcont (TypePat name', fvs)
+
+
+-- helper for renaming constructor patterns
+rnConPatAndThen :: NameMaker
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> Located RdrName -- the constructor
+ -> HsConPatDetails RdrName
+ -> ((LPat Name, FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards
+ -> RnM (a, FreeVars)
+
+rnConPatAndThen var fix_env (con@(L loc _)) (PrefixCon pats) cont
+ = do con' <- lookupLocatedOccRn con
+ rnLPatsAndThen var fix_env pats $
+ \ (pats', fvs) ->
+ cont (L loc $ ConPatIn con' (PrefixCon pats'),
+ fvs `addOneFV` unLoc con')
+
+rnConPatAndThen var fix_env (con@(L loc _)) (InfixCon pat1 pat2) cont
+ = do con' <- lookupLocatedOccRn con
+ (rnLPatAndThen var fix_env pat1 $
+ (\ (pat1', fvs1) ->
+ rnLPatAndThen var fix_env pat2 $
+ (\ (pat2', fvs2) -> do
+ fixity <- lookupFixityRn (unLoc con')
+ pat' <- mkConOpPatRn con' fixity pat1' pat2'
+ cont (L loc pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con'))))
+
+rnConPatAndThen var fix_env (con@(L loc _)) (RecCon rpats) cont = do
+ con' <- lookupLocatedOccRn con
+ rnHsRecFieldsAndThen_Pattern con' var fix_env rpats $ \ (rpats', fvs) ->
+ cont (L loc $ ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')
+
+
+-- what kind of record expression we're doing
+-- the first two tell the name of the datatype constructor in question
+-- and give a way of creating a variable to fill in a ..
+data RnHsRecFieldsChoice a = Constructor (Located Name) (RdrName -> a)
+ | Pattern (Located Name) (RdrName -> a)
+ | Update
+
+choiceToMessage (Constructor _ _) = "construction"
+choiceToMessage (Pattern _ _) = "pattern"
+choiceToMessage Update = "update"
+
+doDotDot (Constructor a b) = Just (a,b)
+doDotDot (Pattern a b) = Just (a,b)
+doDotDot Update = Nothing
+
+getChoiceName (Constructor n _) = Just n
+getChoiceName (Pattern n _) = Just n
+getChoiceName (Update) = Nothing
+
+
+
+-- helper for renaming record patterns;
+-- parameterized so that it can also be used for expressions
+rnHsRecFieldsAndThen :: RnHsRecFieldsChoice field
+ -- how to rename the fields (CPSed)
+ -> (Located field -> ((Located field', FreeVars) -> RnM (c, FreeVars))
+ -> RnM (c, FreeVars))
+ -- the actual fields
+ -> HsRecFields RdrName (Located field)
+ -- what to do in the scope of the field vars
+ -> ((HsRecFields Name (Located field'), FreeVars) -> RnM (c, FreeVars))
+ -> RnM (c, FreeVars)
+-- Haddock comments for record fields are renamed to Nothing here
+rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont =
+ let
+
+ -- helper to collect and report duplicate record fields
+ reportDuplicateFields doingstr fields =
+ let
+ -- each list represents a RdrName that occurred more than once
+ -- (the list contains all occurrences)
+ -- invariant: each list in dup_fields is non-empty
+ (_, dup_fields :: [[RdrName]]) = removeDups compare
+ (map (unLoc . hsRecFieldId) fields)
+
+ -- duplicate field reporting function
+ field_dup_err dup_group = addErr (dupFieldErr doingstr (head dup_group))
+ in
+ mappM_ field_dup_err dup_fields
+
+ -- helper to rename each field
+ rn_field pun_ok (HsRecField field inside pun) cont = do
+ fieldname <- lookupRecordBndr (getChoiceName choice) field
+ checkErr (not pun || pun_ok) (badPun field)
+ rn_thing inside $ \ (inside', fvs) ->
+ cont (HsRecField fieldname inside' pun,
+ fvs `addOneFV` unLoc fieldname)
+
+ -- Compute the extra fields to be filled in by the dot-dot notation
+ dot_dot_fields fs con mk_field cont = do
+ con_fields <- lookupConstructorFields (unLoc con)
+ let missing_fields = con_fields `minusList` fs
+ loc <- getSrcSpanM -- Rather approximate
+ -- it's important that we make the RdrName fields that we morally wrote
+ -- and then rename them in the usual manner
+ -- (rather than trying to make the result of renaming directly)
+ -- because, for patterns, renaming can bind vars in the continuation
+ mapFvRnCPS rn_thing
+ (map (L loc . mk_field . mkRdrUnqual . getOccName) missing_fields) $
+ \ (rhss, fvs_s) ->
+ let new_fs = [ HsRecField (L loc f) r False
+ | (f, r) <- missing_fields `zip` rhss ]
+ in
+ cont (new_fs, fvs_s)
+
+ in do
+ -- report duplicate fields
+ let doingstr = choiceToMessage choice
+ reportDuplicateFields doingstr fields
+
+ -- rename the records as written
+ -- check whether punning (implicit x=x) is allowed
+ pun_flag <- doptM Opt_RecordPuns
+ -- rename the fields
+ mapFvRnCPS (rn_field pun_flag) fields $ \ (fields1, fvs1) ->
+
+ -- handle ..
+ case dd of
+ Nothing -> cont (HsRecFields fields1 dd, fvs1)
+ Just n -> ASSERT( n == length fields ) do
+ dd_flag <- doptM Opt_RecordWildCards
+ checkErr dd_flag (needFlagDotDot doingstr)
+ let fld_names1 = map (unLoc . hsRecFieldId) fields1
+ case doDotDot choice of
+ Nothing -> addErr (badDotDot doingstr) `thenM_`
+ -- we return a junk value here so that error reporting goes on
+ cont (HsRecFields fields1 dd, fvs1)
+ Just (con, mk_field) ->
+ dot_dot_fields fld_names1 con mk_field $
+ \ (fields2, fvs2) ->
+ cont (HsRecFields (fields1 ++ fields2) dd,
+ fvs1 `plusFV` fvs2)
+
+needFlagDotDot str = vcat [ptext SLIT("Illegal `..' in record") <+> text str,
+ ptext SLIT("Use -XRecordWildCards to permit this")]
+
+badDotDot str = ptext SLIT("You cannot use `..' in record") <+> text str
+
+badPun fld = vcat [ptext SLIT("Illegal use of punning for field") <+> quotes (ppr fld),
+ ptext SLIT("Use -XRecordPuns to permit this")]
+
+
+-- wrappers
+rnHsRecFieldsAndThen_Pattern :: Located Name
+ -> NameMaker -- new name maker
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> HsRecFields RdrName (LPat RdrName)
+ -> ((HsRecFields Name (LPat Name), FreeVars) -> RnM (c, FreeVars))
+ -> RnM (c, FreeVars)
+rnHsRecFieldsAndThen_Pattern n var fix_env = rnHsRecFieldsAndThen (Pattern n VarPat) (rnLPatAndThen var fix_env)
+
+
+-- wrapper to use rnLExpr in CPS style;
+-- because it does not bind any vars going forward, it does not need
+-- to be written that way
+rnLExprAndThen :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
+ -> LHsExpr RdrName
+ -> ((LHsExpr Name, FreeVars) -> RnM (c, FreeVars))
+ -> RnM (c, FreeVars)
+rnLExprAndThen f e cont = do {x <- f e; cont x}
+
+
+-- non-CPSed because exprs don't leave anything bound
+rnHsRecFields_Con :: Located Name
+ -> (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
+ -> HsRecFields RdrName (LHsExpr RdrName)
+ -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)
+rnHsRecFields_Con n rnLExpr fields = rnHsRecFieldsAndThen (Constructor n HsVar)
+ (rnLExprAndThen rnLExpr) fields return
+
+rnHsRecFields_Update :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
+ -> HsRecFields RdrName (LHsExpr RdrName)
+ -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)
+rnHsRecFields_Update rnLExpr fields = rnHsRecFieldsAndThen Update
+ (rnLExprAndThen rnLExpr) fields return
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsubsection{Literals}
+%* *
+%************************************************************************
+
+When literals occur we have to make sure
+that the types and classes they involve
+are made available.
+
+\begin{code}
+rnLit :: HsLit -> RnM ()
+rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
+rnLit other = returnM ()
+
+rnOverLit (HsIntegral i _ _)
+ = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) ->
+ if inIntRange i then
+ returnM (HsIntegral i from_integer_name placeHolderType, fvs)
+ else let
+ extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
+ -- Big integer literals are built, using + and *,
+ -- out of small integers (DsUtils.mkIntegerLit)
+ -- [NB: plusInteger, timesInteger aren't rebindable...
+ -- they are used to construct the argument to fromInteger,
+ -- which is the rebindable one.]
+ in
+ returnM (HsIntegral i from_integer_name placeHolderType, fvs `plusFV` extra_fvs)
+
+rnOverLit (HsFractional i _ _)
+ = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) ->
+ let
+ extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
+ -- We have to make sure that the Ratio type is imported with
+ -- its constructor, because literals of type Ratio t are
+ -- built with that constructor.
+ -- The Rational type is needed too, but that will come in
+ -- as part of the type for fromRational.
+ -- The plus/times integer operations may be needed to construct the numerator
+ -- and denominator (see DsUtils.mkIntegerLit)
+ in
+ returnM (HsFractional i from_rat_name placeHolderType, fvs `plusFV` extra_fvs)
+
+rnOverLit (HsIsString s _ _)
+ = lookupSyntaxName fromStringName `thenM` \ (from_string_name, fvs) ->
+ returnM (HsIsString s from_string_name placeHolderType, fvs)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Errors}
+%* *
+%************************************************************************
+
+\begin{code}
+checkTupSize :: Int -> RnM ()
+checkTupSize tup_size
+ | tup_size <= mAX_TUPLE_SIZE
+ = returnM ()
+ | otherwise
+ = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"),
+ nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),
+ nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])
+
+patSigErr ty
+ = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
+ $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
+
+dupFieldErr str dup
+ = hsep [ptext SLIT("duplicate field name"),
+ quotes (ppr dup),
+ ptext SLIT("in record"), text str]
+
+bogusCharError c
+ = ptext SLIT("character literal out of range: '\\") <> char c <> char '\''
+
+badViewPat pat = vcat [ptext SLIT("Illegal view pattern: ") <+> ppr pat,
+ ptext SLIT("Use -XViewPatterns to enalbe view patterns")]
+
+\end{code}
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index d4812ad95a..7573f5ef26 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -23,27 +23,31 @@ import {-# SOURCE #-} RnExpr( rnLExpr ) import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, - globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE ) + globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn ) +import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, + makeMiniFixityEnv) import RnEnv ( lookupLocalDataTcNames, lookupLocatedTopBndrRn, lookupLocatedOccRn, lookupOccRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalNames, checkDupNames, mapFvRn + bindLocalNames, checkDupNames, mapFvRn, lookupGreLocalRn, ) +import RnNames (importsFromLocalDecls, extendRdrEnvRn) +import HscTypes (GenAvailInfo(..)) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad -import HscTypes ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), plusDeprecs ) +import HscTypes ( FixityEnv, FixItem(..), Deprecations(..), plusDeprecs ) import Class ( FunDep ) import Name ( Name, nameOccName ) import NameSet import NameEnv -import OccName ( occEnvElts ) +import UniqFM +import OccName import Outputable import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) @@ -51,6 +55,8 @@ import Maybes ( seqMaybe ) import Maybe ( isNothing ) import Monad ( liftM, when ) import BasicTypes ( Boxity(..) ) + +import ListSetOps (findDupsEq, mkLookupFun) \end{code} @rnSourceDecl@ `renames' declarations. @@ -70,85 +76,134 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} -rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) - -rnSrcDecls (HsGroup { hs_valds = val_decls, - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_depds = deprec_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_docs = docs }) - - = do { -- Deal with deprecations (returns only the extra deprecations) - deprecs <- rnSrcDeprecDecls deprec_decls ; - updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs }) - $ do { - - -- Deal with top-level fixity decls - -- (returns the total new fixity env) - rn_fix_decls <- rnSrcFixityDecls fix_decls ; - tcg_env <- extendGblFixityEnv rn_fix_decls ; - setGblEnv tcg_env $ do { - - -- Rename type and class decls - -- You might think that we could build proper def/use information - -- for type and class declarations, but they can be involved - -- in mutual recursion across modules, and we only do the SCC - -- analysis for them in the type checker. - -- So we content ourselves with gathering uses only; that - -- means we'll only report a declaration as unused if it isn't - -- mentioned at all. Ah well. - traceRn (text "Start rnTyClDecls") ; - (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ; - - -- Extract the mapping from data constructors to field names - tcg_env <- extendRecordFieldEnv rn_tycl_decls ; - setGblEnv tcg_env $ do { - - -- Value declarations - traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBinds val_decls ; - traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; - - -- Other decls - (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; - (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ; - (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ; - (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; - (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; - - -- Haddock docs; no free vars - rn_docs <- mapM (wrapLocM rnDocDecl) docs ; - - let { - rn_group = HsGroup { hs_valds = rn_val_decls, +-- brings the binders of the group into scope in the appropriate places; +-- does NOT assume that anything is in scope already +-- +-- the Bool determines whether (True) names in the group shadow existing +-- Unquals in the global environment (used in Template Haskell) or +-- (False) whether duplicates are reported as an error +rnSrcDecls :: Bool -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) + +rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_depds = deprec_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_docs = docs }) + = do { + -- (A) Process the fixity declarations, creating a mapping from + -- FastStrings to FixItems. + -- Also checks for duplcates. + local_fix_env <- makeMiniFixityEnv fix_decls; + + -- (B) Bring top level binders (and their fixities) into scope, + -- except for the value bindings, which get brought in below. + inNewEnv (importsFromLocalDecls shadowP group local_fix_env) $ \ tcg_env -> do { + + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + + -- (C) Extract the mapping from data constructors to field names and + -- extend the record field env. + -- This depends on the data constructors and field names being in + -- scope from (B) above + inNewEnv (extendRecordFieldEnv tycl_decls) $ \ tcg_env -> do { + + -- (D) Rename the left-hand sides of the value bindings. + -- This depends on everything from (B) being in scope, + -- and on (C) for resolving record wild cards. + -- It uses the fixity env from (A) to bind fixities for view patterns. + new_lhs <- rnTopBindsLHS local_fix_env val_decls ; + -- bind the LHSes (and their fixities) in the global rdr environment + let { lhs_binders = map unLoc $ collectHsValBinders new_lhs; + lhs_avails = map Avail lhs_binders + } ; + inNewEnv (extendRdrEnvRn shadowP (tcg_rdr_env tcg_env, tcg_fix_env tcg_env) + lhs_avails local_fix_env + >>= \ (new_rdr_env, new_fix_env) -> + return (tcg_env { tcg_rdr_env = new_rdr_env, + tcg_fix_env = new_fix_env + })) $ \tcg_env -> do { + + -- Now everything is in scope, as the remaining renaming assumes. + + -- (E) Rename type and class decls + -- (note that value LHSes need to be in scope for default methods) + -- + -- You might think that we could build proper def/use information + -- for type and class declarations, but they can be involved + -- in mutual recursion across modules, and we only do the SCC + -- analysis for them in the type checker. + -- So we content ourselves with gathering uses only; that + -- means we'll only report a declaration as unused if it isn't + -- mentioned at all. Ah well. + traceRn (text "Start rnTyClDecls") ; + (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ; + + -- (F) Rename Value declarations right-hand sides + traceRn (text "Start rnmono") ; + (rn_val_decls, bind_dus) <- rnTopBindsRHS lhs_binders new_lhs ; + traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; + + -- (G) Rename Fixity and deprecations + + -- rename fixity declarations and error if we try to + -- fix something from another module (duplicates were checked in (A)) + rn_fix_decls <- rnSrcFixityDecls fix_decls ; + -- rename deprec decls; + -- check for duplicates and ensure that deprecated things are defined locally + -- at the moment, we don't keep these around past renaming + rn_deprecs <- rnSrcDeprecDecls deprec_decls ; + + -- (H) Rename Everything else + + (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; + (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ; + (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ; + (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; + -- Haddock docs; no free vars + rn_docs <- mapM (wrapLocM rnDocDecl) docs ; + + -- (I) Compute the results and return + let {rn_group = HsGroup { hs_valds = rn_val_decls, hs_tyclds = rn_tycl_decls, hs_instds = rn_inst_decls, - hs_derivds = rn_deriv_decls, + hs_derivds = rn_deriv_decls, hs_fixds = rn_fix_decls, - hs_depds = [], + hs_depds = [], -- deprecs are returned in the tcg_env (see below) + -- not in the HsGroup hs_fords = rn_foreign_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, - hs_docs = rn_docs } ; + hs_docs = rn_docs } ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3, - src_fvs4, src_fvs5] ; - src_dus = bind_dus `plusDU` usesOnly other_fvs + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3, + src_fvs4, src_fvs5] ; + src_dus = bind_dus `plusDU` usesOnly other_fvs; -- Note: src_dus will contain *uses* for locally-defined types -- and classes, but no *defs* for them. (Because rnTyClDecl -- returns only the uses.) This is a little -- surprising but it doesn't actually matter at all. - } ; - traceRn (text "finish rnSrc" <+> ppr rn_group) ; - traceRn (text "finish Dus" <+> ppr src_dus ) ; - return (tcg_env `addTcgDUs` src_dus, rn_group) - }}}} + final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus) + in -- we return the deprecs in the env, not in the HsGroup above + tcg_env' { tcg_deprecs = tcg_deprecs tcg_env' `plusDeprecs` rn_deprecs }; + } ; + + traceRn (text "finish rnSrc" <+> ppr rn_group) ; + traceRn (text "finish Dus" <+> ppr src_dus ) ; + return (final_tcg_env , rn_group) + }}}} + +-- some utils because we do this a bunch above +-- compute and install the new env +inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a +inNewEnv env cont = do e <- env + setGblEnv e $ cont e rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] -- Used for external core @@ -194,8 +249,9 @@ rnDocDecl (DocGroup lev doc) = do \begin{code} rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name] --- First rename the fixity decls, so we can put --- the renamed decls in the renamed syntax tre +-- Rename the fixity decls, so we can put +-- the renamed decls in the renamed syntax tree +-- Errors if the thing being fixed is not defined locally. rnSrcFixityDecls fix_decls = do fix_decls <- mapM rn_decl fix_decls return (concat fix_decls) @@ -207,36 +263,10 @@ rnSrcFixityDecls fix_decls -- add both to the fixity env rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) = setSrcSpan name_loc $ + -- this lookup will fail if the definition isn't local do names <- lookupLocalDataTcNames rdr_name return [ L loc (FixitySig (L name_loc name) fixity) - | name <- names ] - -extendGblFixityEnv :: [LFixitySig Name] -> RnM TcGblEnv --- Extend the global envt with fixity decls, checking for duplicate decls -extendGblFixityEnv decls - = do { env <- getGblEnv - ; fix_env' <- foldlM add_one (tcg_fix_env env) decls - ; return (env { tcg_fix_env = fix_env' }) } - where - add_one fix_env (L loc (FixitySig (L name_loc name) fixity)) - | Just (FixItem _ _ loc') <- lookupNameEnv fix_env name - = do { setSrcSpan loc $ - addLocErr (L name_loc name) (dupFixityDecl loc') - ; return fix_env } - | otherwise - = return (extendNameEnv fix_env name fix_item) - where - fix_item = FixItem (nameOccName name) fixity loc - -pprFixEnv :: FixityEnv -> SDoc -pprFixEnv env - = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n) - (nameEnvElts env) - -dupFixityDecl loc rdr_name - = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("also at ") <+> ppr loc - ] + | name <- names ] \end{code} @@ -246,22 +276,39 @@ dupFixityDecl loc rdr_name %* * %********************************************************* -For deprecations, all we do is check that the names are in scope. +Check that the deprecated names are defined, are defined locally, and +that there are no duplicate deprecations. + It's only imported deprecations, dealt with in RnIfaces, that we gather them together. \begin{code} +-- checks that the deprecations are defined locally, and that there are no duplicates rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations rnSrcDeprecDecls [] = returnM NoDeprecs -rnSrcDeprecDecls decls - = mappM (addLocM rn_deprec) decls `thenM` \ pairs_s -> - returnM (DeprecSome (mkNameEnv (concat pairs_s))) +rnSrcDeprecDecls decls + = do { -- check for duplicates + ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupDeprecDecl lrdr')) deprec_rdr_dups + ; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s -> + returnM (DeprecSome ((concat pairs_s))) } where rn_deprec (Deprecation rdr_name txt) + -- ensures that the names are defined locally = lookupLocalDataTcNames rdr_name `thenM` \ names -> - returnM [(name, (nameOccName name, txt)) | name <- names] + returnM [(nameOccName name, txt) | name <- names] + + -- look for duplicates among the OccNames; + -- we check that the names are defined above + -- invt: the lists returned by findDupsEq always have at least two elements + deprec_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) + (map (\ (L loc (Deprecation rdr_name _)) -> L loc rdr_name) decls) + +dupDeprecDecl (L loc _) rdr_name + = vcat [ptext SLIT("Multiple deprecation declarations for") <+> quotes (ppr rdr_name), + ptext SLIT("also at ") <+> ppr loc] + \end{code} %********************************************************* @@ -886,19 +933,30 @@ badDataCon name Get the mapping from constructors to fields for this module. It's convenient to do this after the data type decls have been renamed \begin{code} -extendRecordFieldEnv :: [LTyClDecl Name] -> TcM TcGblEnv +extendRecordFieldEnv :: [LTyClDecl RdrName] -> TcM TcGblEnv extendRecordFieldEnv decls = do { tcg_env <- getGblEnv - ; let field_env' = foldr get (tcg_field_env tcg_env) decls + ; field_env' <- foldrM get (tcg_field_env tcg_env) decls ; return (tcg_env { tcg_field_env = field_env' }) } where - get (L _ (TyData { tcdCons = cons })) env = foldr get_con env cons - get other env = env + -- we want to lookup: + -- (a) a datatype constructor + -- (b) a record field + -- knowing that they're from this module. + -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn, + -- which keeps only the local ones. + lookup x = do { x' <- lookupLocatedTopBndrRn x + ; return $ unLoc x'} + + get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons + get other env = return env get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env - = extendNameEnv env (unLoc con) (map (unLoc . cd_fld_name) flds) + = do { con' <- lookup con + ; flds' <- mappM lookup (map cd_fld_name flds) + ; return $ extendNameEnv env con' flds' } get_con other env - = env + = return env \end{code} %********************************************************* diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 584f4384ce..aad8de83b3 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -16,17 +16,9 @@ module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsSigType, rnHsTypeFVs, - -- Patterns and literals - rnLPat, rnPatsAndThen, -- Here because it's not part - rnLit, rnOverLit, -- of any mutual recursion - rnHsRecFields, - -- Precence related stuff - mkOpAppRn, mkNegAppRn, mkOpFormRn, - checkPrecMatch, checkSectionPrec, - - -- Error messages - patSigErr, checkTupSize + mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, + checkPrecMatch, checkSectionPrec ) where import DynFlags @@ -41,7 +33,7 @@ import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupLocatedGlobalOccRn, bindTyVarsRn, lookupFixityRn, lookupTyFixityRn, lookupConstructorFields, lookupRecordBndr, mapFvRn, warnUnusedMatches, - newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV ) + newIPNameRn, bindPatSigTyVarsFV) import TcRnMonad import RdrName import PrelNames ( eqClassName, integralClassName, geName, eqName, @@ -227,6 +219,39 @@ rnForAll doc exp forall_tyvars ctxt ty -- so that we can later print it correctly \end{code} +%********************************************************* +%* * +\subsection{Contexts and predicates} +%* * +%********************************************************* + +\begin{code} +rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name) +rnContext doc = wrapLocM (rnContext' doc) + +rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name) +rnContext' doc ctxt = mappM (rnLPred doc) ctxt + +rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) +rnLPred doc = wrapLocM (rnPred doc) + +rnPred doc (HsClassP clas tys) + = do { clas_name <- lookupOccRn clas + ; tys' <- rnLHsTypes doc tys + ; returnM (HsClassP clas_name tys') + } +rnPred doc (HsEqualP ty1 ty2) + = do { ty1' <- rnLHsType doc ty1 + ; ty2' <- rnLHsType doc ty2 + ; returnM (HsEqualP ty1' ty2') + } +rnPred doc (HsIParam n ty) + = do { name <- newIPNameRn n + ; ty' <- rnLHsType doc ty + ; returnM (HsIParam name ty') + } +\end{code} + %************************************************************************ %* * @@ -495,317 +520,11 @@ ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity) %********************************************************* %* * -\subsection{Contexts and predicates} -%* * -%********************************************************* - -\begin{code} -rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name) -rnContext doc = wrapLocM (rnContext' doc) - -rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name) -rnContext' doc ctxt = mappM (rnLPred doc) ctxt - -rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) -rnLPred doc = wrapLocM (rnPred doc) - -rnPred doc (HsClassP clas tys) - = do { clas_name <- lookupOccRn clas - ; tys' <- rnLHsTypes doc tys - ; returnM (HsClassP clas_name tys') - } -rnPred doc (HsEqualP ty1 ty2) - = do { ty1' <- rnLHsType doc ty1 - ; ty2' <- rnLHsType doc ty2 - ; returnM (HsEqualP ty1' ty2') - } -rnPred doc (HsIParam n ty) - = do { name <- newIPNameRn n - ; ty' <- rnLHsType doc ty - ; returnM (HsIParam name ty') - } -\end{code} - - -********************************************************* -* * -\subsection{Patterns} -* * -********************************************************* - -\begin{code} -rnPatsAndThen :: HsMatchContext Name - -> [LPat RdrName] - -> ([LPat Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- Bring into scope all the binders and type variables --- bound by the patterns; then rename the patterns; then --- do the thing inside. --- --- Note that we do a single bindLocalsRn for all the --- matches together, so that we spot the repeated variable in --- f x x = 1 - -rnPatsAndThen ctxt pats thing_inside - = bindPatSigTyVarsFV pat_sig_tys $ - bindLocatedLocalsFV doc_pat bndrs $ \ new_bndrs -> - rnLPats pats `thenM` \ (pats', pat_fvs) -> - thing_inside pats' `thenM` \ (res, res_fvs) -> - let - unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs - in - warnUnusedMatches unused_binders `thenM_` - returnM (res, res_fvs `plusFV` pat_fvs) - where - pat_sig_tys = collectSigTysFromPats pats - bndrs = collectLocatedPatsBinders pats - doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt - -rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars) -rnLPats ps = mapFvRn rnLPat ps - -rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars) -rnLPat = wrapLocFstM rnPat - --- ----------------------------------------------------------------------------- --- rnPat - -rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars) - -rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs) - -rnPat (VarPat name) - = lookupBndrRn name `thenM` \ vname -> - returnM (VarPat vname, emptyFVs) - -rnPat (SigPatIn pat ty) - = doptM Opt_PatternSignatures `thenM` \ patsigs -> - - if patsigs - then rnLPat pat `thenM` \ (pat', fvs1) -> - rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) -> - returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2) - - else addErr (patSigErr ty) `thenM_` - rnPat (unLoc pat) -- XXX shouldn't throw away the loc - where - doc = text "In a pattern type-signature" - -rnPat (LitPat lit@(HsString s)) - = do { ovlStr <- doptM Opt_OverloadedStrings - ; if ovlStr then rnPat (mkNPat (mkHsIsString s) Nothing) - else do { rnLit lit; return (LitPat lit, emptyFVs) } } -- Same as below -rnPat (LitPat lit) - = rnLit lit `thenM_` - returnM (LitPat lit, emptyFVs) - -rnPat (NPat lit mb_neg eq _) - = rnOverLit lit `thenM` \ (lit', fvs1) -> - (case mb_neg of - Nothing -> returnM (Nothing, emptyFVs) - Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) -> - returnM (Just neg, fvs) - ) `thenM` \ (mb_neg', fvs2) -> - lookupSyntaxName eqName `thenM` \ (eq', fvs3) -> - returnM (NPat lit' mb_neg' eq' placeHolderType, - fvs1 `plusFV` fvs2 `plusFV` fvs3) - -- Needed to find equality on pattern - -rnPat (NPlusKPat name lit _ _) - = rnOverLit lit `thenM` \ (lit', fvs1) -> - lookupLocatedBndrRn name `thenM` \ name' -> - lookupSyntaxName minusName `thenM` \ (minus, fvs2) -> - lookupSyntaxName geName `thenM` \ (ge, fvs3) -> - returnM (NPlusKPat name' lit' ge minus, - fvs1 `plusFV` fvs2 `plusFV` fvs3) - -- The Report says that n+k patterns must be in Integral - -rnPat (LazyPat pat) - = rnLPat pat `thenM` \ (pat', fvs) -> - returnM (LazyPat pat', fvs) - -rnPat (BangPat pat) - = rnLPat pat `thenM` \ (pat', fvs) -> - returnM (BangPat pat', fvs) - -rnPat (AsPat name pat) - = rnLPat pat `thenM` \ (pat', fvs) -> - lookupLocatedBndrRn name `thenM` \ vname -> - returnM (AsPat vname pat', fvs) - -rnPat (ConPatIn con stuff) = rnConPat con stuff - -rnPat (ParPat pat) - = rnLPat pat `thenM` \ (pat', fvs) -> - returnM (ParPat pat', fvs) - -rnPat (ListPat pats _) - = rnLPats pats `thenM` \ (patslist, fvs) -> - returnM (ListPat patslist placeHolderType, fvs) - -rnPat (PArrPat pats _) - = rnLPats pats `thenM` \ (patslist, fvs) -> - returnM (PArrPat patslist placeHolderType, - fvs `plusFV` implicit_fvs) - where - implicit_fvs = mkFVs [lengthPName, indexPName] - -rnPat (TuplePat pats boxed _) - = checkTupSize (length pats) `thenM_` - rnLPats pats `thenM` \ (patslist, fvs) -> - returnM (TuplePat patslist boxed placeHolderType, fvs) - -rnPat (TypePat name) = - rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) -> - returnM (TypePat name', fvs) - --- ----------------------------------------------------------------------------- --- rnConPat - -rnConPat :: Located RdrName -> HsConPatDetails RdrName -> RnM (Pat Name, FreeVars) -rnConPat con (PrefixCon pats) - = do { con' <- lookupLocatedOccRn con - ; (pats', fvs) <- rnLPats pats - ; return (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con') } - -rnConPat con (RecCon rpats) - = do { con' <- lookupLocatedOccRn con - ; (rpats', fvs) <- rnHsRecFields "pattern" (Just con') rnLPat VarPat rpats - ; return (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con') } - -rnConPat con (InfixCon pat1 pat2) - = do { con' <- lookupLocatedOccRn con - ; (pat1', fvs1) <- rnLPat pat1 - ; (pat2', fvs2) <- rnLPat pat2 - ; fixity <- lookupFixityRn (unLoc con') - ; pat' <- mkConOpPatRn con' fixity pat1' pat2' - ; return (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con') } - --- ----------------------------------------------------------------------------- -rnHsRecFields :: String -- "pattern" or "construction" or "update" - -> Maybe (Located Name) - -> (Located a -> RnM (Located b, FreeVars)) - -> (RdrName -> a) -- How to fill in ".." - -> HsRecFields RdrName (Located a) - -> RnM (HsRecFields Name (Located b), FreeVars) --- Haddock comments for record fields are renamed to Nothing here -rnHsRecFields str mb_con rn_thing mk_rhs (HsRecFields fields dd) - = do { mappM_ field_dup_err dup_fields - ; pun_flag <- doptM Opt_RecordPuns - ; (fields1, fvs1) <- mapFvRn (rn_rpat pun_flag) fields - ; case dd of - Nothing -> return (HsRecFields fields1 dd, fvs1) - Just n -> ASSERT( n == length fields ) do - { dd_flag <- doptM Opt_RecordWildCards - ; checkErr dd_flag (needFlagDotDot str) - - ; let fld_names1 = map (unLoc . hsRecFieldId) fields1 - ; (fields2, fvs2) <- dot_dot_fields fld_names1 mb_con - - ; return (HsRecFields (fields1 ++ fields2) dd, fvs1 `plusFV` fvs2) } } - where - (_, dup_fields) = removeDups compare (map (unLoc . hsRecFieldId) fields) - - field_dup_err dups = addErr (dupFieldErr str (head dups)) - - rn_rpat pun_ok (HsRecField field pat pun) - = do { fieldname <- lookupRecordBndr mb_con field - ; checkErr (not pun || pun_ok) (badPun field) - ; (pat', fvs) <- rn_thing pat - ; return (HsRecField fieldname pat' pun, - fvs `addOneFV` unLoc fieldname) } - - dot_dot_fields fs Nothing = do { addErr (badDotDot str) - ; return ([], emptyFVs) } - - -- Compute the extra fields to be filled in by the dot-dot notation - dot_dot_fields fs (Just con) - = do { con_fields <- lookupConstructorFields (unLoc con) - ; let missing_fields = con_fields `minusList` fs - ; loc <- getSrcSpanM -- Rather approximate - ; (rhss, fvs_s) <- mapAndUnzipM rn_thing - [ L loc (mk_rhs (mkRdrUnqual (getOccName f))) - | f <- missing_fields ] - ; let new_fs = [ HsRecField (L loc f) r False - | (f, r) <- missing_fields `zip` rhss ] - ; return (new_fs, plusFVs fvs_s) } - -needFlagDotDot str = vcat [ptext SLIT("Illegal `..' in record") <+> text str, - ptext SLIT("Use -frecord-dot-dot to permit this")] - -badDotDot str = ptext SLIT("You cannot use `..' in record") <+> text str - -badPun fld = vcat [ptext SLIT("Illegal use of punning for field") <+> quotes (ppr fld), - ptext SLIT("Use -frecord-puns to permit this")] -\end{code} - - -%************************************************************************ -%* * -\subsubsection{Literals} -%* * -%************************************************************************ - -When literals occur we have to make sure -that the types and classes they involve -are made available. - -\begin{code} -rnLit :: HsLit -> RnM () -rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) -rnLit other = returnM () - -rnOverLit (HsIntegral i _) - = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> - if inIntRange i then - returnM (HsIntegral i from_integer_name, fvs) - else let - extra_fvs = mkFVs [plusIntegerName, timesIntegerName] - -- Big integer literals are built, using + and *, - -- out of small integers (DsUtils.mkIntegerLit) - -- [NB: plusInteger, timesInteger aren't rebindable... - -- they are used to construct the argument to fromInteger, - -- which is the rebindable one.] - in - returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) - -rnOverLit (HsFractional i _) - = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) -> - let - extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] - -- We have to make sure that the Ratio type is imported with - -- its constructor, because literals of type Ratio t are - -- built with that constructor. - -- The Rational type is needed too, but that will come in - -- as part of the type for fromRational. - -- The plus/times integer operations may be needed to construct the numerator - -- and denominator (see DsUtils.mkIntegerLit) - in - returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) - -rnOverLit (HsIsString s _) - = lookupSyntaxName fromStringName `thenM` \ (from_string_name, fvs) -> - returnM (HsIsString s from_string_name, fvs) -\end{code} - - - -%********************************************************* -%* * \subsection{Errors} %* * %********************************************************* \begin{code} -checkTupSize :: Int -> RnM () -checkTupSize tup_size - | tup_size <= mAX_TUPLE_SIZE - = returnM () - | otherwise - = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"), - nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)), - nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))]) - forAllWarn doc ty (L loc tyvar) = ifOptM Opt_WarnUnusedMatches $ addWarnAt loc (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), @@ -816,16 +535,4 @@ forAllWarn doc ty (L loc tyvar) opTyErr op ty = hang (ptext SLIT("Illegal operator") <+> quotes (ppr op) <+> ptext SLIT("in type") <+> quotes (ppr ty)) 2 (parens (ptext SLIT("Use -XTypeOperators to allow operators in types"))) - -bogusCharError c - = ptext SLIT("character literal out of range: '\\") <> char c <> char '\'' - -patSigErr ty - = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) - $$ nest 4 (ptext SLIT("Use -XPatternSignatures to permit it")) - -dupFieldErr str dup - = hsep [ptext SLIT("duplicate field name"), - quotes (ppr dup), - ptext SLIT("in record"), text str] \end{code} diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 9c152e189e..1032f91c60 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -776,7 +776,7 @@ lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_lo -- [Same shortcut as in newOverloadedLit, but we -- may have done some unification by now] -lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc}) +lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc}) | Just expr <- shortCutIntLit i ty = returnM (GenInst [] (noLoc expr)) | otherwise @@ -788,7 +788,7 @@ lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty (mkHsApp (L (instLocSpan loc) (HsVar (instToId method_inst))) integer_lit)) -lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc}) +lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc}) | Just expr <- shortCutFracLit f ty = returnM (GenInst [] (noLoc expr)) @@ -800,7 +800,7 @@ lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) (HsVar (instToId method_inst))) rat_lit)) -lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc}) +lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc}) | Just expr <- shortCutStringLit s ty = returnM (GenInst [] (noLoc expr)) | otherwise diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 8276bc893c..0055d6453f 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -206,7 +206,7 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g where n_pats = length pats stk' = drop n_pats cmd_stk - match_ctxt = LambdaExpr -- Maybe KappaExpr? + match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt tc_grhss (GRHSs grhss binds) res_ty diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 58bda528cf..4c87a12671 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -110,7 +110,7 @@ tcLookupGlobal name = do { env <- getGblEnv -- Try local envt - ; case lookupNameEnv (tcg_type_env env) name of { + ; case lookupNameEnv (tcg_type_env env) name of { Just thing -> return thing ; Nothing -> do @@ -123,12 +123,12 @@ tcLookupGlobal name -- Should it have been in the local envt? { case nameModule_maybe name of - Nothing -> notFound name -- Internal names can happen in GHCi + Nothing -> notFound name env -- Internal names can happen in GHCi Just mod | mod == tcg_mod env -- Names from this module - -> notFound name -- should be in tcg_type_env + -> notFound name env -- should be in tcg_type_env | mod == thFAKE -- Names bound in TH declaration brackets - -> notFound name -- should be in tcg_env + -> notFound name env -- should be in tcg_env | otherwise -> tcImportDecl name -- Go find it in an interface }}}}} @@ -708,9 +708,11 @@ pprBinders :: [Name] -> SDoc pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs -notFound name - = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> - ptext SLIT("is not in scope")) +notFound name env + = failWithTc (vcat[ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> + ptext SLIT("is not in scope during type checking, but it passed the renamer"), + ptext SLIT("tcg_type_env of environment:") <+> ppr (tcg_type_env env)] + ) wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 2c17568aef..206629cebf 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -12,8 +12,7 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module TcExpr ( tcPolyExpr, tcPolyExprNC, - tcMonoExpr, tcInferRho, tcSyntaxOp ) where +module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp) where #include "HsVersions.h" diff --git a/compiler/typecheck/TcExpr.lhs-boot b/compiler/typecheck/TcExpr.lhs-boot index be097ef485..4ff2c191f8 100644 --- a/compiler/typecheck/TcExpr.lhs-boot +++ b/compiler/typecheck/TcExpr.lhs-boot @@ -24,4 +24,5 @@ tcSyntaxOp :: -> HsExpr Name -> TcType -> TcM (HsExpr TcId) + \end{code} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 4c76b428fc..075ae71539 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -85,12 +85,13 @@ hsPatType (BangPat pat) = hsLPatType pat hsPatType (LazyPat pat) = hsLPatType pat hsPatType (LitPat lit) = hsLitType lit hsPatType (AsPat var pat) = idType (unLoc var) +hsPatType (ViewPat expr pat ty) = ty hsPatType (ListPat _ ty) = mkListTy ty hsPatType (PArrPat _ ty) = mkPArrTy ty hsPatType (TuplePat pats box ty) = ty hsPatType (ConPatOut{ pat_ty = ty })= ty hsPatType (SigPatOut pat ty) = ty -hsPatType (NPat lit _ _ ty) = ty +hsPatType (NPat lit _ _) = overLitType lit hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) hsPatType (CoPat _ _ ty) = ty @@ -561,12 +562,17 @@ zonkDo env do_or_lc = do_or_lc ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) -zonkOverLit env (HsIntegral i e) - = do { e' <- zonkExpr env e; return (HsIntegral i e') } -zonkOverLit env (HsFractional r e) - = do { e' <- zonkExpr env e; return (HsFractional r e') } -zonkOverLit env (HsIsString s e) - = do { e' <- zonkExpr env e; return (HsIsString s e') } +zonkOverLit env ol = + let + zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol) + e' <- zonkExpr env (overLitExpr ol) + return (e', ty') + ru f (x, y) = return (f x y) + in + case ol of + (HsIntegral i _ _) -> ru (HsIntegral i) =<< zonkedStuff + (HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff + (HsIsString s _ _) -> ru (HsIsString s) =<< zonkedStuff ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) @@ -705,6 +711,11 @@ zonk_pat env (AsPat (L loc v) pat) ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat ; return (env', AsPat (L loc v') pat') } +zonk_pat env (ViewPat expr pat ty) + = do { expr' <- zonkLExpr env expr + ; (env', pat') <- zonkPat env pat + ; return (env', ViewPat expr' pat' ty) } + zonk_pat env (ListPat pats ty) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats @@ -737,15 +748,14 @@ zonk_pat env (SigPatOut pat ty) ; (env', pat') <- zonkPat env pat ; return (env', SigPatOut pat' ty') } -zonk_pat env (NPat lit mb_neg eq_expr ty) +zonk_pat env (NPat lit mb_neg eq_expr) = do { lit' <- zonkOverLit env lit ; mb_neg' <- case mb_neg of Nothing -> return Nothing Just neg -> do { neg' <- zonkExpr env neg ; return (Just neg') } ; eq_expr' <- zonkExpr env eq_expr - ; ty' <- zonkTcTypeToType env ty - ; return (env, NPat lit' mb_neg' eq_expr' ty') } + ; return (env, NPat lit' mb_neg' eq_expr') } zonk_pat env (NPlusKPat (L loc n) lit e1 e2) = do { n' <- zonkIdBndr env n diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 3569038ab9..d11cb9754a 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -106,7 +106,7 @@ tcMatchLambda match res_ty where n_pats = matchGroupArity match doc = sep [ ptext SLIT("The lambda expression") - <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match), + <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match), -- The pprSetDepth makes the abstraction print briefly ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))] match_ctxt = MC { mc_what = LambdaExpr, diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 5b25122853..ecca2496c3 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -18,7 +18,7 @@ module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit, #include "HsVersions.h" -import {-# SOURCE #-} TcExpr( tcSyntaxOp ) +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho) import HsSyn import TcHsSyn @@ -63,7 +63,7 @@ import FastString \begin{code} tcLetPat :: (Name -> Maybe TcRhoType) -> LPat Name -> BoxySigmaType - -> TcM a + -> TcM a -> TcM (LPat TcId, a) tcLetPat sig_fn pat pat_ty thing_inside = do { let init_state = PS { pat_ctxt = LetPat sig_fn, @@ -210,6 +210,7 @@ bindInstsOfPatId id thing_inside ------------------- unBoxPatBndrType ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name)) unBoxWildCardType ty = unBoxArgType ty (ptext SLIT("A wild-card pattern")) +unBoxViewPatType ty pat = unBoxArgType ty (ptext SLIT("The view pattern") <+> ppr pat) unBoxArgType :: BoxyType -> SDoc -> TcM TcType -- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind; @@ -312,11 +313,12 @@ tc_lpat (L span pat) pat_ty pstate thing_inside -------------------- tc_pat :: PatState - -> Pat Name -> BoxySigmaType -- Fully refined result type - -> (PatState -> TcM a) -- Thing inside - -> TcM (Pat TcId, -- Translated pattern - [TcTyVar], -- Existential binders - a) -- Result of thing inside + -> Pat Name + -> BoxySigmaType -- Fully refined result type + -> (PatState -> TcM a) -- Thing inside + -> TcM (Pat TcId, -- Translated pattern + [TcTyVar], -- Existential binders + a) -- Result of thing inside tc_pat pstate (VarPat name) pat_ty thing_inside = do { id <- tcPatBndr pstate name pat_ty @@ -394,6 +396,32 @@ tc_pat pstate (AsPat (L nm_loc name) pat) pat_ty thing_inside -- If you fix it, don't forget the bindInstsOfPatIds! ; return (AsPat (L nm_loc bndr_id) pat', tvs, res) } +tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside + = do { -- morally, expr must have type + -- `forall a1...aN. OPT' -> B` + -- where overall_pat_ty is an instance of OPT'. + -- Here, we infer a rho type for it, + -- which replaces the leading foralls and constraints + -- with fresh unification variables. + (expr',expr'_inferred) <- tcInferRho expr + -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty` + ; let expr'_expected = \ pat_ty -> (mkFunTy overall_pat_ty pat_ty) + -- tcSubExp: expected first, offered second + -- returns coercion + -- + -- NOTE: this forces pat_ty to be a monotype (because we use a unification + -- variable to find it). this means that in an example like + -- (view -> f) where view :: _ -> forall b. b + -- we will only be able to use view at one instantation in the + -- rest of the view + ; (expr_coerc, pat_ty) <- tcInfer (\ pat_ty -> tcSubExp (expr'_expected pat_ty) expr'_inferred) + -- pattern must have pat_ty + ; (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside + -- this should get zonked later on, but we unBox it here + -- so that we do the same checks as above + ; annotation_ty <- unBoxViewPatType overall_pat_ty orig + ; return (ViewPat (mkLHsWrap expr_coerc expr') pat' annotation_ty, tvs, res) } + -- Type signatures in patterns -- See Note [Pattern coercions] below tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside @@ -465,7 +493,7 @@ tc_pat pstate (LitPat simple_lit) pat_ty thing_inside ------------------------ -- Overloaded patterns: n, and n+k -tc_pat pstate pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside +tc_pat pstate pat@(NPat over_lit mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; lit' <- tcOverloadedLit orig over_lit pat_ty ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy) @@ -476,7 +504,7 @@ tc_pat pstate pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty) ; return (Just neg') } ; res <- thing_inside pstate - ; returnM (NPat lit' mb_neg' eq' pat_ty, [], res) } + ; returnM (NPat lit' mb_neg' eq', [], res) } tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty) @@ -811,7 +839,7 @@ tcOverloadedLit :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsOverLit TcId) -tcOverloadedLit orig lit@(HsIntegral i fi) res_ty +tcOverloadedLit orig lit@(HsIntegral i fi _) res_ty | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax. -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, @@ -819,16 +847,16 @@ tcOverloadedLit orig lit@(HsIntegral i fi) res_ty -- ToDo: noLoc sadness = do { integer_ty <- tcMetaTy integerTyConName ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty) - ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) } + ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty))) res_ty) } | Just expr <- shortCutIntLit i res_ty - = return (HsIntegral i expr) + = return (HsIntegral i expr res_ty) | otherwise = do { expr <- newLitInst orig lit res_ty - ; return (HsIntegral i expr) } + ; return (HsIntegral i expr res_ty) } -tcOverloadedLit orig lit@(HsFractional r fr) res_ty +tcOverloadedLit orig lit@(HsFractional r fr _) res_ty | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case = do { rat_ty <- tcMetaTy rationalTyConName ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty) @@ -836,27 +864,27 @@ tcOverloadedLit orig lit@(HsFractional r fr) res_ty -- we're instantiating an overloaded function here, -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2 -- However this'll be picked up by tcSyntaxOp if necessary - ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) } + ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty))) res_ty) } | Just expr <- shortCutFracLit r res_ty - = return (HsFractional r expr) + = return (HsFractional r expr res_ty) | otherwise = do { expr <- newLitInst orig lit res_ty - ; return (HsFractional r expr) } + ; return (HsFractional r expr res_ty) } -tcOverloadedLit orig lit@(HsIsString s fr) res_ty +tcOverloadedLit orig lit@(HsIsString s fr _) res_ty | not (fr `isHsVar` fromStringName) -- c.f. HsIntegral case = do { str_ty <- tcMetaTy stringTyConName ; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty) - ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s)))) } + ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s))) res_ty) } | Just expr <- shortCutStringLit s res_ty - = return (HsIsString s expr) + = return (HsIsString s expr res_ty) | otherwise = do { expr <- newLitInst orig lit res_ty - ; return (HsIsString s expr) } + ; return (HsIsString s expr res_ty) } newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId) newLitInst orig lit res_ty -- Make a LitInst diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 7c79e62523..694a77a21d 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -170,8 +170,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ; -- Process the export list + traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; - traceRn (text "rn4") ; + traceRn (text "rn4b: after exportss") ; -- Compare the hi-boot iface (if any) with the real thing -- Must be done after processing the exports @@ -282,9 +283,15 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) let { ldecls = map noLoc decls } ; - -- Deal with the type declarations; first bring their stuff - -- into scope, then rname them, then type check them - tcg_env <- importsFromLocalDecls (mkFakeGroup ldecls) ; + -- bring the type and class decls into scope + -- ToDo: check that this doesn't need to extract the val binds. + -- It seems that only the type and class decls need to be in scope below because + -- (a) tcTyAndClassDecls doesn't need the val binds, and + -- (b) tcExtCoreBindings doesn't need anything + -- (in fact, it might not even need to be in the scope of + -- this tcg_env at all) + tcg_env <- importsFromLocalDecls False (mkFakeGroup ldecls) + emptyUFM {- no fixity decls -} ; setGblEnv tcg_env $ do { @@ -632,17 +639,11 @@ monad; it augments it and returns the new TcGblEnv. ------------------------------------------------ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls group - = do { -- Bring top level binders into scope - tcg_env <- importsFromLocalDecls group ; - setGblEnv tcg_env $ do { - - failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations - - -- Rename the source decls - (tcg_env, rn_decls) <- rnSrcDecls group ; + = do { -- Rename the source decls (with no shadowing; error on duplicates) + (tcg_env, rn_decls) <- rnSrcDecls False group ; failIfErrsM ; - -- save the renamed syntax, if we want it + -- save the renamed syntax, if we want it let { tcg_env' | Just grp <- tcg_rn_decls tcg_env = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } @@ -653,7 +654,7 @@ rnTopSrcDecls group rnDump (ppr rn_decls) ; return (tcg_env', rn_decls) - }} + } ------------------------------------------------ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index c7c51ed605..396805fb8c 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -44,6 +44,7 @@ import Bag import Outputable import UniqSupply import Unique +import UniqFM import DynFlags import StaticFlags import FastString @@ -916,8 +917,8 @@ setLocalRdrEnv rdr_env thing_inside mkIfLclEnv :: Module -> SDoc -> IfLclEnv mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, if_loc = loc, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + if_tv_env = emptyUFM, + if_id_env = emptyUFM } initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 2ea26a8245..50199a7887 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -1,4 +1,4 @@ -% + % (c) The University of Glasgow 2006 % (c) The GRASP Project, Glasgow University, 1992-2002 % @@ -152,7 +152,7 @@ data TcGblEnv -- (Ids defined in this module start in the local envt, -- though they move to the global envt during zonking) - tcg_type_env_var :: TcRef TypeEnv, + tcg_type_env_var :: TcRef TypeEnv, -- Used only to initialise the interface-file -- typechecker in initIfaceTcRn, so that it can see stuff -- bound in this module when dealing with hi-boot recursions diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index e578dc3314..92ed3ec125 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -141,7 +141,7 @@ initGlobalEnv info instEnvs famInstEnvs , global_tycons = mapNameEnv snd $ vectInfoTyCon info , global_datacons = mapNameEnv snd $ vectInfoDataCon info , global_pa_funs = mapNameEnv snd $ vectInfoPADFun info - , global_pr_funs = emptyVarEnv + , global_pr_funs = emptyNameEnv , global_inst_env = instEnvs , global_fam_inst_env = famInstEnvs , global_bindings = [] |