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).
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)
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
-%
+\%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1998
%
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
-- 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
import Unique(Unique)
import UniqFM
import Maybes
+import Outputable
\end{code}
%************************************************************************
%************************************************************************
\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
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}
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,
TvName -> 'v'
TcClsName -> 't'
-type OccEnv a = UniqFM a
+newtype OccEnv a = A (UniqFM a)
emptyOccEnv :: OccEnv a
unitOccEnv :: 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
| 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.
-- 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
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
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
-- 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 })
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))
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
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
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)
-----------------------------------------------------------------------------
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
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
module DsMonad (
DsM, mappM, mapAndUnzipM,
initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
- foldlDs, foldrDs,
+ foldlDs, foldrDs, ifOptDs,
newTyVarsDs, newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
foldlDs = foldlM
foldrDs = foldrM
mapAndUnzipDs = mapAndUnzipM
-
+ifOptDs = ifOptM
type DsWarning = (SrcSpan, SDoc)
-- Not quite the same as a WarnMsg, we have an SDoc here
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
- mkCoLetMatchResult, mkGuardedMatchResult,
+ mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
matchCanFail, mkEvalMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
wrapBind, wrapBinds,
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)])
#include "HsVersions.h"
+import {-#SOURCE#-} DsExpr (dsLExpr)
+
import DynFlags
import HsSyn
import TcHsSyn
(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
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
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}
%************************************************************************
= 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...
| 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],
-- 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}
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}
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}
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}
; 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
; 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
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]
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
-- 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:
-- 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
}
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
-- '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
------------
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)
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
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
| 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
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
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
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")],
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,
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
%************************************************************************
\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
-- 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}
\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
type LHsExpr a = Located (HsExpr a)
type SyntaxExpr a = HsExpr a
+pprLExpr :: (OutputableBndr i) =>
+ LHsExpr i -> SDoc
+
pprExpr :: (OutputableBndr i) =>
HsExpr i -> SDoc
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}
#include "HsVersions.h"
-import {-# SOURCE #-} HsExpr( SyntaxExpr )
+import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
+import HsTypes (PostTcType)
import Type ( Type )
import Outputable
import FastString
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}
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}
#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
| 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
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.
(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
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)
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)
isLitPat (AsPat _ pat) = isLitPat (unLoc pat)
isLitPat (LitPat _) = True
-isLitPat (NPat _ _ _ _) = True
+isLitPat (NPat _ _ _) = True
isLitPat (NPlusKPat _ _ _ _) = True
isLitPat other = False
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
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
&& all go (hsConPatArgs details)
go1 (LitPat _) = False
- go1 (NPat _ _ _ _) = False
+ go1 (NPat _ _ _) = False
go1 (NPlusKPat _ _ _ _) = False
go1 (TypePat _) = panic "isIrrefutableHsPat: type pattern"
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
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
-- 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}
%************************************************************************
\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
collectStmtBinders (ParStmt xs) = collectLStmtsBinders
$ concatMap fst xs
collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
-collectStmtBinders s = pprPanic "collectStmtBinders" (ppr s)
\end{code}
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
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
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
-- 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
; 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)
-- 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,
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
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
| 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
| 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
| Opt_DisambiguateRecordFields
| Opt_RecordWildCards
| Opt_RecordPuns
+ | Opt_ViewPatterns
| Opt_GADTs
| Opt_RelaxedPolyRec
| Opt_StandaloneDeriving
, ( "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))
( "DisambiguateRecordFields", Opt_DisambiguateRecordFields ),
( "OverloadedStrings", Opt_OverloadedStrings ),
( "GADTs", Opt_GADTs ),
+ ( "ViewPatterns", Opt_ViewPatterns),
( "TypeFamilies", Opt_TypeFamilies ),
( "BangPatterns", Opt_BangPatterns ),
-- On by default:
#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 )
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
emptyIfaceDepCache,
- Deprecs(..), IfaceDeprecs,
-
FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
implicitTyThings, isImplicitTyThing,
GenAvailInfo(..), AvailInfo, RdrAvailInfo,
IfaceExport,
- Deprecations, DeprecTxt, plusDeprecs,
+ Deprecations(..), DeprecTxt, plusDeprecs,
PackageInstEnv, PackageRuleBase,
-- 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
%************************************************************************
\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
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]
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
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}
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}
handleRunStatus expr ref bindings final_ids
breakMVar statusMVar status hist'
-
back :: Session -> IO ([Name], Int, SrcSpan)
back = moveHist (+1)
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
| 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
: {- 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 }
-- 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))
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
-- 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)
-- 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"
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 )
%* *
%************************************************************************
-@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}
%*********************************************************
\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) }
%************************************************************************
\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)
(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}
----------------------
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 ()
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
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}
) `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)
-%
+\%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-2006
%
\section[RnEnv]{Environment manipulation for the renamer monad}
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,
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
import List ( nubBy )
import Monad ( when )
import DynFlags
+import FastString
\end{code}
%*********************************************************
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:
-- 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?
; 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) } }
| 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}
--------------------------------
\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
--
-- 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
setLocalRdrEnv (extendLocalRdrEnv local_env names)
(enclosed_scope names)
-
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
= getLocalRdrEnv `thenM` \ name_env ->
-------------------------------------
-- 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) ->
(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}
#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 )
import Name ( Name, nameOccName, nameIsLocalOrFrom )
import NameSet
+import UniqFM
import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals )
import LoadIface ( loadInterfaceForName )
import UniqFM ( isNullUFM )
= 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)
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) }
\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)
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}
<- 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)
-- 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
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
----------------------------------------------------
+
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
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
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]
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 )
import Module
import Name
import NameEnv
+import UniqFM
import NameSet
import OccName
import HscTypes
import SrcLoc
import FiniteMap
import ErrUtils
-import BasicTypes ( DeprecTxt )
+import BasicTypes ( DeprecTxt, Fixity )
import DriverPhases ( isHsBoot )
import Util
import ListSetOps
* 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
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
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
--- /dev/null
+%\r
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
+%\r
+\section[RnPat]{Renaming of patterns}\r
+\r
+Basically dependency analysis.\r
+\r
+Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In\r
+general, all of these functions return a renamed thing, and a set of\r
+free variables.\r
+\r
+\begin{code}\r
+{-# OPTIONS -w #-}\r
+-- The above warning supression flag is a temporary kludge.\r
+-- While working on this module you are encouraged to remove it and fix\r
+-- any warnings in the module. See\r
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings\r
+-- for details\r
+\r
+module RnPat (-- main entry points\r
+ rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec,\r
+\r
+ NameMaker, applyNameMaker, -- a utility for making names:\r
+ localNameMaker, topNameMaker, -- sometimes we want to make local names,\r
+ -- sometimes we want to make top (qualified) names.\r
+\r
+ rnHsRecFields_Con, rnHsRecFields_Update, --rename record fields in a constructor\r
+ --and in an update\r
+\r
+ -- Literals\r
+ rnLit, rnOverLit, \r
+\r
+ -- Pattern Error messages that are also used elsewhere\r
+ checkTupSize, patSigErr\r
+ ) where\r
+\r
+-- ENH: thin imports to only what is necessary for patterns\r
+\r
+import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts)\r
+\r
+#include "HsVersions.h"\r
+\r
+import HsSyn \r
+import TcRnMonad\r
+import RnEnv\r
+import HscTypes ( availNames )\r
+import RnNames ( getLocalDeclBinders, extendRdrEnvRn )\r
+import RnTypes ( rnHsTypeFVs, \r
+ mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, mkConOpPatRn\r
+ )\r
+import DynFlags ( DynFlag(..) )\r
+import BasicTypes ( FixityDirection(..) )\r
+import SrcLoc ( SrcSpan )\r
+import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,\r
+ loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,\r
+ negateName, thenMName, bindMName, failMName,\r
+ eqClassName, integralClassName, geName, eqName,\r
+ negateName, minusName, lengthPName, indexPName,\r
+ plusIntegerName, fromIntegerName, timesIntegerName,\r
+ ratioDataConName, fromRationalName, fromStringName )\r
+import Constants ( mAX_TUPLE_SIZE )\r
+import Name ( Name, nameOccName, nameIsLocalOrFrom, getOccName, nameSrcSpan )\r
+import NameSet\r
+import UniqFM\r
+import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, mkRdrUnqual, nameRdrName )\r
+import LoadIface ( loadInterfaceForName )\r
+import UniqFM ( isNullUFM )\r
+import UniqSet ( emptyUniqSet )\r
+import List ( nub )\r
+import Util ( isSingleton )\r
+import ListSetOps ( removeDups, minusList )\r
+import Maybes ( expectJust )\r
+import Outputable\r
+import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated, noLoc )\r
+import FastString\r
+import Literal ( inIntRange, inCharRange )\r
+import List ( unzip4 )\r
+import Bag (foldrBag)\r
+\r
+import ErrUtils (Message)\r
+\end{code}\r
+\r
+\r
+*********************************************************\r
+* *\r
+\subsection{Patterns}\r
+* *\r
+*********************************************************\r
+\r
+\begin{code}\r
+-- externally abstract type of name makers,\r
+-- which is how you go from a RdrName to a Name\r
+data NameMaker = NM (Located RdrName -> RnM Name)\r
+localNameMaker = NM (\name -> do [newname] <- newLocalsRn [name]\r
+ return newname)\r
+\r
+topNameMaker = NM (\name -> do mod <- getModule\r
+ newTopSrcBinder mod name)\r
+\r
+applyNameMaker :: NameMaker -> Located RdrName -> RnM Name\r
+applyNameMaker (NM f) x = f x\r
+\r
+\r
+-- There are various entry points to renaming patterns, depending on\r
+-- (1) whether the names created should be top-level names or local names\r
+-- (2) whether the scope of the names is entirely given in a continuation\r
+-- (e.g., in a case or lambda, but not in a let or at the top-level,\r
+-- because of the way mutually recursive bindings are handled)\r
+-- (3) whether the type signatures can bind variables\r
+-- (for unpacking existential type vars in data constructors)\r
+-- (4) whether we do duplicate and unused variable checking\r
+-- (5) whether there are fixity declarations associated with the names\r
+-- bound by the patterns that need to be brought into scope with them.\r
+-- \r
+-- Rather than burdening the clients of this module with all of these choices,\r
+-- we export the three points in this design space that we actually need:\r
+\r
+-- entry point 1:\r
+-- binds local names; the scope of the bindings is entirely in the thing_inside\r
+-- allows type sigs to bind vars\r
+-- local namemaker\r
+-- unused and duplicate checking\r
+-- no fixities\r
+rnPatsAndThen_LocalRightwards :: HsMatchContext Name -- for error messages\r
+ -> [LPat RdrName] \r
+ -- the continuation gets:\r
+ -- the list of renamed patterns\r
+ -- the (overall) free vars of all of them\r
+ -> (([LPat Name], FreeVars) -> RnM (a, FreeVars))\r
+ -> RnM (a, FreeVars)\r
+\r
+rnPatsAndThen_LocalRightwards ctxt pats thing_inside = \r
+ -- (0) bring into scope all of the type variables bound by the patterns\r
+ bindPatSigTyVarsFV (collectSigTysFromPats pats) $ \r
+ -- (1) rename the patterns, bringing into scope all of the term variables\r
+ rnLPatsAndThen localNameMaker emptyUFM pats $ \ (pats', pat_fvs) ->\r
+ -- (2) then do the thing inside.\r
+ thing_inside (pats', pat_fvs) `thenM` \ (res, res_fvs) ->\r
+ let\r
+ -- walk again to collect the names bound by the pattern\r
+ new_bndrs = collectPatsBinders pats'\r
+\r
+ -- uses now include both pattern uses and thing_inside uses\r
+ used = res_fvs `plusFV` pat_fvs\r
+ unused_binders = filter (not . (`elemNameSet` used)) new_bndrs\r
+\r
+ -- restore the locations and rdrnames of the new_bndrs\r
+ -- lets us use the existing checkDupNames, rather than reimplementing\r
+ -- the error reporting for names\r
+ new_bndrs_rdr = map (\ n -> (L (nameSrcSpan n) \r
+ (mkRdrUnqual (getOccName n)))) new_bndrs\r
+ in \r
+ -- (3) check for duplicates explicitly\r
+ -- (because we don't bind the vars all at once, it doesn't happen\r
+ -- for free in the binding)\r
+ checkDupNames doc_pat new_bndrs_rdr `thenM_`\r
+ -- (4) warn about unused binders\r
+ warnUnusedMatches unused_binders `thenM_`\r
+ -- (5) return; note that the fvs are pruned by the rnLPatsAndThen\r
+ returnM (res, res_fvs `plusFV` pat_fvs)\r
+ where\r
+ doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt\r
+\r
+\r
+-- entry point 2:\r
+-- binds local names; in a recursive scope that involves other bound vars\r
+-- allows type sigs to bind vars\r
+-- local namemaker\r
+-- no unused and duplicate checking\r
+-- fixities might be coming in\r
+rnPat_LocalRec :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> LPat RdrName\r
+ -> RnM (LPat Name, \r
+ -- free variables of the pattern,\r
+ -- but not including variables bound by this pattern \r
+ FreeVars)\r
+\r
+rnPat_LocalRec fix_env pat = \r
+ bindPatSigTyVarsFV (collectSigTysFromPats [pat]) $ \r
+ rnLPatsAndThen localNameMaker fix_env [pat] $ \ ([pat'], pat_fvs) ->\r
+ return (pat', pat_fvs)\r
+\r
+\r
+-- entry point 3:\r
+-- binds top names; in a recursive scope that involves other bound vars\r
+-- does NOT allow type sigs to bind vars\r
+-- top namemaker\r
+-- no unused and duplicate checking\r
+-- fixities might be coming in\r
+rnPat_TopRec :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> LPat RdrName\r
+ -> RnM (LPat Name, \r
+ -- free variables of the pattern,\r
+ -- but not including variables bound by this pattern \r
+ FreeVars)\r
+\r
+rnPat_TopRec fix_env pat = \r
+ rnLPatsAndThen topNameMaker fix_env [pat] $ \ ([pat'], pat_fvs) ->\r
+ return (pat', pat_fvs)\r
+\r
+\r
+-- general version: parametrized by how you make new names\r
+-- invariant: what-to-do continuation only gets called with a list whose length is the same as\r
+-- the part of the pattern we're currently renaming\r
+rnLPatsAndThen :: NameMaker -- how to make a new variable\r
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> [LPat RdrName] -- part of pattern we're currently renaming\r
+ -> (([LPat Name],FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards\r
+ -> RnM (a, FreeVars) -- renaming of the whole thing\r
+ \r
+rnLPatsAndThen var fix_env = mapFvRnCPS (rnLPatAndThen var fix_env)\r
+\r
+\r
+-- the workhorse\r
+rnLPatAndThen :: NameMaker\r
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> LPat RdrName -- part of pattern we're currently renaming\r
+ -> ((LPat Name, FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards\r
+ -> RnM (a, FreeVars) -- renaming of the whole thing\r
+rnLPatAndThen var@(NM varf) fix_env (L loc p) cont = \r
+ setSrcSpan loc $ \r
+ let reloc = L loc \r
+ lcont = \ (unlocated, fv) -> cont (reloc unlocated, fv)\r
+\r
+ -- Note: this is somewhat suspicious because it sometimes\r
+ -- binds a top-level name as a local name (when the NameMaker\r
+ -- returns a top-level name).\r
+ -- however, this binding seems to work, and it only exists for\r
+ -- the duration of the patterns and the continuation;\r
+ -- then the top-level name is added to the global env\r
+ -- before going on to the RHSes (see RnSource.lhs).\r
+ --\r
+ -- and doing things this way saves us from having to parametrize\r
+ -- by the environment extender, repeating the FreeVar handling,\r
+ -- etc.\r
+ bind n = bindLocalNamesFV_WithFixities [n] fix_env\r
+ in\r
+ case p of\r
+ WildPat _ -> lcont (WildPat placeHolderType, emptyFVs)\r
+ \r
+ VarPat name -> do\r
+ newBoundName <- varf (reloc name)\r
+ -- we need to bind pattern variables for view pattern expressions\r
+ -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)\r
+ bind newBoundName $ \r
+ (lcont (VarPat newBoundName, emptyFVs))\r
+ \r
+ SigPatIn pat ty ->\r
+ doptM Opt_PatternSignatures `thenM` \ patsigs ->\r
+ if patsigs\r
+ then rnLPatAndThen var fix_env pat\r
+ (\ (pat', fvs1) ->\r
+ rnHsTypeFVs tvdoc ty `thenM` \ (ty', fvs2) ->\r
+ lcont (SigPatIn pat' ty', fvs1 `plusFV` fvs2))\r
+ else addErr (patSigErr ty) `thenM_`\r
+ rnLPatAndThen var fix_env pat cont \r
+ where\r
+ tvdoc = text "In a pattern type-signature"\r
+ \r
+ LitPat lit@(HsString s) -> \r
+ do ovlStr <- doptM Opt_OverloadedStrings\r
+ if ovlStr \r
+ then rnLPatAndThen var fix_env (reloc $ mkNPat (mkHsIsString s placeHolderType) Nothing) cont\r
+ else do \r
+ rnLit lit\r
+ lcont (LitPat lit, emptyFVs) -- Same as below\r
+ \r
+ LitPat lit -> do \r
+ rnLit lit\r
+ lcont (LitPat lit, emptyFVs)\r
+\r
+ NPat lit mb_neg eq ->\r
+ rnOverLit lit `thenM` \ (lit', fvs1) ->\r
+ (case mb_neg of\r
+ Nothing -> returnM (Nothing, emptyFVs)\r
+ Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) ->\r
+ returnM (Just neg, fvs)\r
+ ) `thenM` \ (mb_neg', fvs2) ->\r
+ lookupSyntaxName eqName `thenM` \ (eq', fvs3) -> \r
+ lcont (NPat lit' mb_neg' eq',\r
+ fvs1 `plusFV` fvs2 `plusFV` fvs3) \r
+ -- Needed to find equality on pattern\r
+\r
+ NPlusKPat name lit _ _ -> do\r
+ new_name <- varf name \r
+ bind new_name $ \r
+ rnOverLit lit `thenM` \ (lit', fvs1) ->\r
+ lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->\r
+ lookupSyntaxName geName `thenM` \ (ge, fvs3) ->\r
+ lcont (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus,\r
+ fvs1 `plusFV` fvs2 `plusFV` fvs3)\r
+ -- The Report says that n+k patterns must be in Integral\r
+\r
+ LazyPat pat ->\r
+ rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> lcont (LazyPat pat', fvs)\r
+\r
+ BangPat pat ->\r
+ rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> lcont (BangPat pat', fvs)\r
+\r
+ AsPat name pat -> do\r
+ new_name <- varf name \r
+ bind new_name $ \r
+ rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> \r
+ lcont (AsPat (L (nameSrcSpan new_name) new_name) pat', fvs)\r
+\r
+ ViewPat expr pat ty -> \r
+ do vp_flag <- doptM Opt_ViewPatterns\r
+ checkErr vp_flag (badViewPat p)\r
+ -- because of the way we're arranging the recursive calls,\r
+ -- this will be in the right context \r
+ (expr', fvExpr) <- rnLExpr expr \r
+ rnLPatAndThen var fix_env pat $ \ (pat', fvPat) ->\r
+ lcont (ViewPat expr' pat' ty, fvPat `plusFV` fvExpr)\r
+\r
+ ConPatIn con stuff -> \r
+ -- rnConPatAndThen takes care of reconstructing the pattern\r
+ rnConPatAndThen var fix_env con stuff cont\r
+\r
+ ParPat pat -> rnLPatAndThen var fix_env pat $ \r
+ \ (pat', fv') -> lcont (ParPat pat', fv')\r
+\r
+ ListPat pats _ -> \r
+ rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->\r
+ lcont (ListPat patslist placeHolderType, fvs)\r
+\r
+ PArrPat pats _ -> \r
+ rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->\r
+ lcont (PArrPat patslist placeHolderType, \r
+ fvs `plusFV` implicit_fvs)\r
+ where\r
+ implicit_fvs = mkFVs [lengthPName, indexPName]\r
+\r
+ TuplePat pats boxed _ -> \r
+ checkTupSize (length pats) `thenM_`\r
+ (rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->\r
+ lcont (TuplePat patslist boxed placeHolderType, fvs))\r
+\r
+ TypePat name -> \r
+ rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->\r
+ lcont (TypePat name', fvs)\r
+\r
+\r
+-- helper for renaming constructor patterns\r
+rnConPatAndThen :: NameMaker\r
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> Located RdrName -- the constructor\r
+ -> HsConPatDetails RdrName \r
+ -> ((LPat Name, FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards\r
+ -> RnM (a, FreeVars)\r
+\r
+rnConPatAndThen var fix_env (con@(L loc _)) (PrefixCon pats) cont\r
+ = do con' <- lookupLocatedOccRn con\r
+ rnLPatsAndThen var fix_env pats $ \r
+ \ (pats', fvs) -> \r
+ cont (L loc $ ConPatIn con' (PrefixCon pats'),\r
+ fvs `addOneFV` unLoc con')\r
+\r
+rnConPatAndThen var fix_env (con@(L loc _)) (InfixCon pat1 pat2) cont\r
+ = do con' <- lookupLocatedOccRn con\r
+ (rnLPatAndThen var fix_env pat1 $\r
+ (\ (pat1', fvs1) -> \r
+ rnLPatAndThen var fix_env pat2 $ \r
+ (\ (pat2', fvs2) -> do \r
+ fixity <- lookupFixityRn (unLoc con')\r
+ pat' <- mkConOpPatRn con' fixity pat1' pat2'\r
+ cont (L loc pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con'))))\r
+\r
+rnConPatAndThen var fix_env (con@(L loc _)) (RecCon rpats) cont = do\r
+ con' <- lookupLocatedOccRn con\r
+ rnHsRecFieldsAndThen_Pattern con' var fix_env rpats $ \ (rpats', fvs) -> \r
+ cont (L loc $ ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')\r
+\r
+\r
+-- what kind of record expression we're doing\r
+-- the first two tell the name of the datatype constructor in question\r
+-- and give a way of creating a variable to fill in a ..\r
+data RnHsRecFieldsChoice a = Constructor (Located Name) (RdrName -> a)\r
+ | Pattern (Located Name) (RdrName -> a)\r
+ | Update\r
+\r
+choiceToMessage (Constructor _ _) = "construction"\r
+choiceToMessage (Pattern _ _) = "pattern"\r
+choiceToMessage Update = "update"\r
+\r
+doDotDot (Constructor a b) = Just (a,b)\r
+doDotDot (Pattern a b) = Just (a,b)\r
+doDotDot Update = Nothing\r
+\r
+getChoiceName (Constructor n _) = Just n\r
+getChoiceName (Pattern n _) = Just n\r
+getChoiceName (Update) = Nothing\r
+\r
+\r
+\r
+-- helper for renaming record patterns;\r
+-- parameterized so that it can also be used for expressions\r
+rnHsRecFieldsAndThen :: RnHsRecFieldsChoice field\r
+ -- how to rename the fields (CPSed)\r
+ -> (Located field -> ((Located field', FreeVars) -> RnM (c, FreeVars)) \r
+ -> RnM (c, FreeVars)) \r
+ -- the actual fields \r
+ -> HsRecFields RdrName (Located field) \r
+ -- what to do in the scope of the field vars\r
+ -> ((HsRecFields Name (Located field'), FreeVars) -> RnM (c, FreeVars)) \r
+ -> RnM (c, FreeVars)\r
+-- Haddock comments for record fields are renamed to Nothing here\r
+rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont = \r
+ let\r
+\r
+ -- helper to collect and report duplicate record fields\r
+ reportDuplicateFields doingstr fields = \r
+ let \r
+ -- each list represents a RdrName that occurred more than once\r
+ -- (the list contains all occurrences)\r
+ -- invariant: each list in dup_fields is non-empty\r
+ (_, dup_fields :: [[RdrName]]) = removeDups compare\r
+ (map (unLoc . hsRecFieldId) fields)\r
+ \r
+ -- duplicate field reporting function\r
+ field_dup_err dup_group = addErr (dupFieldErr doingstr (head dup_group))\r
+ in\r
+ mappM_ field_dup_err dup_fields\r
+\r
+ -- helper to rename each field\r
+ rn_field pun_ok (HsRecField field inside pun) cont = do \r
+ fieldname <- lookupRecordBndr (getChoiceName choice) field\r
+ checkErr (not pun || pun_ok) (badPun field)\r
+ rn_thing inside $ \ (inside', fvs) -> \r
+ cont (HsRecField fieldname inside' pun, \r
+ fvs `addOneFV` unLoc fieldname)\r
+\r
+ -- Compute the extra fields to be filled in by the dot-dot notation\r
+ dot_dot_fields fs con mk_field cont = do \r
+ con_fields <- lookupConstructorFields (unLoc con)\r
+ let missing_fields = con_fields `minusList` fs\r
+ loc <- getSrcSpanM -- Rather approximate\r
+ -- it's important that we make the RdrName fields that we morally wrote\r
+ -- and then rename them in the usual manner\r
+ -- (rather than trying to make the result of renaming directly)\r
+ -- because, for patterns, renaming can bind vars in the continuation\r
+ mapFvRnCPS rn_thing \r
+ (map (L loc . mk_field . mkRdrUnqual . getOccName) missing_fields) $\r
+ \ (rhss, fvs_s) -> \r
+ let new_fs = [ HsRecField (L loc f) r False\r
+ | (f, r) <- missing_fields `zip` rhss ]\r
+ in \r
+ cont (new_fs, fvs_s)\r
+\r
+ in do\r
+ -- report duplicate fields\r
+ let doingstr = choiceToMessage choice\r
+ reportDuplicateFields doingstr fields\r
+\r
+ -- rename the records as written\r
+ -- check whether punning (implicit x=x) is allowed\r
+ pun_flag <- doptM Opt_RecordPuns\r
+ -- rename the fields\r
+ mapFvRnCPS (rn_field pun_flag) fields $ \ (fields1, fvs1) ->\r
+\r
+ -- handle ..\r
+ case dd of\r
+ Nothing -> cont (HsRecFields fields1 dd, fvs1)\r
+ Just n -> ASSERT( n == length fields ) do\r
+ dd_flag <- doptM Opt_RecordWildCards\r
+ checkErr dd_flag (needFlagDotDot doingstr)\r
+ let fld_names1 = map (unLoc . hsRecFieldId) fields1\r
+ case doDotDot choice of \r
+ Nothing -> addErr (badDotDot doingstr) `thenM_` \r
+ -- we return a junk value here so that error reporting goes on\r
+ cont (HsRecFields fields1 dd, fvs1)\r
+ Just (con, mk_field) ->\r
+ dot_dot_fields fld_names1 con mk_field $\r
+ \ (fields2, fvs2) -> \r
+ cont (HsRecFields (fields1 ++ fields2) dd, \r
+ fvs1 `plusFV` fvs2)\r
+\r
+needFlagDotDot str = vcat [ptext SLIT("Illegal `..' in record") <+> text str,\r
+ ptext SLIT("Use -XRecordWildCards to permit this")]\r
+\r
+badDotDot str = ptext SLIT("You cannot use `..' in record") <+> text str\r
+\r
+badPun fld = vcat [ptext SLIT("Illegal use of punning for field") <+> quotes (ppr fld),\r
+ ptext SLIT("Use -XRecordPuns to permit this")]\r
+\r
+\r
+-- wrappers\r
+rnHsRecFieldsAndThen_Pattern :: Located Name\r
+ -> NameMaker -- new name maker\r
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> HsRecFields RdrName (LPat RdrName) \r
+ -> ((HsRecFields Name (LPat Name), FreeVars) -> RnM (c, FreeVars)) \r
+ -> RnM (c, FreeVars)\r
+rnHsRecFieldsAndThen_Pattern n var fix_env = rnHsRecFieldsAndThen (Pattern n VarPat) (rnLPatAndThen var fix_env)\r
+\r
+\r
+-- wrapper to use rnLExpr in CPS style;\r
+-- because it does not bind any vars going forward, it does not need\r
+-- to be written that way\r
+rnLExprAndThen :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))\r
+ -> LHsExpr RdrName \r
+ -> ((LHsExpr Name, FreeVars) -> RnM (c, FreeVars)) \r
+ -> RnM (c, FreeVars) \r
+rnLExprAndThen f e cont = do {x <- f e; cont x}\r
+\r
+\r
+-- non-CPSed because exprs don't leave anything bound\r
+rnHsRecFields_Con :: Located Name\r
+ -> (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))\r
+ -> HsRecFields RdrName (LHsExpr RdrName) \r
+ -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)\r
+rnHsRecFields_Con n rnLExpr fields = rnHsRecFieldsAndThen (Constructor n HsVar) \r
+ (rnLExprAndThen rnLExpr) fields return\r
+\r
+rnHsRecFields_Update :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))\r
+ -> HsRecFields RdrName (LHsExpr RdrName) \r
+ -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)\r
+rnHsRecFields_Update rnLExpr fields = rnHsRecFieldsAndThen Update\r
+ (rnLExprAndThen rnLExpr) fields return\r
+\end{code}\r
+\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection{Literals}\r
+%* *\r
+%************************************************************************\r
+\r
+When literals occur we have to make sure\r
+that the types and classes they involve\r
+are made available.\r
+\r
+\begin{code}\r
+rnLit :: HsLit -> RnM ()\r
+rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)\r
+rnLit other = returnM ()\r
+\r
+rnOverLit (HsIntegral i _ _)\r
+ = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) ->\r
+ if inIntRange i then\r
+ returnM (HsIntegral i from_integer_name placeHolderType, fvs)\r
+ else let\r
+ extra_fvs = mkFVs [plusIntegerName, timesIntegerName]\r
+ -- Big integer literals are built, using + and *, \r
+ -- out of small integers (DsUtils.mkIntegerLit)\r
+ -- [NB: plusInteger, timesInteger aren't rebindable... \r
+ -- they are used to construct the argument to fromInteger, \r
+ -- which is the rebindable one.]\r
+ in\r
+ returnM (HsIntegral i from_integer_name placeHolderType, fvs `plusFV` extra_fvs)\r
+\r
+rnOverLit (HsFractional i _ _)\r
+ = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) ->\r
+ let\r
+ extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]\r
+ -- We have to make sure that the Ratio type is imported with\r
+ -- its constructor, because literals of type Ratio t are\r
+ -- built with that constructor.\r
+ -- The Rational type is needed too, but that will come in\r
+ -- as part of the type for fromRational.\r
+ -- The plus/times integer operations may be needed to construct the numerator\r
+ -- and denominator (see DsUtils.mkIntegerLit)\r
+ in\r
+ returnM (HsFractional i from_rat_name placeHolderType, fvs `plusFV` extra_fvs)\r
+\r
+rnOverLit (HsIsString s _ _)\r
+ = lookupSyntaxName fromStringName `thenM` \ (from_string_name, fvs) ->\r
+ returnM (HsIsString s from_string_name placeHolderType, fvs)\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection{Errors}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+checkTupSize :: Int -> RnM ()\r
+checkTupSize tup_size\r
+ | tup_size <= mAX_TUPLE_SIZE \r
+ = returnM ()\r
+ | otherwise \r
+ = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"),\r
+ nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),\r
+ nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])\r
+\r
+patSigErr ty\r
+ = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)\r
+ $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))\r
+\r
+dupFieldErr str dup\r
+ = hsep [ptext SLIT("duplicate field name"), \r
+ quotes (ppr dup),\r
+ ptext SLIT("in record"), text str]\r
+\r
+bogusCharError c\r
+ = ptext SLIT("character literal out of range: '\\") <> char c <> char '\''\r
+\r
+badViewPat pat = vcat [ptext SLIT("Illegal view pattern: ") <+> ppr pat,\r
+ ptext SLIT("Use -XViewPatterns to enalbe view patterns")]\r
+\r
+\end{code}\r
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(..) )
import Maybe ( isNothing )
import Monad ( liftM, when )
import BasicTypes ( Boxity(..) )
+
+import ListSetOps (findDupsEq, mkLookupFun)
\end{code}
@rnSourceDecl@ `renames' declarations.
\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
\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)
-- 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}
%* *
%*********************************************************
-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}
%*********************************************************
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}
%*********************************************************
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
lookupLocatedGlobalOccRn, bindTyVarsRn,
lookupFixityRn, lookupTyFixityRn, lookupConstructorFields,
lookupRecordBndr, mapFvRn, warnUnusedMatches,
- newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
+ newIPNameRn, bindPatSigTyVarsFV)
import TcRnMonad
import RdrName
import PrelNames ( eqClassName, integralClassName, geName, eqName,
-- 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}
+
%************************************************************************
%* *
%*********************************************************
%* *
-\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),
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}
-- [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
(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))
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
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
= 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
-- 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
}}}}}
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) <+>
-- 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"
-> HsExpr Name
-> TcType
-> TcM (HsExpr TcId)
+
\end{code}
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
-------------------------------------------------------------------------
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)
; (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
; (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
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,
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcSyntaxOp )
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho)
import HsSyn
import TcHsSyn
\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,
-------------------
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;
--------------------
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
-- 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
------------------------
-- 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)
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)
-> 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,
-- 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)
-- 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
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
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 {
------------------------------------------------
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) }
rnDump (ppr rn_decls) ;
return (tcg_env', rn_decls)
- }}
+ }
------------------------------------------------
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
import Outputable
import UniqSupply
import Unique
+import UniqFM
import DynFlags
import StaticFlags
import FastString
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
-%
+
% (c) The University of Glasgow 2006
% (c) The GRASP Project, Glasgow University, 1992-2002
%
-- (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
, 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 = []
<entry><option>-XNoPatternGuards</option></entry>
</row>
<row>
+ <entry><option>-XViewPatterns</option></entry>
+ <entry>Enable <link linkend="view-patterns">view patterns</link>.</entry>
+ <entry>dynamic</entry>
+ <entry><option>-XNoViewPatterns</option></entry>
+ </row>
+ <row>
<entry><option>-XUnicodeSyntax</option></entry>
<entry>Enable unicode syntax.</entry>
<entry>dynamic</entry>
</para>
</sect2>
+ <!-- ===================== View patterns =================== -->
+
+<sect2 id="view-patterns">
+<title>View patterns
+</title>
+
+<para>
+View patterns are enabled by the flag <literal>-XViewPatterns</literal>.
+More information and examples of view patterns can be found on the
+<ulink url="http://hackage.haskell.org/trac/ghc/wiki/ViewPatterns">Wiki
+page</ulink>.
+</para>
+
+<para>
+View patterns are somewhat like pattern guards that can be nested inside
+of other patterns. They are a convenient way of pattern-matching
+against values of abstract types. For example, in a programming language
+implementation, we might represent the syntax of the types of the
+language as follows:
+
+<programlisting>
+type Typ
+
+data TypView = Unit
+ | Arrow Typ Typ
+
+view :: Type -> TypeView
+
+-- additional operations for constructing Typ's ...
+</programlisting>
+
+The representation of Typ is held abstract, permitting implementations
+to use a fancy representation (e.g., hash-consing to managage sharing).
+
+Without view patterns, using this signature a little inconvenient:
+<programlisting>
+size :: Typ -> Integer
+size t = case view t of
+ Unit -> 1
+ Arrow t1 t2 -> size t1 + size t2
+</programlisting>
+
+It is necessary to iterate the case, rather than using an equational
+function definition. And the situation is even worse when the matching
+against <literal>t</literal> is buried deep inside another pattern.
+</para>
+
+<para>
+View patterns permit calling the view function inside the pattern and
+matching against the result:
+<programlisting>
+size (view -> Unit) = 1
+size (view -> Arrow t1 t2) = size t1 + size t2
+</programlisting>
+
+That is, we add a new form of pattern, written
+<replaceable>expression</replaceable> <literal>-></literal>
+<replaceable>pattern</replaceable> that means "apply the expression to
+whatever we're trying to match against, and then match the result of
+that application against the pattern". The expression can be any Haskell
+expression of function type, and view patterns can be used wherever
+patterns are used.
+</para>
+
+<para>
+The semantics of a pattern <literal>(</literal>
+<replaceable>exp</replaceable> <literal>-></literal>
+<replaceable>pat</replaceable> <literal>)</literal> are as follows:
+
+<itemizedlist>
+
+<listitem> Scoping:
+
+<para>The variables bound by the view pattern are the variables bound by
+<replaceable>pat</replaceable>.
+</para>
+
+<para>
+Any variables in <replaceable>exp</replaceable> are bound occurrences,
+but variables bound "to the left" in a pattern are in scope. This
+feature permits, for example, one argument to a function to be used in
+the view of another argument. For example, the function
+<literal>clunky</literal> from <xref linkend="pattern-guards" /> can be
+written using view patterns as follows:
+
+<programlisting>
+clunky env (lookup env -> Just val1) (lookup env -> Just val2) = val1 + val2
+...other equations for clunky...
+</programlisting>
+</para>
+
+<para>
+More precisely, the scoping rules are:
+<itemizedlist>
+<listitem>
+<para>
+In a single pattern, variables bound by patterns to the left of a view
+pattern expression are in scope. For example:
+<programlisting>
+example :: Maybe ((String -> Integer,Integer), String) -> Bool
+example Just ((f,_), f -> 4) = True
+</programlisting>
+
+Additionally, in function definitions, variables bound by matching earlier curried
+arguments may be used in view pattern expressions in later arguments:
+<programlisting>
+example :: (String -> Integer) -> String -> Bool
+example f (f -> 4) = True
+</programlisting>
+That is, the scoping is the same as it would be if the curried arguments
+were collected into a tuple.
+</para>
+</listitem>
+
+<listitem>
+<para>
+In mutually recursive bindings, such as <literal>let</literal>,
+<literal>where</literal>, or the top level, view patterns in one
+declaration may not mention variables bound by other declarations. That
+is, each declaration must be self-contained. For example, the following
+program is not allowed:
+<programlisting>
+let {(x -> y) = e1 ;
+ (y -> x) = e2 } in x
+</programlisting>
+
+(We may lift this
+restriction in the future; the only cost is that type checking patterns
+would get a little more complicated.)
+
+
+</para>
+</listitem>
+</itemizedlist>
+
+</para>
+</listitem>
+
+<listitem><para> Typing: If <replaceable>exp</replaceable> has type
+<replaceable>T1</replaceable> <literal>-></literal>
+<replaceable>T2</replaceable> and <replaceable>pat</replaceable> matches
+a <replaceable>T2</replaceable>, then the whole view pattern matches a
+<replaceable>T1</replaceable>.
+</para></listitem>
+
+<listitem><para> Matching: To the equations in Section 3.17.3 of the
+<ulink url="http://www.haskell.org/onlinereport/">Haskell 98
+Report</ulink>, add the following:
+<programlisting>
+case v of { (e -> p) -> e1 ; _ -> e2 }
+ =
+case (e v) of { p -> e1 ; _ -> e2 }
+</programlisting>
+That is, to match a variable <replaceable>v</replaceable> against a pattern
+<literal>(</literal> <replaceable>exp</replaceable>
+<literal>-></literal> <replaceable>pat</replaceable>
+<literal>)</literal>, evaluate <literal>(</literal>
+<replaceable>exp</replaceable> <replaceable> v</replaceable>
+<literal>)</literal> and match the result against
+<replaceable>pat</replaceable>.
+</para></listitem>
+
+<listitem><para> Efficiency: When the same view function is applied in
+multiple branches of a function definition or a case expression (e.g.,
+in <literal>size</literal> above), GHC makes an attempt to collect these
+applications into a single nested case expression, so that the view
+function is only applied once. Pattern compilation in GHC follows the
+matrix algorithm described in Chapter 4 of <ulink
+url="http://research.microsoft.com/~simonpj/Papers/slpj-book-1987/">The
+Implementation of Functional Programming Languages</ulink>. When the
+top rows of the first column of a matrix are all view patterns with the
+"same" expression, these patterns are transformed into a single nested
+case. This includes, for example, adjacent view patterns that line up
+in a tuple, as in
+<programlisting>
+f ((view -> A, p1), p2) = e1
+f ((view -> B, p3), p4) = e2
+</programlisting>
+</para>
+
+<para> The current notion of when two view pattern expressions are "the
+same" is very restricted: it is not even full syntactic equality.
+However, it does include variables, literals, applications, and tuples;
+e.g., two instances of <literal>view ("hi", "there")</literal> will be
+collected. However, the current implementation does not compare up to
+alpha-equivalence, so two instances of <literal>(x, view x ->
+y)</literal> will not be coalesced.
+</para>
+
+</listitem>
+
+</itemizedlist>
+</para>
+
+</sect2>
+
<!-- ===================== Recursive do-notation =================== -->
<sect2 id="mdo-notation">
</sect2>
+ <!-- ===================== REBINDABLE SYNTAX =================== -->
+
<sect2 id="rebindable-syntax">
<title>Rebindable syntax</title>
-
<para>GHC allows most kinds of built-in syntax to be rebound by
the user, to facilitate replacing the <literal>Prelude</literal>
with a home-grown version, for example.</para>
records from different modules that use the same field name.
</para>
</sect2>
+
+ <!-- ===================== Record puns =================== -->
+
+<sect2 id="record-puns">
+<title>Record puns
+</title>
+
+<para>
+Record puns are enabled by the flag <literal>-XRecordPuns</literal>.
+</para>
+
+<para>
+When using records, it is common to write a pattern that binds a
+variable with the same name as a record field, such as:
+
+<programlisting>
+data C = C {a :: Int}
+f (C {a = a}) = a
+</programlisting>
+</para>
+
+<para>
+Record punning permits the variable name to be elided, so one can simply
+write
+
+<programlisting>
+f (C {a}) = a
+</programlisting>
+
+to mean the same pattern as above. That is, in a record pattern, the
+pattern <literal>a</literal> expands into the pattern <literal>a =
+a</literal> for the same name <literal>a</literal>.
+</para>
+
+<para>
+Note that puns and other patterns can be mixed in the same record:
+<programlisting>
+data C = C {a :: Int, b :: Int}
+f (C {a, b = 4}) = a
+</programlisting>
+and that puns can be used wherever record patterns occur (e.g. in
+<literal>let</literal> bindings or at the top-level).
+</para>
+
+<para>
+Record punning can also be used in an expression, writing, for example,
+<programlisting>
+let a = 1 in C {a}
+</programlisting>
+instead of
+<programlisting>
+let a = 1 in C {a = a}
+</programlisting>
+
+Note that this expansion is purely syntactic, so the record pun
+expression refers to the nearest enclosing variable that is spelled the
+same as the field name.
+</para>
+
+</sect2>
+
+ <!-- ===================== Record wildcards =================== -->
+
+<sect2 id="record-wildcards">
+<title>Record wildcards
+</title>
+
+<para>
+Record wildcards are enabled by the flag <literal>-XRecordWildCards</literal>.
+</para>
+
+<para>
+For records with many fields, it can be tiresome to write out each field
+individually in a record pattern, as in
+<programlisting>
+data C = C {a :: Int, b :: Int, c :: Int, d :: Int}
+f (C {a = 1, b = b, c = c, d = d}) = b + c + d
+</programlisting>
+</para>
+
+<para>
+Record wildcard syntax permits a (<literal>..</literal>) in a record
+pattern, where each elided field <literal>f</literal> is replaced by the
+pattern <literal>f = f</literal>. For example, the above pattern can be
+written as
+<programlisting>
+f (C {a = 1, ..}) = b + c + d
+</programlisting>
+</para>
+
+<para>
+Note that wildcards can be mixed with other patterns, including puns
+(<xref linkend="record-puns"/>); for example, in a pattern <literal>C {a
+= 1, b, ..})</literal>. Additionally, record wildcards can be used
+wherever record patterns occur, including in <literal>let</literal>
+bindings and at the top-level. For example, the top-level binding
+<programlisting>
+C {a = 1, ..} = e
+</programlisting>
+defines <literal>b</literal>, <literal>c</literal>, and
+<literal>d</literal>.
+</para>
+
+<para>
+Record wildcards can also be used in expressions, writing, for example,
+
+<programlisting>
+let {a = 1; b = 2; c = 3; d = 4} in C {..}
+</programlisting>
+
+in place of
+
+<programlisting>
+let {a = 1; b = 2; c = 3; d = 4} in C {a=a, b=b, c=c, d=d}
+</programlisting>
+
+Note that this expansion is purely syntactic, so the record wildcard
+expression refers to the nearest enclosing variables that are spelled
+the same as the omitted field names.
+</para>
+
+</sect2>
+
+ <!-- ===================== Local fixity declarations =================== -->
+
+<sect2 id="local-fixity-declarations">
+<title>Local Fixity Declarations
+</title>
+
+<para>A careful reading of the Haskell 98 Report reveals that fixity
+declarations (<literal>infix</literal>, <literal>infixl</literal>, and
+<literal>infixr</literal>) are permitted to appear inside local bindings
+such those introduced by <literal>let</literal> and
+<literal>where</literal>. However, the Haskell Report does not specify
+the semantics of such bindings very precisely.
+</para>
+
+<para>In GHC, a fixity declaration may accompany a local binding:
+<programlisting>
+let f = ...
+ infixr 3 `f`
+in
+ ...
+</programlisting>
+and the fixity declaration applies wherever the binding is in scope.
+For example, in a <literal>let</literal>, it applies in the right-hand
+sides of other <literal>let</literal>-bindings and the body of the
+<literal>let</literal>C. Or, in recursive <literal>do</literal>
+expressions (<xref linkend="mdo-notation"/>), the local fixity
+declarations of aA <literal>let</literal> statement scope over other
+statements in the group, just as the bound name does.
+</para>
+
+Moreover, a local fixity declatation *must* accompany a local binding of
+that name: it is not possible to revise the fixity of name bound
+elsewhere, as in
+<programlisting>
+let infixr 9 $ in ...
+</programlisting>
+
+Because local fixity declarations are technically Haskell 98, no flag is
+necessary to enable them.
+</sect2>
+
</sect1>
projects / ghc-hetmet.git / commitdiff