projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Print more nicely in -ddump-splices
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcBinds.lhs
diff --git
a/compiler/typecheck/TcBinds.lhs
b/compiler/typecheck/TcBinds.lhs
index
b4c0d1a
..
59cd315
100644
(file)
--- a/
compiler/typecheck/TcBinds.lhs
+++ b/
compiler/typecheck/TcBinds.lhs
@@
-98,7
+98,7
@@
tcHsBootSigs :: HsValBinds Name -> TcM [Id]
-- signatures in it. The renamer checked all this
tcHsBootSigs (ValBindsOut binds sigs)
= do { checkTc (null binds) badBootDeclErr
-- signatures in it. The renamer checked all this
tcHsBootSigs (ValBindsOut binds sigs)
= do { checkTc (null binds) badBootDeclErr
- ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
+ ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
tc_boot_sig (TypeSig (L _ name) ty)
= do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
where
tc_boot_sig (TypeSig (L _ name) ty)
= do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
@@
-151,7
+151,7
@@
tcValBinds _ (ValBindsIn binds _) _
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
= do { -- Typecheck the signature
; let { prag_fn = mkPragFun sigs
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
= do { -- Typecheck the signature
; let { prag_fn = mkPragFun sigs
- ; ty_sigs = filter isVanillaLSig sigs
+ ; ty_sigs = filter isTypeLSig sigs
; sig_fn = mkTcSigFun ty_sigs }
; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
; sig_fn = mkTcSigFun ty_sigs }
; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
@@
-428,8
+428,7
@@
tcPrag :: TcId -> Sig Name -> TcM Prag
tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl
tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec
tcPrag _ (InlineSig _ inl) = return (InlinePrag inl)
tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl
tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec
tcPrag _ (InlineSig _ inl) = return (InlinePrag inl)
-tcPrag _ (FixSig {}) = panic "tcPrag FixSig"
-tcPrag _ (TypeSig {}) = panic "tcPrag TypeSig"
+tcPrag _ sig = pprPanic "tcPrag" (ppr sig)
tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
@@
-476,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
@@
-487,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:"))
@@
-813,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"))
}
@@
-1045,8
+1054,10
@@
mkTcSigFun :: [LSig Name] -> TcSigFun
-- Precondition: no duplicates
mkTcSigFun sigs = lookupNameEnv env
where
-- Precondition: no duplicates
mkTcSigFun sigs = lookupNameEnv env
where
- env = mkNameEnv [(name, hsExplicitTvs lhs_ty)
- | L _ (TypeSig (L _ name) lhs_ty) <- sigs]
+ env = mkNameEnv (mapCatMaybes mk_pair sigs)
+ mk_pair (L _ (TypeSig (L _ name) lhs_ty)) = Just (name, hsExplicitTvs lhs_ty)
+ mk_pair (L _ (IdSig id)) = Just (idName id, [])
+ mk_pair _ = Nothing
-- The scoped names are the ones explicitly mentioned
-- in the HsForAll. (There may be more in sigma_ty, because
-- of nested type synonyms. See Note [More instantiated than scoped].)
-- The scoped names are the ones explicitly mentioned
-- in the HsForAll. (There may be more in sigma_ty, because
-- of nested type synonyms. See Note [More instantiated than scoped].)
@@
-1100,6
+1111,8
@@
tcTySig (L span (TypeSig (L _ name) ty))
= setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; return (mkLocalId name sigma_ty) }
= setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; return (mkLocalId name sigma_ty) }
+tcTySig (L _ (IdSig id))
+ = return id
tcTySig s = pprPanic "tcTySig" (ppr s)
-------------------
tcTySig s = pprPanic "tcTySig" (ppr s)
-------------------