projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
a364279
)
Fix warnings in TcPat
author
Ian Lynagh
<igloo@earth.li>
Tue, 10 Jun 2008 12:33:43 +0000
(12:33 +0000)
committer
Ian Lynagh
<igloo@earth.li>
Tue, 10 Jun 2008 12:33:43 +0000
(12:33 +0000)
compiler/typecheck/TcPat.lhs
patch
|
blob
|
history
diff --git
a/compiler/typecheck/TcPat.lhs
b/compiler/typecheck/TcPat.lhs
index
f64dcb2
..
6a30754
100644
(file)
--- a/
compiler/typecheck/TcPat.lhs
+++ b/
compiler/typecheck/TcPat.lhs
@@
-6,13
+6,6
@@
TcPat: Typechecking patterns
\begin{code}
TcPat: Typechecking patterns
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcProcPat, tcOverloadedLit,
addDataConStupidTheta, badFieldCon, polyPatSig ) where
module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcProcPat, tcOverloadedLit,
addDataConStupidTheta, badFieldCon, polyPatSig ) where
@@
-32,6
+25,7
@@
import TcSimplify
import TcEnv
import TcMType
import TcType
import TcEnv
import TcMType
import TcType
+import VarEnv
import VarSet
import TcUnify
import TcHsType
import VarSet
import TcUnify
import TcHsType
@@
-41,7
+35,6
@@
import Coercion
import StaticFlags
import TyCon
import DataCon
import StaticFlags
import TyCon
import DataCon
-import DynFlags
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import SrcLoc
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import SrcLoc
@@
-98,14
+91,16
@@
tcLamPats pats tys res_ty thing_inside
= tc_lam_pats LamPat (zipEqual "tcLamPats" pats tys)
res_ty thing_inside
= tc_lam_pats LamPat (zipEqual "tcLamPats" pats tys)
res_ty thing_inside
-tcLamPat :: LPat Name -> BoxySigmaType
- -> BoxyRhoType -- Result type
- -> (BoxyRhoType -> TcM a) -- Checker for body, given its result type
- -> TcM (LPat TcId, a)
-
-tcProcPat = tc_lam_pat ProcPat
+tcLamPat, tcProcPat :: LPat Name -> BoxySigmaType
+ -> BoxyRhoType -- Result type
+ -> (BoxyRhoType -> TcM a) -- Checker for body, given
+ -- its result type
+ -> TcM (LPat TcId, a)
tcLamPat = tc_lam_pat LamPat
tcLamPat = tc_lam_pat LamPat
+tcProcPat = tc_lam_pat ProcPat
+tc_lam_pat :: PatCtxt -> LPat Name -> BoxySigmaType -> BoxyRhoType
+ -> (BoxyRhoType -> TcM a) -> TcM (LPat TcId, a)
tc_lam_pat ctxt pat pat_ty res_ty thing_inside
= do { ([pat'],thing) <- tc_lam_pats ctxt [(pat, pat_ty)] res_ty thing_inside
; return (pat', thing) }
tc_lam_pat ctxt pat pat_ty res_ty thing_inside
= do { ([pat'],thing) <- tc_lam_pats ctxt [(pat, pat_ty)] res_ty thing_inside
; return (pat', thing) }
@@
-144,7
+139,7
@@
tcCheckExistentialPat :: [LPat TcId] -- Patterns (just for error message)
-- f (C g) x = g x
-- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
-- f (C g) x = g x
-- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
-tcCheckExistentialPat pats [] pat_tys body_ty
+tcCheckExistentialPat _ [] _ _
= return () -- Short cut for case when there are no existentials
tcCheckExistentialPat pats ex_tvs pat_tys body_ty
= return () -- Short cut for case when there are no existentials
tcCheckExistentialPat pats ex_tvs pat_tys body_ty
@@
-166,7
+161,7
@@
data PatCtxt
patSigCtxt :: PatState -> UserTypeCtxt
patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
patSigCtxt :: PatState -> UserTypeCtxt
patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
-patSigCtxt other = LamPatSigCtxt
+patSigCtxt _ = LamPatSigCtxt
\end{code}
\end{code}
@@
-214,8
+209,13
@@
bindInstsOfPatId id thing_inside
; return (res, binds) }
-------------------
; return (res, binds) }
-------------------
+unBoxPatBndrType :: BoxyType -> Name -> TcM TcType
unBoxPatBndrType ty name = unBoxArgType ty (ptext (sLit "The variable") <+> quotes (ppr name))
unBoxPatBndrType ty name = unBoxArgType ty (ptext (sLit "The variable") <+> quotes (ppr name))
+
+unBoxWildCardType :: BoxyType -> TcM TcType
unBoxWildCardType ty = unBoxArgType ty (ptext (sLit "A wild-card pattern"))
unBoxWildCardType ty = unBoxArgType ty (ptext (sLit "A wild-card pattern"))
+
+unBoxViewPatType :: BoxyType -> Pat Name -> TcM TcType
unBoxViewPatType ty pat = unBoxArgType ty (ptext (sLit "The view pattern") <+> ppr pat)
unBoxArgType :: BoxyType -> SDoc -> TcM TcType
unBoxViewPatType ty pat = unBoxArgType ty (ptext (sLit "The view pattern") <+> ppr pat)
unBoxArgType :: BoxyType -> SDoc -> TcM TcType
@@
-427,7
+427,7
@@
tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
tc_lpat pat inner_ty pstate thing_inside
; return (SigPatOut pat' inner_ty, tvs, res) }
tc_lpat pat inner_ty pstate thing_inside
; return (SigPatOut pat' inner_ty, tvs, res) }
-tc_pat pstate pat@(TypePat ty) pat_ty thing_inside
+tc_pat _ pat@(TypePat _) _ _
= failWithTc (badTypePat pat)
------------------------
= failWithTc (badTypePat pat)
------------------------
@@
-474,7
+474,7
@@
tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
------------------------
-- Data constructors
------------------------
-- Data constructors
-tc_pat pstate pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
+tc_pat pstate (ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
= do { data_con <- tcLookupDataCon con_name
; let tycon = dataConTyCon data_con
; tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside }
= do { data_con <- tcLookupDataCon con_name
; let tycon = dataConTyCon data_con
; tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside }
@@
-486,7
+486,6
@@
tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
; coi <- boxyUnify lit_ty pat_ty
-- coi is of kind: lit_ty ~ pat_ty
; res <- thing_inside pstate
; coi <- boxyUnify lit_ty pat_ty
-- coi is of kind: lit_ty ~ pat_ty
; res <- thing_inside pstate
- ; span <- getSrcSpanM
-- pattern coercions have to
-- be of kind: pat_ty ~ lit_ty
-- hence, sym coi
-- pattern coercions have to
-- be of kind: pat_ty ~ lit_ty
-- hence, sym coi
@@
-495,7
+494,7
@@
tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
------------------------
-- Overloaded patterns: n, and n+k
------------------------
-- Overloaded patterns: n, and n+k
-tc_pat pstate pat@(NPat over_lit mb_neg eq) pat_ty thing_inside
+tc_pat pstate (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 { let orig = LiteralOrigin over_lit
; lit' <- tcOverloadedLit orig over_lit pat_ty
; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
@@
-508,7
+507,7
@@
tc_pat pstate pat@(NPat over_lit mb_neg eq) pat_ty thing_inside
; res <- thing_inside pstate
; return (NPat lit' mb_neg' eq', [], res) }
; res <- thing_inside pstate
; return (NPat lit' mb_neg' eq', [], res) }
-tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
+tc_pat pstate (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
= do { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
; let pat_ty' = idType bndr_id
orig = LiteralOrigin lit
= do { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
; let pat_ty' = idType bndr_id
orig = LiteralOrigin lit
@@
-647,7
+646,7
@@
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
else do -- The general case, with existential, and local equality
-- constraints
else do -- The general case, with existential, and local equality
-- constraints
- { checkTc (case pat_ctxt pstate of { ProcPat -> False; other -> True })
+ { checkTc (case pat_ctxt pstate of { ProcPat -> False; _ -> True })
(existentialProcPat data_con)
-- Need to test for rigidity if *any* constraints in theta as class
(existentialProcPat data_con)
-- Need to test for rigidity if *any* constraints in theta as class
@@
-745,9
+744,6
@@
tcConArgs data_con arg_tys (InfixCon p1 p2) pstate thing_inside
where
con_arity = dataConSourceArity data_con
where
con_arity = dataConSourceArity data_con
-tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside
- = pprPanic "tcConArgs" (ppr data_con) -- InfixCon always has two arguments
-
tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
= do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
; return (RecCon (HsRecFields rpats' dd), tvs, res) }
tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
= do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
; return (RecCon (HsRecFields rpats' dd), tvs, res) }
@@
-959,6
+955,7
@@
patCtxt pat = Just (hang (ptext (sLit "In the pattern:"))
-----------------------------------------------
-----------------------------------------------
+existentialExplode :: LPat Name -> SDoc
existentialExplode pat
= hang (vcat [text "My brain just exploded.",
text "I can't handle pattern bindings for existentially-quantified constructors.",
existentialExplode pat
= hang (vcat [text "My brain just exploded.",
text "I can't handle pattern bindings for existentially-quantified constructors.",
@@
-966,6
+963,8
@@
existentialExplode pat
text "In the binding group for"])
4 (ppr pat)
text "In the binding group for"])
4 (ppr pat)
+sigPatCtxt :: [LPat Var] -> [Var] -> [TcType] -> TcType -> TidyEnv
+ -> TcM (TidyEnv, SDoc)
sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
= do { pat_tys' <- mapM zonkTcType pat_tys
; body_ty' <- zonkTcType body_ty
sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
= do { pat_tys' <- mapM zonkTcType pat_tys
; body_ty' <- zonkTcType body_ty
@@
-996,6
+995,7
@@
polyPatSig sig_ty
= hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
2 (ppr sig_ty)
= hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
2 (ppr sig_ty)
+badTypePat :: Pat Name -> SDoc
badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
existentialProcPat :: DataCon -> SDoc
badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
existentialProcPat :: DataCon -> SDoc
@@
-1003,15
+1003,18
@@
existentialProcPat con
= hang (ptext (sLit "Illegal constructor") <+> quotes (ppr con) <+> ptext (sLit "in a 'proc' pattern"))
2 (ptext (sLit "Proc patterns cannot use existentials or GADTs"))
= hang (ptext (sLit "Illegal constructor") <+> quotes (ppr con) <+> ptext (sLit "in a 'proc' pattern"))
2 (ptext (sLit "Proc patterns cannot use existentials or GADTs"))
-lazyPatErr pat tvs
+lazyPatErr :: Pat name -> [TcTyVar] -> TcM ()
+lazyPatErr _ tvs
= failWithTc $
hang (ptext (sLit "A lazy (~) pattern cannot bind existential type variables"))
2 (vcat (map pprSkolTvBinding tvs))
= failWithTc $
hang (ptext (sLit "A lazy (~) pattern cannot bind existential type variables"))
2 (vcat (map pprSkolTvBinding tvs))
+nonRigidMatch :: DataCon -> SDoc
nonRigidMatch con
= hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))
2 (ptext (sLit "Solution: add a type signature"))
nonRigidMatch con
= hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))
2 (ptext (sLit "Solution: add a type signature"))
+nonRigidResult :: Type -> TcM a
nonRigidResult res_ty
= do { env0 <- tcInitTidyEnv
; let (env1, res_ty') = tidyOpenType env0 res_ty
nonRigidResult res_ty
= do { env0 <- tcInitTidyEnv
; let (env1, res_ty') = tidyOpenType env0 res_ty
@@
-1019,7
+1022,4
@@
nonRigidResult res_ty
<+> quotes (ppr res_ty'))
2 (ptext (sLit "Solution: add a type signature"))
; failWithTcM (env1, msg) }
<+> quotes (ppr res_ty'))
2 (ptext (sLit "Solution: add a type signature"))
; failWithTcM (env1, msg) }
-
-inaccessibleAlt msg
- = hang (ptext (sLit "Inaccessible case alternative:")) 2 msg
\end{code}
\end{code}