TcPat: Typechecking patterns
\begin{code}
-module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..)
- , tcPat, tcPats, newLetBndr
+module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..), TcPragFun
+ , LetBndrSpec(..), addInlinePrags, warnPrags
+ , tcPat, tcPats, newNoSigLetBndr, newSigLetBndr
, addDataConStupidTheta, badFieldCon, polyPatSig ) where
#include "HsVersions.h"
import StaticFlags
import TyCon
import DataCon
-import VarSet ( emptyVarSet )
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import DynFlags
%************************************************************************
\begin{code}
-tcLetPat :: (Name -> Maybe TcSigInfo)
- -> Bool -- True <=> monomorphic
+tcLetPat :: TcSigFun -> LetBndrSpec
-> LPat Name -> TcSigmaType
-> TcM a
-> TcM (LPat TcId, a)
-tcLetPat sig_fn is_mono pat pat_ty thing_inside
+tcLetPat sig_fn no_gen pat pat_ty thing_inside
= tc_lpat pat pat_ty penv thing_inside
where
- penv = PE { pe_res_tvs = emptyVarSet, pe_lazy = True
- , pe_ctxt = LetPat sig_fn is_mono }
+ penv = PE { pe_lazy = True
+ , pe_ctxt = LetPat sig_fn no_gen }
-----------------
tcPats :: HsMatchContext Name
-> [LPat Name] -- Patterns,
-> [TcSigmaType] -- and their types
- -> TcRhoType -- Result type,
-> TcM a -- and the checker for the body
-> TcM ([LPat TcId], a)
-- 3. Check the body
-- 4. Check that no existentials escape
-tcPats ctxt pats pat_tys res_ty thing_inside
+tcPats ctxt pats pat_tys thing_inside
= tc_lpats penv pats pat_tys thing_inside
where
- penv = PE { pe_res_tvs = tyVarsOfTypes (res_ty : pat_tys)
- , pe_lazy = False
- , pe_ctxt = LamPat ctxt }
+ penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt }
tcPat :: HsMatchContext Name
-> LPat Name -> TcSigmaType
- -> TcRhoType -- Result type
-> TcM a -- Checker for body, given
-- its result type
-> TcM (LPat TcId, a)
-tcPat ctxt pat pat_ty res_ty thing_inside
+tcPat ctxt pat pat_ty thing_inside
= tc_lpat pat pat_ty penv thing_inside
where
- penv = PE { pe_res_tvs = tyVarsOfTypes [res_ty, pat_ty]
- , pe_lazy = False
- , pe_ctxt = LamPat ctxt }
+ penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt }
-----------------
data PatEnv
- = PE { pe_res_tvs :: TcTyVarSet
- -- For existential escape check; see Note [Existential check]
- -- Nothing <=> inside a "~"
- -- Just tvs <=> unification tvs free in the result
- -- (which should be made untouchable in
- -- any existentials we encounter in the pattern)
-
- , pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed
+ = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed
, pe_ctxt :: PatCtxt -- Context in which the whole pattern appears
- }
+ }
data PatCtxt
= LamPat -- Used for lambdas, case etc
| LetPat -- Used only for let(rec) bindings
-- See Note [Let binders]
- TcSigFun -- Tells type sig if any
- Bool -- True <=> no generalisation of this let
-
+ TcSigFun -- Tells type sig if any
+ LetBndrSpec -- True <=> no generalisation of this let
+
+data LetBndrSpec
+ = LetLclBndr -- The binder is just a local one;
+ -- an AbsBinds will provide the global version
+
+ | LetGblBndr TcPragFun -- There isn't going to be an AbsBinds;
+ -- here is the inline-pragma information
+
makeLazy :: PatEnv -> PatEnv
makeLazy penv = penv { pe_lazy = True }
patSigCtxt (PE { pe_ctxt = LamPat {} }) = LamPatSigCtxt
---------------
-type TcSigFun = Name -> Maybe TcSigInfo
+type TcPragFun = Name -> [LSig Name]
+type TcSigFun = Name -> Maybe TcSigInfo
data TcSigInfo
= TcSigInfo {
Lazy patterns can't bind existentials. They arise in two ways:
* Let bindings let { C a b = e } in b
* Twiddle patterns f ~(C a b) = e
-The pe_res_tvs field of PatEnv says whether we are inside a lazy
+The pe_lazy field of PatEnv says whether we are inside a lazy
pattern (perhaps deeply)
If we aren't inside a lazy pattern then we can bind existentials,
--
tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
| Just sig <- lookup_sig bndr_name
- = do { bndr_id <- if no_gen then return (sig_id sig)
- else do { mono_name <- newLocalName bndr_name
- ; return (Id.mkLocalId mono_name (sig_tau sig)) }
+ = do { bndr_id <- newSigLetBndr no_gen bndr_name sig
; coi <- unifyPatType (idType bndr_id) pat_ty
; return (coi, bndr_id) }
| otherwise
- = do { bndr_id <- newLetBndr no_gen bndr_name pat_ty
+ = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty
; return (IdCo pat_ty, bndr_id) }
tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty
= do { bndr <- mkLocalBinder bndr_name pat_ty
; return (IdCo pat_ty, bndr) }
-newLetBndr :: Bool -> Name -> TcType -> TcM TcId
+------------
+newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId
+newSigLetBndr LetLclBndr name sig
+ = do { mono_name <- newLocalName name
+ ; mkLocalBinder mono_name (sig_tau sig) }
+newSigLetBndr (LetGblBndr prags) name sig
+ = addInlinePrags (sig_id sig) (prags name)
+
+------------
+newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId
-- In the polymorphic case (no_gen = False), generate a "monomorphic version"
-- of the Id; the original name will be bound to the polymorphic version
-- by the AbsBinds
-- In the monomorphic case there is no AbsBinds, and we use the original
-- name directly
-newLetBndr no_gen name ty
- | no_gen = mkLocalBinder name ty
- | otherwise = do { mono_name <- newLocalName name
- ; mkLocalBinder mono_name ty }
+newNoSigLetBndr LetLclBndr name ty
+ =do { mono_name <- newLocalName name
+ ; mkLocalBinder mono_name ty }
+newNoSigLetBndr (LetGblBndr prags) name ty
+ = do { id <- mkLocalBinder name ty
+ ; addInlinePrags id (prags name) }
+
+----------
+addInlinePrags :: TcId -> [LSig Name] -> TcM TcId
+addInlinePrags poly_id prags
+ = tc_inl inl_sigs
+ where
+ inl_sigs = filter isInlineLSig prags
+ tc_inl [] = return poly_id
+ tc_inl (L loc (InlineSig _ prag) : other_inls)
+ = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline)
+ ; return (poly_id `setInlinePragma` prag) }
+ tc_inl _ = panic "tc_inl"
+
+ warn_dup_inline = warnPrags poly_id inl_sigs $
+ ptext (sLit "Duplicate INLINE pragmas for")
+
+warnPrags :: Id -> [LSig Name] -> SDoc -> TcM ()
+warnPrags id bad_sigs herald
+ = addWarnTc (hang (herald <+> quotes (ppr id))
+ 2 (ppr_sigs bad_sigs))
+ where
+ ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
-----------------
mkLocalBinder :: Name -> TcType -> TcM TcId
| not (isOverloadedTy (idType id))
= do { res <- thing_inside; return (res, emptyTcEvBinds) }
| otherwise
- = do { (res, lie) <- getConstraints thing_inside
+ = do { (res, lie) <- captureConstraints thing_inside
; binds <- bindLocalMethods lie [id]
; return (res, binds) }
-}
tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside
= do { (pat', (res, pat_ct))
<- tc_lpat pat pat_ty (makeLazy penv) $
- getConstraints thing_inside
+ captureConstraints thing_inside
-- Ignore refined penv', revert to penv
; emitConstraints pat_ct
- -- getConstraints/extendConstraintss: see Note [Hopping the LIE in lazy patterns]
+ -- captureConstraints/extendConstraints:
+ -- see Note [Hopping the LIE in lazy patterns]
-- Check there are no unlifted types under the lazy pattern
; when (any (isUnLiftedType . idType) $ collectPatBinders pat') $
the pattern C!
So we have to make the constraints from thing_inside "hop around"
-the pattern. Hence the getConstraints and emitConstraints.
+the pattern. Hence the captureConstraints and emitConstraints.
The same thing ensures that equality constraints in a lazy match
are not made available in the RHS of the match. For example
-- dictionary binders from theta'
no_equalities = not (any isEqPred theta')
- ; gadts_on <- doptM Opt_GADTs
+ ; gadts_on <- xoptM Opt_GADTs
; checkTc (no_equalities || gadts_on)
(ptext (sLit "A pattern match on a GADT requires -XGADTs"))
-- Trac #2905 decided that a *pattern-match* of a GADT
-- should require the GADT language flag
; given <- newEvVars theta'
- ; let free_tvs = pe_res_tvs penv
- -- Since we have done checkExistentials,
- -- pe_res_tvs can only be Just at this point
- --
- -- Nor do we need pat_ty, because we've put all the
- -- unification variables in right at the start when
- -- initialising the PatEnv; and the pattern itself
- -- only adds skolems.
-
; (ev_binds, (arg_pats', res))
- <- checkConstraints skol_info free_tvs ex_tvs' given $
+ <- checkConstraints skol_info ex_tvs' given $
tcConArgs data_con arg_tys' arg_pats penv thing_inside
; let res_pat = ConPatOut { pat_con = L con_span data_con,
projects / ghc-hetmet.git / blobdiff