summaryrefslogtreecommitdiff
path: root/compiler/typecheck
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/typecheck')
-rw-r--r--compiler/typecheck/TcBinds.lhs25
-rw-r--r--compiler/typecheck/TcDeriv.lhs13
-rw-r--r--compiler/typecheck/TcExpr.lhs20
-rw-r--r--compiler/typecheck/TcForeign.lhs19
-rw-r--r--compiler/typecheck/TcHsSyn.lhs26
-rw-r--r--compiler/typecheck/TcInstDcls.lhs9
-rw-r--r--compiler/typecheck/TcPat.lhs7
-rw-r--r--compiler/typecheck/TcPatSyn.lhs6
-rw-r--r--compiler/typecheck/TcRnDriver.lhs10
-rw-r--r--compiler/typecheck/TcRules.lhs19
-rw-r--r--compiler/typecheck/TcTyClsDecls.lhs129
11 files changed, 179 insertions, 104 deletions
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 00f9f628f9..acd469ed15 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -822,7 +822,8 @@ tcSpecPrags :: Id -> [LSig Name]
tcSpecPrags poly_id prag_sigs
= do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
; unless (null bad_sigs) warn_discarded_sigs
- ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
+ ; pss <- mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs
+ ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
where
spec_sigs = filter isSpecLSig prag_sigs
bad_sigs = filter is_bad_sig prag_sigs
@@ -833,21 +834,21 @@ tcSpecPrags poly_id prag_sigs
--------------
-tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag
-tcSpec poly_id prag@(SpecSig fun_name hs_ty inl)
+tcSpec :: TcId -> Sig Name -> TcM [TcSpecPrag]
+tcSpec poly_id prag@(SpecSig fun_name hs_tys inl)
-- The Name fun_name in the SpecSig may not be the same as that of the poly_id
-- Example: SPECIALISE for a class method: the Name in the SpecSig is
-- for the selector Id, but the poly_id is something like $cop
-- However we want to use fun_name in the error message, since that is
-- what the user wrote (Trac #8537)
= addErrCtxt (spec_ctxt prag) $
- do { spec_ty <- tcHsSigType sig_ctxt hs_ty
+ do { spec_tys <- mapM (tcHsSigType sig_ctxt) hs_tys
; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
(ptext (sLit "SPECIALISE pragma for non-overloaded function")
<+> quotes (ppr fun_name))
-- Note [SPECIALISE pragmas]
- ; wrap <- tcSubType sig_ctxt (idType poly_id) spec_ty
- ; return (SpecPrag poly_id wrap inl) }
+ ; wraps <- mapM (tcSubType origin sig_ctxt (idType poly_id)) spec_tys
+ ; return [ (SpecPrag poly_id wrap inl) | wrap <- wraps ] }
where
name = idName poly_id
poly_ty = idType poly_id
@@ -864,10 +865,12 @@ tcImpPrags prags
; dflags <- getDynFlags
; if (not_specialising dflags) then
return []
- else
- mapAndRecoverM (wrapLocM tcImpSpec)
- [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
- , not (nameIsLocalOrFrom this_mod name) ] }
+ else do
+ { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
+ [L loc (name,prag)
+ | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
+ , not (nameIsLocalOrFrom this_mod name) ]
+ ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
where
-- Ignore SPECIALISE pragmas for imported things
-- when we aren't specialising, or when we aren't generating
@@ -880,7 +883,7 @@ tcImpPrags prags
HscInterpreted -> True
_other -> False
-tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
+tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
tcImpSpec (name, prag)
= do { id <- tcLookupId name
; unless (isAnyInlinePragma (idInlinePragma id))
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index b5616538eb..dd746a5a99 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -577,8 +577,8 @@ deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name
tys = mkTyVarTys tvs
; case preds of
- Just preds' -> concatMapM (deriveTyData False tvs tc tys) preds'
- Nothing -> return [] }
+ Just (L _ preds') -> concatMapM (deriveTyData False tvs tc tys) preds'
+ Nothing -> return [] }
deriveTyDecl _ = return []
@@ -592,8 +592,10 @@ deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam
------------------------------------------------------------------
deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
-deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats
- , dfid_defn = defn@(HsDataDefn { dd_derivs = Just preds }) })
+deriveFamInst decl@(DataFamInstDecl
+ { dfid_tycon = L _ tc_name, dfid_pats = pats
+ , dfid_defn
+ = defn@(HsDataDefn { dd_derivs = Just (L _ preds) }) })
= tcAddDataFamInstCtxt decl $
do { fam_tc <- tcLookupTyCon tc_name
; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $
@@ -659,7 +661,8 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
; mkPolyKindedTypeableEqn cls tc }
| isAlgTyCon tc -- All other classes
- -> do { spec <- mkEqnHelp overlap_mode tvs cls cls_tys tc tc_args (Just theta)
+ -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
+ tvs cls cls_tys tc tc_args (Just theta)
; return [spec] }
_ -> -- Complain about functions, primitive types, etc,
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 1a2deba879..d8db986c8b 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -389,8 +389,8 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty
; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
; let actual_res_ty
- = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
- (mkTyConApp tup_tc arg_tys)
+ = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args]
+ (mkTyConApp tup_tc arg_tys)
; coi <- unifyType actual_res_ty res_ty
@@ -640,7 +640,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
| (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
not (isRecordSelector sel_id), -- Excludes class ops
- let L loc fld_name = hsRecFieldId fld ]
+ let L loc fld_name = hsRecFieldId (unLoc fld) ]
; unless (null bad_guys) (sequence bad_guys >> failM)
-- STEP 1
@@ -968,13 +968,13 @@ tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
(tcPolyExprNC arg ty)
----------------
-tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId]
+tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
tcTupArgs args tys
= ASSERT( equalLength args tys ) mapM go (args `zip` tys)
where
- go (Missing {}, arg_ty) = return (Missing arg_ty)
- go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
- ; return (Present expr') }
+ go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
+ go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+ ; return (L l (Present expr')) }
----------------
unifyOpFunTysWrap :: LHsExpr Name -> Arity -> TcRhoType
@@ -1342,7 +1342,8 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
; return (HsRecFields (catMaybes mb_binds) dd) }
where
flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
- do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
+ do_bind (L l fld@(HsRecField { hsRecFieldId = L loc field_lbl
+ , hsRecFieldArg = rhs }))
| Just field_ty <- assocMaybe flds_w_tys field_lbl
= addErrCtxt (fieldCtxt field_lbl) $
do { rhs' <- tcPolyExprNC rhs field_ty
@@ -1353,7 +1354,8 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
-- (so we can find it easily)
-- but is a LocalId with the appropriate type of the RHS
-- (so the desugarer knows the type of local binder to make)
- ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
+ ; return (Just (L l (fld { hsRecFieldId = L loc field_id
+ , hsRecFieldArg = rhs' }))) }
| otherwise
= do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl)
; return Nothing }
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 9d1da3fc48..73b3b1cf65 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -263,16 +263,16 @@ tcFImport d = pprPanic "tcFImport" (ppr d)
\begin{code}
tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
-tcCheckFIType arg_tys res_ty (CImport cconv safety mh l@(CLabel _))
+tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
-- Foreign import label
= do checkCg checkCOrAsmOrLlvmOrInterp
-- NB check res_ty not sig_ty!
-- In case sig_ty is (forall a. ForeignPtr a)
check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
cconv' <- checkCConv cconv
- return (CImport cconv' safety mh l)
+ return (CImport (L lc cconv') safety mh l src)
-tcCheckFIType arg_tys res_ty (CImport cconv safety mh CWrapper) = do
+tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
-- Foreign wrapper (former f.e.d.)
-- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
-- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too.
@@ -286,9 +286,10 @@ tcCheckFIType arg_tys res_ty (CImport cconv safety mh CWrapper) = do
where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
_ -> addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "One argument expected")))
- return (CImport cconv' safety mh CWrapper)
+ return (CImport (L lc cconv') safety mh CWrapper src)
-tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target))
+tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
+ (CFunction target) src)
| isDynamicTarget target = do -- Foreign import dynamic
checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
@@ -302,7 +303,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target))
(illegalForeignTyErr argument)
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
- return $ CImport cconv' safety mh (CFunction target)
+ return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
| cconv == PrimCallConv = do
dflags <- getDynFlags
checkTc (xopt Opt_GHCForeignImportPrim dflags)
@@ -328,7 +329,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target))
| not (null arg_tys) ->
addErrTc (text "`value' imports cannot have function types")
_ -> return ()
- return $ CImport cconv' safety mh (CFunction target)
+ return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
-- This makes a convenient place to check
@@ -402,13 +403,13 @@ tcFExport d = pprPanic "tcFExport" (ppr d)
\begin{code}
tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
-tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
+tcCheckFEType sig_ty (CExport (L l (CExportStatic str cconv)) src) = do
checkCg checkCOrAsmOrLlvm
checkTc (isCLabelString str) (badCName str)
cconv' <- checkCConv cconv
checkForeignArgs isFFIExternalTy arg_tys
checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
- return (CExport (CExportStatic str cconv'))
+ return (CExport (L l (CExportStatic str cconv')) src)
where
-- Drop the foralls before inspecting n
-- the structure of the foreign type.
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index d5dfd8e07c..0265dec38d 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -651,8 +651,10 @@ zonkExpr env (ExplicitTuple tup_args boxed)
= do { new_tup_args <- mapM zonk_tup_arg tup_args
; return (ExplicitTuple new_tup_args boxed) }
where
- zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
- zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
+ zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e
+ ; return (L l (Present e')) }
+ zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
+ ; return (L l (Missing t')) }
zonkExpr env (HsCase expr ms)
= do new_expr <- zonkLExpr env expr
@@ -985,10 +987,11 @@ zonkRecFields env (HsRecFields flds dd)
= do { flds' <- mapM zonk_rbind flds
; return (HsRecFields flds' dd) }
where
- zonk_rbind fld
+ zonk_rbind (L l fld)
= do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
; new_expr <- zonkLExpr env (hsRecFieldArg fld)
- ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
+ ; return (L l (fld { hsRecFieldId = new_id
+ , hsRecFieldArg = new_expr })) }
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b)
@@ -1128,8 +1131,9 @@ zonkConStuff env (InfixCon p1 p2)
; return (env', InfixCon p1' p2') }
zonkConStuff env (RecCon (HsRecFields rpats dd))
- = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
- ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
+ = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
+ ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' }))
+ rpats pats'
; return (env', RecCon (HsRecFields rpats' dd)) }
-- Field selectors have declared types; hence no zonking
@@ -1176,18 +1180,18 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
; unbound_tkvs <- readMutVar unbound_tkv_set
- ; let final_bndrs :: [RuleBndr Var]
- final_bndrs = map (RuleBndr . noLoc)
+ ; let final_bndrs :: [LRuleBndr Var]
+ final_bndrs = map (noLoc . RuleBndr . noLoc)
(varSetElemsKvsFirst unbound_tkvs)
++ new_bndrs
; return $
HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs }
where
- zonk_bndr env (RuleBndr (L loc v))
+ zonk_bndr env (L l (RuleBndr (L loc v)))
= do { (env', v') <- zonk_it env v
- ; return (env', RuleBndr (L loc v')) }
- zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
+ ; return (env', L l (RuleBndr (L loc v'))) }
+ zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"
zonk_it env v
| isId v = do { v' <- zonkIdBndr env v
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 215aa2d175..033ee0ef6c 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -543,7 +543,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
-- Dfun location is that of instance *header*
- ; ispec <- newClsInst overlap_mode dfun_name tyvars theta clas inst_tys
+ ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta
+ clas inst_tys
; let inst_info = InstInfo { iSpec = ispec
, iBinds = InstBindings
{ ib_binds = binds
@@ -706,7 +707,7 @@ tcDataFamInstDecl mb_clsinfo
; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
do { data_cons <- tcConDecls new_or_data rec_rep_tc
- (tvs', orig_res_ty) cons
+ (tvs', orig_res_ty) cons
; tc_rhs <- case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
@@ -717,7 +718,9 @@ tcDataFamInstDecl mb_clsinfo
(mkTyConApp rep_tc (mkTyVarTys eta_tvs))
parent = FamInstTyCon axiom fam_tc pats'
roles = map (const Nominal) tvs'
- rep_tc = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs
+ rep_tc = buildAlgTyCon rep_tc_name tvs' roles
+ (fmap unLoc cType) stupid_theta
+ tc_rhs
Recursive
False -- No promotable to the kind level
gadt_syntax parent
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index cfa995d9d0..b7f8d2e9db 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -965,11 +965,12 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
= do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside
; return (RecCon (HsRecFields rpats' dd), res) }
where
- tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
- tc_field (HsRecField field_lbl pat pun) penv thing_inside
+ tc_field :: Checker (LHsRecField FieldLabel (LPat Name))
+ (LHsRecField TcId (LPat TcId))
+ tc_field (L l (HsRecField field_lbl pat pun)) penv thing_inside
= do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
- ; return (HsRecField sel_id pat' pun, res) }
+ ; return (L l (HsRecField sel_id pat' pun), res) }
find_field_ty :: FieldLabel -> TcM (Id, TcType)
find_field_ty field_lbl
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index 0796472202..23262f3db8 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -509,7 +509,7 @@ tcPatToExpr args = go
; return $ ExplicitList ptt (fmap snd reb) exprs }
go1 (TuplePat pats box _)
= do { exprs <- mapM go pats
- ; return (ExplicitTuple (map Present exprs) box)
+ ; return (ExplicitTuple (map (noLoc . Present) exprs) box)
}
go1 (LitPat lit) = return $ HsLit lit
go1 (NPat n Nothing _) = return $ HsOverLit n
@@ -558,7 +558,7 @@ tcCollectEx = return . go
goConDetails (RecCon HsRecFields{ rec_flds = flds })
= mconcat . map goRecFd $ flds
- goRecFd :: HsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
- goRecFd HsRecField{ hsRecFieldArg = p } = go p
+ goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
+ goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p
\end{code}
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index d2bfd25898..c2eabbf67d 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -293,9 +293,9 @@ tcRnModuleTcRnM hsc_env hsc_src
-- If the whole module is warned about or deprecated
-- (via mod_deprec) record that in tcg_warns. If we do thereby add
-- a WarnAll, it will override any subseqent depracations added to tcg_warns
- let { tcg_env1 = case mod_deprec of
- Just txt -> tcg_env { tcg_warns = WarnAll txt }
- Nothing -> tcg_env
+ let { tcg_env1 = case mod_deprec of
+ Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }
+ Nothing -> tcg_env
} ;
setGblEnv tcg_env1 $ do {
@@ -1241,8 +1241,8 @@ tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
= concatMap (get_fi_cons . unLoc) fids
get_fi_cons :: DataFamInstDecl Name -> [Name]
- get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
- = map (unLoc . con_name . unLoc) cons
+ get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
+ = map unLoc $ concatMap (con_names . unLoc) cons
\end{code}
Note [AFamDataCon: not promoting data family constructors]
diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs
index f1d528f098..cd4776f69a 100644
--- a/compiler/typecheck/TcRules.lhs
+++ b/compiler/typecheck/TcRules.lhs
@@ -124,7 +124,7 @@ tcRules decls = mapM (wrapLocM tcRule) decls
tcRule :: RuleDecl Name -> TcM (RuleDecl TcId)
tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
- = addErrCtxt (ruleCtxt name) $
+ = addErrCtxt (ruleCtxt $ unLoc name) $
do { traceTc "---- Rule ------" (ppr name)
-- Note [Typechecking rules]
@@ -137,7 +137,8 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty)
; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) }
- ; (lhs_evs, other_lhs_wanted) <- simplifyRule name lhs_wanted rhs_wanted
+ ; (lhs_evs, other_lhs_wanted) <- simplifyRule (unLoc name) lhs_wanted
+ rhs_wanted
-- Now figure out what to quantify over
-- c.f. TcSimplify.simplifyInfer
@@ -156,7 +157,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
; gbls <- tcGetGlobalTyVars -- Even though top level, there might be top-level
-- monomorphic bindings from the MR; test tc111
; qtkvs <- quantifyTyVars gbls forall_tvs
- ; traceTc "tcRule" (vcat [ doubleQuotes (ftext name)
+ ; traceTc "tcRule" (vcat [ doubleQuotes (ftext $ unLoc name)
, ppr forall_tvs
, ppr qtkvs
, ppr rule_ty
@@ -173,7 +174,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
, ic_wanted = rhs_wanted
, ic_insol = insolubleWC rhs_wanted
, ic_binds = rhs_binds_var
- , ic_info = RuleSkol name
+ , ic_info = RuleSkol (unLoc name)
, ic_env = lcl_env }
-- For the LHS constraints we must solve the remaining constraints
@@ -187,22 +188,22 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
, ic_wanted = other_lhs_wanted
, ic_insol = insolubleWC other_lhs_wanted
, ic_binds = lhs_binds_var
- , ic_info = RuleSkol name
+ , ic_info = RuleSkol (unLoc name)
, ic_env = lcl_env }
; return (HsRule name act
- (map (RuleBndr . noLoc) (qtkvs ++ tpl_ids))
+ (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids))
(mkHsDictLet (TcEvBinds lhs_binds_var) lhs') fv_lhs
(mkHsDictLet (TcEvBinds rhs_binds_var) rhs') fv_rhs) }
-tcRuleBndrs :: [RuleBndr Name] -> TcM [Var]
+tcRuleBndrs :: [LRuleBndr Name] -> TcM [Var]
tcRuleBndrs []
= return []
-tcRuleBndrs (RuleBndr (L _ name) : rule_bndrs)
+tcRuleBndrs (L _ (RuleBndr (L _ name)) : rule_bndrs)
= do { ty <- newFlexiTyVarTy openTypeKind
; vars <- tcRuleBndrs rule_bndrs
; return (mkLocalId name ty : vars) }
-tcRuleBndrs (RuleBndrSig (L _ name) rn_ty : rule_bndrs)
+tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs)
-- e.g x :: a->a
-- The tyvar 'a' is brought into scope first, just as if you'd written
-- a::*, x :: a->a
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index f5f19bd86d..1cffcf04a1 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -378,18 +378,20 @@ getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs =
; return (main_pr : inner_prs) }
getInitialKind decl@(DataDecl { tcdLName = L _ name
- , tcdTyVars = ktvs
- , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
- , dd_cons = cons } })
- = do { (decl_kind, _) <-
+ , tcdTyVars = ktvs
+ , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
+ , dd_cons = cons' } })
+ = let cons = cons' -- AZ list monad coming
+ in
+ do { (decl_kind, _) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $
do { res_k <- case m_sig of
Just ksig -> tcLHsKind ksig
Nothing -> return liftedTypeKind
; return (res_k, ()) }
; let main_pr = (name, AThing decl_kind)
- inner_prs = [ (unLoc (con_name con), APromotionErr RecDataConPE)
- | L _ con <- cons ]
+ inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
+ | L _ con' <- cons, con <- con_names con' ]
; return (main_pr : inner_prs) }
getInitialKind (FamDecl { tcdFam = decl })
@@ -501,10 +503,10 @@ kcTyClDecl (FamDecl {}) = return ()
-------------------
kcConDecl :: ConDecl Name -> TcM ()
-kcConDecl (ConDecl { con_name = name, con_qvars = ex_tvs
+kcConDecl (ConDecl { con_names = names, con_qvars = ex_tvs
, con_cxt = ex_ctxt, con_details = details
, con_res = res })
- = addErrCtxt (dataConCtxt name) $
+ = addErrCtxt (dataConCtxtName names) $
-- the 'False' says that the existentials don't have a CUSK, as the
-- concept doesn't really apply here. We just need to bring the variables
-- into scope!
@@ -760,8 +762,9 @@ tcDataDefn :: RecTyInfo -> Name
tcDataDefn rec_info tc_name tvs kind
(HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = ctxt, dd_kindSig = mb_ksig
- , dd_cons = cons })
- = do { extra_tvs <- tcDataKindSig kind
+ , dd_cons = cons' })
+ = let cons = cons' -- AZ List monad coming
+ in do { extra_tvs <- tcDataKindSig kind
; let final_tvs = tvs ++ extra_tvs
roles = rti_roles rec_info tc_name
; stupid_tc_theta <- tcHsContext ctxt
@@ -789,7 +792,8 @@ tcDataDefn rec_info tc_name tvs kind
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
- ; return (buildAlgTyCon tc_name final_tvs roles cType stupid_theta tc_rhs
+ ; return (buildAlgTyCon tc_name final_tvs roles (fmap unLoc cType)
+ stupid_theta tc_rhs
(rti_is_rec rec_info tc_name)
(rti_promotable rec_info)
gadt_syntax NoParentTyCon) }
@@ -1144,29 +1148,31 @@ consUseGadtSyntax _ = False
tcConDecls :: NewOrData -> TyCon -> ([TyVar], Type)
-> [LConDecl Name] -> TcM [DataCon]
tcConDecls new_or_data rep_tycon (tmpl_tvs, res_tmpl) cons
- = mapM (addLocM $ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl) cons
+ = concatMapM (addLocM $ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl)
+ cons
tcConDecl :: NewOrData
-> TyCon -- Representation tycon
-> [TyVar] -> Type -- Return type template (with its template tyvars)
-- (tvs, T tys), where T is the family TyCon
-> ConDecl Name
- -> TcM DataCon
+ -> TcM [DataCon]
tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types
- (ConDecl { con_name = name
+ (ConDecl { con_names = names
, con_qvars = hs_tvs, con_cxt = hs_ctxt
, con_details = hs_details, con_res = hs_res_ty })
- = addErrCtxt (dataConCtxt name) $
- do { traceTc "tcConDecl 1" (ppr name)
- ; (ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts)
+ = addErrCtxt (dataConCtxtName names) $
+ do { traceTc "tcConDecl 1" (ppr names)
+ ; (ctxt, arg_tys, res_ty, field_lbls, stricts)
<- tcHsTyVarBndrs hs_tvs $ \ _ ->
do { ctxt <- tcHsContext hs_ctxt
; details <- tcConArgs new_or_data hs_details
; res_ty <- tcConRes hs_res_ty
- ; let (is_infix, field_lbls, btys) = details
- (arg_tys, stricts) = unzip btys
- ; return (ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) }
+ ; let (field_lbls, btys) = details
+ (arg_tys, stricts) = unzip btys
+ ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
+ }
-- Generalise the kind variables (returning quantified TcKindVars)
-- and quantify the type variables (substituting their kinds)
@@ -1189,29 +1195,60 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types
; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty
; fam_envs <- tcGetFamInstEnvs
- ; buildDataCon fam_envs (unLoc name) is_infix
- stricts field_lbls
- univ_tvs ex_tvs eq_preds ctxt arg_tys
- res_ty' rep_tycon
- -- NB: we put data_tc, the type constructor gotten from the
- -- constructor type signature into the data constructor;
- -- that way checkValidDataCon can complain if it's wrong.
+ ; let
+ buildOneDataCon (L _ name) = do
+ { is_infix <- tcConIsInfix name hs_details res_ty
+ ; buildDataCon fam_envs name is_infix
+ stricts field_lbls
+ univ_tvs ex_tvs eq_preds ctxt arg_tys
+ res_ty' rep_tycon
+ -- NB: we put data_tc, the type constructor gotten from the
+ -- constructor type signature into the data constructor;
+ -- that way checkValidDataCon can complain if it's wrong.
+ }
+ ; mapM buildOneDataCon names
}
-tcConArgs :: NewOrData -> HsConDeclDetails Name -> TcM (Bool, [Name], [(TcType, HsBang)])
+
+tcConIsInfix :: Name
+ -> HsConDetails (LHsType Name) [LConDeclField Name]
+ -> ResType Type
+ -> TcM Bool
+tcConIsInfix _ details ResTyH98
+ = case details of
+ InfixCon {} -> return True
+ _ -> return False
+tcConIsInfix con details (ResTyGADT _)
+ = case details of
+ InfixCon {} -> return True
+ RecCon {} -> return False
+ PrefixCon arg_tys -- See Note [Infix GADT cons]
+ | isSymOcc (getOccName con)
+ , [_ty1,_ty2] <- arg_tys
+ -> do { fix_env <- getFixityEnv
+ ; return (con `elemNameEnv` fix_env) }
+ | otherwise -> return False
+
+
+
+tcConArgs :: NewOrData -> HsConDeclDetails Name
+ -> TcM ([Name], [(TcType, HsBang)])
tcConArgs new_or_data (PrefixCon btys)
= do { btys' <- mapM (tcConArg new_or_data) btys
- ; return (False, [], btys') }
+ ; return ([], btys') }
tcConArgs new_or_data (InfixCon bty1 bty2)
= do { bty1' <- tcConArg new_or_data bty1
; bty2' <- tcConArg new_or_data bty2
- ; return (True, [], [bty1', bty2']) }
+ ; return ([], [bty1', bty2']) }
tcConArgs new_or_data (RecCon fields)
= do { btys' <- mapM (tcConArg new_or_data) btys
- ; return (False, field_names, btys') }
+ ; return (field_names, btys') }
where
- field_names = map (unLoc . cd_fld_name) fields
- btys = map cd_fld_type fields
+ -- We need a one-to-one mapping from field_names to btys
+ combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) fields
+ explode (ns,ty) = zip (map unLoc ns) (repeat ty)
+ exploded = concatMap explode combined
+ (field_names,btys) = unzip exploded
tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang)
tcConArg new_or_data bty
@@ -1227,6 +1264,20 @@ tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty
\end{code}
+Note [Infix GADT constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not currently have syntax to declare an infix constructor in GADT syntax,
+but it makes a (small) difference to the Show instance. So as a slightly
+ad-hoc solution, we regard a GADT data constructor as infix if
+ a) it is an operator symbol
+ b) it has two arguments
+ c) there is a fixity declaration for it
+For example:
+ infix 6 (:--:)
+ data T a where
+ (:--:) :: t1 -> t2 -> T Int
+
+
Note [Checking GADT return types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There is a delicacy around checking the return types of a datacon. The
@@ -1905,9 +1956,9 @@ mkRecSelBind (tycon, sel_name)
(L loc (HsVar field_var))
mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
- rec_field = HsRecField { hsRecFieldId = sel_lname
- , hsRecFieldArg = L loc (VarPat field_var)
- , hsRecPun = False }
+ rec_field = noLoc (HsRecField { hsRecFieldId = sel_lname
+ , hsRecFieldArg = L loc (VarPat field_var)
+ , hsRecPun = False })
sel_lname = L loc sel_name
field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
@@ -2073,6 +2124,12 @@ fieldTypeMisMatch field_name con1 con2
= sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
ptext (sLit "give different types for field"), quotes (ppr field_name)]
+dataConCtxtName :: [Located Name] -> SDoc
+dataConCtxtName [con]
+ = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
+dataConCtxtName con
+ = ptext (sLit "In the definition of data constructors") <+> interpp'SP con
+
dataConCtxt :: Outputable a => a -> SDoc
dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
View Lorry Controller Status