diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2014-11-21 11:20:06 -0600 |
|---|---|---|
| committer | Austin Seipp <austin@well-typed.com> | 2014-11-21 11:26:10 -0600 |
| commit | 7927658ed1dcf557c7dd78e4b9844100521391c8 (patch) | |
| tree | 16a5978453233ba0889af5fa3e59a60b42bc0bfc | |
| parent | cfa574cea30b411080de5d641309bdf135ed9be5 (diff) | |
| download | haskell-7927658ed1dcf557c7dd78e4b9844100521391c8.tar.gz | |
AST changes to prepare for API annotations, for #9628
Summary:
AST changes to prepare for API annotations
Add locations to parts of the AST so that API annotations can
then be added.
The outline of the whole process is captured here
https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations
This change updates the haddock submodule.
Test Plan: sh ./validate
Reviewers: austin, simonpj, Mikolaj
Reviewed By: simonpj, Mikolaj
Subscribers: thomie, goldfire, carter
Differential Revision: https://phabricator.haskell.org/D426
GHC Trac Issues: #9628
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 |