projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Implement -XMonoLocalBinds: a radical new flag
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcBinds.lhs
diff --git
a/compiler/typecheck/TcBinds.lhs
b/compiler/typecheck/TcBinds.lhs
index
c67eeef
..
4fd3ae0
100644
(file)
--- a/
compiler/typecheck/TcBinds.lhs
+++ b/
compiler/typecheck/TcBinds.lhs
@@
-475,6
+475,11
@@
checkStrictBinds top_lvl rec_group mbind mono_tys infos
(strictBindErr "Recursive" unlifted mbind)
; checkTc (isSingletonBag mbind)
(strictBindErr "Multiple" unlifted mbind)
(strictBindErr "Recursive" unlifted mbind)
; checkTc (isSingletonBag mbind)
(strictBindErr "Multiple" unlifted mbind)
+ -- This should be a checkTc, not a warnTc, but as of GHC 6.11
+ -- the versions of alex and happy available have non-conforming
+ -- templates, so the GHC build fails if it's an error:
+ ; warnTc (not bang_pat)
+ (unliftedMustBeBang mbind)
; mapM_ check_sig infos
; return True }
| otherwise
; mapM_ check_sig infos
; return True }
| otherwise
@@
-486,6
+491,11
@@
checkStrictBinds top_lvl rec_group mbind mono_tys infos
(badStrictSig unlifted sig)
check_sig _ = return ()
(badStrictSig unlifted sig)
check_sig _ = return ()
+unliftedMustBeBang :: LHsBindsLR Var Var -> SDoc
+unliftedMustBeBang mbind
+ = hang (text "Bindings containing unlifted types must use an outermost bang pattern:")
+ 4 (pprLHsBinds mbind)
+
strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc
strictBindErr flavour unlifted mbind
= hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc
strictBindErr flavour unlifted mbind
= hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
@@
-724,7
+734,7
@@
generalise :: DynFlags -> TopLevelFlag
-- The returned [TyVar] are all ready to quantify
generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
-- The returned [TyVar] are all ready to quantify
generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
- | isMonoGroup dflags bind_list
+ | isMonoGroup dflags top_lvl bind_list sigs
= do { extendLIEs lie_req
; return ([], [], emptyBag) }
= do { extendLIEs lie_req
; return ([], [], emptyBag) }
@@
-812,7
+822,7
@@
unifyCtxts (sig1 : sigs) -- Argument is always non-empty
-- where F is a type function and (F a ~ [a])
-- Then unification might succeed with a coercion. But it's much
-- much simpler to require that such signatures have identical contexts
-- where F is a type function and (F a ~ [a])
-- Then unification might succeed with a coercion. But it's much
-- much simpler to require that such signatures have identical contexts
- checkTc (all isIdentityCoercion cois)
+ checkTc (all isIdentityCoI cois)
(ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
}
(ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
}
@@
-1147,10
+1157,12
@@
tcInstSig use_skols name
sig_loc = loc }) }
-------------------
sig_loc = loc }) }
-------------------
-isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool
+isMonoGroup :: DynFlags -> TopLevelFlag -> [LHsBind Name]
+ -> [TcSigInfo] -> Bool
-- No generalisation at all
-- No generalisation at all
-isMonoGroup dflags binds
- = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds
+isMonoGroup dflags top_lvl binds sigs
+ = (dopt Opt_MonoPatBinds dflags && any is_pat_bind binds)
+ || (dopt Opt_MonoLocalBinds dflags && null sigs && not (isTopLevel top_lvl))
where
is_pat_bind (L _ (PatBind {})) = True
is_pat_bind _ = False
where
is_pat_bind (L _ (PatBind {})) = True
is_pat_bind _ = False