diff options
47 files changed, 864 insertions, 620 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 252d0fe5d7..d8c651964c 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -89,6 +89,7 @@ module BasicTypes( import FastString import Outputable +import SrcLoc ( Located,unLoc ) import Data.Data hiding (Fixity) import Data.Function (on) @@ -263,14 +264,14 @@ initialVersion = 1 \begin{code} -- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt = WarningTxt [FastString] - | DeprecatedTxt [FastString] +data WarningTxt = WarningTxt [Located FastString] + | DeprecatedTxt [Located FastString] deriving (Eq, Data, Typeable) instance Outputable WarningTxt where - ppr (WarningTxt ws) = doubleQuotes (vcat (map ftext ws)) + ppr (WarningTxt ws) = doubleQuotes (vcat (map (ftext . unLoc) ws)) ppr (DeprecatedTxt ds) = text "Deprecated:" <+> - doubleQuotes (vcat (map ftext ds)) + doubleQuotes (vcat (map (ftext . unLoc) ds)) \end{code} %************************************************************************ diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 3e6912f20e..52d81ed6ed 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -166,8 +166,9 @@ untidy_con :: HsConPatDetails Name -> HsConPatDetails Name untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) untidy_con (RecCon (HsRecFields flds dd)) - = RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) } - | fld <- flds ] dd) + = RecCon (HsRecFields [ L l (fld { hsRecFieldArg + = untidy_pars (hsRecFieldArg fld) }) + | L l fld <- flds ] dd) pars :: NeedPars -> WarningPat -> Pat Name pars True p = ParPat p @@ -765,7 +766,8 @@ tidy_con con (RecCon (HsRecFields fs _)) field_pats = case con of RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc) PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax" - all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc) + all_pats = foldr (\(L _ (HsRecField id p _)) acc + -> insertNm (getName (unLoc id)) p acc) field_pats fs insertNm nm p [] = [(nm,p)] diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 5e7289f00c..ae6cef2347 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -593,9 +593,10 @@ addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" -- Others dhould never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) -addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id) -addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') } -addTickTupArg (Missing ty) = return (Missing ty) +addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id) +addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e + ; return (L l (Present e')) } +addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id)) addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do @@ -891,9 +892,9 @@ addTickHsRecordBinds (HsRecFields fields dd) = do { fields' <- mapM process fields ; return (HsRecFields fields' dd) } where - process (HsRecField ids expr doc) + process (L l (HsRecField ids expr doc)) = do { expr' <- addTickLHsExpr expr - ; return (HsRecField ids expr' doc) } + ; return (L l (HsRecField ids expr' doc)) } addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id) addTickArithSeqInfo (From e1) = diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index e2170e7dd4..500c411ffa 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -349,7 +349,7 @@ Reason dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule) dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) = putSrcSpanDs loc $ - do { let bndrs' = [var | RuleBndr (L _ var) <- vars] + do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars] ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ unsetWOptM Opt_WarnIdentities $ @@ -373,7 +373,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) fn_name = idName fn_id final_rhs = simpleOptExpr rhs'' -- De-crap it rule = mkRule False {- Not auto -} is_local - name act fn_name final_bndrs args final_rhs + (unLoc name) act fn_name final_bndrs args + final_rhs inline_shadows_rule -- Function can be inlined before rule fires | wopt Opt_WarnInlineRuleShadowing dflags @@ -390,7 +391,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) | otherwise = False ; when inline_shadows_rule $ - warnDs (vcat [ hang (ptext (sLit "Rule") <+> doubleQuotes (ftext name) + warnDs (vcat [ hang (ptext (sLit "Rule") + <+> doubleQuotes (ftext $ unLoc name) <+> ptext (sLit "may never fire")) 2 (ptext (sLit "because") <+> quotes (ppr fn_id) <+> ptext (sLit "might inline first")) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 6844f48970..03544bb6ae 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -278,12 +278,12 @@ dsExpr (SectionR op expr) = do Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id])) dsExpr (ExplicitTuple tup_args boxity) - = do { let go (lam_vars, args) (Missing ty) + = do { let go (lam_vars, args) (L _ (Missing ty)) -- For every missing expression, we need -- another lambda in the desugaring. = do { lam_var <- newSysLocalDs ty ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (Present expr) + go (lam_vars, args) (L _ (Present expr)) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExpr expr @@ -495,15 +495,15 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) ; return (add_field_binds field_binds' $ bindNonRec discrim_var record_expr' matching_code) } where - ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr) + ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr) -- Clone the Id in the HsRecField, because its Name is that -- of the record selector, and we must not make that a lcoal binder -- else we shadow other uses of the record selector -- Hence 'lcl_id'. Cf Trac #2735 - ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field) - ; let fld_id = unLoc (hsRecFieldId rec_field) - ; lcl_id <- newSysLocalDs (idType fld_id) - ; return (idName fld_id, lcl_id, rhs) } + ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) + ; let fld_id = unLoc (hsRecFieldId rec_field) + ; lcl_id <- newSysLocalDs (idType fld_id) + ; return (idName fld_id, lcl_id, rhs) } add_field_binds [] expr = expr add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) @@ -613,9 +613,9 @@ dsExpr (HsType {}) = panic "dsExpr:HsType" dsExpr (HsDo {}) = panic "dsExpr:HsDo" -findField :: [HsRecField Id arg] -> Name -> [arg] +findField :: [LHsRecField Id arg] -> Name -> [arg] findField rbinds lbl - = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds + = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds , lbl == idName (unLoc id) ] \end{code} diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 311069ec67..660cbf0231 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -107,7 +107,8 @@ dsForeigns' fos = do traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) - do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do + do_decl (ForeignExport (L _ id) _ co + (CExport (L _ (CExportStatic ext_nm cconv)) _)) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) \end{code} @@ -142,8 +143,8 @@ dsFImport :: Id -> Coercion -> ForeignImport -> DsM ([Binding], SDoc, SDoc) -dsFImport id co (CImport cconv safety mHeader spec) = do - (ids, h, c) <- dsCImport id co spec cconv safety mHeader +dsFImport id co (CImport cconv safety mHeader spec _) = do + (ids, h, c) <- dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader return (ids, h, c) dsCImport :: Id diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index afdfae3db6..5bb933a115 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -63,6 +63,7 @@ import DynFlags import FastString import ForeignCall import Util +import MonadUtils import Data.Maybe import Control.Monad @@ -154,7 +155,8 @@ repTopDs group@(HsGroup { hs_valds = valds -- more needed ; return (de_loc $ sort_by_loc $ - val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds + val_ds ++ catMaybes tycl_ds ++ role_ds + ++ (concat fix_ds) ++ inst_ds ++ rule_ds ++ for_ds ++ ann_ds ++ deriv_ds) }) ; @@ -293,8 +295,15 @@ repDataDefn tc bndrs opt_tys tv_names ; derivs1 <- repDerivs mb_derivs ; case new_or_data of NewType -> do { con1 <- repC tv_names (head cons) - ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 } - DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons + ; case con1 of + [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1 + _cs -> failWithDs (ptext + (sLit "Multiple constructors for newtype:") + <+> pprQuotedList + (con_names $ unLoc $ head cons)) + } + DataType -> do { consL <- concatMapM (repC tv_names) cons + ; cons1 <- coreList conQTyConName consL ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } } repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr] @@ -464,7 +473,7 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name ; repDataDefn tc bndrs (Just tys1) tv_names defn } } repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) -repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis))) +repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _))) = do MkC name' <- lookupLOcc name MkC typ' <- repLTy typ MkC cc' <- repCCallConv cc @@ -499,16 +508,18 @@ repSafety PlayRisky = rep2 unsafeName [] repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] -repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ) -repFixD (L loc (FixitySig name (Fixity prec dir))) - = do { MkC name' <- lookupLOcc name - ; MkC prec' <- coreIntLit prec +repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)] +repFixD (L loc (FixitySig names (Fixity prec dir))) + = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of InfixL -> infixLDName InfixR -> infixRDName InfixN -> infixNDName - ; dec <- rep2 rep_fn [prec', name'] - ; return (loc, dec) } + ; let do_one name + = do { MkC name' <- lookupLOcc name + ; dec <- rep2 rep_fn [prec', name'] + ; return (loc,dec) } + ; mapM do_one names } repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ) repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) @@ -516,7 +527,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ; ss <- mkGenSyms bndr_names ; rule1 <- addBinds ss $ do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs - ; n' <- coreStringLit $ unpackFS n + ; n' <- coreStringLit $ unpackFS $ unLoc n ; act' <- repPhases act ; lhs' <- repLE lhs ; rhs' <- repLE rhs @@ -524,16 +535,16 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ; rule2 <- wrapGenSyms ss rule1 ; return (loc, rule2) } -ruleBndrNames :: RuleBndr Name -> [Name] -ruleBndrNames (RuleBndr n) = [unLoc n] -ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })) +ruleBndrNames :: LRuleBndr Name -> [Name] +ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] +ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))) = unLoc n : kvs ++ tvs -repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ) -repRuleBndr (RuleBndr n) +repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) +repRuleBndr (L _ (RuleBndr n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } -repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty })) +repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty }))) = do { MkC n' <- lookupLBinder n ; MkC ty' <- repLTy ty ; rep2 typedRuleVarName [n', ty'] } @@ -562,14 +573,14 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") -- Constructors ------------------------------------------------------- -repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ) -repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ [] +repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ] +repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ [] , con_details = details, con_res = ResTyH98 })) | null (hsQTvBndrs con_tvs) - = do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] - ; repConstr con1 details } + = do { con1 <- mapM lookupLOcc con -- See Note [Binders and occurrences] + ; mapM (\c -> repConstr c details) con1 } -repC tvs (L _ (ConDecl { con_name = con +repC tvs (L _ (ConDecl { con_names = cons , con_qvars = con_tvs, con_cxt = L _ ctxt , con_details = details , con_res = res_ty })) @@ -578,12 +589,14 @@ repC tvs (L _ (ConDecl { con_name = con , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) } ; binds <- mapM dupBinder con_tv_subst - ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs + ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs - do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] - ; c' <- repConstr con1 details + do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences] + ; c' <- mapM (\c -> repConstr c details) cons1 ; ctxt' <- repContext (eq_ctxt ++ ctxt) - ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } } + ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) } + ; return [b] + } in_subst :: [(Name,Name)] -> Name -> Bool in_subst [] _ = False @@ -646,9 +659,9 @@ repBangTy ty= do -- Deriving clause ------------------------------------------------------- -repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name]) +repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name]) repDerivs Nothing = coreList nameTyConName [] -repDerivs (Just ctxt) +repDerivs (Just (L _ ctxt)) = repList nameTyConName rep_deriv ctxt where rep_deriv :: LHsType Name -> DsM (Core TH.Name) @@ -680,7 +693,8 @@ rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty) rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc -rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc +rep_sig (L loc (SpecSig nm tys ispec)) + = concatMapM (\t -> rep_specialise nm t ispec loc) tys rep_sig (L loc (SpecInstSig ty)) = rep_specialiseInst ty loc rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty @@ -1046,8 +1060,9 @@ repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) - | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs } - | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs } + | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs } + | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es] + ; repUnboxedTup xs } repE (RecordCon c _ flds) = do { x <- lookupLOcc c; @@ -1133,9 +1148,9 @@ repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) repFields (HsRecFields { rec_flds = flds }) = repList fieldExpQTyConName rep_fld flds where - rep_fld fld = do { fn <- lookupLOcc (hsRecFieldId fld) - ; e <- repLE (hsRecFieldArg fld) - ; repFieldExp fn e } + rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldId fld) + ; e <- repLE (hsRecFieldArg fld) + ; repFieldExp fn e } ----------------------------------------------------------------------------- @@ -1360,9 +1375,9 @@ repP (ConPatIn dc details) repPinfix p1' con_str p2' } } where - rep_fld fld = do { MkC v <- lookupLOcc (hsRecFieldId fld) - ; MkC p <- repLP (hsRecFieldArg fld) - ; rep2 fieldPatName [v,p] } + rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldId fld) + ; MkC p <- repLP (hsRecFieldArg fld) + ; rep2 fieldPatName [v,p] } repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } @@ -1831,13 +1846,16 @@ repConstr :: Core TH.Name -> HsConDeclDetails Name repConstr con (PrefixCon ps) = do arg_tys <- repList strictTypeQTyConName repBangTy ps rep2 normalCName [unC con, unC arg_tys] + repConstr con (RecCon ips) - = do { arg_vtys <- repList varStrictTypeQTyConName rep_ip ips + = do { args <- concatMapM rep_ip ips + ; arg_vtys <- coreList varStrictTypeQTyConName args ; rep2 recCName [unC con, unC arg_vtys] } where - rep_ip ip = do { MkC v <- lookupLOcc (cd_fld_name ip) - ; MkC ty <- repBangTy (cd_fld_type ip) - ; rep2 varStrictTypeName [v,ty] } + rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) + rep_one_ip t n = do { MkC v <- lookupLOcc n + ; MkC ty <- repBangTy t + ; rep2 varStrictTypeName [v,ty] } repConstr con (InfixCon st1 st2) = do arg1 <- repBangTy st1 diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index ddcd089546..8bc8a116af 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -973,8 +973,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp _ _ = False --------- - tup_arg (Present e1) (Present e2) = lexp e1 e2 - tup_arg (Missing t1) (Missing t2) = eqType t1 t2 + tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2 + tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False --------- diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index 611d48e456..8377e2a7cd 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -187,8 +187,8 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor = arg_vars where fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars - lookup_fld rpat = lookupNameEnv_NF fld_var_env - (idName (unLoc (hsRecFieldId rpat))) + lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env + (idName (unLoc (hsRecFieldId rpat))) select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" matchOneConLike _ _ [] = panic "matchOneCon []" @@ -203,7 +203,8 @@ compatible_pats _ _ = True -- Prefix or infix co same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool same_fields flds1 flds2 - = all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) + = all2 (\(L _ f1) (L _ f2) + -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) (rec_flds flds1) (rec_flds flds2) @@ -224,7 +225,7 @@ conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) | null rpats = map WildPat arg_tys -- Important special case for C {}, which can be used for a -- datacon that isn't declared to have fields at all - | otherwise = map (unLoc . hsRecFieldArg) rpats + | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats \end{code} Note [Record patterns] diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 141b8b840a..c7c31f3d8d 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -176,7 +176,7 @@ cvtDec (TH.InfixD fx nm) -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. = do { nm' <- vcNameL nm - ; returnJustL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) } + ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) } cvtDec (PragmaD prag) = cvtPragmaD prag @@ -208,7 +208,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs) ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing , dd_ctxt = ctxt' , dd_kindSig = Nothing - , dd_cons = [con'], dd_derivs = derivs' } + , dd_cons = [con'] + , dd_derivs = derivs' } ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' , tcdDataDefn = defn , tcdFVs = placeHolderNames }) } @@ -416,7 +417,8 @@ cvtConstr (RecC c varstrtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') } + ; returnL $ mkSimpleConDecl c' noExistentials cxt' + (RecCon args') } cvtConstr (InfixC st1 c st2) = do { c' <- cNameL c @@ -437,16 +439,18 @@ cvt_arg (NotStrict, ty) = cvtType ty cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing True) ty' } cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' } -cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName) +cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName) cvt_id_arg (i, str, ty) = do { i' <- vNameL i ; ty' <- cvt_arg (str,ty) - ; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) } + ; return $ noLoc (ConDeclField { cd_fld_names = [i'] + , cd_fld_type = ty' + , cd_fld_doc = Nothing}) } -cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName]) +cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName])) cvtDerivs [] = return Nothing cvtDerivs cs = do { cs' <- mapM cvt_one cs - ; return (Just cs') } + ; return (Just (noLoc cs')) } where cvt_one c = do { c' <- tconName c ; returnL $ HsTyVar c' } @@ -463,8 +467,9 @@ noExistentials = [] cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) cvtForD (ImportF callconv safety from nm ty) - | Just impspec <- parseCImport (cvt_conv callconv) safety' - (mkFastString (TH.nameBase nm)) from + | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') + (mkFastString (TH.nameBase nm)) + from (noLoc (mkFastString from)) = do { nm' <- vNameL nm ; ty' <- cvtType ty ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec) @@ -480,7 +485,9 @@ cvtForD (ImportF callconv safety from nm ty) cvtForD (ExportF callconv as nm ty) = do { nm' <- vNameL nm ; ty' <- cvtType ty - ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv)) + ; let e = CExport (noLoc (CExportStatic (mkFastString as) + (cvt_conv callconv))) + (noLoc (mkFastString as)) ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e } cvt_conv :: TH.Callconv -> CCallConv @@ -514,7 +521,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases) , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ SpecSig nm' ty' ip } + ; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip } cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty @@ -526,7 +533,7 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases) ; bndrs' <- mapM cvtRuleBndr bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs - ; returnJustL $ Hs.RuleD $ HsRule nm' act bndrs' + ; returnJustL $ Hs.RuleD $ HsRule (noLoc nm') act bndrs' lhs' placeHolderNames rhs' placeHolderNames } @@ -567,14 +574,14 @@ cvtPhases AllPhases dflt = dflt cvtPhases (FromPhase i) _ = ActiveAfter i cvtPhases (BeforePhase i) _ = ActiveBefore i -cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.RuleBndr RdrName) +cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName) cvtRuleBndr (RuleVar n) = do { n' <- vNameL n - ; return $ Hs.RuleBndr n' } + ; return $ noLoc $ Hs.RuleBndr n' } cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameL n ; ty' <- cvtType ty - ; return $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' } + ; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' } --------------------------------------------------- -- Declarations @@ -622,8 +629,12 @@ cvtl e = wrapL (cvt e) cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } -- Note [Dropping constructors] -- Singleton tuples treated like nothing (just parens) - cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed } - cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed } + cvt (TupE es) = do { es' <- mapM cvtl es + ; return $ ExplicitTuple (map (noLoc . Present) es') + Boxed } + cvt (UnboxedTupE es) = do { es' <- mapM cvtl es + ; return $ ExplicitTuple + (map (noLoc . Present) es') Unboxed } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; ; return $ HsIf (Just noSyntaxExpr) x' y' z' } cvt (MultiIfE alts) @@ -694,10 +705,11 @@ and the above expression would be reassociated to which we don't want. -} -cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName)) +cvtFld :: (TH.Name, TH.Exp) -> CvtM (LHsRecField RdrName (LHsExpr RdrName)) cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e - ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) } + ; return (noLoc $ HsRecField { hsRecFieldId = v', hsRecFieldArg = e' + , hsRecPun = False}) } cvtDD :: Range -> CvtM (ArithSeqInfo RdrName) cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } @@ -907,10 +919,11 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat e' p' placeHolderType } -cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) +cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName)) cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p - ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) } + ; return (noLoc $ HsRecField { hsRecFieldId = s', hsRecFieldArg = p' + , hsRecPun = False}) } {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix patterns will be left-biased, provided @x@ is. diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index b345e88a08..28e234389d 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -607,7 +607,7 @@ data Sig name -- > {-# SPECIALISE f :: Int -> Int #-} -- | SpecSig (Located name) -- Specialise a function or datatype ... - (LHsType name) -- ... to these types + [LHsType name] -- ... to these types InlinePragma -- The pragma on SPECIALISE_INLINE form. -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE @@ -630,7 +630,7 @@ deriving instance (DataId name) => Data (Sig name) type LFixitySig name = Located (FixitySig name) -data FixitySig name = FixitySig (Located name) Fixity +data FixitySig name = FixitySig [Located name] Fixity deriving (Data, Typeable) -- | TsSpecPrags conveys pragmas from the type checker to the desugarer @@ -727,7 +727,8 @@ ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (ppr ty) inl) +ppr_sig (SpecSig var ty inl) + = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) ppr_sig (MinimalSig bf) = pragBrackets (pprMinimalSig bf) @@ -750,7 +751,9 @@ pprPatSynSig ident _is_bidir tvs prov req ty (Just prov, Just req) -> prov <+> darrow <+> req <+> darrow instance OutputableBndr name => Outputable (FixitySig name) where - ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)] + ppr (FixitySig names fixity) = sep [ppr fixity, pprops] + where + pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) pragBrackets :: SDoc -> SDoc pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 323f0cdbe5..f8f370cbf0 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -12,6 +12,8 @@ {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Abstract syntax of global declarations. -- @@ -42,7 +44,7 @@ module HsDecls ( -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, -- ** @RULE@ declarations - RuleDecl(..), LRuleDecl, RuleBndr(..), + RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, -- ** @VECTORISE@ declarations VectDecl(..), LVectDecl, @@ -770,7 +772,7 @@ data HsDataDefn name -- The payload of a data type defn -- @ HsDataDefn { dd_ND :: NewOrData, dd_ctxt :: LHsContext name, -- ^ Context - dd_cType :: Maybe CType, + dd_cType :: Maybe (Located CType), dd_kindSig:: Maybe (LHsKind name), -- ^ Optional kind signature. -- @@ -787,7 +789,7 @@ data HsDataDefn name -- The payload of a data type defn -- For @data T a where { T1 :: T a }@ -- the 'LConDecls' all have 'ResTyGADT'. - dd_derivs :: Maybe [LHsType name] + dd_derivs :: Maybe (Located [LHsType name]) -- ^ Derivings; @Nothing@ => not specified, -- @Just []@ => derive exactly what is asked -- @@ -822,10 +824,11 @@ type LConDecl name = Located (ConDecl name) data ConDecl name = ConDecl - { con_name :: Located name - -- ^ Constructor name. This is used for the DataCon itself, and for + { con_names :: [Located name] + -- ^ Constructor names. This is used for the DataCon itself, and for -- the user-callable wrapper Id. - + -- It is a list to deal with GADT constructors of the form + -- T1, T2, T3 :: <payload> , con_explicit :: HsExplicitFlag -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy') @@ -860,12 +863,12 @@ data ConDecl name } deriving (Typeable) deriving instance (DataId name) => Data (ConDecl name) -type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name] +type HsConDeclDetails name = HsConDetails (LBangType name) [LConDeclField name] hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name] hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] -hsConDeclArgTys (RecCon flds) = map cd_fld_type flds +hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) flds data ResType ty = ResTyH98 -- Constructor was declared using Haskell 98 syntax @@ -899,8 +902,9 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Nothing -> empty Just kind -> dcolon <+> ppr kind pp_derivings = case derivings of - Nothing -> empty - Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)] + Nothing -> empty + Just (L _ ds) -> hsep [ptext (sLit "deriving"), + parens (interpp'SP ds)] instance OutputableBndr name => Outputable (HsDataDefn name) where ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d @@ -919,32 +923,47 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where ppr = pprConDecl pprConDecl :: OutputableBndr name => ConDecl name -> SDoc -pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs +pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = details , con_res = ResTyH98, con_doc = doc }) = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details] where - ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2] - ppr_details (PrefixCon tys) = hsep (pprPrefixOcc (unLoc con) : map (pprParendHsType . unLoc) tys) - ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields + ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc cons, ppr t2] + ppr_details (PrefixCon tys) = hsep (pprPrefixOcc cons + : map (pprParendHsType . unLoc) tys) + ppr_details (RecCon fields) = ppr_con_names cons + <+> pprConDeclFields fields -pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs +pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = PrefixCon arg_tys , con_res = ResTyGADT res_ty }) - = ppr con <+> dcolon <+> + = ppr_con_names cons <+> dcolon <+> sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] where mk_fun_ty a b = noLoc (HsFunTy a b) -pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs +pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty }) - = sep [ppr con <+> dcolon <+> pprHsForAll expl tvs cxt, + = sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt, pprConDeclFields fields <+> arrow <+> ppr res_ty] pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} }) = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] }) -- In GADT syntax we don't allow infix constructors -- but the renamer puts them in this form (Note [Infix GADT constructors] in RnSource) + +ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc +ppr_con_names [x] = ppr x +ppr_con_names xs = interpp'SP xs + +instance (Outputable name) => OutputableBndr [Located name] where + pprBndr _bs xs = cat $ punctuate comma (map ppr xs) + + pprPrefixOcc [x] = ppr x + pprPrefixOcc xs = cat $ punctuate comma (map ppr xs) + + pprInfixOcc [x] = ppr x + pprInfixOcc xs = cat $ punctuate comma (map ppr xs) \end{code} %************************************************************************ @@ -1027,7 +1046,7 @@ data ClsInstDecl name , cid_sigs :: [LSig name] -- User-supplied pragmatic info , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances - , cid_overlap_mode :: Maybe OverlapMode + , cid_overlap_mode :: Maybe (Located OverlapMode) } deriving (Typeable) deriving instance (DataId id) => Data (ClsInstDecl id) @@ -1123,15 +1142,15 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl name) where top_matter = ptext (sLit "instance") <+> ppOverlapPragma mbOverlap <+> ppr inst_ty -ppOverlapPragma :: Maybe OverlapMode -> SDoc +ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc ppOverlapPragma mb = case mb of Nothing -> empty - Just NoOverlap -> ptext (sLit "{-# NO_OVERLAP #-}") - Just Overlappable -> ptext (sLit "{-# OVERLAPPABLE #-}") - Just Overlapping -> ptext (sLit "{-# OVERLAPPING #-}") - Just Overlaps -> ptext (sLit "{-# OVERLAPS #-}") - Just Incoherent -> ptext (sLit "{-# INCOHERENT #-}") + Just (L _ NoOverlap) -> ptext (sLit "{-# NO_OVERLAP #-}") + Just (L _ Overlappable) -> ptext (sLit "{-# OVERLAPPABLE #-}") + Just (L _ Overlapping) -> ptext (sLit "{-# OVERLAPPING #-}") + Just (L _ Overlaps) -> ptext (sLit "{-# OVERLAPS #-}") + Just (L _ Incoherent) -> ptext (sLit "{-# INCOHERENT #-}") @@ -1162,9 +1181,10 @@ instDeclDataFamInsts inst_decls \begin{code} type LDerivDecl name = Located (DerivDecl name) -data DerivDecl name = DerivDecl { deriv_type :: LHsType name - , deriv_overlap_mode :: Maybe OverlapMode - } +data DerivDecl name = DerivDecl + { deriv_type :: LHsType name + , deriv_overlap_mode :: Maybe (Located OverlapMode) + } deriving (Typeable) deriving instance (DataId name) => Data (DerivDecl name) @@ -1257,10 +1277,12 @@ data ForeignImport = -- import of a C entity -- -- * `Safety' is irrelevant for `CLabel' and `CWrapper' -- - CImport CCallConv -- ccall or stdcall - Safety -- interruptible, safe or unsafe + CImport (Located CCallConv) -- ccall or stdcall + (Located Safety) -- interruptible, safe or unsafe (Maybe Header) -- name of C header CImportSpec -- details of the C entity + (Located FastString) -- original source text for + -- the C entity deriving (Data, Typeable) -- details of an external C entity @@ -1274,7 +1296,10 @@ data CImportSpec = CLabel CLabelString -- import address of a C label -- specification of an externally exported entity in dependence on the calling -- convention -- -data ForeignExport = CExport CExportSpec -- contains the calling convention +data ForeignExport = CExport (Located CExportSpec) -- contains the calling + -- convention + (Located FastString) -- original source text for + -- the C entity deriving (Data, Typeable) -- pretty printing of foreign declarations @@ -1289,7 +1314,7 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where 2 (dcolon <+> ppr ty) instance Outputable ForeignImport where - ppr (CImport cconv safety mHeader spec) = + ppr (CImport cconv safety mHeader spec _) = ppr cconv <+> ppr safety <+> char '"' <> pprCEntity spec <> char '"' where @@ -1309,7 +1334,7 @@ instance Outputable ForeignImport where pprCEntity (CWrapper) = ptext (sLit "wrapper") instance Outputable ForeignExport where - ppr (CExport (CExportStatic lbl cconv)) = + ppr (CExport (L _ (CExportStatic lbl cconv)) _) = ppr cconv <+> char '"' <> ppr lbl <> char '"' \end{code} @@ -1325,16 +1350,18 @@ type LRuleDecl name = Located (RuleDecl name) data RuleDecl name = HsRule -- Source rule - RuleName -- Rule name + (Located RuleName) -- Rule name Activation - [RuleBndr name] -- Forall'd vars; after typechecking this includes tyvars + [LRuleBndr name] -- Forall'd vars; after typechecking this + -- includes tyvars (Located (HsExpr name)) -- LHS - (PostRn name NameSet) -- Free-vars from the LHS + (PostRn name NameSet) -- Free-vars from the LHS (Located (HsExpr name)) -- RHS - (PostRn name NameSet) -- Free-vars from the RHS + (PostRn name NameSet) -- Free-vars from the RHS deriving (Typeable) deriving instance (DataId name) => Data (RuleDecl name) +type LRuleBndr name = Located (RuleBndr name) data RuleBndr name = RuleBndr (Located name) | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name)) @@ -1346,7 +1373,8 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] instance OutputableBndr name => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) - = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act, + = sep [text "{-# RULES" <+> doubleQuotes (ftext $ unLoc name) + <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ] where diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index eaac719df9..79c30a0b78 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -161,8 +161,8 @@ data HsExpr id (LHsExpr id) -- operand -- | Used for explicit tuples and sections thereof - | ExplicitTuple - [HsTupArg id] + | ExplicitTuple + [LHsTupArg id] Boxity | HsCase (LHsExpr id) @@ -339,17 +339,18 @@ data HsExpr id deriving instance (DataId id) => Data (HsExpr id) -- | HsTupArg is used for tuple sections --- (,a,) is represented by ExplicitTuple [Mising ty1, Present a, Missing ty3] +-- (,a,) is represented by ExplicitTuple [Missing ty1, Present a, Missing ty3] -- Which in turn stands for (\x:ty1 \y:ty2. (x,a,y)) +type LHsTupArg id = Located (HsTupArg id) data HsTupArg id = Present (LHsExpr id) -- ^ The argument | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type deriving (Typeable) deriving instance (DataId id) => Data (HsTupArg id) -tupArgPresent :: HsTupArg id -> Bool -tupArgPresent (Present {}) = True -tupArgPresent (Missing {}) = False +tupArgPresent :: LHsTupArg id -> Bool +tupArgPresent (L _ (Present {})) = True +tupArgPresent (L _ (Missing {})) = False \end{code} Note [Parens in HsSyn] @@ -477,7 +478,8 @@ ppr_expr (SectionR op expr) pp_infixly v = sep [pprInfixOcc v, pp_expr] ppr_expr (ExplicitTuple exprs boxity) - = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs)) + = tupleParens (boxityNormalTupleSort boxity) + (fcat (ppr_tup_args $ map unLoc exprs)) where ppr_tup_args [] = [] ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 7163cbfe10..dd23dbab86 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -41,7 +41,8 @@ data ImportDecl name ideclQualified :: Bool, -- ^ True => qualified ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) ideclAs :: Maybe ModuleName, -- ^ as Module - ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names) + ideclHiding :: Maybe (Bool, Located [LIE name]) + -- ^ (True => hiding, names) } deriving (Data, Typeable) simpleImportDecl :: ModuleName -> ImportDecl name @@ -86,8 +87,8 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) ppr_imp False = empty pp_spec Nothing = empty - pp_spec (Just (False, ies)) = ppr_ies ies - pp_spec (Just (True, ies)) = ptext (sLit "hiding") <+> ppr_ies ies + pp_spec (Just (False, (L _ ies))) = ppr_ies ies + pp_spec (Just (True, (L _ ies))) = ptext (sLit "hiding") <+> ppr_ies ies ppr_ies [] = ptext (sLit "()") ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' @@ -104,11 +105,12 @@ type LIE name = Located (IE name) -- | Imported or exported entity. data IE name - = IEVar name - | IEThingAbs name -- ^ Class/Type (can't tell) - | IEThingAll name -- ^ Class/Type plus all methods/constructors - | IEThingWith name [name] -- ^ Class/Type plus some methods/constructors - | IEModuleContents ModuleName -- ^ (Export Only) + = IEVar (Located name) + | IEThingAbs name -- ^ Class/Type (can't tell) + | IEThingAll (Located name) -- ^ Class/Type plus all methods/constructors + | IEThingWith (Located name) [Located name] + -- ^ Class/Type plus some methods/constructors + | IEModuleContents (Located ModuleName) -- ^ (Export Only) | IEGroup Int HsDocString -- ^ Doc section heading | IEDoc HsDocString -- ^ Some documentation | IEDocNamed String -- ^ Reference to named doc @@ -117,21 +119,21 @@ data IE name \begin{code} ieName :: IE name -> name -ieName (IEVar n) = n -ieName (IEThingAbs n) = n -ieName (IEThingWith n _) = n -ieName (IEThingAll n) = n +ieName (IEVar (L _ n)) = n +ieName (IEThingAbs n) = n +ieName (IEThingWith (L _ n) _) = n +ieName (IEThingAll (L _ n)) = n ieName _ = panic "ieName failed pattern match!" ieNames :: IE a -> [a] -ieNames (IEVar n ) = [n] -ieNames (IEThingAbs n ) = [n] -ieNames (IEThingAll n ) = [n] -ieNames (IEThingWith n ns) = n : ns -ieNames (IEModuleContents _ ) = [] -ieNames (IEGroup _ _ ) = [] -ieNames (IEDoc _ ) = [] -ieNames (IEDocNamed _ ) = [] +ieNames (IEVar (L _ n) ) = [n] +ieNames (IEThingAbs n ) = [n] +ieNames (IEThingAll (L _ n) ) = [n] +ieNames (IEThingWith (L _ n) ns) = n : map unLoc ns +ieNames (IEModuleContents _ ) = [] +ieNames (IEGroup _ _ ) = [] +ieNames (IEDoc _ ) = [] +ieNames (IEDocNamed _ ) = [] \end{code} \begin{code} @@ -144,16 +146,15 @@ pprImpExp name = type_pref <+> pprPrefixOcc name | otherwise = empty instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where - ppr (IEVar var) = pprPrefixOcc var + ppr (IEVar var) = pprPrefixOcc (unLoc var) ppr (IEThingAbs thing) = pprImpExp thing - ppr (IEThingAll thing) = hcat [pprImpExp thing, text "(..)"] + ppr (IEThingAll thing) = hcat [pprImpExp (unLoc thing), text "(..)"] ppr (IEThingWith thing withs) - = pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs))) + = pprImpExp (unLoc thing) <> parens (fsep (punctuate comma + (map pprImpExp $ map unLoc withs))) ppr (IEModuleContents mod') = ptext (sLit "module") <+> ppr mod' ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">") ppr (IEDoc doc) = ppr doc ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">") \end{code} - - diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index bbd37bc426..145a8cd3a9 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -18,7 +18,7 @@ module HsPat ( HsConDetails(..), HsConPatDetails, hsConPatArgs, - HsRecFields(..), HsRecField(..), hsRecFields, + HsRecFields(..), HsRecField(..), LHsRecField, hsRecFields, mkPrefixConPat, mkCharLitPat, mkNilPat, @@ -187,7 +187,7 @@ type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id)) hsConPatArgs :: HsConPatDetails id -> [LPat id] hsConPatArgs (PrefixCon ps) = ps -hsConPatArgs (RecCon fs) = map hsRecFieldArg (rec_flds fs) +hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] \end{code} @@ -198,7 +198,7 @@ However HsRecFields is used only for patterns and expressions data HsRecFields id arg -- A bunch of record fields -- { x = 3, y = True } -- Used for both expressions and patterns - = HsRecFields { rec_flds :: [HsRecField id arg], + = HsRecFields { rec_flds :: [LHsRecField id arg], rec_dotdot :: Maybe Int } -- Note [DotDot fields] deriving (Data, Typeable) @@ -216,6 +216,7 @@ data HsRecFields id arg -- A bunch of record fields -- the first 'n' being the user-written ones -- and the remainder being 'filled in' implicitly +type LHsRecField id arg = Located (HsRecField id arg) data HsRecField id arg = HsRecField { hsRecFieldId :: Located id, hsRecFieldArg :: arg, -- Filled in by renamer @@ -235,7 +236,7 @@ data HsRecField id arg = HsRecField { -- T { A.x } means T { A.x = x } hsRecFields :: HsRecFields id arg -> [id] -hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds) +hsRecFields rbinds = map (unLoc . hsRecFieldId . unLoc) (rec_flds rbinds) \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index 7aecfea40b..bd1b2b2274 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -63,7 +63,7 @@ data HsModule name hsmodName :: Maybe (Located ModuleName), -- ^ @Nothing@: \"module X where\" is omitted (in which case the next -- field is Nothing too) - hsmodExports :: Maybe [LIE name], + hsmodExports :: Maybe (Located [LIE name]), -- ^ Export list -- -- - @Nothing@: export list omitted, so export everything @@ -78,7 +78,7 @@ data HsModule name -- downstream. hsmodDecls :: [LHsDecl name], -- ^ Type, class, value, and interface signature decls - hsmodDeprecMessage :: Maybe WarningTxt, + hsmodDeprecMessage :: Maybe (Located WarningTxt), -- ^ reason\/explanation for warning/deprecation of this module hsmodHaddockModHeader :: Maybe LHsDocString -- ^ Haddock module info and description, unparsed @@ -92,7 +92,8 @@ instance (OutputableBndr name, HasOccName name) => Outputable (HsModule name) where ppr (HsModule Nothing _ imports decls _ mbDoc) - = pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls + = pp_mb mbDoc $$ pp_nonnull imports + $$ pp_nonnull decls ppr (HsModule (Just name) exports imports decls deprec mbDoc) = vcat [ @@ -101,7 +102,7 @@ instance (OutputableBndr name, HasOccName name) Nothing -> pp_header (ptext (sLit "where")) Just es -> vcat [ pp_header lparen, - nest 8 (fsep (punctuate comma (map ppr es))), + nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), nest 4 (ptext (sLit ") where")) ], pp_nonnull imports, diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 4a01948430..46cf096def 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -30,7 +30,7 @@ module HsTypes ( LBangType, BangType, HsBang(..), getBangType, getBangStrictness, - ConDeclField(..), pprConDeclFields, + ConDeclField(..), LConDeclField, pprConDeclFields, mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded, mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy, @@ -258,18 +258,18 @@ data HsType name | HsDocTy (LHsType name) LHsDocString -- A documented type | HsBangTy HsBang (LHsType name) -- Bang-style type annotations - | HsRecTy [ConDeclField name] -- Only in data type declarations + | HsRecTy [LConDeclField name] -- Only in data type declarations | HsCoreTy Type -- An escape hatch for tunnelling a *closed* -- Core Type through HsSyn. | HsExplicitListTy -- A promoted explicit list (PostTc name Kind) -- See Note [Promoted lists and tuples] - [LHsType name] - + [LHsType name] + | HsExplicitTupleTy -- A promoted explicit tuple [PostTc name Kind] -- See Note [Promoted lists and tuples] - [LHsType name] + [LHsType name] | HsTyLit HsTyLit -- A promoted numeric literal. @@ -398,10 +398,11 @@ data HsTupleSort = HsUnboxedTuple data HsExplicitFlag = Qualified | Implicit | Explicit deriving (Data, Typeable) +type LConDeclField name = Located (ConDeclField name) data ConDeclField name -- Record fields have Haddoc docs on them - = ConDeclField { cd_fld_name :: Located name, - cd_fld_type :: LBangType name, - cd_fld_doc :: Maybe LHsDocString } + = ConDeclField { cd_fld_names :: [Located name], + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe LHsDocString } deriving (Typeable) deriving instance (DataId name) => Data (ConDeclField name) @@ -616,12 +617,14 @@ pprHsContextMaybe [] = Nothing pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) -pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc +pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where - ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, - cd_fld_doc = doc }) - = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, + cd_fld_doc = doc })) + = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + ppr_names [n] = ppr n + ppr_names ns = sep (punctuate comma (map ppr ns)) \end{code} Note [Printing KindedTyVars] diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index df2406fcd3..f64471b7ee 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -416,7 +416,7 @@ types on the tuple. mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] = e -mkLHsTupleExpr es = noLoc $ ExplicitTuple (map Present es) Boxed +mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed mkLHsVarTuple :: [a] -> LHsExpr a mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) @@ -792,7 +792,8 @@ hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn }) ------------------- -- the SrcLoc returned are for the whole declarations, not just the names hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name] -hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons +hsDataDefnBinders (HsDataDefn { dd_cons = cons }) + = hsConDeclsBinders cons -- See Note [Binders in family instances] ------------------- @@ -809,12 +810,12 @@ hsConDeclsBinders cons = go id cons case r of -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) - L loc (ConDecl { con_name = L _ name , con_details = RecCon flds }) -> - (L loc name) : r' ++ go remSeen' rs - where r' = remSeen (map cd_fld_name flds) + L loc (ConDecl { con_names = names, con_details = RecCon flds }) -> + (map (L loc . unLoc) names) ++ r' ++ go remSeen' rs + where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r'] - L loc (ConDecl { con_name = L _ name }) -> - (L loc name) : go remSeen rs + L loc (ConDecl { con_names = names }) -> + (map (L loc . unLoc) names) ++ go remSeen rs \end{code} @@ -898,7 +899,8 @@ lPatImplicits = hs_lpat details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit) where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat | (i, fld) <- [0..] `zip` rec_flds fs - , let pat = hsRecFieldArg fld + , let pat = hsRecFieldArg + (unLoc fld) pat_explicit = maybe True (i<) (rec_dotdot fs)] details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2 \end{code} diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index c6d72b2cc9..9ac2243af8 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -81,7 +81,8 @@ getImports dflags buf filename source_filename = do ord_idecls implicit_prelude = xopt Opt_ImplicitPrelude dflags - implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps + implicit_imports = mkPrelImports (unLoc mod) main_loc + implicit_prelude imps in return (src_idecls, implicit_imports ++ ordinary_imps, mod) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index c9baa5ac3e..3763e55090 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -813,7 +813,7 @@ hscCheckSafeImports tcg_env = do warns dflags rules = listToBag $ map (warnRules dflags) rules warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = mkPlainWarnMsg dflags loc $ - text "Rule \"" <> ftext n <> text "\" ignored" $+$ + text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" -- | Validate that safe imported modules are actually safe. For modules in the @@ -1519,7 +1519,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule str case is of - [i] -> return (unLoc i) + [L _ i] -> return i _ -> liftIO $ throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ ptext (sLit "parse error in import declaration") diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 4f901b1849..582cb31116 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -78,7 +78,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls val_decls = [d | ValD d <- decls] - real_exports = case exports of { Nothing -> []; Just es -> es } + real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } n_exports = length real_exports export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False}) real_exports @@ -124,9 +124,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) spec_info (Just (False, _)) = (0,0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,0,1) - data_info (DataDecl { tcdDataDefn = HsDataDefn {dd_cons = cs, dd_derivs = derivs}}) - = (length cs, case derivs of Nothing -> 0 - Just ds -> length ds) + data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs + , dd_derivs = derivs}}) + = (length cs, case derivs of Nothing -> 0 + Just (L _ ds) -> length ds) data_info _ = (0,0) class_info decl@(ClassDecl {}) diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs index bf22cd77c1..387cbf8f08 100644 --- a/compiler/parser/HaddockUtils.hs +++ b/compiler/parser/HaddockUtils.hs @@ -9,13 +9,15 @@ import Control.Monad -- ----------------------------------------------------------------------------- -- Adding documentation to record fields (used in parsing). -addFieldDoc :: ConDeclField a -> Maybe LHsDocString -> ConDeclField a -addFieldDoc fld doc = fld { cd_fld_doc = cd_fld_doc fld `mplus` doc } +addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a +addFieldDoc (L l fld) doc + = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }) -addFieldDocs :: [ConDeclField a] -> Maybe LHsDocString -> [ConDeclField a] +addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a] addFieldDocs [] _ = [] addFieldDocs (x:xs) doc = addFieldDoc x doc : xs + addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a addConDoc decl Nothing = decl addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 4117d06930..30cd5525a1 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -452,9 +452,11 @@ maybedocheader :: { Maybe LHsDocString } missing_module_keyword :: { () } : {- empty -} {% pushCurrentContext } -maybemodwarning :: { Maybe WarningTxt } - : '{-# DEPRECATED' strings '#-}' { Just (DeprecatedTxt $ unLoc $2) } - | '{-# WARNING' strings '#-}' { Just (WarningTxt $ unLoc $2) } +maybemodwarning :: { Maybe (Located WarningTxt) } + : '{-# DEPRECATED' strings '#-}' { Just (sLL $1 $> $ + DeprecatedTxt $ unLoc $2) } + | '{-# WARNING' strings '#-}' { Just (sLL $1 $> $ + WarningTxt $ unLoc $2) } | {- empty -} { Nothing } body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } @@ -497,8 +499,8 @@ header_body2 :: { [LImportDecl RdrName] } ----------------------------------------------------------------------------- -- The Export List -maybeexports :: { Maybe [LIE RdrName] } - : '(' exportlist ')' { Just (fromOL $2) } +maybeexports :: { Maybe (Located [LIE RdrName]) } + : '(' exportlist ')' { Just (sLL $1 $> (fromOL $2)) } | {- empty -} { Nothing } exportlist :: { OrdList (LIE RdrName) } @@ -523,10 +525,10 @@ exp_doc :: { OrdList (LIE RdrName) } -- No longer allow things like [] and (,,,) to be exported -- They are built in syntax, always available export :: { OrdList (LIE RdrName) } - : qcname_ext export_subspec { unitOL (sLL $1 $> (mkModuleImpExp (unLoc $1) + : qcname_ext export_subspec { unitOL (sLL $1 $> (mkModuleImpExp $1 (unLoc $2))) } - | 'module' modid { unitOL (sLL $1 $> (IEModuleContents (unLoc $2))) } - | 'pattern' qcon { unitOL (sLL $1 $> (IEVar (unLoc $2))) } + | 'module' modid { unitOL (sLL $1 $> (IEModuleContents $2)) } + | 'pattern' qcon { unitOL (sLL $1 $> (IEVar $2)) } export_subspec :: { Located ImpExpSubSpec } : {- empty -} { sL0 ImpExpAbs } @@ -534,9 +536,9 @@ export_subspec :: { Located ImpExpSubSpec } | '(' ')' { sLL $1 $> (ImpExpList []) } | '(' qcnames ')' { sLL $1 $> (ImpExpList (reverse $2)) } -qcnames :: { [RdrName] } -- A reversed list - : qcnames ',' qcname_ext { unLoc $3 : $1 } - | qcname_ext { [unLoc $1] } +qcnames :: { [Located RdrName] } -- A reversed list + : qcnames ',' qcname_ext { $3 : $1 } + | qcname_ext { [$1] } qcname_ext :: { Located RdrName } -- Variable or data constructor -- or tagged type constructor @@ -555,7 +557,7 @@ qcname :: { Located RdrName } -- Variable or data constructor -- whereas topdecls must contain at least one topdecl. importdecls :: { [LImportDecl RdrName] } - : importdecls ';' importdecl { $3 : $1 } + : importdecls ';' importdecl { ($3 : $1) } | importdecls ';' { $1 } | importdecl { [ $1 ] } | {- empty -} { [] } @@ -588,13 +590,15 @@ maybeas :: { Located (Maybe ModuleName) } : 'as' modid { sLL $1 $> (Just (unLoc $2)) } | {- empty -} { noLoc Nothing } -maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) } +maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) } : impspec { sL1 $1 (Just (unLoc $1)) } | {- empty -} { noLoc Nothing } -impspec :: { Located (Bool, [LIE RdrName]) } - : '(' exportlist ')' { sLL $1 $> (False, fromOL $2) } - | 'hiding' '(' exportlist ')' { sLL $1 $> (True, fromOL $3) } +impspec :: { Located (Bool, Located [LIE RdrName]) } + : '(' exportlist ')' { sLL $1 $> (False, + (sLL $1 $> $ fromOL $2)) } + | 'hiding' '(' exportlist ')' { sLL $1 $> (True, + (sLL $2 $> $ fromOL $3)) } ----------------------------------------------------------------------------- -- Fixity Declarations @@ -658,7 +662,8 @@ topdecl :: { OrdList (LHsDecl RdrName) } -- Type classes -- cl_decl :: { LTyClDecl RdrName } - : 'class' tycl_hdr fds where_cls {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 $4 } + : 'class' tycl_hdr fds where_cls + {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (unLoc $4) } -- Type declarations (toplevel) -- @@ -716,7 +721,7 @@ inst_decl :: { LInstDecl RdrName } -- data/newtype instance declaration | data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving {% mkDataFamInst (comb4 $1 $4 $5 $6) (unLoc $1) $3 $4 - Nothing (reverse (unLoc $5)) (unLoc $6) } + Nothing (reverse (unLoc $5)) (unLoc $6) } -- GADT instance declaration | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig @@ -725,11 +730,11 @@ inst_decl :: { LInstDecl RdrName } {% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4 (unLoc $5) (unLoc $6) (unLoc $7) } -overlap_pragma :: { Maybe OverlapMode } - : '{-# OVERLAPPABLE' '#-}' { Just Overlappable } - | '{-# OVERLAPPING' '#-}' { Just Overlapping } - | '{-# OVERLAPS' '#-}' { Just Overlaps } - | '{-# INCOHERENT' '#-}' { Just Incoherent } +overlap_pragma :: { Maybe (Located OverlapMode) } + : '{-# OVERLAPPABLE' '#-}' { Just (sLL $1 $> Overlappable) } + | '{-# OVERLAPPING' '#-}' { Just (sLL $1 $> Overlapping) } + | '{-# OVERLAPS' '#-}' { Just (sLL $1 $> Overlaps) } + | '{-# INCOHERENT' '#-}' { Just (sLL $1 $> Incoherent) } | {- empty -} { Nothing } @@ -829,10 +834,14 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } : context '=>' type { sLL $1 $> (Just $1, $3) } | type { sL1 $1 (Nothing, $1) } -capi_ctype :: { Maybe CType } -capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) } - | '{-# CTYPE' STRING '#-}' { Just (CType Nothing (getSTRING $2)) } - | { Nothing } +capi_ctype :: { Maybe (Located CType) } +capi_ctype : '{-# CTYPE' STRING STRING '#-}' + { Just $ sLL $1 $> (CType + (Just (Header (getSTRING $2))) + (getSTRING $3)) } + | '{-# CTYPE' STRING '#-}' + { Just $ sLL $1 $> (CType Nothing (getSTRING $2)) } + | { Nothing } ----------------------------------------------------------------------------- -- Stand-alone deriving @@ -1008,7 +1017,7 @@ rules :: { OrdList (LHsDecl RdrName) } rule :: { LHsDecl RdrName } : STRING rule_activation rule_forall infixexp '=' exp - { sLL $1 $> $ RuleD (HsRule (getSTRING $1) + { sLL $1 $> $ RuleD (HsRule (sL1 $1 (getSTRING $1)) ($2 `orElse` AlwaysActive) $3 $4 placeHolderNames $6 placeHolderNames) } @@ -1022,17 +1031,17 @@ rule_explicit_activation :: { Activation } -- In brackets | '[' '~' INTEGER ']' { ActiveBefore (fromInteger (getINTEGER $3)) } | '[' '~' ']' { NeverActive } -rule_forall :: { [RuleBndr RdrName] } +rule_forall :: { [LRuleBndr RdrName] } : 'forall' rule_var_list '.' { $2 } | {- empty -} { [] } -rule_var_list :: { [RuleBndr RdrName] } +rule_var_list :: { [LRuleBndr RdrName] } : rule_var { [$1] } | rule_var rule_var_list { $1 : $2 } -rule_var :: { RuleBndr RdrName } - : varid { RuleBndr $1 } - | '(' varid '::' ctype ')' { RuleBndrSig $2 (mkHsWithBndrs $4) } +rule_var :: { LRuleBndr RdrName } + : varid { sLL $1 $> $ RuleBndr $1 } + | '(' varid '::' ctype ')' { sLL $1 $> $ RuleBndrSig $2 (mkHsWithBndrs $4) } ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) @@ -1061,13 +1070,14 @@ deprecation :: { OrdList (LHsDecl RdrName) } { toOL [ sLL $1 $> $ WarningD (Warning n (DeprecatedTxt $ unLoc $2)) | n <- unLoc $1 ] } -strings :: { Located [FastString] } - : STRING { sL1 $1 [getSTRING $1] } +strings :: { Located [Located FastString] } + : STRING { sL1 $1 [sL1 $1 (getSTRING $1)] } | '[' stringlist ']' { sLL $1 $> $ fromOL (unLoc $2) } -stringlist :: { Located (OrdList FastString) } - : stringlist ',' STRING { sLL $1 $> (unLoc $1 `snocOL` getSTRING $3) } - | STRING { sLL $1 $> (unitOL (getSTRING $1)) } +stringlist :: { Located (OrdList (Located FastString)) } + : stringlist ',' STRING { sLL $1 $> (unLoc $1 `snocOL` + (L (getLoc $3) (getSTRING $3))) } + | STRING { sLL $1 $> (unitOL (sLL $1 $> (getSTRING $1))) } ----------------------------------------------------------------------------- -- Annotations @@ -1084,22 +1094,22 @@ fdecl :: { LHsDecl RdrName } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (unLoc $4) >>= return.sLL $1 $> } | 'import' callconv fspec - {% do { d <- mkImport $2 PlaySafe (unLoc $3); + {% do { d <- mkImport $2 (noLoc PlaySafe) (unLoc $3); return (sLL $1 $> d) } } | 'export' callconv fspec {% mkExport $2 (unLoc $3) >>= return.sLL $1 $> } -callconv :: { CCallConv } - : 'stdcall' { StdCallConv } - | 'ccall' { CCallConv } - | 'capi' { CApiConv } - | 'prim' { PrimCallConv} - | 'javascript' { JavaScriptCallConv } +callconv :: { Located CCallConv } + : 'stdcall' { sLL $1 $> StdCallConv } + | 'ccall' { sLL $1 $> CCallConv } + | 'capi' { sLL $1 $> CApiConv } + | 'prim' { sLL $1 $> PrimCallConv } + | 'javascript' { sLL $1 $> JavaScriptCallConv } -safety :: { Safety } - : 'unsafe' { PlayRisky } - | 'safe' { PlaySafe } - | 'interruptible' { PlayInterruptible } +safety :: { Located Safety } + : 'unsafe' { sLL $1 $> PlayRisky } + | 'safe' { sLL $1 $> PlaySafe } + | 'interruptible' { sLL $1 $> PlayInterruptible } fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } : STRING var '::' sigtypedoc { sLL $1 $> (L (getLoc $1) (getSTRING $1), $2, $4) } @@ -1348,14 +1358,14 @@ both become a HsTyVar ("Zero", DataName) after the renamer. ----------------------------------------------------------------------------- -- Datatype declarations -gadt_constrlist :: { Located [LConDecl RdrName] } -- Returned in order +gadt_constrlist :: { Located [LConDecl RdrName] } -- Returned in order : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3) (unLoc $3) } | 'where' vocurly gadt_constrs close { L (comb2 $1 $3) (unLoc $3) } | {- empty -} { noLoc [] } gadt_constrs :: { Located [LConDecl RdrName] } - : gadt_constr ';' gadt_constrs { L (comb2 (head $1) $3) ($1 ++ unLoc $3) } - | gadt_constr { L (getLoc (head $1)) $1 } + : gadt_constr ';' gadt_constrs { sLL $1 $> ($1 : unLoc $3) } + | gadt_constr { sLL $1 $> [$1] } | {- empty -} { noLoc [] } -- We allow the following forms: @@ -1364,15 +1374,16 @@ gadt_constrs :: { Located [LConDecl RdrName] } -- D { x,y :: a } :: T a -- forall a. Eq a => D { x,y :: a } :: T a -gadt_constr :: { [LConDecl RdrName] } -- Returns a list because of: C,D :: ty +gadt_constr :: { LConDecl RdrName } + -- Returns a list because of: C,D :: ty : con_list '::' sigtype - { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } + { sLL $1 $> $ mkGadtDecl (unLoc $1) $3 } -- Deprecated syntax for GADT record declarations | oqtycon '{' fielddecls '}' '::' sigtype {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6 ; cd' <- checkRecordSyntax cd - ; return [cd'] } } + ; return cd' } } constrs :: { Located [LConDecl RdrName] } : maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) } @@ -1406,30 +1417,32 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } : btype {% splitCon $1 >>= return.sLL $1 $> } | btype conop btype { sLL $1 $> ($2, InfixCon $1 $3) } -fielddecls :: { [ConDeclField RdrName] } +fielddecls :: { [LConDeclField RdrName] } : {- empty -} { [] } | fielddecls1 { $1 } -fielddecls1 :: { [ConDeclField RdrName] } +fielddecls1 :: { [LConDeclField RdrName] } : fielddecl maybe_docnext ',' maybe_docprev fielddecls1 - { [ addFieldDoc f $4 | f <- $1 ] ++ addFieldDocs $5 $2 } - -- This adds the doc $4 to each field separately - | fielddecl { $1 } + { (addFieldDoc $1 $4) : addFieldDocs $5 $2 } + | fielddecl { [$1] } -fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int - : maybe_docnext sig_vars '::' ctype maybe_docprev { [ ConDeclField fld $4 ($1 `mplus` $5) - | fld <- reverse (unLoc $2) ] } +fielddecl :: { LConDeclField RdrName } + -- A list because of f,g :: Int + : maybe_docnext sig_vars '::' ctype maybe_docprev + { L (comb2 $2 $4) + (ConDeclField (reverse (unLoc $2)) $4 ($1 `mplus` $5)) } -- We allow the odd-looking 'inst_type' in a deriving clause, so that -- we can do deriving( forall a. C [a] ) in a newtype (GHC extension). -- The 'C [a]' part is converted to an HsPredTy by checkInstType -- We don't allow a context, but that's sorted out by the type checker. -deriving :: { Located (Maybe [LHsType RdrName]) } - : {- empty -} { noLoc Nothing } - | 'deriving' qtycon { let { L loc tv = $2 } - in sLL $1 $> (Just [L loc (HsTyVar tv)]) } - | 'deriving' '(' ')' { sLL $1 $> (Just []) } - | 'deriving' '(' inst_types1 ')' { sLL $1 $> (Just $3) } +deriving :: { Located (Maybe (Located [LHsType RdrName])) } + : {- empty -} { noLoc Nothing } + | 'deriving' qtycon + { let { L loc tv = $2 } + in sLL $1 $> (Just (sLL $1 $> [L loc (HsTyVar tv)])) } + | 'deriving' '(' ')' { sLL $1 $> (Just (noLoc [])) } + | 'deriving' '(' inst_types1 ')' { sLL $1 $> (Just (sLL $1 $> $3)) } -- Glasgow extension: allow partial -- applications in derivings @@ -1512,19 +1525,24 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } {% do s <- checkValSig $1 $3 ; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD s)) } | var ',' sig_vars '::' sigtypedoc - { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] } - | infix prec ops { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) - | n <- unLoc $3 ] } + { sLL $1 $> $ toOL [ sLL $1 $> $ SigD + (TypeSig ($1 : reverse (unLoc $3)) $5) ] } + | infix prec ops + { sLL $1 $> $ toOL [ sLL $1 $> $ SigD + (FixSig (FixitySig (unLoc $3) (Fixity $2 (unLoc $1)))) ] } + | pattern_synonym_sig { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 } + | '{-# INLINE' activation qvar '#-}' { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) } | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' { let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2 - in sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t inl_prag) - | t <- $5] } + in sLL $1 $> $ + toOL [ sLL $1 $> $ SigD (SpecSig $3 $5 inl_prag) ] } + | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2)) - | t <- $5] } + { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 $5 + (mkInlinePragma (getSPEC_INLINE $1) $2)) ] } | '{-# SPECIALISE' 'instance' inst_type '#-}' { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (SpecInstSig $3)) } -- A minimal complete definition @@ -1694,7 +1712,8 @@ aexp2 :: { LHsExpr RdrName } | '(' texp ')' { sLL $1 $> (HsPar $2) } | '(' tup_exprs ')' { sLL $1 $> (ExplicitTuple $2 Boxed) } - | '(#' texp '#)' { sLL $1 $> (ExplicitTuple [Present $2] Unboxed) } + | '(#' texp '#)' { sLL $1 $> (ExplicitTuple [L (getLoc $2) + (Present $2)] Unboxed) } | '(#' tup_exprs '#)' { sLL $1 $> (ExplicitTuple $2 Unboxed) } | '[' list ']' { sLL $1 $> (unLoc $2) } @@ -1773,19 +1792,20 @@ texp :: { LHsExpr RdrName } | exp '->' texp { sLL $1 $> $ EViewPat $1 $3 } -- Always at least one comma -tup_exprs :: { [HsTupArg RdrName] } - : texp commas_tup_tail { Present $1 : $2 } - | commas tup_tail { replicate $1 missingTupArg ++ $2 } +tup_exprs :: { [LHsTupArg RdrName] } + : texp commas_tup_tail { sL1 $1 (Present $1) : $2 } + | commas tup_tail { replicate $1 (noLoc missingTupArg) ++ $2 } -- Always starts with commas; always follows an expr -commas_tup_tail :: { [HsTupArg RdrName] } -commas_tup_tail : commas tup_tail { replicate ($1-1) missingTupArg ++ $2 } +commas_tup_tail :: { [LHsTupArg RdrName] } +commas_tup_tail : commas tup_tail + { replicate ($1-1) (noLoc missingTupArg) ++ $2 } -- Always follows a comma -tup_tail :: { [HsTupArg RdrName] } - : texp commas_tup_tail { Present $1 : $2 } - | texp { [Present $1] } - | {- empty -} { [missingTupArg] } +tup_tail :: { [LHsTupArg RdrName] } + : texp commas_tup_tail { sL1 $1 (Present $1) : $2 } + | texp { [sL1 $1 $ Present $1] } + | {- empty -} { [noLoc missingTupArg] } ----------------------------------------------------------------------------- -- List expressions @@ -1993,22 +2013,22 @@ qual :: { LStmt RdrName (LHsExpr RdrName) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } +fbinds :: { ([LHsRecField RdrName (LHsExpr RdrName)], Bool) } : fbinds1 { $1 } | {- empty -} { ([], False) } -fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } +fbinds1 :: { ([LHsRecField RdrName (LHsExpr RdrName)], Bool) } : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) } | fbind { ([$1], False) } | '..' { ([], True) } -fbind :: { HsRecField RdrName (LHsExpr RdrName) } - : qvar '=' texp { HsRecField $1 $3 False } +fbind :: { LHsRecField RdrName (LHsExpr RdrName) } + : qvar '=' texp { sLL $1 $> $ HsRecField $1 $3 False } -- RHS is a 'texp', allowing view patterns (Trac #6038) -- and, incidentaly, sections. Eg -- f (R { x = show -> s }) = ... - | qvar { HsRecField $1 placeHolderPunRhs True } + | qvar { sLL $1 $> $ HsRecField $1 placeHolderPunRhs True } -- In the punning case, use a place-holder -- The renamer fills in the final value @@ -2419,7 +2439,7 @@ sL span a = span `seq` a `seq` L span a sL0 = L noSrcSpan -- #define L0 L noSrcSpan {-# INLINE sL1 #-} -sL1 x = sL (getLoc x) -- #define L1 sL (getLoc $1) +sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sLL #-} sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index e57af70e99..eb15b81133 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -121,12 +121,12 @@ mkInstD (L loc d) = L loc (InstD d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Located [Located (FunDep RdrName)] - -> Located (OrdList (LHsDecl RdrName)) + -> OrdList (LHsDecl RdrName) -> P (LTyClDecl RdrName) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls - = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs (unLoc where_cls) - ; let cxt = fromMaybe (noLoc []) mcxt + = do { let (binds, sigs, ats, at_insts, _, docs) = cvBindsAndSigs where_cls + cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams) <- checkTyClHdr tycl_hdr ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams ; at_defs <- mapM (eitherToP . mkATDefault) at_insts @@ -152,11 +152,11 @@ mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) mkTyData :: SrcSpan -> NewOrData - -> Maybe CType + -> Maybe (Located CType) -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] - -> Maybe [LHsType RdrName] + -> Maybe (Located [LHsType RdrName]) -> P (LTyClDecl RdrName) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr @@ -167,11 +167,11 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv tcdFVs = placeHolderNames })) } mkDataDefn :: NewOrData - -> Maybe CType + -> Maybe (Located CType) -> Maybe (LHsContext RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] - -> Maybe [LHsType RdrName] + -> Maybe (Located [LHsType RdrName]) -> P (HsDataDefn RdrName) mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt @@ -203,11 +203,11 @@ mkTyFamInstEqn lhs rhs mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe CType + -> Maybe (Located CType) -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] - -> Maybe [LHsType RdrName] + -> Maybe (Located [LHsType RdrName]) -> P (LInstDecl RdrName) mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr @@ -458,7 +458,7 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) = mkDeprecatedGadtRecordDecl :: SrcSpan -> Located RdrName - -> [ConDeclField RdrName] + -> [LConDeclField RdrName] -> LHsType RdrName -> P (LConDecl RdrName) -- This one uses the deprecated syntax @@ -467,7 +467,7 @@ mkDeprecatedGadtRecordDecl :: SrcSpan mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty = do { data_con <- tyConToDataCon con_loc con ; return (L loc (ConDecl { con_old_rec = True - , con_name = data_con + , con_names = [data_con] , con_explicit = Implicit , con_qvars = mkHsQTvs [] , con_cxt = noLoc [] @@ -481,7 +481,7 @@ mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName] mkSimpleConDecl name qvars cxt details = ConDecl { con_old_rec = False - , con_name = name + , con_names = [name] , con_explicit = Explicit , con_qvars = mkHsQTvs qvars , con_cxt = cxt @@ -491,22 +491,22 @@ mkSimpleConDecl name qvars cxt details mkGadtDecl :: [Located RdrName] -> LHsType RdrName -- Always a HsForAllTy - -> [ConDecl RdrName] + -> ConDecl RdrName -- We allow C,D :: ty -- and expand it as if it had been -- C :: ty; D :: ty -- (Just like type signatures in general.) mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau)) - = [mk_gadt_con name | name <- names] + = mk_gadt_con names where (details, res_ty) -- See Note [Sorting out the result type] = case tau of L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty) _other -> (PrefixCon [], tau) - mk_gadt_con name + mk_gadt_con names = ConDecl { con_old_rec = False - , con_name = name + , con_names = names , con_explicit = imp , con_qvars = qvars , con_cxt = cxt @@ -726,7 +726,8 @@ checkAPat msg loc e0 = do return (PArrPat ps placeHolderType) ExplicitTuple es b - | all tupArgPresent es -> do ps <- mapM (checkLPat msg) [e | Present e <- es] + | all tupArgPresent es -> do ps <- mapM (checkLPat msg) + [e | L _ (Present e) <- es] return (TuplePat ps b []) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) @@ -748,9 +749,10 @@ plus_RDR = mkUnqual varName (fsLit "+") -- Hack bang_RDR = mkUnqual varName (fsLit "!") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") -checkPatField :: SDoc -> HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName)) -checkPatField msg fld = do p <- checkLPat msg (hsRecFieldArg fld) - return (fld { hsRecFieldArg = p }) +checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName) + -> P (LHsRecField RdrName (LPat RdrName)) +checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) + return (L l (fld { hsRecFieldArg = p })) patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a patFail msg loc e = parseErrorSDoc loc err @@ -771,12 +773,12 @@ checkValDef msg lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding = checkPatBind msg (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss -checkValDef msg lhs opt_sig grhss +checkValDef msg lhs opt_sig g@(L l grhss) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats) -> checkFunBind msg (getLoc lhs) - fun is_infix pats opt_sig grhss - Nothing -> checkPatBind msg lhs grhss } + fun is_infix pats opt_sig (L l grhss) + Nothing -> checkPatBind msg lhs g } checkFunBind :: SDoc -> SrcSpan @@ -1036,7 +1038,7 @@ checkPrecP (L l i) mkRecConstrOrUpdate :: LHsExpr RdrName -> SrcSpan - -> ([HsRecField RdrName (LHsExpr RdrName)], Bool) + -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool) -> P (HsExpr RdrName) mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) @@ -1045,7 +1047,7 @@ mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) mkRecConstrOrUpdate exp _ (fs,dd) = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) -mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg +mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } @@ -1070,30 +1072,34 @@ mkInlinePragma (inl, match_info) mb_act -- construct a foreign import declaration -- -mkImport :: CCallConv - -> Safety +mkImport :: Located CCallConv + -> Located Safety -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkImport cconv safety (L loc entity, v, ty) +mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty) | cconv == PrimCallConv = do let funcTarget = CFunction (StaticTarget entity Nothing True) - importSpec = CImport PrimCallConv safety Nothing funcTarget + importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget + (L loc entity) return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | cconv == JavaScriptCallConv = do let funcTarget = CFunction (StaticTarget entity Nothing True) - importSpec = CImport JavaScriptCallConv safety Nothing funcTarget + importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing + funcTarget (L loc entity) return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | otherwise = do - case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of + case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v)) + (unpackFS entity) (L loc entity) of Nothing -> parseErrorSDoc loc (text "Malformed entity string") Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) -- the string "foo" is ambigous: either a header or a C identifier. The -- C identifier case comes first in the alternatives below, so we pick -- that one. -parseCImport :: CCallConv -> Safety -> FastString -> String +parseCImport :: Located CCallConv -> Located Safety -> FastString -> String + -> Located FastString -> Maybe ForeignImport -parseCImport cconv safety nm str = +parseCImport cconv safety nm str sourceText = listToMaybe $ map fst $ filter (null.snd) $ readP_to_S parse str where @@ -1118,7 +1124,7 @@ parseCImport cconv safety nm str = | id_char c -> pfail _ -> return () - mk = CImport cconv safety + mk h n = CImport cconv safety h n sourceText hdr_char c = not (isSpace c) -- header files are filenames, which can contain -- pretty much any char (depending on the platform), @@ -1128,7 +1134,7 @@ parseCImport cconv safety nm str = cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) +++ (do isFun <- case cconv of - CApiConv -> + L _ CApiConv -> option True (do token "value" skipSpaces @@ -1145,11 +1151,12 @@ parseCImport cconv safety nm str = -- construct a foreign export declaration -- -mkExport :: CCallConv +mkExport :: Located CCallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkExport cconv (L _ entity, v, ty) = return $ - ForD (ForeignExport v ty noForeignExportCoercionYet (CExport (CExportStatic entity' cconv))) +mkExport (L lc cconv) (L le entity, v, ty) = return $ + ForD (ForeignExport v ty noForeignExportCoercionYet + (CExport (L lc (CExportStatic entity' cconv)) (L le entity))) where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity @@ -1166,16 +1173,16 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) -------------------------------------------------------------------------------- -- Help with module system imports/exports -data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [ RdrName ] +data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [Located RdrName] -mkModuleImpExp :: RdrName -> ImpExpSubSpec -> IE RdrName -mkModuleImpExp name subs = +mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> IE RdrName +mkModuleImpExp n@(L l name) subs = case subs of ImpExpAbs - | isVarNameSpace (rdrNameSpace name) -> IEVar name + | isVarNameSpace (rdrNameSpace name) -> IEVar n | otherwise -> IEThingAbs nameT - ImpExpAll -> IEThingAll nameT - ImpExpList xs -> IEThingWith nameT xs + ImpExpAll -> IEThingAll (L l nameT) + ImpExpList xs -> IEThingWith (L l nameT) xs where nameT = setRdrNameSpace name tcClsName diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index e0f5d0a906..99040e7309 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -385,9 +385,13 @@ rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv -makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls +makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls where - add_one env (L loc (FixitySig (L name_loc name) fixity)) = do + add_one_sig env (L loc (FixitySig names fixity)) = + foldlM add_one env [ (loc,name_loc,name,fixity) + | L name_loc name <- names ] + + add_one env (loc, name_loc, name,fixity) = do { -- this fixity decl is a duplicate iff -- the ReaderName's OccName's FastString is already in the env -- (we only need to check the local fix_env because @@ -821,20 +825,25 @@ renameSig _ (SpecInstSig ty) -- so, in the top-level case (when mb_names is Nothing) -- we use lookupOccRn. If there's both an imported and a local 'f' -- then the SPECIALISE pragma is ambiguous, unlike all other signatures -renameSig ctxt sig@(SpecSig v ty inl) +renameSig ctxt sig@(SpecSig v tys inl) = do { new_v <- case ctxt of TopSigCtxt {} -> lookupLocatedOccRn v _ -> lookupSigOccRn ctxt sig v - ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty + -- ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty + ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys ; return (SpecSig new_v new_ty inl, fvs) } + where + do_one (tys,fvs) ty + = do { (new_ty, fvs_ty) <- rnHsSigType (quotes (ppr v)) ty + ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } renameSig ctxt sig@(InlineSig v s) = do { new_v <- lookupSigOccRn ctxt sig v ; return (InlineSig new_v s, emptyFVs) } -renameSig ctxt sig@(FixSig (FixitySig v f)) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (FixSig (FixitySig new_v f), emptyFVs) } +renameSig ctxt sig@(FixSig (FixitySig vs f)) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; return (FixSig (FixitySig new_vs f), emptyFVs) } renameSig ctxt sig@(MinimalSig bf) = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf @@ -912,7 +921,7 @@ findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]] findDupSigs sigs = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) where - expand_sig sig@(FixSig (FixitySig n _)) = [(n,sig)] + expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig) expand_sig sig@(InlineSig n _) = [(n,sig)] expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns] expand_sig sig@(GenericSig ns _) = [(n,sig) | n <- ns] diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 0a73585976..28f54c82ea 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1855,7 +1855,7 @@ data HsDocContext | TyDataCtx (Located RdrName) | TySynCtx (Located RdrName) | TyFamilyCtx (Located RdrName) - | ConDeclCtx (Located RdrName) + | ConDeclCtx [Located RdrName] | ClassDeclCtx (Located RdrName) | ExprWithTySigCtx | TypBrCtx @@ -1878,7 +1878,12 @@ docOfHsDocContext (RuleCtx name) = text "In the transformation rule" <+> ftext n docOfHsDocContext (TyDataCtx tycon) = text "In the data type declaration for" <+> quotes (ppr tycon) docOfHsDocContext (TySynCtx name) = text "In the declaration for type synonym" <+> quotes (ppr name) docOfHsDocContext (TyFamilyCtx name) = text "In the declaration for type family" <+> quotes (ppr name) -docOfHsDocContext (ConDeclCtx name) = text "In the definition of data constructor" <+> quotes (ppr name) + +docOfHsDocContext (ConDeclCtx [name]) + = text "In the definition of data constructor" <+> quotes (ppr name) +docOfHsDocContext (ConDeclCtx names) + = text "In the definition of data constructors" <+> interpp'SP names + docOfHsDocContext (ClassDeclCtx name) = text "In the declaration for class" <+> ppr name docOfHsDocContext ExprWithTySigCtx = text "In an expression type signature" docOfHsDocContext TypBrCtx = ptext (sLit "In a Template-Haskell quoted type") diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index b24956c85e..98b1358594 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -241,8 +241,10 @@ rnExpr (ExplicitTuple tup_args boxity) ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) } where - rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) } - rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs) + rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e + ; return (L l (Present e'), fvs) } + rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType) + , emptyFVs) rnExpr (RecordCon con_id _ rbinds) = do { conname <- lookupLocatedOccRn con_id @@ -372,8 +374,8 @@ rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd }) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, fvs `plusFV` plusFVs fvss) } where - rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) - ; return (fld { hsRecFieldArg = arg' }, fvs) } + rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } \end{code} @@ -1288,7 +1290,7 @@ okPArrStmt dflags _ stmt LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) --------- -checkTupleSection :: [HsTupArg RdrName] -> RnM () +checkTupleSection :: [LHsTupArg RdrName] -> RnM () checkTupleSection args = do { tuple_section <- xoptM Opt_TupleSections ; checkErr (all tupArgPresent args || tuple_section) msg } diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 51c71b083a..c3e8c7033f 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -227,7 +227,7 @@ rnImportDecl this_mod -- True <=> import M () import_all = case imp_details of - Just (is_hiding, ls) -> not is_hiding && null ls + Just (is_hiding, L _ ls) -> not is_hiding && null ls _ -> False -- should the import be safe? @@ -613,18 +613,19 @@ Note that the imp_occ_env will have entries for data constructors too, although we never look up data constructors. \begin{code} -filterImports :: ModIface - -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, [LIE RdrName]) -- Import spec; True => hiding - -> RnM (Maybe (Bool, [LIE Name]), -- Import spec w/ Names - [GlobalRdrElt]) -- Same again, but in GRE form +filterImports + :: ModIface + -> ImpDeclSpec -- The span for the entire import decl + -> Maybe (Bool, Located [LIE RdrName]) -- Import spec; True => hiding + -> RnM (Maybe (Bool, Located [LIE Name]), -- Import spec w/ Names + [GlobalRdrElt]) -- Same again, but in GRE form filterImports iface decl_spec Nothing = return (Nothing, gresFromAvails prov (mi_exports iface)) where prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }] -filterImports iface decl_spec (Just (want_hiding, import_items)) +filterImports iface decl_spec (Just (want_hiding, L l import_items)) = do -- check for errors, convert RdrNames to Names items1 <- mapM lookup_lie import_items @@ -641,7 +642,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) gres | want_hiding = gresFromAvails hiding_prov pruned_avails | otherwise = concatMap (gresFromIE decl_spec) items2 - return (Just (want_hiding, map fst items2), gres) + return (Just (want_hiding, L l (map fst items2)), gres) where all_avails = mi_exports iface @@ -709,22 +710,23 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) lookup_ie ie = handle_bad_import $ do case ie of - IEVar n -> do + IEVar (L l n) -> do (name, avail, _) <- lookup_name n - return ([(IEVar name, trimAvail avail name)], []) + return ([(IEVar (L l name), trimAvail avail name)], []) - IEThingAll tc -> do + IEThingAll (L l tc) -> do (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc let warns | null (drop 1 subs) = [DodgyImport tc] | not (is_qual decl_spec) = [MissingImportList] | otherwise = [] case mb_parent of -- non-associated ty/cls - Nothing -> return ([(IEThingAll name, avail)], warns) + Nothing -> return ([(IEThingAll (L l name), avail)], warns) -- associated ty - Just parent -> return ([(IEThingAll name, + Just parent -> return ([(IEThingAll (L l name), AvailTC name2 (subs \\ [name])), - (IEThingAll name, AvailTC parent [name])], + (IEThingAll (L l name), + AvailTC parent [name])], warns) IEThingAbs tc @@ -741,7 +743,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -> do nameAvail <- lookup_name tc return ([mkIEThingAbs nameAvail], []) - IEThingWith rdr_tc rdr_ns -> do + IEThingWith (L l rdr_tc) rdr_ns -> do (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc -- Look up the children in the sub-names of the parent @@ -758,13 +760,13 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) case mb_parent of -- non-associated ty/cls - Nothing -> return ([(IEThingWith name children, - AvailTC name (name:children))], + Nothing -> return ([(IEThingWith (L l name) children, + AvailTC name (name:map unLoc children))], []) -- associated ty - Just parent -> return ([(IEThingWith name children, - AvailTC name children), - (IEThingWith name children, + Just parent -> return ([(IEThingWith (L l name) children, + AvailTC name (map unLoc children)), + (IEThingWith (L l name) children, AvailTC parent [name])], []) @@ -860,8 +862,8 @@ gresFromIE decl_spec (L loc ie, avail) = gresFromAvail prov_fn avail where is_explicit = case ie of - IEThingAll name -> \n -> n == name - _ -> \_ -> True + IEThingAll (L _ name) -> \n -> n == name + _ -> \_ -> True prov_fn name = Imported [imp_spec] where imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec } @@ -876,7 +878,7 @@ mkChildEnv gres = foldr add emptyNameEnv gres findChildren :: NameEnv [Name] -> Name -> [Name] findChildren env n = lookupNameEnv env n `orElse` [] -lookupChildren :: [Name] -> [RdrName] -> [Maybe Name] +lookupChildren :: [Name] -> [Located RdrName] -> [Maybe (Located Name)] -- (lookupChildren all_kids rdr_items) maps each rdr_item to its -- corresponding Name all_kids, if the former exists -- The matching is done by FastString, not OccName, so that @@ -885,8 +887,13 @@ lookupChildren :: [Name] -> [RdrName] -> [Maybe Name] -- the RdrName for AssocTy may have a (bogus) DataName namespace -- (Really the rdr_items should be FastStrings in the first place.) lookupChildren all_kids rdr_items - = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items + -- = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items + = map doOne rdr_items where + doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of + Just n -> Just (L l n) + Nothing -> Nothing + kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids] -- | Combines 'AvailInfo's from the same family @@ -964,7 +971,7 @@ type ExportOccMap = OccEnv (Name, IE RdrName) -- that have the same occurrence name rnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe [LIE RdrName] -- Nothing => no explicit export list + -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list -> TcGblEnv -> RnM TcGblEnv @@ -991,7 +998,8 @@ rnExports explicit_mod exports ; let real_exports | explicit_mod = exports | ghcLink dflags == LinkInMemory = Nothing - | otherwise = Just [noLoc (IEVar main_RDR_Unqual)] + | otherwise + = Just (noLoc [noLoc (IEVar (noLoc main_RDR_Unqual))]) -- ToDo: the 'noLoc' here is unhelpful if 'main' -- turns out to be out of scope @@ -1007,7 +1015,7 @@ rnExports explicit_mod exports tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet final_avails) }) } -exports_from_avail :: Maybe [LIE RdrName] +exports_from_avail :: Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list -> GlobalRdrEnv -> ImportAvails @@ -1024,9 +1032,8 @@ exports_from_avail Nothing rdr_env _imports _this_mod in return (Nothing, avails) -exports_from_avail (Just rdr_items) rdr_env imports this_mod +exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items - return (Just ie_names, exports) where do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum @@ -1041,8 +1048,9 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum exports_from_item acc@(ie_names, occs, exports) - (L loc (IEModuleContents mod)) - | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ] + (L loc (IEModuleContents (L lm mod))) + | let earlier_mods = [ mod + | (L _ (IEModuleContents (L _ mod))) <- ie_names ] , mod `elem` earlier_mods -- Duplicate export of M = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ; warnIf warn_dup_exports (dupModuleExport mod) ; @@ -1067,7 +1075,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod -- The qualified and unqualified version of all of -- these names are, in effect, used by this export - ; occs' <- check_occs (IEModuleContents mod) occs names + ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names -- This check_occs not only finds conflicts -- between this item and others, but also -- internally within this item. That is, if @@ -1076,7 +1084,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod -- OccName. ; traceRn (vcat [ text "export mod" <+> ppr mod , ppr new_exports ]) - ; return (L loc (IEModuleContents mod) : ie_names, + ; return (L loc (IEModuleContents (L lm mod)) : ie_names, occs', new_exports ++ exports) } exports_from_item acc@(lie_names, occs, exports) (L loc ie) @@ -1096,9 +1104,9 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod ------------- lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo) - lookup_ie (IEVar rdr) + lookup_ie (IEVar (L l rdr)) = do gre <- lookupGreRn rdr - return (IEVar (gre_name gre), greExportAvail gre) + return (IEVar (L l (gre_name gre)), greExportAvail gre) lookup_ie (IEThingAbs rdr) = do gre <- lookupGreRn rdr @@ -1106,7 +1114,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod avail = greExportAvail gre return (IEThingAbs name, avail) - lookup_ie ie@(IEThingAll rdr) + lookup_ie ie@(IEThingAll (L l rdr)) = do name <- lookupGlobalOccRn rdr let kids = findChildren kids_env name addUsedKids rdr kids @@ -1118,20 +1126,21 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) - return (IEThingAll name, AvailTC name (name:kids)) + return (IEThingAll (L l name), AvailTC name (name:kids)) - lookup_ie ie@(IEThingWith rdr sub_rdrs) + lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs) = do name <- lookupGlobalOccRn rdr if isUnboundName name - then return (IEThingWith name [], AvailTC name [name]) + then return (IEThingWith (L l name) [], AvailTC name [name]) else do let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs if any isNothing mb_names then do addErr (exportItemErr ie) - return (IEThingWith name [], AvailTC name [name]) + return (IEThingWith (L l name) [], AvailTC name [name]) else do let names = catMaybes mb_names - addUsedKids rdr names - return (IEThingWith name names, AvailTC name (name:names)) + addUsedKids rdr (map unLoc names) + return (IEThingWith (L l name) names + , AvailTC name (name:map unLoc names)) lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier @@ -1238,7 +1247,7 @@ dupExport_ok n ie1 ie2 || (explicit_in ie1 && explicit_in ie2) ) where explicit_in (IEModuleContents _) = False -- module M - explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc r -- T(..) + explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc (unLoc r) -- T(..) explicit_in _ = True single (IEVar {}) = True @@ -1254,7 +1263,7 @@ dupExport_ok n ie1 ie2 %********************************************************* \begin{code} -reportUnusedNames :: Maybe [LIE RdrName] -- Export list +reportUnusedNames :: Maybe (Located [LIE RdrName]) -- Export list -> TcGblEnv -> RnM () reportUnusedNames _export_decls gbl_env = do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env))) @@ -1381,15 +1390,17 @@ findImportUsage imports rdr_env rdrs unused_imps -- Not trivial; see eg Trac #7454 = case imps of - Just (False, imp_ies) -> foldr (add_unused . unLoc) emptyNameSet imp_ies + Just (False, L _ imp_ies) -> + foldr (add_unused . unLoc) emptyNameSet imp_ies _other -> emptyNameSet -- No explicit import list => no unused-name list add_unused :: IE Name -> NameSet -> NameSet - add_unused (IEVar n) acc = add_unused_name n acc - add_unused (IEThingAbs n) acc = add_unused_name n acc - add_unused (IEThingAll n) acc = add_unused_all n acc - add_unused (IEThingWith p ns) acc = add_unused_with p ns acc - add_unused _ acc = acc + add_unused (IEVar (L _ n)) acc = add_unused_name n acc + add_unused (IEThingAbs n) acc = add_unused_name n acc + add_unused (IEThingAll (L _ n)) acc = add_unused_all n acc + add_unused (IEThingWith (L _ p) ns) acc + = add_unused_with p (map unLoc ns) acc + add_unused _ acc = acc add_unused_name n acc | n `elemNameSet` used_names = acc @@ -1447,10 +1458,10 @@ extendImportMap rdr_env rdr imp_map \begin{code} warnUnusedImport :: ImportDeclUsage -> RnM () warnUnusedImport (L loc decl, used, unused) - | Just (False,[]) <- ideclHiding decl + | Just (False,L _ []) <- ideclHiding decl = return () -- Do not warn for 'import M()' - | Just (True, hides) <- ideclHiding decl + | Just (True, L _ hides) <- ideclHiding decl , not (null hides) , pRELUDE_NAME == unLoc (ideclName decl) = return () -- Note [Do not warn about Prelude hiding] @@ -1527,7 +1538,7 @@ printMinimalImports imports_w_usage , ideclPkgQual = mb_pkg } = decl ; iface <- loadSrcInterface doc mod_name is_boot mb_pkg ; let lies = map (L l) (concatMap (to_ie iface) used) - ; return (L l (decl { ideclHiding = Just (False, lies) })) } + ; return (L l (decl { ideclHiding = Just (False, L l lies) })) } where doc = text "Compute minimal imports for" <+> ppr decl @@ -1536,7 +1547,7 @@ printMinimalImports imports_w_usage -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. to_ie _ (Avail n) - = [IEVar n] + = [IEVar (noLoc n)] to_ie _ (AvailTC n [m]) | n==m = [IEThingAbs n] to_ie iface (AvailTC n ns) @@ -1544,9 +1555,10 @@ printMinimalImports imports_w_usage , x == n , x `elem` xs -- Note [Partial export] ] of - [xs] | all_used xs -> [IEThingAll n] - | otherwise -> [IEThingWith n (filter (/= n) ns)] - _other -> map IEVar ns + [xs] | all_used xs -> [IEThingAll (noLoc n)] + | otherwise -> [IEThingWith (noLoc n) + (map noLoc (filter (/= n) ns))] + _other -> map (IEVar . noLoc) ns where all_used avail_occs = all (`elem` ns) avail_occs \end{code} @@ -1640,7 +1652,8 @@ dodgyExportWarn item = dodgyMsg (ptext (sLit "export")) item dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc dodgyMsg kind tc - = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item") <+> quotes (ppr (IEThingAll tc)) + = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item") + <+> quotes (ppr (IEThingAll (noLoc tc))) <+> ptext (sLit "suggests that"), quotes (ppr tc) <+> ptext (sLit "has (in-scope) constructors or class methods,"), ptext (sLit "but it has none") ] diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index d80b05e4b5..4b9fe62b0a 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -491,9 +491,9 @@ rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) ; flds' <- mapM rn_field (flds `zip` [1..]) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where - rn_field (fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') - (hsRecFieldArg fld) - ; return (fld { hsRecFieldArg = arg' }) } + rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') + (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldArg = arg' })) } -- Suppress unused-match reporting for fields introduced by ".." nested_mk Nothing mk _ = mk @@ -519,7 +519,7 @@ rnHsRecFields HsRecFieldContext -> (RdrName -> arg) -- When punning, use this to build a new field -> HsRecFields RdrName (Located arg) - -> RnM ([HsRecField Name (Located arg)], FreeVars) + -> RnM ([LHsRecField Name (Located arg)], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation) @@ -560,23 +560,23 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) Nothing -> ptext (sLit "constructor field name") Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con) - rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld - , hsRecFieldArg = arg - , hsRecPun = pun }) + rn_fld pun_ok parent (L l (HsRecField { hsRecFieldId = fld + , hsRecFieldArg = arg + , hsRecPun = pun })) = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld ; arg' <- if pun then do { checkErr pun_ok (badPun fld) ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) } else return arg - ; return (HsRecField { hsRecFieldId = fld' - , hsRecFieldArg = arg' - , hsRecPun = pun }) } + ; return (L l (HsRecField { hsRecFieldId = fld' + , hsRecFieldArg = arg' + , hsRecPun = pun })) } rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat -> Maybe Name -- The constructor (Nothing for an update -- or out of scope constructor) - -> [HsRecField Name (Located arg)] -- Explicit fields - -> RnM [HsRecField Name (Located arg)] -- Filled in .. fields + -> [LHsRecField Name (Located arg)] -- Explicit fields + -> RnM [LHsRecField Name (Located arg)] -- Filled in .. fields rn_dotdot Nothing _mb_con _flds -- No ".." at all = return [] rn_dotdot (Just {}) Nothing _flds -- ".." on record update @@ -619,10 +619,10 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) _other -> True ] ; addUsedRdrNames (map greRdrName dot_dot_gres) - ; return [ HsRecField + ; return [ L loc (HsRecField { hsRecFieldId = L loc fld , hsRecFieldArg = L loc (mk_arg arg_rdr) - , hsRecPun = False } + , hsRecPun = False }) | gre <- dot_dot_gres , let fld = gre_name gre arg_rdr = mkRdrUnqual (nameOccName fld) ] } @@ -654,8 +654,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) -- Each list in dup_fields is non-empty (_, dup_flds) = removeDups compare (getFieldIds flds) -getFieldIds :: [HsRecField id arg] -> [id] -getFieldIds flds = map (unLoc . hsRecFieldId) flds +getFieldIds :: [LHsRecField id arg] -> [id] +getFieldIds flds = map (unLoc . hsRecFieldId . unLoc) flds needFlagDotDot :: HsRecFieldContext -> SDoc needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt, diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 8b8eff3fa4..80db79ac72 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -273,12 +273,17 @@ rnSrcFixityDecls bndr_set fix_decls -- for con-like things; hence returning a list -- If neither are in scope, report an error; otherwise -- return a fixity sig for each (slightly odd) - rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) + rn_decl (L loc (FixitySig fnames fixity)) + = do names <- mapM lookup_one fnames + return [ L loc (FixitySig name fixity) + | name <- names ] + + lookup_one :: Located RdrName -> RnM [Located Name] + lookup_one (L name_loc rdr_name) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local do names <- lookupLocalTcNames sig_ctxt what rdr_name - return [ L loc (FixitySig (L name_loc name) fixity) - | name <- names ] + return [ L name_loc name | name <- names ] what = ptext (sLit "fixity signature") \end{code} @@ -405,8 +410,8 @@ rnHsForeignDecl (ForeignExport name ty _ spec) -- know where they're from. -- patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport -patchForeignImport packageKey (CImport cconv safety fs spec) - = CImport cconv safety fs (patchCImportSpec packageKey spec) +patchForeignImport packageKey (CImport cconv safety fs spec src) + = CImport cconv safety fs (patchCImportSpec packageKey spec) src patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec patchCImportSpec packageKey spec @@ -683,18 +688,18 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) ; checkDupRdrNames rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc - ; bindHsRuleVars rule_name vars names $ \ vars' -> + ; bindHsRuleVars (unLoc rule_name) vars names $ \ vars' -> do { (lhs', fv_lhs') <- rnLExpr lhs ; (rhs', fv_rhs') <- rnLExpr rhs - ; checkValidRule rule_name names lhs' fv_lhs' + ; checkValidRule (unLoc rule_name) names lhs' fv_lhs' ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', fv_lhs' `plusFV` fv_rhs') } } where - get_var (RuleBndrSig v _) = v - get_var (RuleBndr v) = v + get_var (L _ (RuleBndrSig v _)) = v + get_var (L _ (RuleBndr v)) = v -bindHsRuleVars :: RuleName -> [RuleBndr RdrName] -> [Name] - -> ([RuleBndr Name] -> RnM (a, FreeVars)) +bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name] + -> ([LRuleBndr Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) bindHsRuleVars rule_name vars names thing_inside = go vars names $ \ vars' -> @@ -702,14 +707,14 @@ bindHsRuleVars rule_name vars names thing_inside where doc = RuleCtx rule_name - go (RuleBndr (L loc _) : vars) (n : ns) thing_inside + go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside = go vars ns $ \ vars' -> - thing_inside (RuleBndr (L loc n) : vars') + thing_inside (L l (RuleBndr (L loc n)) : vars') - go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside + go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside = rnHsBndrSig doc bsig $ \ bsig' -> go vars ns $ \ vars' -> - thing_inside (RuleBndrSig (L loc n) bsig' : vars') + thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) @@ -1106,8 +1111,7 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType -- data T a where { T1 :: forall b. b-> b } ; let { zap_lcl_env | h98_style = \ thing -> thing | otherwise = setLocalRdrEnv emptyLocalRdrEnv } - ; (condecls', con_fvs) <- zap_lcl_env $ - rnConDecls condecls + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls -- No need to check for duplicate constructor decls -- since that is done by RnNames.extendGlobalRdrEnvRn @@ -1115,17 +1119,18 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType con_fvs `plusFV` sig_fvs ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType , dd_ctxt = context', dd_kindSig = sig' - , dd_cons = condecls', dd_derivs = derivs' } + , dd_cons = condecls' + , dd_derivs = derivs' } , all_fvs ) } where - h98_style = case condecls of -- Note [Stupid theta] + h98_style = case condecls of -- Note [Stupid theta] L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False _ -> True rn_derivs Nothing = return (Nothing, emptyFVs) - rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes doc ds - ; return (Just ds', fvs) } + rn_derivs (Just (L ld ds)) = do { (ds', fvs) <- rnLHsTypes doc ds + ; return (Just (L ld ds'), fvs) } badGadtStupidTheta :: HsDocContext -> SDoc badGadtStupidTheta _ @@ -1187,18 +1192,18 @@ depAnalTyClDecls ds_w_fvs assoc_env :: NameEnv Name -- Maps a data constructor back -- to its parent type constructor - assoc_env = mkNameEnv assoc_env_list + assoc_env = mkNameEnv $ concat assoc_env_list assoc_env_list = do (L _ d, _) <- ds_w_fvs case d of ClassDecl { tcdLName = L _ cls_name , tcdATs = ats } -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats - return (fam_name, cls_name) + return [(fam_name, cls_name)] DataDecl { tcdLName = L _ data_name , tcdDataDefn = HsDataDefn { dd_cons = cons } } -> do L _ dc <- cons - return (unLoc (con_name dc), data_name) + return $ zip (map unLoc $ con_names dc) (repeat data_name) _ -> [] \end{code} @@ -1265,13 +1270,13 @@ rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) rnConDecls = mapFvRn (wrapLocFstM rnConDecl) rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) -rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs +rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs , con_cxt = lcxt@(L loc cxt), con_details = details , con_res = res_ty, con_doc = mb_doc , con_old_rec = old_rec, con_explicit = expl }) - = do { addLocM checkConName name + = do { mapM_ (addLocM checkConName) names ; when old_rec (addWarn (deprecRecSyntax decl)) - ; new_name <- lookupLocatedTopBndrRn name + ; new_names <- mapM lookupLocatedTopBndrRn names -- For H98 syntax, the tvs are the existential ones -- For GADT syntax, the tvs are all the quantified tyvars @@ -1299,21 +1304,23 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do { (new_context, fvs1) <- rnContext doc lcxt ; (new_details, fvs2) <- rnConDeclDetails doc details - ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty - ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context - , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }, + ; (new_details', new_res_ty, fvs3) + <- rnConResult doc (map unLoc new_names) new_details res_ty + ; return (decl { con_names = new_names, con_qvars = new_tyvars + , con_cxt = new_context, con_details = new_details' + , con_res = new_res_ty, con_doc = mb_doc' }, fvs1 `plusFV` fvs2 `plusFV` fvs3) }} where - doc = ConDeclCtx name + doc = ConDeclCtx names get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) -rnConResult :: HsDocContext -> Name - -> HsConDetails (LHsType Name) [ConDeclField Name] +rnConResult :: HsDocContext -> [Name] + -> HsConDetails (LHsType Name) [LConDeclField Name] -> ResType (LHsType RdrName) - -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], + -> RnM (HsConDetails (LHsType Name) [LConDeclField Name], ResType (LHsType Name), FreeVars) rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs) -rnConResult doc con details (ResTyGADT ty) +rnConResult doc _con details (ResTyGADT ty) = do { (ty', fvs) <- rnLHsType doc ty ; let (arg_tys, res_ty) = splitHsFunType ty' -- We can finally split it up, @@ -1328,19 +1335,12 @@ rnConResult doc con details (ResTyGADT ty) (addErr (badRecResTy (docOfHsDocContext doc))) ; return (details, ResTyGADT res_ty, fvs) } - PrefixCon {} | isSymOcc (getOccName con) -- See Note [Infix GADT cons] - , [ty1,ty2] <- arg_tys - -> do { fix_env <- getFixityEnv - ; return (if con `elemNameEnv` fix_env - then InfixCon ty1 ty2 - else PrefixCon arg_tys - , ResTyGADT res_ty, fvs) } - | otherwise - -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) } - -rnConDeclDetails :: HsDocContext - -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] - -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], FreeVars) + PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) } + +rnConDeclDetails + :: HsDocContext + -> HsConDetails (LHsType RdrName) [LConDeclField RdrName] + -> RnM (HsConDetails (LHsType Name) [LConDeclField Name], FreeVars) rnConDeclDetails doc (PrefixCon tys) = do { (new_tys, fvs) <- rnLHsTypes doc tys ; return (PrefixCon new_tys, fvs) } @@ -1359,7 +1359,7 @@ rnConDeclDetails doc (RecCon fields) ------------------------------------------------- deprecRecSyntax :: ConDecl RdrName -> SDoc deprecRecSyntax decl - = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl)) + = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_names decl)) <+> ptext (sLit "uses deprecated syntax") , ptext (sLit "Instead, use the form") , nest 2 (ppr decl) ] -- Pretty printer uses new form @@ -1368,19 +1368,6 @@ badRecResTy :: SDoc -> SDoc badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc \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 - %********************************************************* %* * \subsection{Support code for type/data declarations} @@ -1408,14 +1395,17 @@ extendRecordFieldEnv tycl_decls inst_decls all_data_cons :: [ConDecl RdrName] all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs , L _ con <- cons ] - all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn }) <- tyClGroupConcat tycl_decls ] - ++ map dfid_defn (instDeclDataFamInsts inst_decls) -- Do not forget associated types! + all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn }) + <- tyClGroupConcat tycl_decls ] + ++ map dfid_defn (instDeclDataFamInsts inst_decls) + -- Do not forget associated types! - get_con (ConDecl { con_name = con, con_details = RecCon flds }) + get_con (ConDecl { con_names = cons, con_details = RecCon flds }) (RecFields env fld_set) - = do { con' <- lookup con - ; flds' <- mapM lookup (map cd_fld_name flds) - ; let env' = extendNameEnv env con' flds' + = do { cons' <- mapM lookup cons + ; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc) flds) + ; let env' = foldl (\e c -> extendNameEnv e c flds') env cons' + fld_set' = addListToNameSet fld_set flds' ; return $ (RecFields env' fld_set') } get_con _ env = return env diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 38985a45d9..c3692d30cd 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -536,16 +536,17 @@ but it seems tiresome to do so. %********************************************************* \begin{code} -rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] - -> RnM ([ConDeclField Name], FreeVars) +rnConDeclFields :: HsDocContext -> [LConDeclField RdrName] + -> RnM ([LConDeclField Name], FreeVars) rnConDeclFields doc fields = mapFvRn (rnField doc) fields -rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars) -rnField doc (ConDeclField name ty haddock_doc) - = do { new_name <- lookupLocatedTopBndrRn name +rnField :: HsDocContext -> LConDeclField RdrName + -> RnM (LConDeclField Name, FreeVars) +rnField doc (L l (ConDeclField names ty haddock_doc)) + = do { new_names <- mapM lookupLocatedTopBndrRn names ; (new_ty, fvs) <- rnLHsType doc ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) } + ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) } rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) rnContext doc (L loc cxt) @@ -958,7 +959,7 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig , dd_cons = cons, dd_derivs = derivs }) = fst $ extract_lctxt ctxt $ extract_mb extract_lkind ksig $ - extract_mb extract_ltys derivs $ + extract_mb (extract_ltys . unLoc) derivs $ foldr (extract_con . unLoc) ([],[]) cons where extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc @@ -989,7 +990,8 @@ extract_lty (L _ ty) acc = case ty of HsTyVar tv -> extract_tv tv acc HsBangTy _ ty -> extract_lty ty acc - HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds + HsRecTy flds -> foldr (extract_lty . cd_fld_type . unLoc) acc + flds HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) HsListTy ty -> extract_lty ty acc HsPArrTy ty -> extract_lty ty acc 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) diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index ea53b31729..1e85a73d0e 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +{-# LANGUAGE FlexibleInstances #-} + {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -67,6 +69,7 @@ import UniqFM import FastMutInt import Fingerprint import BasicTypes +import SrcLoc import Foreign import Data.Array @@ -892,3 +895,38 @@ instance Binary WarningTxt where _ -> do d <- get bh return (DeprecatedTxt d) +instance Binary a => Binary (GenLocated SrcSpan a) where + put_ bh (L l x) = do + put_ bh l + put_ bh x + + get bh = do + l <- get bh + x <- get bh + return (L l x) + +instance Binary SrcSpan where + put_ bh (RealSrcSpan ss) = do + putByte bh 0 + put_ bh (srcSpanFile ss) + put_ bh (srcSpanStartLine ss) + put_ bh (srcSpanStartCol ss) + put_ bh (srcSpanEndLine ss) + put_ bh (srcSpanEndCol ss) + + put_ bh (UnhelpfulSpan s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> do f <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + return (mkSrcSpan (mkSrcLoc f sl sc) + (mkSrcLoc f el ec)) + _ -> do s <- get bh + return (UnhelpfulSpan s) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 1d4504815c..03a67905a7 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1948,9 +1948,10 @@ iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude && (not (ideclQualified d1) || ideclQualified d2) && (ideclHiding d1 `hidingSubsumes` ideclHiding d2) where - _ `hidingSubsumes` Just (False,[]) = True - Just (False, xs) `hidingSubsumes` Just (False,ys) = all (`elem` xs) ys - h1 `hidingSubsumes` h2 = h1 == h2 + _ `hidingSubsumes` Just (False,L _ []) = True + Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys) + = all (`elem` xs) ys + h1 `hidingSubsumes` h2 = h1 == h2 iiSubsumes _ _ = False diff --git a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr index 7ce82d0067..cde205a25d 100644 --- a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr +++ b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr @@ -110,13 +110,11 @@ data R = This is the 'C1' record constructor, with the following fields: C1 {p :: Int This comment applies to the 'p' field, q :: forall a. a -> a This comment applies to the 'q' field, - r :: Int This comment applies to both 'r' and 's', - s :: Int This comment applies to both 'r' and 's'} | + r, s :: Int This comment applies to both 'r' and 's'} | This is the 'C2' record constructor, also with some fields: C2 {t :: T1 -> (T2 Int Int) -> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), - u :: Int, - v :: Int} + u, v :: Int} <document comment> data R1 = This is the 'C3' record constructor diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 4a094f50a1..a377953b38 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -307,7 +307,7 @@ boundThings modname lbinding = _ -> error "boundThings" conArgs (PrefixCon ps) tl = foldr patThings tl ps conArgs (RecCon (HsRecFields { rec_flds = flds })) tl - = foldr (\f tl' -> patThings (hsRecFieldArg f) tl') tl flds + = foldr (\(L _ f) tl' -> patThings (hsRecFieldArg f) tl') tl flds conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl diff --git a/utils/haddock b/utils/haddock -Subproject 2b3712d701c1df626abbc60525c35e735272e45 +Subproject 5d8117d8f1f910c85d36865d646b65510b23583 |