import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, rnLPat )
-import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch )
+import RnExpr ( rnMatchGroup, rnMatch, rnGRHSs, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn,
lookupLocatedInstDeclBndr,
lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
- bindLocalFixities,
+ bindLocalFixities, bindSigTyVarsFV,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
-import CmdLineOpts ( DynFlag(..) )
+import DynFlags ( DynFlag(..) )
import Digraph ( SCC(..), stronglyConnComp )
import Name ( Name, nameOccName, nameSrcLoc )
import NameSet
import SrcLoc ( mkSrcSpan, Located(..), unLoc )
import Bag
import Outputable
-
import Monad ( foldM )
\end{code}
contains bindings for the binders of this particular binding.
\begin{code}
-rnTopBinds :: Bag (LHsBind RdrName)
+rnTopBinds :: LHsBinds RdrName
-> [LSig RdrName]
-> RnM ([HsBindGroup Name], DefUses)
-- the top level scope resolution does that
rnTopBinds mbinds sigs
- = bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ ->
- -- Hmm; by analogy with Ids, this doesn't look right
- -- Top-level bound type vars should really scope over
- -- everything, but we only scope them over the other bindings
-
- rnBinds TopLevel mbinds sigs
+ = do { is_boot <- tcIsHsBoot
+ ; if is_boot then
+ rnHsBoot mbinds sigs
+ else bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ ->
+ -- Hmm; by analogy with Ids, this doesn't look right
+ -- Top-level bound type vars should really scope over
+ -- everything, but we only scope them over the other bindings
+ rnBinds TopLevel mbinds sigs }
+
+rnHsBoot :: LHsBinds RdrName
+ -> [LSig RdrName]
+ -> RnM ([HsBindGroup Name], DefUses)
+-- A hs-boot file has no bindings.
+-- Return a single HsBindGroup with empty binds and renamed signatures
+rnHsBoot mbinds sigs
+ = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
+ ; sigs' <- renameSigs sigs
+ ; return ([HsBindGroup emptyLHsBinds sigs' NonRecursive],
+ usesOnly (hsSigsFVs sigs')) }
\end{code}
\begin{code}
rnBinds :: TopLevelFlag
- -> Bag (LHsBind RdrName)
+ -> LHsBinds RdrName
-> [LSig RdrName]
-> RnM ([HsBindGroup Name], DefUses)
\begin{code}
mkBindVertices :: [LSig Name] -- Signatures
- -> Bag (LHsBind RdrName)
+ -> LHsBinds RdrName
-> RnM [BindVertex]
mkBindVertices sigs = mapM (mkBindVertex sigs) . bagToList
mkBindVertex :: [LSig Name] -> LHsBind RdrName -> RnM BindVertex
-mkBindVertex sigs (L loc (PatBind pat grhss))
- = addSrcSpan loc $
+mkBindVertex sigs (L loc (PatBind pat grhss ty))
+ = setSrcSpan loc $
rnLPat pat `thenM` \ (pat', pat_fvs) ->
-- Find which things are bound in this group
names_bound_here = mkNameSet (collectPatBinders pat')
in
sigsForMe names_bound_here sigs `thenM` \ sigs_for_me ->
- rnGRHSs PatBindRhs grhss `thenM` \ (grhss', fvs) ->
+ bindSigTyVarsFV sigs_for_me (
+ rnGRHSs PatBindRhs grhss
+ ) `thenM` \ (grhss', fvs) ->
returnM
(names_bound_here, fvs `plusFV` pat_fvs,
- L loc (PatBind pat' grhss'), sigs_for_me
+ L loc (PatBind pat' grhss' ty), sigs_for_me
)
mkBindVertex sigs (L loc (FunBind name inf matches))
- = addSrcSpan loc $
+ = setSrcSpan loc $
lookupLocatedBndrRn name `thenM` \ new_name ->
let
plain_name = unLoc new_name
names_bound_here = unitNameSet plain_name
in
sigsForMe names_bound_here sigs `thenM` \ sigs_for_me ->
- mapFvRn (rnMatch (FunRhs plain_name)) matches `thenM` \ (new_matches, fvs) ->
- mappM_ (checkPrecMatch inf plain_name) new_matches `thenM_`
+ bindSigTyVarsFV sigs_for_me (
+ rnMatchGroup (FunRhs plain_name) matches
+ ) `thenM` \ (new_matches, fvs) ->
+ checkPrecMatch inf plain_name new_matches `thenM_`
returnM
(unitNameSet plain_name, fvs,
L loc (FunBind new_name inf new_matches), sigs_for_me
\begin{code}
rnMethodBinds :: Name -- Class name
-> [Name] -- Names for generic type variables
- -> (LHsBinds RdrName)
+ -> LHsBinds RdrName
-> RnM (LHsBinds Name, FreeVars)
rnMethodBinds cls gen_tyvars binds
(bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind
return (bind' `unionBags` binds, fvs_bind `plusFV` fvs)
-
-rnMethodBind cls gen_tyvars (L loc (FunBind name inf matches))
- = addSrcSpan loc $
+rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _)))
+ = setSrcSpan loc $
lookupLocatedInstDeclBndr cls name `thenM` \ sel_name ->
let plain_name = unLoc sel_name in
-- We use the selector name as the binder
mapFvRn (rn_match plain_name) matches `thenM` \ (new_matches, fvs) ->
- mappM_ (checkPrecMatch inf plain_name) new_matches `thenM_`
- returnM (unitBag (L loc (FunBind sel_name inf new_matches)), fvs `addOneFV` plain_name)
+ let
+ new_group = MatchGroup new_matches placeHolderType
+ in
+ checkPrecMatch inf plain_name new_group `thenM_`
+ returnM (unitBag (L loc (FunBind sel_name inf new_group)), fvs `addOneFV` plain_name)
where
- -- Gruesome; bring into scope the correct members of the generic type variables
- -- See comments in RnSource.rnSourceDecl(ClassDecl)
+ -- Truly gruesome; bring into scope the correct members of the generic
+ -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl)
rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _))
= extendTyVarEnvFVRn gen_tvs $
rnMatch (FunRhs sel_name) match
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _))
+rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _))
= addLocErr mbind methodBindErr `thenM_`
returnM (emptyBag, emptyFVs)
\end{code}
-- Doesn't seem worth much trouble to sort this.
renameSigs :: [LSig RdrName] -> RnM [LSig Name]
-renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixitySig . unLoc) sigs)
+renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixityLSig) sigs)
-- Remove fixity sigs which have been dealt with already
renameSig :: Sig RdrName -> RnM (Sig Name)
loc = nameSrcLoc var -- TODO: make a proper span
methodBindErr mbind
- = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))
- 4 (ppr mbind)
+ = hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations"))
+ 2 (ppr mbind)
+
+bindsInHsBootFile mbinds
+ = hang (ptext SLIT("Bindings in hs-boot files are not allowed"))
+ 2 (ppr mbinds)
\end{code}
projects / ghc-hetmet.git / blobdiff