ppr_expr (ExplicitTuple _ exprs boxity)
-- Special-case unary boxed tuples so that they are pretty-printed as
-- `Unit x`, not `(x)`
- | [dL -> L _ (Present _ expr)] <- exprs
+ | [L _ (Present _ expr)] <- exprs
, Boxed <- boxity
= hsep [text (mkTupleStr Boxed 1), ppr expr]
| otherwise
go (ConPatIn {}) = False -- Conservative
go (ConPatOut
- { pat_con = (dL->L _ (RealDataCon con))
+ { pat_con = L _ (RealDataCon con)
, pat_args = details })
=
isJust (tyConSingleDataCon_maybe (dataConTyCon con))
-- the latter is false of existentials. See #4439
&& all goL (hsConPatArgs details)
go (ConPatOut
- { pat_con = (dL->L _ (PatSynCon _pat)) })
+ { pat_con = L _ (PatSynCon _pat) })
= False -- Conservative
- go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884
go (LitPat {}) = False
go (NPat {}) = False
go (NPlusKPat {}) = False
-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
-parenthesizePat p lpat@(dL->L loc pat)
- | patNeedsParens p pat = cL loc (ParPat noExtField lpat)
+parenthesizePat p lpat@(L loc pat)
+ | patNeedsParens p pat = L loc (ParPat noExtField lpat)
| otherwise = lpat
{-
hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec
hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p))
-hsLTyVarLocName = onHasSrcSpan hsTyVarName
+hsLTyVarLocName = mapLoc hsTyVarName
hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Convert a LHsTyVarBndr to an equivalent LHsType.
hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
-hsLTyVarBndrToType = onHasSrcSpan cvt
+hsLTyVarBndrToType = mapLoc cvt
where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
cvt (KindedTyVar _ (L name_loc n) kind)
= HsKindSig noExtField
-- | e => (e)
mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkHsPar e = cL (getLoc e) (HsPar noExtField e)
+mkHsPar e = L (getLoc e) (HsPar noExtField e)
mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)] -> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch ctxt pats rhs
- = cL loc $
+ = L loc $
Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats
, m_grhss = unguardedGRHSs rhs }
where
unguardedGRHSs :: Located (body (GhcPass p))
-> GRHSs (GhcPass p) (Located (body (GhcPass p)))
-unguardedGRHSs rhs@(dL->L loc _)
+unguardedGRHSs rhs@(L loc _)
= GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
-> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
-unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)]
+unguardedRHS loc rhs = [L loc (GRHS noExtField [] rhs)]
mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField)
=> Origin -> [LMatch name (Located (body name))]
mkLocatedList :: [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
-mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms
+mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2)
mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
-mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches))
+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
where
matches = mkMatchGroup Generated
[mkSimpleMatch LambdaExpr pats' body]
-- | Wrap in parens if (hsExprNeedsParens appPrec) says it needs them
-- So 'f x' becomes '(f x)', but '3' stays as '3'
mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkLHsPar le@(dL->L loc e)
- | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le)
+mkLHsPar le@(L loc e)
+ | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le)
| otherwise = le
mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
-mkParPat lp@(dL->L loc p)
- | patNeedsParens appPrec p = cL loc (ParPat noExtField lp)
+mkParPat lp@(L loc p)
+ | patNeedsParens appPrec p = L loc (ParPat noExtField lp)
| otherwise = lp
nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts)
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
where
- last_stmt = cL (getLoc expr) $ mkLastStmt expr
+ last_stmt = L (getLoc expr) $ mkLastStmt expr
mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
-> HsExpr (GhcPass p)
mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
mkLHsPatTup [] = noLoc $ TuplePat noExtField [] Boxed
mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed
+mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed
-- | The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
-- of which use this function
where
(gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
- is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True
- is_gen_dm_sig _ = False
+ is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True
+ is_gen_dm_sig _ = False
mk_pairs :: [LSig GhcRn] -> [(Name, a)]
mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
- , (dL->L _ n) <- ns ]
+ , L _ n <- ns ]
mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
-- ^ Convert TypeSig to ClassOpSig
mkClassOpSigs sigs
= map fiddle sigs
where
- fiddle (dL->L loc (TypeSig _ nms ty))
- = cL loc (ClassOpSig noExtField False nms (dropWildCards ty))
+ fiddle (L loc (TypeSig _ nms ty))
+ = L loc (ClassOpSig noExtField False nms (dropWildCards ty))
fiddle sig = sig
typeToLHsType :: Type -> LHsType GhcPs
********************************************************************* -}
mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e)
+mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
-- | Avoid (HsWrap co (HsWrap co' _)).
-- See Note [Detecting forced eta expansion] in DsExpr
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e)
+mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
| otherwise = HsCmdWrap noExtField w cmd
mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
-mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c)
+mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs
mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
-mkVarBind var rhs = cL (getLoc rhs) $
+mkVarBind var rhs = L (getLoc rhs) $
VarBind { var_ext = noExtField,
var_id = var, var_rhs = rhs, var_inline = False }
mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
-> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind loc fun pats expr
- = cL loc $ mkFunBind Generated (cL loc fun)
- [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr
+ = L loc $ mkFunBind Generated (L loc fun)
+ [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
(noLoc emptyLocalBinds)]
-- | Make a prefix, non-strict function 'HsMatchContext'
, m_pats = map paren pats
, m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds })
where
- paren lp@(dL->L l p)
- | patNeedsParens appPrec p = cL l (ParPat noExtField lp)
+ paren lp@(L l p)
+ | patNeedsParens appPrec p = L l (ParPat noExtField lp)
| otherwise = lp
{-
isBangedHsBind (AbsBinds { abs_binds = binds })
= anyBag (isBangedHsBind . unLoc) binds
isBangedHsBind (FunBind {fun_matches = matches})
- | [dL->L _ match] <- unLoc $ mg_alts matches
+ | [L _ match] <- unLoc $ mg_alts matches
, FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
= True
isBangedHsBind (PatBind {pat_lhs = pat})
collectHsIdBinders = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False
-collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=>
- HsBindLR p idR -> [IdP p]
+collectHsBindBinders :: XRec pass Pat ~ Located (Pat pass) =>
+ HsBindLR pass idR -> [IdP pass]
-- ^ Collect both Ids and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []
-- ^ Collect Ids, or Ids + pattern synonyms, depending on boolean flag
collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds
-collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
- Bool -> HsBindLR p idR -> [IdP p] -> [IdP p]
+collect_bind :: XRec pass Pat ~ Located (Pat pass) =>
+ Bool -> HsBindLR pass idR ->
+ [IdP pass] -> [IdP pass]
collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
-collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc
+collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind _ (VarBind { var_id = f }) acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
-- I don't think we want the binders from the abe_binds
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc
+collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc
| omitPatSyn = acc
| otherwise = ps : acc
collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
collectPatsBinders pats = foldr collect_lpat [] pats
-------------
-collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
- LPat p -> [IdP p] -> [IdP p]
+collect_lpat :: XRec pass Pat ~ Located (Pat pass) =>
+ LPat pass -> [IdP pass] -> [IdP pass]
collect_lpat p bndrs
= go (unLoc p)
where
-- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
-- See Note [SrcSpan for binders]
-hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl
- { fdLName = (dL->L _ name) } }))
- = ([cL loc name], [])
-hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec }))
+hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl
+ { fdLName = (L _ name) } }))
+ = ([L loc name], [])
+hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl nec }))
= noExtCon nec
-hsLTyClDeclBinders (dL->L loc (SynDecl
- { tcdLName = (dL->L _ name) }))
- = ([cL loc name], [])
-hsLTyClDeclBinders (dL->L loc (ClassDecl
- { tcdLName = (dL->L _ cls_name)
+hsLTyClDeclBinders (L loc (SynDecl
+ { tcdLName = (L _ name) }))
+ = ([L loc name], [])
+hsLTyClDeclBinders (L loc (ClassDecl
+ { tcdLName = (L _ cls_name)
, tcdSigs = sigs
, tcdATs = ats }))
- = (cL loc cls_name :
- [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl
+ = (L loc cls_name :
+ [ L fam_loc fam_name | (L fam_loc (FamilyDecl
{ fdLName = L _ fam_name })) <- ats ]
++
- [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs
- , (dL->L _ mem_name) <- ns ]
+ [ L mem_loc mem_name | (L mem_loc (ClassOpSig _ False ns _)) <- sigs
+ , (L _ mem_name) <- ns ]
, [])
-hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name)
- , tcdDataDefn = defn }))
- = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn
-hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec
-hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match"
- -- due to #15884
+hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name)
+ , tcdDataDefn = defn }))
+ = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
+hsLTyClDeclBinders (L _ (XTyClDecl nec)) = noExtCon nec
-------------------
hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
-- ^ See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
- = [ cL decl_loc n
- | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) }))
+ = [ L decl_loc n
+ | L decl_loc (ForeignImport { fd_name = L _ n })
<- foreign_decls]
getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds binds
= [ psb | (_, lbinds) <- binds
- , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ]
+ , L _ (PatSynBind _ psb) <- bagToList lbinds ]
-------------------
hsLInstDeclBinders :: LInstDecl (GhcPass p)
-> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
-hsLInstDeclBinders (dL->L _ (ClsInstD
+hsLInstDeclBinders (L _ (ClsInstD
{ cid_inst = ClsInstDecl
{ cid_datafam_insts = dfis }}))
= foldMap (hsDataFamInstBinders . unLoc) dfis
-hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi }))
+hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
= hsDataFamInstBinders fi
-hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty
-hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec)))
+hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
+hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl nec)))
= noExtCon nec
-hsLInstDeclBinders (dL->L _ (XInstDecl nec))
+hsLInstDeclBinders (L _ (XInstDecl nec))
= noExtCon nec
-hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match"
- -- due to #15884
-------------------
-- | the SrcLoc returned are for the whole declarations, not just the names
-- remove only the first occurrence of any seen field in order to
-- avoid circumventing detection of duplicate fields (#9156)
ConDeclGADT { con_names = names, con_args = args }
- -> (map (cL loc . unLoc) names ++ ns, flds ++ fs)
+ -> (map (L loc . unLoc) names ++ ns, flds ++ fs)
where
(remSeen', flds) = get_flds remSeen args
(ns, fs) = go remSeen' rs
ConDeclH98 { con_name = name, con_args = args }
- -> ([cL loc (unLoc name)] ++ ns, flds ++ fs)
+ -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
where
(remSeen', flds) = get_flds remSeen args
(ns, fs) = go remSeen' rs
(Covered , _ ) -> plain -- useful
(NotCovered, NotDiverged) -> plain { pmresultRedundant = m } -- redundant
(NotCovered, Diverged ) -> plain { pmresultInaccessible = m } -- inaccessible rhs
- where m = [cL locn [cL locn p]]
+ where m = [L locn [L locn p]]
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions.
dflags <- getDynFlags
let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
dsMatchContext = DsMatchContext hs_ctx combinedLoc
- match = cL combinedLoc $
+ match = L combinedLoc $
Match { m_ext = noExtField
, m_ctxt = hs_ctx
, m_pats = []
(NotCovered, Diverged ) -> (rs, final_u, m:is, pc1 Semi.<> pc2)
hsLMatchToLPats :: LMatch id body -> Located [LPat id]
- hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats
- hsLMatchToLPats _ = panic "checkMatches'"
+ hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats
+ hsLMatchToLPats _ = panic "checkMatches'"
getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta]
getNFirstUncovered _ 0 _ = pure []
-- (x@pat) ==> Translate pat with x as match var and handle impedance
-- mismatch with incoming match var
- AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p
+ AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p
SigPat _ p _ty -> translateLPat fam_insts x p
pure (PmLet y (wrap_rhs_y (Var x)) : grds)
-- (n + k) ===> let b = x >= k, True <- b, let n = x-k
- NPlusKPat _pat_ty (dL->L _ n) k1 k2 ge minus -> do
+ NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do
b <- mkPmId boolTy
let grd_b = vanillaConGrd b trueDataCon []
[ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]
--
-- See #14547, especially comment#9 and comment#10.
- ConPatOut { pat_con = (dL->L _ con)
+ ConPatOut { pat_con = L _ con
, pat_arg_tys = arg_tys
, pat_tvs = ex_tvs
, pat_dicts = dicts
, pat_args = ps } -> do
translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps
- NPat ty (dL->L _ olit) mb_neg _ -> do
+ NPat ty (L _ olit) mb_neg _ -> do
-- See Note [Literal short cut] in MatchLit.hs
-- We inline the Literal short cut for @ty@ here, because @ty@ is more
-- precise than the field of OverLitTc, which is all that dsOverLit (which
-- Translate a single match
translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc)
-> DsM (GrdVec, [GrdVec])
-translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))
+translateMatch fam_insts vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
= do
pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats
guards' <- mapM (translateGuards fam_insts) guards
return (pats', guards')
where
extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
- extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs
- extractGuards _ = panic "translateMatch"
+ extractGuards (L _ (GRHS _ gs _)) = map unLoc gs
+ extractGuards _ = panic "translateMatch"
guards = map extractGuards (grhssGRHSs grhss)
translateMatch _ _ _ = panic "translateMatch"
when (approx && (exists_u || exists_i)) $
putSrcSpanDs loc (warnDs NoReason approx_msg)
- when exists_r $ forM_ redundant $ \(dL->L l q) -> do
+ when exists_r $ forM_ redundant $ \(L l q) -> do
putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
(pprEqn q "is redundant"))
- when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do
+ when exists_i $ forM_ inaccessible $ \(L l q) -> do
putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
(pprEqn q "has inaccessible right hand side"))
when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $
(ppr_match, pref)
= case kind of
- FunRhs { mc_fun = (dL->L _ fun) }
+ FunRhs { mc_fun = L _ fun }
-> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
setL :: SrcSpan -> CvtM ()
setL loc = CvtM (\_ _ -> Right (loc, ()))
-returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
-returnL x = CvtM (\_ loc -> Right (loc, cL loc x))
+returnL :: a -> CvtM (Located a)
+returnL x = CvtM (\_ loc -> Right (loc, L loc x))
-returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
+returnJustL :: a -> CvtM (Maybe (Located a))
returnJustL = fmap Just . returnL
-wrapParL :: HasSrcSpan a =>
- (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a)
-wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (cL loc x)))
+wrapParL :: (Located a -> a) -> a -> CvtM a
+wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x)))
wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
-- E.g wrapMsg "declaration" dec thing
then text (show item)
else text (pprint item))
-wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
+wrapL :: CvtM a -> CvtM (Located a)
wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
Left err -> Left err
- Right (loc',v) -> Right (loc',cL loc v)
+ Right (loc', v) -> Right (loc', L loc v)
-------------------------------------------------------------------
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
; ctxt' <- cvtContext funPrec ctxt
- ; (dL->L loc ty') <- cvtType ty
- ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'
+ ; (L loc ty') <- cvtType ty
+ ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
; returnJustL $ InstD noExtField $ ClsInstD noExtField $
ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty'
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
- , cid_overlap_mode = fmap (cL loc . overlap) o } }
+ , cid_overlap_mode = fmap (L loc . overlap) o } }
where
overlap pragma =
case pragma of
, feqn_fixity = Prefix } }}}
cvtDec (TySynInstD eqn)
- = do { (dL->L _ eqn') <- cvtTySynEqn eqn
+ = do { (L _ eqn') <- cvtTySynEqn eqn
; returnJustL $ InstD noExtField $ TyFamInstD
{ tfid_ext = noExtField
, tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
cvtDec (TH.StandaloneDerivD ds cxt ty)
= do { cxt' <- cvtContext funPrec cxt
; ds' <- traverse cvtDerivStrategy ds
- ; (dL->L loc ty') <- cvtType ty
- ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
+ ; (L loc ty') <- cvtType ty
+ ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
; returnJustL $ DerivD noExtField $
DerivDecl { deriv_ext =noExtField
, deriv_strategy = ds'
-------------------------------------------------------------------
is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
-is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)
+is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d)
is_fam_decl decl = Right decl
is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
- = Left (cL loc d)
+is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
+ = Left (L loc d)
is_tyfam_inst decl
= Right decl
is_datafam_inst :: LHsDecl GhcPs
-> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_datafam_inst (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d })))
- = Left (cL loc d)
+is_datafam_inst (L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d })))
+ = Left (L loc d)
is_datafam_inst decl
= Right decl
is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
-is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)
-is_sig decl = Right decl
+is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
+is_sig decl = Right decl
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
-is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)
-is_bind decl = Right decl
+is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
+is_bind decl = Right decl
is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
cvtConstr (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
; ctxt' <- cvtContext funPrec ctxt
- ; (dL->L _ con') <- cvtConstr con
+ ; L _ con' <- cvtConstr con
; returnL $ add_forall tvs' ctxt' con' }
where
add_cxt lcxt Nothing = Just lcxt
- add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))
- = Just (cL loc (cxt1 ++ cxt2))
+ add_cxt (L loc cxt1) (Just (L _ cxt2))
+ = Just (L loc (cxt1 ++ cxt2))
add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
= con { con_forall = noLoc $ not (null all_tvs)
cvtConstr (GadtC c strtys ty)
= do { c' <- mapM cNameL c
; args <- mapM cvt_arg strtys
- ; (dL->L _ ty') <- cvtType ty
+ ; L _ ty' <- cvtType ty
; c_ty <- mk_arr_apps args ty'
; returnL $ fst $ mkGadtDecl c' c_ty}
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg (i, str, ty)
- = do { (dL->L li i') <- vNameL i
+ = do { L li i' <- vNameL i
; ty' <- cvt_arg (str,ty)
; return $ noLoc (ConDeclField
{ cd_fld_ext = noExtField
, cd_fld_names
- = [cL li $ FieldOcc noExtField (cL li i')]
+ = [L li $ FieldOcc noExtField (L li i')]
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
; let Just (stmts'', last') = snocView stmts'
; last'' <- case last' of
- (dL->L loc (BodyStmt _ body _ _))
- -> return (cL loc (mkLastStmt body))
+ (L loc (BodyStmt _ body _ _))
+ -> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last')
; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) }
cvtMatch ctxt (TH.Match p body decs)
= do { p' <- cvtPat p
; let lp = case p' of
- (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875
- _ -> p'
+ (L loc SigPat{}) -> L loc (ParPat noExtField p') -- #14875
+ _ -> p'
; g' <- cvtGuard body
; decs' <- cvtLocalDecs (text "a where clause") decs
; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
- = do { (dL->L ls s') <- vNameL s
+ = do { L ls s' <- vNameL s
; p' <- cvtPat p
; return (noLoc $ HsRecField { hsRecFieldLbl
- = cL ls $ mkFieldOcc (cL ls s')
+ = L ls $ mkFieldOcc (L ls s')
, hsRecFieldArg = p'
, hsRecPun = False}) }
PromotedConsT -- See Note [Representing concrete syntax in types]
-- in Language.Haskell.TH.Syntax
| Just normals <- m_normals
- , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals
+ , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals
-> do
returnL (HsExplicitListTy noExtField ip (ty1:tys2))
| otherwise
go type_args
where
-- See Note [Adding parens for splices]
- add_parens lt@(dL->L _ t)
+ add_parens lt@(L _ t)
| hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt)
| otherwise = return lt
| null exis, null provs = cvtType (ForallT univs reqs ty)
| null univs, null reqs = do { l <- getL
; ty' <- cvtType (ForallT exis provs ty)
- ; return $ cL l (HsQualTy { hst_ctxt = cL l []
- , hst_xqual = noExtField
- , hst_body = ty' }) }
+ ; return $ L l (HsQualTy { hst_ctxt = L l []
+ , hst_xqual = noExtField
+ , hst_body = ty' }) }
| null reqs = do { l <- getL
; univs' <- hsQTvExplicit <$> cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
{ hst_fvf = ForallInvis
, hst_bndrs = univs'
, hst_xforall = noExtField
- , hst_body = cL l cxtTy }
- cxtTy = HsQualTy { hst_ctxt = cL l []
+ , hst_body = L l cxtTy }
+ cxtTy = HsQualTy { hst_ctxt = L l []
, hst_xqual = noExtField
, hst_body = ty' }
- ; return $ cL l forTy }
+ ; return $ L l forTy }
| otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
cvtPatSynSigTy ty = cvtType ty
-- ^ The complete type, quantified with a forall if necessary
mkHsForAllTy tvs loc fvf tvs' rho_ty
| null tvs = rho_ty
- | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf
- , hst_bndrs = hsQTvExplicit tvs'
- , hst_xforall = noExtField
- , hst_body = rho_ty }
+ | otherwise = L loc $ HsForAllTy { hst_fvf = fvf
+ , hst_bndrs = hsQTvExplicit tvs'
+ , hst_xforall = noExtField
+ , hst_body = rho_ty }
-- | If passed an empty 'TH.Cxt', this simply returns the third argument
-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
-- ^ The complete type, qualified with a context if necessary
mkHsQualTy ctxt loc ctxt' ty
| null ctxt = ty
- | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField
- , hst_ctxt = ctxt'
- , hst_body = ty }
+ | otherwise = L loc $ HsQualTy { hst_xqual = noExtField
+ , hst_ctxt = ctxt'
+ , hst_body = ty }
--------------------------------------------------------------------
-- Turning Name back into RdrName
nameSrcLoc name = srcSpanStart (n_loc name)
nameSrcSpan name = n_loc name
-type instance SrcSpanLess Name = Name
-instance HasSrcSpan Name where
- composeSrcSpan (L sp n) = n {n_loc = sp}
- decomposeSrcSpan n = L (n_loc n) n
-
-
{-
************************************************************************
* *
leftmost_smallest, leftmost_largest, rightmost,
spans, isSubspanOf, sortLocated,
- -- ** HasSrcSpan
- HasSrcSpan(..), SrcSpanLess, dL, cL,
- pattern LL, onHasSrcSpan, liftL
+ liftL
) where
import GhcPrelude
************************************************************************
-}
-sortLocated :: HasSrcSpan a => [a] -> [a]
+sortLocated :: [Located a] -> [Located a]
sortLocated things = sortBy (comparing getLoc) things
instance Outputable RealSrcLoc where
mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc = fmap
-unLoc :: HasSrcSpan a => a -> SrcSpanLess a
-unLoc (dL->L _ e) = e
+unLoc :: GenLocated l e -> e
+unLoc (L _ e) = e
-getLoc :: HasSrcSpan a => a -> SrcSpan
-getLoc (dL->L l _) = l
+getLoc :: GenLocated l e -> l
+getLoc (L l _) = l
-noLoc :: HasSrcSpan a => SrcSpanLess a -> a
-noLoc e = cL noSrcSpan e
+noLoc :: e -> Located e
+noLoc e = L noSrcSpan e
-mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e
-mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e
+mkGeneralLocated :: String -> e -> Located e
+mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e
-combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
+combineLocs :: Located a -> Located b -> SrcSpan
combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
-- | Combine locations from two 'Located' things and add them to a third thing
-addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
- a -> b -> SrcSpanLess c -> c
-addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c
+addCLoc :: Located a -> Located b -> c -> Located c
+addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
-- not clear whether to add a general Eq instance, but this is useful sometimes:
-- | Tests whether the two located things are equal
-eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool
+eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool
eqLocated a b = unLoc a == unLoc b
-- not clear whether to add a general Ord instance, but this is useful sometimes:
-- | Tests the ordering of the two located things
-cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering
+cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b
instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
| otherwise = srcSpanStart parent <= srcSpanStart src &&
srcSpanEnd parent >= srcSpanEnd src
-
-{-
-************************************************************************
-* *
-\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans}
-* *
-************************************************************************
--}
-
-{-
-Note [HasSrcSpan Typeclass]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-To be able to uniformly set/get source location spans (of `SrcSpan`) in
-syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`.
-More details can be found at the following wiki page
- ImplementingTreesThatGrow/HandlingSourceLocations
-
-For most syntactic entities, the source location spans are stored in
-a syntactic entity by a wapper constuctor (introduced by TTG's
-new constructor extension), e.g., by `NewPat (WrapperPat sp pat)`
-for a source location span `sp` and a pattern `pat`.
--}
-
--- | Determines the type of undecorated syntactic entities
--- For most syntactic entities `E`, where source location spans are
--- introduced by a wrapper construtor of the same syntactic entity,
--- we have `SrcSpanLess E = E`.
--- However, some syntactic entities have a different type compared to
--- a syntactic entity `e :: E` may have the type `Located E` when
--- decorated by wrapping it with `L sp e` for a source span `sp`.
-type family SrcSpanLess a
-
--- | A typeclass to set/get SrcSpans
-class HasSrcSpan a where
- -- | Composes a `SrcSpan` decoration with an undecorated syntactic
- -- entity to form its decorated variant
- composeSrcSpan :: Located (SrcSpanLess a) -> a
-
- -- | Decomposes a decorated syntactic entity into its `SrcSpan`
- -- decoration and its undecorated variant
- decomposeSrcSpan :: a -> Located (SrcSpanLess a)
- {- laws:
- composeSrcSpan . decomposeSrcSpan = id
- decomposeSrcSpan . composeSrcSpan = id
-
- in other words, `HasSrcSpan` defines an iso relation between
- a `SrcSpan`-decorated syntactic entity and its undecorated variant
- (together with the `SrcSpan`).
- -}
-
-type instance SrcSpanLess (GenLocated l e) = e
-instance HasSrcSpan (Located a) where
- composeSrcSpan = id
- decomposeSrcSpan = id
-
-
--- | An abbreviated form of decomposeSrcSpan,
--- mainly to be used in ViewPatterns
-dL :: HasSrcSpan a => a -> Located (SrcSpanLess a)
-dL = decomposeSrcSpan
-
--- | An abbreviated form of composeSrcSpan,
--- mainly to replace the hardcoded `L`
-cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
-cL sp e = composeSrcSpan (L sp e)
-
--- | A Pattern Synonym to Set/Get SrcSpans
-pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
-pattern LL sp e <- (dL->L sp e)
- where
- LL sp e = cL sp e
-
--- | Lifts a function of undecorated entities to one of decorated ones
-onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) =>
- (SrcSpanLess a -> SrcSpanLess b) -> a -> b
-onHasSrcSpan f (dL->L l e) = cL l (f e)
-
-liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) =>
- (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
-liftL f (dL->L loc a) = do
+liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b)
+liftL f (L loc a) = do
a' <- f a
- return $ cL loc a'
-
+ return $ L loc a'
getRealSrcSpan :: RealLocated a -> RealSrcSpan
getRealSrcSpan (L l _) = l
guessSourceFile binds orig_file =
-- Try look for a file generated from a .hsc file to a
-- .hs file, by peeking ahead.
- let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest ->
+ let top_pos = catMaybes $ foldr (\ (L pos _) rest ->
srcSpanFileName_maybe pos : rest) [] binds
in
case top_pos of
addTickLHsBinds = mapBagM addTickLHsBind
addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
-addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds,
+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
abs_exports = abs_exports })) = do
withEnv add_exports $ do
withEnv add_inlines $ do
binds' <- addTickLHsBinds binds
- return $ cL pos $ bind { abs_binds = binds' }
+ return $ L pos $ bind { abs_binds = binds' }
where
-- in AbsBinds, the Id on each binding is not the actual top-level
-- Id that we are defining, they are related by the abs_exports
| ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
, isInlinePragma (idInlinePragma pid) ] }
-addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
let name = getOccString id
decl_path <- getPathEntry
density <- getDensity
-- See Note [inline sccs]
tickish <- tickishType `liftM` getEnv
- if inline && tickish == ProfNotes then return (cL pos funBind) else do
+ if inline && tickish == ProfNotes then return (L pos funBind) else do
(fvs, mg) <-
getFreeVars $
return Nothing
let mbCons = maybe Prelude.id (:)
- return $ cL pos $ funBind { fun_matches = mg
- , fun_tick = tick `mbCons` fun_tick funBind }
+ return $ L pos $ funBind { fun_matches = mg
+ , fun_tick = tick `mbCons` fun_tick funBind }
where
-- a binding is a simple pattern binding if it is a funbind with
isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
-- TODO: Revisit this
-addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs
- , pat_rhs = rhs }))) = do
+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
+ , pat_rhs = rhs }))) = do
let name = "(...)"
(fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
let pat' = pat { pat_rhs = rhs'}
decl_path <- getPathEntry
let top_lev = null decl_path
if not (shouldTickPatBind density top_lev)
- then return (cL pos pat')
+ then return (L pos pat')
else do
-- Allocate the ticks
rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
patvar_tickss = zipWith mbCons patvar_ticks
(snd (pat_ticks pat') ++ repeat [])
- return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
+ return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
-addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind
-addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind
-addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind
-addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884
-
+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
+addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
bindTick
-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExpr e@(dL->L pos e0) = do
+addTickLHsExpr e@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
-- (because the body will definitely have a tick somewhere). ToDo: perhaps
-- we should treat 'case' and 'if' the same way?
addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprRHS e@(dL->L pos e0) = do
+addTickLHsExprRHS e@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
-- break012. This gives the user the opportunity to inspect the
-- values of the let-bound variables.
addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprLetBody e@(dL->L pos e0) = do
+addTickLHsExprLetBody e@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
-- because the scope of this tick is completely subsumed by
-- another.
addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprNever (dL->L pos e0) = do
+addTickLHsExprNever (L pos e0) = do
e1 <- addTickHsExpr e0
- return $ cL pos e1
+ return $ L pos e1
-- general heuristic: expressions which do not denote values are good
-- break points
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprOptAlt oneOfMany (dL->L pos e0)
+addTickLHsExprOptAlt oneOfMany (L pos e0)
= ifDensity TickForCoverage
(allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
- (addTickLHsExpr (cL pos e0))
+ (addTickLHsExpr (L pos e0))
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addBinTickLHsExpr boxLabel (dL->L pos e0)
+addBinTickLHsExpr boxLabel (L pos e0)
= ifDensity TickForCoverage
(allocBinTickBox boxLabel pos $ addTickHsExpr e0)
- (addTickLHsExpr (cL pos e0))
+ (addTickLHsExpr (L pos e0))
-- -----------------------------------------------------------------------------
-- in the addTickLHsExpr family of functions.)
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e
+addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsConLikeOut _ con)
| Just id <- conLikeWrapId_maybe con = do freeVar id; return e
= do { let isOneOfMany = case alts of [_] -> False; _ -> True
; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet x (dL->L l binds) e) =
+addTickHsExpr (HsLet x (L l binds) e) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsLet x . cL l)
+ liftM2 (HsLet x . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprLetBody e)
-addTickHsExpr (HsDo srcloc cxt (dL->L l stmts))
+addTickHsExpr (HsDo srcloc cxt (L l stmts))
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
- ; return (HsDo srcloc cxt (cL l stmts')) }
+ ; return (HsDo srcloc cxt (L l stmts')) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
addTickHsExpr (HsBinTick x t0 t1 e) =
liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
-addTickHsExpr (HsPragE _ HsPragTick{} (dL->L pos e0)) = do
+addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do
e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0
return $ unLoc e2
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
-addTickTupArg (dL->L l (Present x e)) = do { e' <- addTickLHsExpr e
- ; return (cL l (Present x e')) }
-addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))
-addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec
-addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884
+addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e
+ ; return (L l (Present x e')) }
+addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
+addTickTupArg (L _ (XTupArg nec)) = noExtCon nec
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do
+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
- return $ mg { mg_alts = cL l matches' }
+ return $ mg { mg_alts = L l matches' }
addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do
+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
- return $ GRHSs x guarded' (cL l local_binds')
+ return $ GRHSs x guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec
addTickGRHS _ _ (XGRHS nec) = noExtCon nec
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do
+addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
d <- getDensity
case d of
TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
-addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do
- liftM (LetStmt x . cL l)
+addTickStmt _isGuard (LetStmt x (L l binds)) = do
+ liftM (LetStmt x . L l)
(addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
liftM3 (ParStmt x)
(mapM (addTickStmtAndBinders isGuard) pairs)
- (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr))
+ (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
(addTickSyntaxExpr hpcSrcSpan bindExpr)
addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
args' <- mapM (addTickApplicativeArg isGuard) args
t_u <- addTickLHsExprRHS using
t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
- t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr))
+ t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr))
return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
, trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
addTickArg (ApplicativeArgMany x stmts ret pat) =
(ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
- <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))
+ <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
<*> addTickLPat pat
addTickArg (XApplicativeArg nec) = noExtCon nec
-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
- x' <- fmap unLoc (addTickLHsExpr (cL pos x))
+ x' <- fmap unLoc (addTickLHsExpr (L pos x))
return $ syn { syn_expr = x' }
-- we do not walk into patterns.
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickHsCmdTop (XCmdTop nec) = noExtCon nec
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
-addTickLHsCmd (dL->L pos c0) = do
+addTickLHsCmd (L pos c0) = do
c1 <- addTickHsCmd c0
- return $ cL pos c1
+ return $ L pos c1
addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd (HsCmdLam x matchgroup) =
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet x (dL->L l binds) c) =
+addTickHsCmd (HsCmdLet x (L l binds) c) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsCmdLet x . cL l)
+ liftM2 (HsCmdLet x . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
-addTickHsCmd (HsCmdDo srcloc (dL->L l stmts))
+addTickHsCmd (HsCmdDo srcloc (L l stmts))
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
- ; return (HsCmdDo srcloc (cL l stmts')) }
+ ; return (HsCmdDo srcloc (L l stmts')) }
addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) =
liftM5 HsCmdArrApp
addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
-addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do
+addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
matches' <- mapM (liftL addTickCmdMatch) matches
- return $ mg { mg_alts = cL l matches' }
+ return $ mg { mg_alts = L l matches' }
addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch (XMatch nec) = noExtCon nec
addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
-addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do
+addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (liftL addTickCmdGRHS) guarded
- return $ GRHSs x guarded' (cL l local_binds')
+ return $ GRHSs x guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
addTickCmdGRHSs (XGRHSs nec) = noExtCon nec
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
-addTickCmdStmt (LetStmt x (dL->L l binds)) = do
- liftM (LetStmt x . cL l)
+addTickCmdStmt (LetStmt x (L l binds)) = do
+ liftM (LetStmt x . L l)
(addTickHsLocalBinds binds)
addTickCmdStmt stmt@(RecStmt {})
= do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
-> TM (LHsRecField' id (LHsExpr GhcTc))
-addTickHsRecField (dL->L l (HsRecField id expr pun))
+addTickHsRecField (L l (HsRecField id expr pun))
= do { expr' <- addTickLHsExpr expr
- ; return (cL l (HsRecField id expr' pun)) }
+ ; return (L l (HsRecField id expr' pun)) }
addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
(fvs, e) <- getFreeVars m
env <- getEnv
tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
- return (cL pos (HsTick noExtField tickish (cL pos e)))
+ return (L pos (HsTick noExtField tickish (L pos e)))
) (do
e <- m
- return (cL pos e)
+ return (L pos e)
)
-- the tick application inherits the source position of its
allocBinTickBox boxLabel pos m = do
env <- getEnv
case tickishType env of
- HpcTicks -> do e <- liftM (cL pos) m
+ HpcTicks -> do e <- liftM (L pos) m
ifGoodTickSrcSpan pos
(mkBinTickBoxHpc boxLabel pos e)
(return e)
c = tickBoxCount st
mes = mixEntries st
in
- ( cL pos $ HsTick noExtField (HpcTick (this_mod env) c)
- $ cL pos $ HsBinTick noExtField (c+1) (c+2) e
+ ( L pos $ HsTick noExtField (HpcTick (this_mod env) c)
+ $ L pos $ HsBinTick noExtField (c+1) (c+2) e
-- notice that F and T are reversed,
-- because we are building the list in
-- reverse...
matchesOneOfMany :: [LMatch GhcTc body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
- matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ }))
+ matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
= length grhss
- matchCount (dL->L _ (Match { m_grhss = XGRHSs nec }))
+ matchCount (L _ (Match { m_grhss = XGRHSs nec }))
= noExtCon nec
- matchCount (dL->L _ (XMatch nec)) = noExtCon nec
- matchCount _ = panic "matchCount: Impossible Match" -- due to #15884
+ matchCount (L _ (XMatch nec)) = noExtCon nec
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
-}
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
-dsRule (dL->L loc (HsRule { rd_name = name
- , rd_act = rule_act
- , rd_tmvs = vars
- , rd_lhs = lhs
- , rd_rhs = rhs }))
+dsRule (L loc (HsRule { rd_name = name
+ , rd_act = rule_act
+ , rd_tmvs = vars
+ , rd_lhs = lhs
+ , rd_rhs = rhs }))
= putSrcSpanDs loc $
- do { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars]
+ do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
; lhs' <- unsetGOptM Opt_EnableRewriteRules $
unsetWOptM Opt_WarnIdentities $
; return (Just rule)
} } }
-dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec
-dsRule _ = panic "dsRule: Impossible Match" -- due to #15884
+dsRule (L _ (XRuleDecl nec)) = noExtCon nec
warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
-- See Note [Rules and inlining/other rules]
:: LPat GhcTc
-> LHsCmdTop GhcTc
-> DsM CoreExpr
-dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
+dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
let locals = mkVarSet (collectPatBinders pat)
(core_cmd, _free_vars, env_ids)
dsCmd ids local_vars stack_ty res_ty
(HsCmdLam _ (MG { mg_alts
- = (dL->L _ [dL->L _ (Match { m_pats = pats
- , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) }))
+ = (L _ [L _ (Match { m_pats = pats
+ , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))
env_ids = do
let pat_vars = mkVarSet (collectPatsBinders pats)
let
-}
dsCmd ids local_vars stack_ty res_ty
- (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches)
+ (HsCmdCase _ exp (MG { mg_alts = L l matches
, mg_ext = MatchGroupTc arg_tys _
, mg_origin = origin }))
env_ids = do
in_ty = envStackType env_ids stack_ty
core_body <- dsExpr (HsCase noExtField exp
- (MG { mg_alts = cL l matches'
+ (MG { mg_alts = L l matches'
, mg_ext = MatchGroupTc arg_tys sum_ty
, mg_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty,
--
-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body)
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
env_ids = do
let
defined_vars = mkVarSet (collectLocalBinders binds)
-- ---> premap (\ (env,stk) -> env) c
dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty
- (dL->L loc stmts))
+ (L loc stmts))
env_ids = do
putSrcSpanDs loc $
dsNoLevPoly stmts_ty
-> DsM (CoreExpr, -- desugared expression
DIdSet) -- subset of local vars that occur free
dsTrimCmdArg local_vars env_ids
- (dL->L _ (HsCmdTop
+ (L _ (HsCmdTop
(CmdTopTc stack_ty cmd_ty ids) cmd )) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
(core_cmd, free_vars, env_ids')
--
-- ---> premap (\ (xs) -> ((xs), ())) c
-dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do
+dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do
putSrcSpanDs loc $ dsNoLevPoly res_ty
(text "In the command:" <+> ppr body)
(core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
leavesMatch :: LMatch GhcTc (Located (body GhcTc))
-> [(Located (body GhcTc), IdSet)]
-leavesMatch (dL->L _ (Match { m_pats = pats
- , m_grhss = GRHSs _ grhss (dL->L _ binds) }))
+leavesMatch (L _ (Match { m_pats = pats
+ , m_grhss = GRHSs _ grhss (L _ binds) }))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
[(body,
mkVarSet (collectLStmtsBinders stmts)
`unionVarSet` defined_vars)
- | (dL->L _ (GRHS _ stmts body)) <- grhss]
+ | L _ (GRHS _ stmts body) <- grhss]
leavesMatch _ = panic "leavesMatch"
-- Replace the leaf commands in a match
-> ([Located (body' GhcTc)], -- remaining leaf expressions
LMatch GhcTc (Located (body' GhcTc))) -- updated match
replaceLeavesMatch _res_ty leaves
- (dL->L loc
+ (L loc
match@(Match { m_grhss = GRHSs x grhss binds }))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
- (leaves', cL loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))
+ (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))
replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"
replaceLeavesGRHS
-> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command
-> ([Located (body' GhcTc)], -- remaining leaf expressions
LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _))
- = (leaves, cL loc (GRHS x stmts leaf))
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
+ = (leaves, L loc (GRHS x stmts leaf))
replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS"
---------------------
collectl :: LPat GhcTc -> [Id] -> [Id]
-- See Note [Dictionary binders in ConPatOut]
-collectl (dL->L _ pat) bndrs
+collectl (L _ pat) bndrs
= go pat
where
- go (VarPat _ (dL->L _ var)) = var : bndrs
+ go (VarPat _ (L _ var)) = var : bndrs
go (WildPat _) = bndrs
go (LazyPat _ pat) = collectl pat bndrs
go (BangPat _ pat) = collectl pat bndrs
- go (AsPat _ (dL->L _ a) pat) = a : collectl pat bndrs
+ go (AsPat _ (L _ a) pat) = a : collectl pat bndrs
go (ParPat _ pat) = collectl pat bndrs
go (ListPat _ pats) = foldr collectl bndrs pats
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _ _) = bndrs
go (NPat {}) = bndrs
- go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs
+ go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
go (SigPat _ pat _) = collectl pat bndrs
go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
bang_binds = filterBag (isBangedHsBind . unLoc) binds
- top_level_err desc (dL->L loc bind)
+ top_level_err desc (L loc bind)
= putSrcSpanDs loc $
errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
2 (ppr bind))
------------------------
dsLHsBind :: LHsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
-dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags
- putSrcSpanDs loc $ dsHsBind dflags bind
+dsLHsBind (L loc bind) = do dflags <- getDynFlags
+ putSrcSpanDs loc $ dsHsBind dflags bind
-- | Desugar a single binding (or group of recursive binds).
dsHsBind :: DynFlags
else []
; return (force_var, [core_bind]) }
-dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun)
+dsHsBind dflags b@(FunBind { fun_id = L _ fun
, fun_matches = matches
, fun_co_fn = co_fn
, fun_tick = tick })
-- rhs is in the Id's unfolding
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
+dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| isJust (isClassOpId_maybe poly_id)
= putSrcSpanDs loc $
do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
-}
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsLocalBinds (dL->L _ (EmptyLocalBinds _)) body = return body
-dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
- dsValBinds binds body
-dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
-dsLocalBinds _ _ = panic "dsLocalBinds"
+dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body
+dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
+ dsValBinds binds body
+dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
+dsLocalBinds _ _ = panic "dsLocalBinds"
-------------------------
-- caller sets location
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
where
- ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body
+ ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
= do e' <- dsLExpr e
return (Let (NonRec n e') body)
ds_ip_bind _ _ = panic "dsIPBinds"
-- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas...
ds_val_bind (NonRecursive, hsbinds) body
- | [dL->L loc bind] <- bagToList hsbinds
+ | [L loc bind] <- bagToList hsbinds
-- Non-recursive, non-overloaded bindings only come in ones
-- ToDo: in some bizarre case it's conceivable that there
-- could be dict binds in the 'binds'. (See the notes
; ds_binds <- dsTcEvBinds_s ev_binds
; return (mkCoreLets ds_binds body2) }
-dsUnliftedBind (FunBind { fun_id = (dL->L l fun)
+dsUnliftedBind (FunBind { fun_id = L l fun
, fun_matches = matches
, fun_co_fn = co_fn
, fun_tick = tick }) body
-- Can't be a bang pattern (that looks like a PatBind)
-- so must be simply unboxed
- = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun))
+ = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
Nothing matches
; MASSERT( null args ) -- Functions aren't lifted
; MASSERT( isIdHsWrapper co_fn )
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
-dsLExpr (dL->L loc e)
+dsLExpr (L loc e)
= putSrcSpanDs loc $
do { core_expr <- dsExpr e
-- uncomment this check to test the hsExprType function in TcHsSyn
-- See Note [Levity polymorphism checking] in DsMonad
-- See Note [Levity polymorphism invariants] in CoreSyn
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
-dsLExprNoLP (dL->L loc e)
+dsLExprNoLP (L loc e)
= putSrcSpanDs loc $
do { e' <- dsExpr e
; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
-> HsExpr GhcTc -> DsM CoreExpr
ds_expr _ (HsPar _ e) = dsLExpr e
ds_expr _ (ExprWithTySig _ e _) = dsLExpr e
-ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var
+ds_expr w (HsVar _ (L _ var)) = dsHsVar w var
ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
ds_expr w (HsConLikeOut _ con) = dsConLike w con
ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar"
; warnAboutIdentities dflags e' wrapped_ty
; return wrapped_e }
-ds_expr _ (NegApp _ (dL->L loc
+ds_expr _ (NegApp _ (L loc
(HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
neg_expr)
= do { expr' <- putSrcSpanDs loc $ do
core_op [Var x_id, Var y_id]))
ds_expr _ (ExplicitTuple _ tup_args boxity)
- = do { let go (lam_vars, args) (dL->L _ (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 <- newSysLocalDsNoLP ty
; return (lam_var : lam_vars, Var lam_var : args) }
- go (lam_vars, args) (dL->L _ (Present _ expr))
+ go (lam_vars, args) (L _ (Present _ expr))
-- Expressions that are present don't generate
-- lambdas, just arguments.
= do { core_expr <- dsLExprNoLP expr
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
-ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty
-ds_expr _ (HsDo _ DoExpr (dL->L _ stmts)) = dsDo stmts
-ds_expr _ (HsDo _ GhciStmtCtxt (dL->L _ stmts)) = dsDo stmts
-ds_expr _ (HsDo _ MDoExpr (dL->L _ stmts)) = dsDo stmts
-ds_expr _ (HsDo _ MonadComp (dL->L _ stmts)) = dsMonadComp stmts
+ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
+ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
g = ... makeStatic loc f ...
-}
-ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do
+ds_expr _ (HsStatic _ expr@(L loc _)) = do
expr_ds <- dsLExprNoLP expr
let ty = exprType expr_ds
makeStaticId <- dsLookupGlobalId makeStaticName
-- of the record selector, and we must not make that a local binder
-- else we shadow other uses of the record selector
-- Hence 'lcl_id'. Cf #2735
- ds_field (dL->L _ rec_field)
+ ds_field (L _ rec_field)
= do { rhs <- dsLExpr (hsRecFieldArg rec_field)
; let fld_id = unLoc (hsRecUpdFieldId rec_field)
; lcl_id <- newSysLocalDs (idType fld_id)
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField rbinds sel
- = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds
+ = [hsRecFieldArg fld | L _ fld <- rbinds
, sel == idName (unLoc $ hsRecFieldId fld) ]
{-
= goL stmts
where
goL [] = panic "dsDo"
- goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+ goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
go _ (LastStmt _ body _ _) stmts
= ASSERT( null stmts ) dsLExpr body
, recS_ret_ty = body_ty} }) stmts
= goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
where
- new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
+ new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
| otherwise
= extractMatchResult match (error "It can't fail")
-mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
+mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
showPpr dflags (getLoc pat)
checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
checkForcedEtaExpansion expr ty
| Just var <- case expr of
- HsVar _ (dL->L _ var) -> Just var
+ HsVar _ (L _ var) -> Just var
HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
_ -> Nothing
, let bad_tys = badUseOfLevPolyPrimop var ty
(vcat cs $$ vcat fe_init_code),
foldr (appOL . toOL) nilOL bindss)
where
- do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl)
+ do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
traceIf (text "fi start" <+> ppr id)
traceIf (text "fi end" <+> ppr id)
return (h, c, [], bs)
- do_decl (ForeignExport { fd_name = (dL->L _ id)
+ do_decl (ForeignExport { fd_name = L _ id
, fd_e_ext = co
, fd_fe = CExport
- (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do
+ (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
do_decl (XForeignDecl nec) = noExtCon nec
dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM MatchResult
-dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))
+dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
-dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec
-dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884
+dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec
{-
************************************************************************
dsMonadComp stmts = dsMcStmts stmts
dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr
-dsMcStmts [] = panic "dsMcStmts"
-dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+dsMcStmts [] = panic "dsMcStmts"
+dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
---------------
dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
| otherwise
= extractMatchResult match (error "It can't fail")
- mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
+ mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg dflags pat
= "Pattern match failure in monad comprehension at " ++
showPpr dflags (getLoc pat)
wrapGenSyms ss q_decs
}
where
- no_splice (dL->L loc _)
+ no_splice (L loc _)
= notHandledL loc "Splices within declaration brackets" empty
- no_default_decl (dL->L loc decl)
+ no_default_decl (L loc decl)
= notHandledL loc "Default declarations" (ppr decl)
- no_warn (dL->L loc (Warning _ thing _))
+ no_warn (L loc (Warning _ thing _))
= notHandledL loc "WARNING and DEPRECATION pragmas" $
text "Pragma for declaration of" <+> ppr thing
no_warn _ = panic "repTopDs"
- no_doc (dL->L loc _)
+ no_doc (L loc _)
= notHandledL loc "Haddock documentation" empty
repTopDs (XHsGroup nec) = noExtCon nec
XValBindsLR (NValBinds _ sigs) -> sigs
get_scoped_tvs :: LSig GhcRn -> [Name]
-get_scoped_tvs (dL->L _ signature)
+get_scoped_tvs (L _ signature)
| TypeSig _ _ sig <- signature
= get_scoped_tvs_from_sig (hswc_body sig)
| ClassOpSig _ _ _ sig <- signature
--
repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
-repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $
- repFamilyDecl (L loc fam)
+repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
+ repFamilyDecl (L loc fam)
-repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
+repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
repSynDecl tc1 bndrs rhs
; return (Just (loc, dec)) }
-repTyClD (dL->L loc (DataDecl { tcdLName = tc
- , tcdTyVars = tvs
- , tcdDataDefn = defn }))
+repTyClD (L loc (DataDecl { tcdLName = tc
+ , tcdTyVars = tvs
+ , tcdDataDefn = defn }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
repDataDefn tc1 (Left bndrs) defn
; return (Just (loc, dec)) }
-repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
+repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
tcdTyVars = tvs, tcdFDs = fds,
tcdSigs = sigs, tcdMeths = meth_binds,
tcdATs = ats, tcdATDefs = atds }))
-------------------------
repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles))
+repRoleD (L loc (RoleAnnotDecl _ tycon roles))
= do { tycon1 <- lookupLOcc tycon
; roles1 <- mapM repRole roles
; roles2 <- coreList roleTyConName roles1
-------------------------
repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repKiSigD (dL->L loc kisig) =
+repKiSigD (L loc kisig) =
case kisig of
StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
XStandaloneKindSig nec -> noExtCon nec
; repTySyn tc bndrs ty1 }
repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo = info
- , fdLName = tc
- , fdTyVars = tvs
- , fdResultSig = dL->L _ resultSig
- , fdInjectivityAnn = injectivity }))
+repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info
+ , fdLName = tc
+ , fdTyVars = tvs
+ , fdResultSig = L _ resultSig
+ , fdInjectivityAnn = injectivity }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
mkHsQTvs tvs = HsQTvs { hsq_ext = []
-> DsM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn Nothing =
do { coreNothing injAnnTyConName }
-repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) =
+repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
do { lhs' <- lookupBinder (unLoc lhs)
; rhs1 <- mapM (lookupBinder . unLoc) rhs
; rhs2 <- coreList nameTyConName rhs1
repLFunDeps fds = repList funDepTyConName repLFunDep fds
repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
-repLFunDep (dL->L _ (xs, ys))
+repLFunDep (L _ (xs, ys))
= do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
ys' <- repList nameTyConName (lookupBinder . unLoc) ys
repFunDep xs' ys'
-- Represent instance declarations
--
repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl }))
+repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
= do { dec <- repTyFamInstD fi_decl
; return (loc, dec) }
-repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl }))
+repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
= do { dec <- repDataFamInstD fi_decl
; return (loc, dec) }
-repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl }))
+repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
= do { dec <- repClsInstD cls_decl
; return (loc, dec) }
repInstD _ = panic "repInstD"
repClsInstD (XClsInstDecl nec) = noExtCon nec
repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat
- , deriv_type = ty }))
+repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
+ , deriv_type = ty }))
= do { dec <- addSimpleTyVarBinds tvs $
do { cxt' <- repLContext cxt
; strat' <- repDerivStrategy strat
= noExtCon nec
repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
-repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
- , fd_fi = CImport (dL->L _ cc)
- (dL->L _ s) mch cis _ }))
+repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
+ , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
= do MkC name' <- lookupLOcc name
MkC typ' <- repHsSigType typ
MkC cc' <- repCCallConv cc
repSafety PlaySafe = rep2 safeName []
repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))
+repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
= do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
InfixL -> infixLDName
repFixD _ = panic "repFixD"
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRuleD (dL->L loc (HsRule { rd_name = n
- , rd_act = act
- , rd_tyvs = ty_bndrs
- , rd_tmvs = tm_bndrs
- , rd_lhs = lhs
- , rd_rhs = rhs }))
+repRuleD (L loc (HsRule { rd_name = n
+ , rd_act = act
+ , rd_tyvs = ty_bndrs
+ , rd_tmvs = tm_bndrs
+ , rd_lhs = lhs
+ , rd_rhs = rhs }))
= do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
; ss <- mkGenSyms tm_bndr_names
repRuleD _ = panic "repRuleD"
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
-ruleBndrNames (dL->L _ (RuleBndr _ n)) = [unLoc n]
-ruleBndrNames (dL->L _ (RuleBndrSig _ n sig))
+ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
+ruleBndrNames (L _ (RuleBndrSig _ n sig))
| HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
= unLoc n : vars
-ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
+ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
= panic "ruleBndrNames"
-ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
+ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
= panic "ruleBndrNames"
-ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec
-ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884
+ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec
repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
-repRuleBndr (dL->L _ (RuleBndr _ n))
+repRuleBndr (L _ (RuleBndr _ n))
= do { MkC n' <- lookupLBinder n
; rep2 ruleVarName [n'] }
-repRuleBndr (dL->L _ (RuleBndrSig _ n sig))
+repRuleBndr (L _ (RuleBndrSig _ n sig))
= do { MkC n' <- lookupLBinder n
; MkC ty' <- repLTy (hsSigWcType sig)
; rep2 typedRuleVarName [n', ty'] }
repRuleBndr _ = panic "repRuleBndr"
repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))
+repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
= do { target <- repAnnProv ann_prov
; exp' <- repE exp
; dec <- repPragAnn target exp'
repAnnD _ = panic "repAnnD"
repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
-repAnnProv (ValueAnnProvenance (dL->L _ n))
+repAnnProv (ValueAnnProvenance (L _ n))
= do { MkC n' <- globalVar n -- ANNs are allowed only at top-level
; rep2 valueAnnotationName [ n' ] }
-repAnnProv (TypeAnnProvenance (dL->L _ n))
+repAnnProv (TypeAnnProvenance (L _ n))
= do { MkC n' <- globalVar n
; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
-------------------------------------------------------
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
-repC (dL->L _ (ConDeclH98 { con_name = con
- , con_forall = (dL->L _ False)
- , con_mb_cxt = Nothing
- , con_args = args }))
+repC (L _ (ConDeclH98 { con_name = con
+ , con_forall = L _ False
+ , con_mb_cxt = Nothing
+ , con_args = args }))
= repDataCon con args
-repC (dL->L _ (ConDeclH98 { con_name = con
- , con_forall = (dL->L _ is_existential)
- , con_ex_tvs = con_tvs
- , con_mb_cxt = mcxt
- , con_args = args }))
+repC (L _ (ConDeclH98 { con_name = con
+ , con_forall = L _ is_existential
+ , con_ex_tvs = con_tvs
+ , con_mb_cxt = mcxt
+ , con_args = args }))
= do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
do { c' <- repDataCon con args
; ctxt' <- repMbContext mcxt
}
}
-repC (dL->L _ (ConDeclGADT { con_names = cons
- , con_qvars = qtvs
- , con_mb_cxt = mcxt
- , con_args = args
- , con_res_ty = res_ty }))
+repC (L _ (ConDeclGADT { con_names = cons
+ , con_qvars = qtvs
+ , con_mb_cxt = mcxt
+ , con_args = args
+ , con_res_ty = res_ty }))
| isEmptyLHsQTvs qtvs -- No implicit or explicit variables
, Nothing <- mcxt -- No context
-- ==> no need for a forall
repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
repMbContext Nothing = repContext []
-repMbContext (Just (dL->L _ cxt)) = repContext cxt
+repMbContext (Just (L _ cxt)) = repContext cxt
repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []
-------------------------------------------------------
repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
-repDerivs (dL->L _ clauses)
+repDerivs (L _ clauses)
= repList derivClauseQTyConName repDerivClause clauses
repDerivClause :: LHsDerivingClause GhcRn
-> DsM (Core TH.DerivClauseQ)
-repDerivClause (dL->L _ (HsDerivingClause
+repDerivClause (L _ (HsDerivingClause
{ deriv_clause_strategy = dcs
- , deriv_clause_tys = (dL->L _ dct) }))
+ , deriv_clause_tys = L _ dct }))
= do MkC dcs' <- repDerivStrategy dcs
MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
rep2 derivClauseName [dcs',dct']
rep_sigs = concatMapM rep_sig
rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_sig (dL->L loc (TypeSig _ nms ty))
+rep_sig (L loc (TypeSig _ nms ty))
= mapM (rep_wc_ty_sig sigDName loc ty) nms
-rep_sig (dL->L loc (PatSynSig _ nms ty))
+rep_sig (L loc (PatSynSig _ nms ty))
= mapM (rep_patsyn_ty_sig loc ty) nms
-rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty))
+rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
| is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
| otherwise = mapM (rep_ty_sig sigDName loc ty) nms
-rep_sig d@(dL->L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
-rep_sig (dL->L _ (FixSig {})) = return [] -- fixity sigs at top level
-rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
-rep_sig (dL->L loc (SpecSig _ nm tys ispec))
+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 tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec loc) tys
-rep_sig (dL->L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
-rep_sig (dL->L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
-rep_sig (dL->L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
-rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty))
+rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
+rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
+rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
+rep_sig (L loc (CompleteMatchSig _ _st cls mty))
= rep_complete_sig cls mty loc
rep_sig _ = panic "rep_sig"
-> Maybe (Located Name)
-> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
-rep_complete_sig (dL->L _ cls) mty loc
+rep_complete_sig (L _ cls) mty loc
= do { mty' <- repMaybe nameTyConName lookupLOcc mty
; cls' <- repList nameTyConName lookupLOcc cls
; sig <- repPragComplete cls' mty'
--
repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
-> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
-repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm
+repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
= repPlainTV nm
-repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
= repLTy ki >>= repKindedTV nm
repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind"
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
-repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) )
+repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )
= do { nm' <- lookupBinder nm
; repPlainTV nm' }
-repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki))
+repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki))
= do { nm' <- lookupBinder nm
; ki' <- repLTy ki
; repKindedTV nm' ki' }
repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf ty
repTy ty@(HsQualTy {}) = repForall ForallInvis ty
-repTy (HsTyVar _ _ (dL->L _ n))
+repTy (HsTyVar _ _ (L _ n))
| isLiftedTypeKindTyConName n = repTStar
| n `hasKey` constraintKindTyConKey = repTConstraint
| n `hasKey` funTyConKey = repArrowTyCon
repMaybeLTy = repMaybe kindQTyConName repLTy
repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
-repRole (dL->L _ (Just Nominal)) = rep2 nominalRName []
-repRole (dL->L _ (Just Representational)) = rep2 representationalRName []
-repRole (dL->L _ (Just Phantom)) = rep2 phantomRName []
-repRole (dL->L _ Nothing) = rep2 inferRName []
-repRole _ = panic "repRole: Impossible Match" -- due to #15884
+repRole (L _ (Just Nominal)) = rep2 nominalRName []
+repRole (L _ (Just Representational)) = rep2 representationalRName []
+repRole (L _ (Just Phantom)) = rep2 phantomRName []
+repRole (L _ Nothing) = rep2 inferRName []
-----------------------------------------------------------------------------
-- Splices
-- unless we can make sure that constructs, which are plainly not
-- supported in TH already lead to error messages at an earlier stage
repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
-repLE (dL->L loc e) = putSrcSpanDs loc (repE e)
+repLE (L loc e) = putSrcSpanDs loc (repE e)
repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
-repE (HsVar _ (dL->L _ x)) =
+repE (HsVar _ (L _ x)) =
do { mb_val <- dsLookupMetaEnv x
; case mb_val of
Nothing -> do { str <- globalVar x
-- HsOverlit can definitely occur
repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
-repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m
-repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) }))
+repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))
= do { ms' <- mapM repMatchTup ms
; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms }
repE (HsPar _ x) = repLE x
repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) }))
+repE (HsCase _ e (MG { mg_alts = (L _ ms) }))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; core_ms2 <- coreList matchQTyConName ms2
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) expr' }
-repE (HsLet _ (dL->L _ bs) e) = do { (ss,ds) <- repBinds bs
+repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e)
; z <- repLetE ds e2
; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
-repE e@(HsDo _ ctxt (dL->L _ sts))
+repE e@(HsDo _ ctxt (L _ sts))
| case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
e' <- repDoE (nonEmptyCoreList zs);
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE (ExplicitTuple _ es boxity) =
let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))
- tupArgToCoreExp a
- | L _ (Present _ e) <- dL a = do { e' <- repLE e
- ; coreJust expQTyConName e' }
+ tupArgToCoreExp (L _ a)
+ | Present _ e <- a = do { e' <- repLE e
+ ; coreJust expQTyConName e' }
| otherwise = coreNothing expQTyConName
in do { args <- mapM tupArgToCoreExp es
-- Building representations of auxiliary structures like Match, Clause, Stmt,
repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
-repMatchTup (dL->L _ (Match { m_pats = [p]
- , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
+repMatchTup (L _ (Match { m_pats = [p]
+ , m_grhss = GRHSs _ guards (L _ wheres) })) =
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repLP p
repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
-repClauseTup (dL->L _ (Match { m_pats = ps
- , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
+repClauseTup (L _ (Match { m_pats = ps
+ , m_grhss = GRHSs _ guards (L _ wheres) })) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
ps1 <- repLPs ps
gs <- repGuards guards
; clause <- repClause ps1 gs ds
; wrapGenSyms (ss1++ss2) clause }}}
-repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec
+repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec
repClauseTup _ = panic "repClauseTup"
repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)
-repGuards [dL->L _ (GRHS _ [] e)]
+repGuards [L _ (GRHS _ [] e)]
= do {a <- repLE e; repNormal a }
repGuards other
= do { zs <- mapM repLGRHS other
repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
-> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2))
+repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
= do { guarded <- repLNormalGE e1 e2
; return ([], guarded) }
-repLGRHS (dL->L _ (GRHS _ ss rhs))
+repLGRHS (L _ (GRHS _ ss rhs))
= do { (gs, ss') <- repLSts ss
; rhs' <- addBinds gs $ repLE rhs
; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
where
rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
-> DsM (Core (TH.Q TH.FieldExp))
- rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
- ; e <- repLE (hsRecFieldArg fld)
- ; repFieldExp fn e }
+ rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
+ ; e <- repLE (hsRecFieldArg fld)
+ ; repFieldExp fn e }
repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
repUpdFields = repList fieldExpQTyConName rep_fld
where
rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
- rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of
- Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name)
+ rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
+ Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e }
_ -> notHandled "Ambiguous record updates" (ppr fld)
; (ss2,zs) <- repSts ss
; z <- repBindSt p1 e2
; return (ss1++ss2, z : zs) }}
-repSts (LetStmt _ (dL->L _ bs) : ss) =
+repSts (LetStmt _ (L _ bs) : ss) =
do { (ss1,ds) <- repBinds bs
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs)))
+rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
= do { name <- case ename of
- Left (dL->L _ n) -> rep_implicit_param_name n
+ Left (L _ n) -> rep_implicit_param_name n
Right _ ->
panic "rep_implicit_param_bind: post typechecking"
; rhs' <- repE rhs
; ipb <- repImplicitParamBind name rhs'
; return (loc, ipb) }
-rep_implicit_param_bind (dL->L _ b@(XIPBind _))
+rep_implicit_param_bind (L _ b@(XIPBind _))
= notHandled "Implicit parameter bind extension" (ppr b)
-rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match"
- -- due to #15884
rep_implicit_param_name :: HsIPName -> DsM (Core String)
rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
-- Note GHC treats declarations of a variable (not a pattern)
-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
-- with an empty list of patterns
-rep_bind (dL->L loc (FunBind
+rep_bind (L loc (FunBind
{ fun_id = fn,
fun_matches = MG { mg_alts
- = (dL->L _ [dL->L _ (Match
- { m_pats = []
- , m_grhss = GRHSs _ guards
- (dL->L _ wheres) }
+ = (L _ [L _ (Match
+ { m_pats = []
+ , m_grhss = GRHSs _ guards (L _ wheres) }
)]) } }))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; ans' <- wrapGenSyms ss ans
; return (loc, ans') }
-rep_bind (dL->L loc (FunBind { fun_id = fn
- , fun_matches = MG { mg_alts = (dL->L _ ms) } }))
+rep_bind (L loc (FunBind { fun_id = fn
+ , fun_matches = MG { mg_alts = L _ ms } }))
= do { ms1 <- mapM repClauseTup ms
; fn' <- lookupLBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
; return (loc, ans) }
-rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec
+rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec
-rep_bind (dL->L loc (PatBind { pat_lhs = pat
- , pat_rhs = GRHSs _ guards (dL->L _ wheres) }))
+rep_bind (L loc (PatBind { pat_lhs = pat
+ , pat_rhs = GRHSs _ guards (L _ wheres) }))
= do { patcore <- repLP pat
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; ans <- repVal patcore guardcore wherecore
; ans' <- wrapGenSyms ss ans
; return (loc, ans') }
-rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec
+rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec
-rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))
+rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
= do { v' <- lookupBinder v
; e2 <- repLE e
; x <- repNormal e2
; ans <- repVal patcore x empty_decls
; return (srcLocSpan (getSrcLoc v), ans) }
-rep_bind (dL->L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
-rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn
- , psb_args = args
- , psb_def = pat
- , psb_dir = dir })))
+rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
+rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
+ , psb_args = args
+ , psb_def = pat
+ , psb_dir = dir })))
= do { syn' <- lookupLBinder syn
; dir' <- repPatSynDir dir
; ss <- mkGenArgSyms args
wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
-rep_bind (dL->L _ (PatSynBind _ (XPatSynBind nec)))
- = noExtCon nec
-rep_bind (dL->L _ (XHsBindsLR nec)) = noExtCon nec
-rep_bind _ = panic "rep_bind: Impossible match!"
- -- due to #15884
+rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec
+rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec
repPatSynD :: Core TH.Name
-> Core TH.PatSynArgsQ
repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
repPatSynDir Unidirectional = rep2 unidirPatSynName []
repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
-repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) }))
+repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))
= do { clauses' <- mapM repClauseTup clauses
; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
-repLambda (dL->L _ (Match { m_pats = ps
- , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)]
- (dL->L _ (EmptyLocalBinds _)) } ))
+repLambda (L _ (Match { m_pats = ps
+ , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
+ (L _ (EmptyLocalBinds _)) } ))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyms ss lam }
-repLambda (dL->L _ m) = notHandled "Guarded lambdas" (pprMatch m)
+repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)
-----------------------------------------------------------------------------
}
where
rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
- rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
- ; MkC p <- repLP (hsRecFieldArg fld)
- ; rep2 fieldPatName [v,p] }
+ rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
+ ; MkC p <- repLP (hsRecFieldArg fld)
+ ; rep2 fieldPatName [v,p] }
-repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l
- ; repPlit a }
+repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l
+ ; repPlit a }
repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP (SigPat _ p t) = do { p' <- repLP p
-- and all the desugared binds
mkSelectorBinds ticks pat val_expr
- | (dL->L _ (VarPat _ (dL->L _ v))) <- pat' -- Special case (A)
+ | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)
= return (v, [(v, val_expr)])
| is_flat_prod_lpat pat' -- Special case (B)
strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
-- Remove outermost bangs and parens
-strip_bangs (dL->L _ (ParPat _ p)) = strip_bangs p
-strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p
-strip_bangs lp = lp
+strip_bangs (L _ (ParPat _ p)) = strip_bangs p
+strip_bangs (L _ (BangPat _ p)) = strip_bangs p
+strip_bangs lp = lp
is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
is_flat_prod_lpat = is_flat_prod_pat . unLoc
is_flat_prod_pat :: Pat (GhcPass p) -> Bool
is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p
is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
-is_flat_prod_pat (ConPatOut { pat_con = (dL->L _ pcon)
+is_flat_prod_pat (ConPatOut { pat_con = L _ pcon
, pat_args = ps})
| RealDataCon con <- pcon
, isProductTyCon (dataConTyCon con)
mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats = cL (getLoc (head lpats)) $
+mkLHsPatTup lpats = L (getLoc (head lpats)) $
mkVanillaTuplePat lpats Boxed
mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
| otherwise -- -XStrict
= go lpat
where
- go lp@(dL->L l p)
+ go lp@(L l p)
= case p of
- ParPat x p -> cL l (ParPat x (go p))
+ ParPat x p -> L l (ParPat x (go p))
LazyPat _ lp' -> lp'
BangPat _ _ -> lp
- _ -> cL l (BangPat noExtField lp)
+ _ -> L l (BangPat noExtField lp)
-- | Unconditionally make a 'Pat' strict.
addBang :: LPat GhcTc -- ^ Original pattern
-> LPat GhcTc -- ^ Banged pattern
addBang = go
where
- go lp@(dL->L l p)
+ go lp@(L l p)
= case p of
- ParPat x p -> cL l (ParPat x (go p))
- LazyPat _ lp' -> cL l (BangPat noExtField lp')
+ ParPat x p -> L l (ParPat x (go p))
+ LazyPat _ lp' -> L l (BangPat noExtField lp')
-- Should we bring the extension value over?
BangPat _ _ -> lp
- _ -> cL l (BangPat noExtField lp)
+ _ -> L l (BangPat noExtField lp)
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- * Trivial wappings of these
-- The arguments to Just are any HsTicks that we have found,
-- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v)))
+isTrueLHsExpr (L _ (HsVar _ (L _ v)))
| v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
-- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (dL->L _ (HsConLikeOut _ con))
+isTrueLHsExpr (L _ (HsConLikeOut _ con))
| con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (dL->L _ (HsTick _ tickish e))
+isTrueLHsExpr (L _ (HsTick _ tickish e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do wrapped <- ticks x
return (Tick tickish wrapped))
-- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e))
+isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do e <- ticks x
this_mod <- getModule
return (Tick (HpcTick this_mod ixT) e))
-isTrueLHsExpr (dL->L _ (HsPar _ e)) = isTrueLHsExpr e
-isTrueLHsExpr _ = Nothing
+isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e
+isTrueLHsExpr _ = Nothing
import GHC.Hs.Doc
import GHC.Hs.Decls
import GHC.Hs.Extension
+import GHC.Hs.Pat
import GHC.Hs.Types
import GHC.Hs.Utils
import Name
(associated with InstDecls and DerivDecls).
-}
-getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
+getMainDeclBinder :: XRec pass Pat ~ Located (Pat pass) =>
+ HsDecl pass -> [IdP pass]
getMainDeclBinder (TyClD _ d) = [tcdName d]
getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
getInstLoc = \case
ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
DataFamInstD _ (DataFamInstDecl
- { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l
+ { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l
TyFamInstD _ (TyFamInstDecl
-- Since CoAxioms' Names refer to the whole line for type family instances
-- in particular, we need to dig a bit deeper to pull out the entire
-- equation. This does not happen for data family instances, for some
-- reason.
- { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l
+ { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l
ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
subordinates instMap decl = case decl of
InstD _ (ClsInstD _ d) -> do
DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_tycon = (dL->L l _)
+ FamEqn { feqn_tycon = L l _
, feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
[ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
_ -> []
where
classSubs dd = [ (name, doc, declTypeDocs d)
- | (dL->L _ d, doc) <- classDecls dd
+ | (L _ d, doc) <- classDecls dd
, name <- getMainDeclBinder d, not (isValD d)
]
dataSubs :: HsDataDefn GhcRn
| c <- cons, cname <- getConNames c ]
fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
| RecCon flds <- map getConArgs cons
- , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
- , (dL->L _ n) <- ns ]
+ , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
+ , (L _ n) <- ns ]
derivs = [ (instName, [unLoc doc], M.empty)
| (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
concatMap (unLoc . deriv_clause_tys . unLoc) $
, Just instName <- [M.lookup l instMap] ]
extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
- extract_deriv_ty ty =
- case dL ty of
+ extract_deriv_ty (L l ty) =
+ case ty of
-- deriving (forall a. C a {- ^ Doc comment -})
- L l (HsForAllTy{ hst_fvf = ForallInvis
- , hst_body = dL->L _ (HsDocTy _ _ doc) })
- -> Just (l, doc)
+ HsForAllTy{ hst_fvf = ForallInvis
+ , hst_body = L _ (HsDocTy _ _ doc) }
+ -> Just (l, doc)
-- deriving (C a {- ^ Doc comment -})
- L l (HsDocTy _ _ doc) -> Just (l, doc)
- _ -> Nothing
+ HsDocTy _ _ doc -> Just (l, doc)
+ _ -> Nothing
-- | Extract constructor argument docs from inside constructor decls.
conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
- let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1
+ let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
-- do the rest of the compilation
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var pat_ty'
tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat)
tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat)
tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-tidy1 v o (BangPat _ (dL->L l p)) = tidy_bang_pat v o l p
+tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
-tidy1 v _ (VarPat _ (dL->L _ var))
+tidy1 v _ (VarPat _ (L _ var))
= return (wrapBind var v, WildPat (idType var))
-- case v of { x@p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v o (AsPat _ (dL->L _ var) pat)
+tidy1 v o (AsPat _ (L _ var) pat)
= do { (wrap, pat') <- tidy1 v o (unLoc pat)
; return (wrapBind var v . wrap, pat') }
; return (idDsWrapper, tidyLitPat lit) }
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq)
+tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
= do { unless (isGenerated o) $
let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
| otherwise = lit
; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
-- NPlusKPat: we may want to warn about the literals
-tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _)
+tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
= do { unless (isGenerated o) $ do
warnAboutOverflowedOverLit lit1
warnAboutOverflowedOverLit lit2
-> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
-tidy_bang_pat v o _ (ParPat _ (dL->L l p)) = tidy_bang_pat v o l p
-tidy_bang_pat v o _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v o l p
+tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p
+tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
tidy_bang_pat v o l (AsPat x v' p)
- = tidy1 v o (AsPat x v' (cL l (BangPat noExtField p)))
+ = tidy1 v o (AsPat x v' (L l (BangPat noExtField p)))
tidy_bang_pat v o l (CoPat x w p t)
- = tidy1 v o (CoPat x w (BangPat noExtField (cL l p)) t)
+ = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t)
-- Discard bang around strict pattern
tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p
tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p
-- Data/newtype constructors
-tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))
+tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
, pat_args = args
, pat_arg_tys = arg_tys })
-- Newtypes: push bang inwards (#9844)
--
-- NB: SigPatIn, ConPatIn should not happen
-tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (cL l p))
+tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
-------------------
push_bang_into_newtype_arg :: SrcSpan
-- We are transforming !(N p) into (N !p)
push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
= ASSERT( null args)
- PrefixCon [cL l (BangPat noExtField arg)]
+ PrefixCon [L l (BangPat noExtField arg)]
push_bang_into_newtype_arg l _ty (RecCon rf)
- | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf
+ | HsRecFields { rec_flds = L lf fld : flds } <- rf
, HsRecField { hsRecFieldArg = arg } <- fld
= ASSERT( null flds)
- RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg
- = cL l (BangPat noExtField arg) })] })
+ RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
+ = L l (BangPat noExtField arg) })] })
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
| HsRecFields { rec_flds = [] } <- rf
- = PrefixCon [cL l (BangPat noExtField (noLoc (WildPat ty)))]
+ = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))]
push_bang_into_newtype_arg _ _ cd
= pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
JJQC 30-Nov-1997
-}
-matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)
+matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
, mg_ext = MatchGroupTc arg_tys rhs_ty
, mg_origin = origin })
= do { dflags <- getDynFlags
; return (new_vars, result_expr) }
where
-- Called once per equation in the match, or alternative in the case
- mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))
+ mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
= do { dflags <- getDynFlags
; let upats = map (unLoc . decideBangHood dflags) pats
dicts = collectEvVarsPats upats
; return (EqnInfo { eqn_pats = upats
, eqn_orig = FromSource
, eqn_rhs = match_result }) }
- mk_eqn_info _ (dL->L _ (XMatch nec)) = noExtCon nec
- mk_eqn_info _ _ = panic "mk_eqn_info: Impossible Match" -- due to #15884
+ mk_eqn_info _ (L _ (XMatch nec)) = noExtCon nec
handleWarnings = if isGenerated origin
then discardWarningsDs
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
-- real comparison is on HsExpr's
-- strip parens
- exp (HsPar _ (dL->L _ e)) e' = exp e e'
- exp e (HsPar _ (dL->L _ e')) = exp e e'
+ exp (HsPar _ (L _ e)) e' = exp e e'
+ exp e (HsPar _ (L _ e')) = exp e e'
-- because the expressions do not necessarily have the same type,
-- we have to compare the wrappers
exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
wrap res_wrap1 res_wrap2
---------
- tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2
- tup_arg (dL->L _ (Missing t1)) (dL->L _ (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
---------
eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
patGroup :: DynFlags -> Pat GhcTc -> PatGroup
-patGroup _ (ConPatOut { pat_con = (dL->L _ con)
+patGroup _ (ConPatOut { pat_con = L _ con
, pat_arg_tys = tys })
| RealDataCon dcon <- con = PgCon dcon
| PatSynCon psyn <- con = PgSyn psyn tys
patGroup _ (WildPat {}) = PgAny
patGroup _ (BangPat {}) = PgBang
-patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) =
+patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
case (oval, isJust mb_neg) of
(HsIntegral i, False) -> PgN (fromInteger (il_value i))
(HsIntegral i, True ) -> PgN (-fromInteger (il_value i))
(HsFractional r, True ) -> PgN (-fl_value r)
(HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
PgOverS s
-patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) =
+patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
case oval of
HsIntegral i -> PgNpK (il_value i)
_ -> pprPanic "patGroup NPlusKPat" (ppr oval)
alt_wrapper = wrapper1,
alt_result = foldr1 combineMatchResults match_results } }
where
- ConPatOut { pat_con = (dL->L _ con1)
+ ConPatOut { pat_con = L _ con1
, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
= firstPat eqn1
= arg_vars
where
fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
- lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env
+ lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
(idName (unLoc (hsRecFieldId rpat)))
select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
matchOneConLike _ _ [] = panic "matchOneCon []"
same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)
-> Bool
same_fields flds1 flds2
- = all2 (\(dL->L _ f1) (dL->L _ f2)
+ = all2 (\(L _ f1) (L _ f2)
-> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
(rec_flds flds1) (rec_flds flds2)
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
-- ^ See if the expression is an 'Integral' literal.
-- Remember to look through automatically-added tick-boxes! (#8384)
-getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
-getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit
+getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit
getLHsIntegralLit _ = Nothing
-- | If 'Integral', extract the value and type name of the overloaded literal.
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
- = do { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1
+ = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var:vars) ty (eqn1:eqns)
- = do { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus
+ = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
= firstPat eqn1
; lit1_expr <- dsOverLit lit1
; lit2_expr <- dsOverLit lit2
adjustMatchResult (foldr1 (.) wraps) $
match_result) }
where
- shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats })
+ shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
= (wrapBind n n1, eqn { eqn_pats = pats })
-- The wrapBind is a no-op for the first equation
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
-> [LPat (GhcPass p)]
-> [PScoped (LPat (GhcPass p))]
patScopes rsp useScope patScope xs =
- map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $
- listScopes patScope (map dL xs)
+ map (\(RS sc a) -> PS rsp useScope sc a) $
+ listScopes patScope xs
-- | 'listScopes' specialised to 'TVScoped' things
tvScopes
_ -> makeNode bind spn
instance HasType (Located (Pat GhcRn)) where
- getTypeNode (dL -> L spn pat) = makeNode pat spn
+ getTypeNode (L spn pat) = makeNode pat spn
instance HasType (Located (Pat GhcTc)) where
- getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
+ getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat)
instance HasType (LHsExpr GhcRn) where
getTypeNode (L spn e) = makeNode e spn
, HasType (LPat a)
, Data (HsSplice a)
) => ToHie (PScoped (Located (Pat (GhcPass p)))) where
- toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
+ toHie (PS rsp scope pscope lpat@(L ospan opat)) =
concatM $ getTypeNode lpat : case opat of
WildPat _ ->
[]
]
AsPat _ lname pat ->
[ toHie $ C (PatternBind scope
- (combineScopes (mkLScope (dL pat)) pscope)
+ (combineScopes (mkLScope pat) pscope)
rsp)
lname
, toHie $ PS rsp scope pscope pat
]
SigPat _ pat sig ->
[ toHie $ PS rsp scope pscope pat
- , let cscope = mkLScope (dL pat) in
+ , let cscope = mkLScope pat in
toHie $ TS (ResolvedScopes [cscope, scope, pscope])
(protectSig @a cscope sig)
-- See Note [Scoping Rules for SigPat]
getLoc, unLoc,
getRealSrcSpan, unRealSrcSpan,
- -- ** HasSrcSpan
- HasSrcSpan(..), SrcSpanLess, dL, cL,
-
-- *** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost,
addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens _ _ [] = []
-addSourceToTokens loc buf (t@(dL->L span _) : ts)
+addSourceToTokens loc buf (t@(L span _) : ts)
= case span of
UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts
getFile (RealSrcSpan s : _) = srcSpanFile s
startLoc = mkRealSrcLoc sourceFile 1 1
go _ [] = id
- go loc ((dL->L span _, str):ts)
+ go loc ((L span _, str):ts)
= case span of
UnhelpfulSpan _ -> go loc ts
RealSrcSpan s
imps = hsmodImports hsmod
main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
1 1)
- mod = mb_mod `orElse` cL main_loc mAIN_NAME
+ mod = mb_mod `orElse` L main_loc mAIN_NAME
(src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
-- GHC.Prim doesn't exist physically, so don't go looking for it.
implicit_prelude = xopt LangExt.ImplicitPrelude dflags
implicit_imports = mkPrelImports (unLoc mod) main_loc
implicit_prelude imps
- convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i)
- , ideclName i)
+ convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
in
return (map convImport src_idecls,
map convImport (implicit_imports ++ ordinary_imps),
| otherwise = [preludeImportDecl]
where
explicit_prelude_import
- = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod
- , ideclPkgQual = Nothing }))
+ = notNull [ () | L _ (ImportDecl { ideclName = mod
+ , ideclPkgQual = Nothing })
<- import_decls
, unLoc mod == pRELUDE_NAME ]
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
- = cL loc $ ImportDecl { ideclExt = noExtField,
- ideclSourceSrc = NoSourceText,
- ideclName = cL loc pRELUDE_NAME,
- ideclPkgQual = Nothing,
- ideclSource = False,
- ideclSafe = False, -- Not a safe import
- ideclQualified = NotQualified,
- ideclImplicit = True, -- Implicit!
- ideclAs = Nothing,
- ideclHiding = Nothing }
+ = L loc $ ImportDecl { ideclExt = noExtField,
+ ideclSourceSrc = NoSourceText,
+ ideclName = L loc pRELUDE_NAME,
+ ideclPkgQual = Nothing,
+ ideclSource = False,
+ ideclSafe = False, -- Not a safe import
+ ideclQualified = NotQualified,
+ ideclImplicit = True, -- Implicit!
+ ideclAs = Nothing,
+ ideclHiding = Nothing }
--------------------------------------------------------------
-- Get options
_other -> do rest <- lazyLexBuf handle state' eof size
return (t : rest)
_ | not eof -> getMore handle state size
- | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof]
+ | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
-- parser assumes an ITeof sentinel at the end
getMore :: Handle -> PState -> Int -> IO [Located Token]
loc = mkRealSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer False return) state of
- POk _ t@(dL->L _ ITeof) -> [t]
+ POk _ t@(L _ ITeof) -> [t]
POk state' t -> t : lexAll state'
- _ -> [cL (RealSrcSpan (last_loc state)) ITeof]
+ _ -> [L (RealSrcSpan (last_loc state)) ITeof]
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
= case toArgs str of
Left _err -> optionsParseError str dflags $ -- #15053
combineSrcSpans (getLoc open) (getLoc close)
- Right args -> map (cL (getLoc open)) args ++ parseToks xs
+ Right args -> map (L (getLoc open)) args ++ parseToks xs
parseToks (open:close:xs)
| ITinclude_prag str <- unLoc open
, ITclose_prag <- unLoc close
- = map (cL (getLoc open)) ["-#include",removeSpaces str] ++
+ = map (L (getLoc open)) ["-#include",removeSpaces str] ++
parseToks xs
parseToks (open:close:xs)
| ITdocOptions str <- unLoc open
, ITclose_prag <- unLoc close
- = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str]
+ = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
++ parseToks xs
parseToks (open:xs)
| ITlanguage_prag <- unLoc open
| isComment (unLoc comment)
= parseToks xs
parseToks _ = []
- parseLanguage ((dL->L loc (ITconid fs)):rest)
- = checkExtension dflags (cL loc fs) :
+ parseLanguage ((L loc (ITconid fs)):rest)
+ = checkExtension dflags (L loc fs) :
case rest of
- (dL->L _loc ITcomma):more -> parseLanguage more
- (dL->L _loc ITclose_prag):more -> parseToks more
- (dL->L loc _):_ -> languagePragParseError dflags loc
+ (L _loc ITcomma):more -> parseLanguage more
+ (L _loc ITclose_prag):more -> parseToks more
+ (L loc _):_ -> languagePragParseError dflags loc
[] -> panic "getOptions'.parseLanguage(1) went past eof token"
parseLanguage (tok:_)
= languagePragParseError dflags (getLoc tok)
checkProcessArgsResult dflags flags
= when (notNull flags) $
liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
- where mkMsg (dL->L loc flag)
+ where mkMsg (L loc flag)
= mkPlainErrMsg dflags loc $
(text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
text flag)
-----------------------------------------------------------------------------
checkExtension :: DynFlags -> Located FastString -> Located String
-checkExtension dflags (dL->L l ext)
+checkExtension dflags (L l ext)
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
= if ext' `elem` supported
- then cL l ("-X"++ext')
+ then L l ("-X"++ext')
else unsupportedExtnError dflags l ext'
where
ext' = unpackFS ext
optionsErrorMsgs dflags unhandled_flags flags_lines _filename
= (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
where unhandled_flags_lines :: [Located String]
- unhandled_flags_lines = [ cL l f
+ unhandled_flags_lines = [ L l f
| f <- unhandled_flags
- , (dL->L l f') <- flags_lines
+ , L l f' <- flags_lines
, f == f' ]
- mkMsg (dL->L flagSpan flag) =
+ mkMsg (L flagSpan flag) =
ErrUtils.mkPlainErrMsg dflags flagSpan $
text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
-- | Source Statistics
ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc
-ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
+ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
= (if short then hcat else vcat)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
val_decls = [d | ValD _ d <- decls]
- real_exports = case exports of { Nothing -> []; Just (dL->L _ 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})
(inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
= sum5 (map inst_info inst_decls)
- count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0)
+ count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0)
count_bind (PatBind {}) = (0,1,0)
count_bind (FunBind {}) = (0,1,0)
count_bind (PatSynBind {}) = (0,0,1)
sig_info (ClassOpSig {}) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
- import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
- , ideclAs = as, ideclHiding = spec }))
+ import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
+ , ideclAs = as, ideclHiding = spec }))
= add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
- import_info (dL->L _ (XImportDecl nec)) = noExtCon nec
- import_info _ = panic " import_info: Impossible Match"
- -- due to #15884
+ import_info (L _ (XImportDecl nec)) = noExtCon nec
safe_info False = 0
safe_info True = 1
data_info (DataDecl { tcdDataDefn = HsDataDefn
{ dd_cons = cs
- , dd_derivs = (dL->L _ derivs)}})
+ , dd_derivs = L _ derivs}})
= ( length cs
, foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
0 derivs )
-- It would be nicer if warns :: [Located MsgDoc], but that
-- has circular import problems.
bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
- | Warn _ (dL->L loc warn) <- warns' ]
+ | Warn _ (L loc warn) <- warns' ]
printOrThrowWarnings dflags bag
signature :: { Located (HsModule GhcPs) }
: maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7)
+ ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
(snd $ snd $7) $4 $1)
)
([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) }
module :: { Located (HsModule GhcPs) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7)
+ ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
(snd $ snd $7) $4 $1)
)
([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) }
| body2
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule Nothing Nothing
+ ams (L loc (HsModule Nothing Nothing
(fst $ snd $1) (snd $ snd $1) Nothing Nothing))
(fst $1) }
header :: { Located (HsModule GhcPs) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
)) [mj AnnModule $2,mj AnnWhere $6] }
| maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
)) [mj AnnModule $2,mj AnnWhere $6] }
| header_body2
{% fileSrcSpan >>= \ loc ->
- return (cL loc (HsModule Nothing Nothing $1 [] Nothing
+ return (L loc (HsModule Nothing Nothing $1 [] Nothing
Nothing)) }
header_body :: { [LImportDecl GhcPs] }
qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list
: qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of
- l@(dL->L _ ImpExpQcWildcard) ->
+ l@(L _ ImpExpQcWildcard) ->
return ([mj AnnComma $2, mj AnnDotdot l]
,(snd (unLoc $3) : snd $1))
l -> (ams (head (snd $1)) [mj AnnComma $2] >>
: 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec
{% do {
; checkImportDecl $4 $7
- ; ams (cL (comb4 $1 $6 (snd $8) $9) $
+ ; ams (L (comb4 $1 $6 (snd $8) $9) $
ImportDecl { ideclExt = noExtField
, ideclSourceSrc = snd $ fst $2
, ideclName = $6, ideclPkgQual = snd $5
: impspec {% let (b, ie) = unLoc $1 in
checkImportSpec ie
>>= \checkedIe ->
- return (cL (gl $1) (Just (b, checkedIe))) }
+ return (L (gl $1) (Just (b, checkedIe))) }
| {- empty -} { noLoc Nothing }
impspec :: { Located (Bool, Located [LIE GhcPs]) }
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
+ ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
(mj AnnInstance $1 : (fst $ unLoc $4)) } }
-- type instance declarations
ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
: '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3]
,Just (unLoc $2)) }
- | vocurly ty_fam_inst_eqns close { let (dL->L loc _) = $2 in
- cL loc ([],Just (unLoc $2)) }
+ | vocurly ty_fam_inst_eqns close { let (L loc _) = $2 in
+ L loc ([],Just (unLoc $2)) }
| '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2
,mcc $3],Nothing) }
- | vocurly '..' close { let (dL->L loc _) = $2 in
- cL loc ([mj AnnDotdot $2],Nothing) }
+ | vocurly '..' close { let (L loc _) = $2 in
+ L loc ([mj AnnDotdot $2],Nothing) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
- {% let (dL->L loc (anns, eqn)) = $3 in
- asl (unLoc $1) $2 (cL loc eqn)
+ {% let (L loc (anns, eqn)) = $3 in
+ asl (unLoc $1) $2 (L loc eqn)
>> ams $3 anns
- >> return (sLL $1 $> (cL loc eqn : unLoc $1)) }
+ >> return (sLL $1 $> (L loc eqn : unLoc $1)) }
| ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) }
- | ty_fam_inst_eqn {% let (dL->L loc (anns, eqn)) = $1 in
+ | ty_fam_inst_eqn {% let (L loc (anns, eqn)) = $1 in
ams $1 anns
- >> return (sLL $1 $> [cL loc eqn]) }
+ >> return (sLL $1 $> [L loc eqn]) }
| {- empty -} { noLoc [] }
ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
, Located (OrdList (LHsDecl GhcPs))) }
: 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2
:mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) }
- | 'where' vocurly decls close { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
+ | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
,sL1 $3 (snd $ unLoc $3)) }
pattern_synonym_sig :: { LSig GhcPs }
:: { Located ([AddAnn]
, OrdList (LHsDecl GhcPs)) } -- Reversed
: '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }
- | vocurly decls_inst close { cL (gl $2) (unLoc $2) }
+ | vocurly decls_inst close { L (gl $2) (unLoc $2) }
-- Instance body
--
decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) }
: '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
,sL1 $2 $ snd $ unLoc $2) }
- | vocurly decls close { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
+ | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
-- Binding groups other than those of class and instance declarations
--
| '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3]
,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }
- | vocurly dbinds close { cL (getLoc $2) ([]
+ | vocurly dbinds close { L (getLoc $2) ([]
,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }
{%runECP_P $4 >>= \ $4 ->
runECP_P $6 >>= \ $6 ->
ams (sLL $1 $> $ HsRule { rd_ext = noExtField
- , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1)
+ , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
, rd_lhs = $4, rd_rhs = $6 })
(fst $ unLoc $2) }
strings :: { Located ([AddAnn],[Located StringLiteral]) }
- : STRING { sL1 $1 ([],[cL (gl $1) (getStringLiteral $1)]) }
+ : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
| '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
stringlist :: { Located (OrdList (Located StringLiteral)) }
: stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> (unLoc $1 `snocOL`
- (cL (gl $3) (getStringLiteral $3)))) }
- | STRING { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) }
+ (L (gl $3) (getStringLiteral $3)))) }
+ | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
| {- empty -} { noLoc nilOL }
-----------------------------------------------------------------------------
fspec :: { Located ([AddAnn]
,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) }
: STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3]
- ,(cL (getLoc $1)
+ ,(L (getLoc $1)
(getStringLiteral $1), $2, mkLHsSigType $4)) }
| var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2]
,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
[mu AnnRarrow $2] }
| btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
>> ams (sLL $1 $> $
- HsFunTy noExtField (cL (comb2 $1 $2)
+ HsFunTy noExtField (L (comb2 $1 $2)
(HsDocTy noExtField $1 $2))
$4)
[mu AnnRarrow $3] }
| docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
>> ams (sLL $1 $> $
- HsFunTy noExtField (cL (comb2 $1 $2)
+ HsFunTy noExtField (L (comb2 $1 $2)
(HsDocTy noExtField $2 $1))
$4)
[mu AnnRarrow $3] }
| fd { sL1 $1 [$1] }
fd :: { Located (FunDep (Located RdrName)) }
- : varids0 '->' varids0 {% ams (cL (comb3 $1 $2 $3)
+ : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3)
(reverse (unLoc $1), reverse (unLoc $3)))
[mu AnnRarrow $2] }
,[LConDecl GhcPs]) } -- Returned in order
: 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $
- cL (comb2 $1 $3)
+ L (comb2 $1 $3)
([mj AnnWhere $1
,moc $2
,mcc $4]
, unLoc $3) }
| 'where' vocurly gadt_constrs close {% checkEmptyGADTs $
- cL (comb2 $1 $3)
+ L (comb2 $1 $3)
([mj AnnWhere $1]
, unLoc $3) }
| {- empty -} { noLoc ([],[]) }
gadt_constrs :: { Located [LConDecl GhcPs] }
: gadt_constr_with_doc ';' gadt_constrs
{% addAnnotation (gl $1) AnnSemi (gl $2)
- >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) }
- | gadt_constr_with_doc { cL (gl $1) [$1] }
+ >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
+ | gadt_constr_with_doc { L (gl $1) [$1] }
| {- empty -} { noLoc [] }
-- We allow the following forms:
-}
constrs :: { Located ([AddAnn],[LConDecl GhcPs]) }
- : maybe_docnext '=' constrs1 { cL (comb2 $2 $3) ([mj AnnEqual $2]
+ : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2]
,addConDocs (unLoc $3) $1)}
constrs1 :: { Located [LConDecl GhcPs] }
constr :: { LConDecl GhcPs }
: maybe_docnext forall constr_context '=>' constr_stuff
{% ams (let (con,details,doc_prev) = unLoc $5 in
- addConDoc (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con
+ addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
(snd $ unLoc $2)
(Just $3)
details))
(mu AnnDarrow $4:(fst $ unLoc $2)) }
| maybe_docnext forall constr_stuff
{% ams ( let (con,details,doc_prev) = unLoc $3 in
- addConDoc (cL (comb2 $2 $3) (mkConDeclH98 con
+ addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
(snd $ unLoc $2)
Nothing -- No context
details))
fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: maybe_docnext sig_vars '::' ctype maybe_docprev
- {% ams (cL (comb2 $2 $4)
- (ConDeclField noExtField (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5)))
+ {% ams (L (comb2 $2 $4)
+ (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5)))
[mu AnnDcolon $3] }
-- Reversed!
deriving :: { LHsDerivingClause GhcPs }
: 'deriving' deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (cL full_loc $ HsDerivingClause noExtField Nothing $2)
+ in ams (L full_loc $ HsDerivingClause noExtField Nothing $2)
[mj AnnDeriving $1] }
| 'deriving' deriv_strategy_no_via deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (cL full_loc $ HsDerivingClause noExtField (Just $2) $3)
+ in ams (L full_loc $ HsDerivingClause noExtField (Just $2) $3)
[mj AnnDeriving $1] }
| 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
- in ams (cL full_loc $ HsDerivingClause noExtField (Just $3) $2)
+ in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2)
[mj AnnDeriving $1] }
deriv_clause_types :: { Located [LHsSigType GhcPs] }
case r of {
(FunBind _ n _ _ _) ->
amsL l (mj AnnFunId n:(fst $2)) >> return () ;
- (PatBind _ (dL->L lh _lhs) _rhs _) ->
+ (PatBind _ (L lh _lhs) _rhs _) ->
amsL lh (fst $2) >> return () } ;
_ <- amsL l (ann ++ (fst $ unLoc $3));
return $! (sL l $ ValD noExtField r) } }
(mj AnnDo $1:(fst $ unLoc $2)) }
| 'mdo' stmtlist {% runPV $2 >>= \ $2 ->
fmap ecpFromExp $
- ams (cL (comb2 $1 $2)
+ ams (L (comb2 $1 $2)
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| 'proc' aexp '->' exp
| '(#' texp '#)' { ECP $
runECP_PV $2 >>= \ $2 ->
- amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [cL (gl $2) (Just $2)]))
+ amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)]))
[mo $1,mc $3] }
| '(#' tup_exprs '#)' { ECP $
$2 >>= \ $2 ->
{ $2 >>= \ $2 ->
do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
; return
- ([],Tuple (map (\l -> cL l Nothing) (fst $1) ++ $2)) } }
+ ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } }
| bars texp bars0
{ runECP_PV $2 >>= \ $2 -> return $
do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)
; return (
(head $ fst $1
- ,(map (\l -> cL l Nothing) (tail $ fst $1)) ++ $2)) } }
+ ,(map (\l -> L l Nothing) (tail $ fst $1)) ++ $2)) } }
-- Always follows a comma
tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] }
: texp commas_tup_tail { runECP_PV $1 >>= \ $1 ->
$2 >>= \ $2 ->
addAnnotation (gl $1) AnnComma (fst $2) >>
- return ((cL (gl $1) (Just $1)) : snd $2) }
+ return ((L (gl $1) (Just $1)) : snd $2) }
| texp { runECP_PV $1 >>= \ $1 ->
- return [cL (gl $1) (Just $1)] }
+ return [L (gl $1) (Just $1)] }
| {- empty -} { return [noLoc Nothing] }
-----------------------------------------------------------------------------
| lexps { \loc -> $1 >>= \ $1 ->
mkHsExplicitListPV loc (reverse $1) }
| texp '..' { \loc -> runECP_PV $1 >>= \ $1 ->
- ams (cL loc $ ArithSeq noExtField Nothing (From $1))
+ ams (L loc $ ArithSeq noExtField Nothing (From $1))
[mj AnnDotdot $2]
>>= ecpFromExp' }
| texp ',' exp '..' { \loc ->
runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
- ams (cL loc $ ArithSeq noExtField Nothing (FromThen $1 $3))
+ ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3))
[mj AnnComma $2,mj AnnDotdot $4]
>>= ecpFromExp' }
| texp '..' exp { \loc -> runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
- ams (cL loc $ ArithSeq noExtField Nothing (FromTo $1 $3))
+ ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3))
[mj AnnDotdot $2]
>>= ecpFromExp' }
| texp ',' exp '..' exp { \loc ->
runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
runECP_PV $5 >>= \ $5 ->
- ams (cL loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5))
+ ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5))
[mj AnnComma $2,mj AnnDotdot $4]
>>= ecpFromExp' }
| texp '|' flattenedpquals
{ \loc ->
checkMonadComp >>= \ ctxt ->
runECP_PV $1 >>= \ $1 ->
- ams (cL loc $ mkHsComp ctxt (unLoc $3) $1)
+ ams (L loc $ mkHsComp ctxt (unLoc $3) $1)
[mj AnnVbar $2]
>>= ecpFromExp' }
: squals '|' pquals
{% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >>
return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) }
- | squals { cL (getLoc $1) [reverse (unLoc $1)] }
+ | squals { L (getLoc $1) [reverse (unLoc $1)] }
squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last
-- one can "grab" the earlier ones
addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| transformqual {% ams $1 (fst $ unLoc $1) >>
- return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
+ return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) }
| qual {% runPV $1 >>= \ $1 ->
return $ sL1 $1 [$1] }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
-- Guards
guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
- : guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) }
+ : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) }
guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 ',' qual {% runPV $3 >>= \ $3 ->
sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse (snd $ unLoc $2))) }
| vocurly alts close { $2 >>= \ $2 -> return $
- cL (getLoc $2) (fst $ unLoc $2
+ L (getLoc $2) (fst $ unLoc $2
,(reverse (snd $ unLoc $2))) }
| '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) }
| vocurly close { return $ noLoc ([],[]) }
sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?
| vocurly stmts close { $2 >>= \ $2 -> return $
- cL (gl $2) (fst $ unLoc $2
+ L (gl $2) (fst $ unLoc $2
,reverse $ snd $ unLoc $2) }
-- do { ;; s ; s ; ; s ;; }
happyError :: P a
happyError = srcParseFail
-getVARID (dL->L _ (ITvarid x)) = x
-getCONID (dL->L _ (ITconid x)) = x
-getVARSYM (dL->L _ (ITvarsym x)) = x
-getCONSYM (dL->L _ (ITconsym x)) = x
-getQVARID (dL->L _ (ITqvarid x)) = x
-getQCONID (dL->L _ (ITqconid x)) = x
-getQVARSYM (dL->L _ (ITqvarsym x)) = x
-getQCONSYM (dL->L _ (ITqconsym x)) = x
-getIPDUPVARID (dL->L _ (ITdupipvarid x)) = x
-getLABELVARID (dL->L _ (ITlabelvarid x)) = x
-getCHAR (dL->L _ (ITchar _ x)) = x
-getSTRING (dL->L _ (ITstring _ x)) = x
-getINTEGER (dL->L _ (ITinteger x)) = x
-getRATIONAL (dL->L _ (ITrational x)) = x
-getPRIMCHAR (dL->L _ (ITprimchar _ x)) = x
-getPRIMSTRING (dL->L _ (ITprimstring _ x)) = x
-getPRIMINTEGER (dL->L _ (ITprimint _ x)) = x
-getPRIMWORD (dL->L _ (ITprimword _ x)) = x
-getPRIMFLOAT (dL->L _ (ITprimfloat x)) = x
-getPRIMDOUBLE (dL->L _ (ITprimdouble x)) = x
-getINLINE (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl)
-getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ True)) = (Inline, FunLike)
-getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
-getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x
-
-getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x
-getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x
-getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x
-getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x)
-
-getINTEGERs (dL->L _ (ITinteger (IL src _ _))) = src
-getCHARs (dL->L _ (ITchar src _)) = src
-getSTRINGs (dL->L _ (ITstring src _)) = src
-getPRIMCHARs (dL->L _ (ITprimchar src _)) = src
-getPRIMSTRINGs (dL->L _ (ITprimstring src _)) = src
-getPRIMINTEGERs (dL->L _ (ITprimint src _)) = src
-getPRIMWORDs (dL->L _ (ITprimword src _)) = src
+getVARID (L _ (ITvarid x)) = x
+getCONID (L _ (ITconid x)) = x
+getVARSYM (L _ (ITvarsym x)) = x
+getCONSYM (L _ (ITconsym x)) = x
+getQVARID (L _ (ITqvarid x)) = x
+getQCONID (L _ (ITqconid x)) = x
+getQVARSYM (L _ (ITqvarsym x)) = x
+getQCONSYM (L _ (ITqconsym x)) = x
+getIPDUPVARID (L _ (ITdupipvarid x)) = x
+getLABELVARID (L _ (ITlabelvarid x)) = x
+getCHAR (L _ (ITchar _ x)) = x
+getSTRING (L _ (ITstring _ x)) = x
+getINTEGER (L _ (ITinteger x)) = x
+getRATIONAL (L _ (ITrational x)) = x
+getPRIMCHAR (L _ (ITprimchar _ x)) = x
+getPRIMSTRING (L _ (ITprimstring _ x)) = x
+getPRIMINTEGER (L _ (ITprimint _ x)) = x
+getPRIMWORD (L _ (ITprimword _ x)) = x
+getPRIMFLOAT (L _ (ITprimfloat x)) = x
+getPRIMDOUBLE (L _ (ITprimdouble x)) = x
+getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl)
+getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike)
+getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
+getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x
+
+getDOCNEXT (L _ (ITdocCommentNext x)) = x
+getDOCPREV (L _ (ITdocCommentPrev x)) = x
+getDOCNAMED (L _ (ITdocCommentNamed x)) = x
+getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
+
+getINTEGERs (L _ (ITinteger (IL src _ _))) = src
+getCHARs (L _ (ITchar src _)) = src
+getSTRINGs (L _ (ITstring src _)) = src
+getPRIMCHARs (L _ (ITprimchar src _)) = src
+getPRIMSTRINGs (L _ (ITprimstring src _)) = src
+getPRIMINTEGERs (L _ (ITprimint src _)) = src
+getPRIMWORDs (L _ (ITprimword src _)) = src
-- See Note [Pragma source text] in BasicTypes for the following
-getINLINE_PRAGs (dL->L _ (ITinline_prag src _ _)) = src
-getSPEC_PRAGs (dL->L _ (ITspec_prag src)) = src
-getSPEC_INLINE_PRAGs (dL->L _ (ITspec_inline_prag src _)) = src
-getSOURCE_PRAGs (dL->L _ (ITsource_prag src)) = src
-getRULES_PRAGs (dL->L _ (ITrules_prag src)) = src
-getWARNING_PRAGs (dL->L _ (ITwarning_prag src)) = src
-getDEPRECATED_PRAGs (dL->L _ (ITdeprecated_prag src)) = src
-getSCC_PRAGs (dL->L _ (ITscc_prag src)) = src
-getGENERATED_PRAGs (dL->L _ (ITgenerated_prag src)) = src
-getCORE_PRAGs (dL->L _ (ITcore_prag src)) = src
-getUNPACK_PRAGs (dL->L _ (ITunpack_prag src)) = src
-getNOUNPACK_PRAGs (dL->L _ (ITnounpack_prag src)) = src
-getANN_PRAGs (dL->L _ (ITann_prag src)) = src
-getMINIMAL_PRAGs (dL->L _ (ITminimal_prag src)) = src
-getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src
-getOVERLAPPING_PRAGs (dL->L _ (IToverlapping_prag src)) = src
-getOVERLAPS_PRAGs (dL->L _ (IToverlaps_prag src)) = src
-getINCOHERENT_PRAGs (dL->L _ (ITincoherent_prag src)) = src
-getCTYPEs (dL->L _ (ITctype src)) = src
+getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src
+getSPEC_PRAGs (L _ (ITspec_prag src)) = src
+getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src
+getSOURCE_PRAGs (L _ (ITsource_prag src)) = src
+getRULES_PRAGs (L _ (ITrules_prag src)) = src
+getWARNING_PRAGs (L _ (ITwarning_prag src)) = src
+getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src
+getSCC_PRAGs (L _ (ITscc_prag src)) = src
+getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src
+getCORE_PRAGs (L _ (ITcore_prag src)) = src
+getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src
+getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src
+getANN_PRAGs (L _ (ITann_prag src)) = src
+getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src
+getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src
+getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src
+getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src
+getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src
+getCTYPEs (L _ (ITctype src)) = src
getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
isUnicode :: Located Token -> Bool
-isUnicode (dL->L _ (ITforall iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITdarrow iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITdcolon iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITlarrow iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITrarrow iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (IToparenbar iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITcparenbar iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITcloseQuote iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITstar iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax
isUnicode _ = False
hasE :: Located Token -> Bool
-hasE (dL->L _ (ITopenExpQuote HasE _)) = True
-hasE (dL->L _ (ITopenTExpQuote HasE)) = True
+hasE (L _ (ITopenExpQuote HasE _)) = True
+hasE (L _ (ITopenTExpQuote HasE)) = True
hasE _ = False
getSCC :: Located Token -> P FastString
else return s
-- Utilities for combining source spans
-comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
+comb2 :: Located a -> Located b -> SrcSpan
comb2 a b = a `seq` b `seq` combineLocs a b
-comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
- a -> b -> c -> SrcSpan
+comb3 :: Located a -> Located b -> Located c -> SrcSpan
comb3 a b c = a `seq` b `seq` c `seq`
combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
-comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) =>
- a -> b -> c -> d -> SrcSpan
+comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
(combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
combineSrcSpans (getLoc c) (getLoc d))
-- strict constructor version:
{-# INLINE sL #-}
-sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
-sL span a = span `seq` a `seq` cL span a
+sL :: SrcSpan -> a -> Located a
+sL span a = span `seq` a `seq` L span a
-- See Note [Adding location info] for how these utility functions are used
-- replaced last 3 CPP macros in this file
{-# INLINE sL0 #-}
-sL0 :: HasSrcSpan a => SrcSpanLess a -> a
-sL0 = cL noSrcSpan -- #define L0 L noSrcSpan
+sL0 :: a -> Located a
+sL0 = L noSrcSpan -- #define L0 L noSrcSpan
{-# INLINE sL1 #-}
-sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b
+sL1 :: Located a -> b -> Located b
sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sLL #-}
-sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
- a -> b -> SrcSpanLess c -> c
+sLL :: Located a -> Located b -> c -> Located c
sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
{- Note [Adding location info]
-- |Construct an AddAnn from the annotation keyword and the location
-- of the keyword itself
-mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn
+mj :: AnnKeywordId -> Located e -> AddAnn
mj a l = AddAnn a (gl l)
-- the token has a unicode equivalent and this has been used, provide the
-- unicode variant of the annotation.
mu :: AnnKeywordId -> Located Token -> AddAnn
-mu a lt@(dL->L l t) = AddAnn (toUnicodeAnn a lt) l
+mu a lt@(L l t) = AddAnn (toUnicodeAnn a lt) l
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
-gl :: HasSrcSpan a => a -> SrcSpan
+gl :: Located a -> SrcSpan
gl = getLoc
-- |Add an annotation to the located element, and return the located
-- element as a pass through
-aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a
-aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a
+aa :: Located a -> (AnnKeywordId, Located c) -> P (Located a)
+aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a
-- |Add an annotation to a located element resulting from a monadic action
-am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a
+am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)
am a (b,s) = do
- av@(dL->L l _) <- a
+ av@(L l _) <- a
addAnnotation l b (gl s)
return av
-- as any annotations that may arise in the binds. This will include open
-- and closing braces if they are used to delimit the let expressions.
--
-ams :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m a
-ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
+ams :: MonadP m => Located a -> [AddAnn] -> m (Located a)
+ams a@(L l _) bs = addAnnsAt l bs >> return a
amsL :: SrcSpan -> [AddAnn] -> P ()
amsL sp bs = addAnnsAt sp bs >> return ()
-- |Add all [AddAnn] to an AST element, and wrap it in a 'Just'
-ajs :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m (Maybe a)
+ajs :: MonadP m => Located a -> [AddAnn] -> m (Maybe (Located a))
ajs a bs = Just <$> ams a bs
-- |Add a list of AddAnns to the given AST element, where the AST element is the
-- result of a monadic action
-amms :: MonadP m => HasSrcSpan a => m a -> [AddAnn] -> m a
-amms a bs = do { av@(dL->L l _) <- a
+amms :: MonadP m => m (Located a) -> [AddAnn] -> m (Located a)
+amms a bs = do { av@(L l _) <- a
; addAnnsAt l bs
; return av }
-- |Add a list of AddAnns to the AST element, and return the element as a
-- OrdList
-amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a)
-amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a)
+amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))
+amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)
-- |Synonyms for AddAnn versions of AnnOpen and AnnClose
mo,mc :: Located Token -> AddAnn
mvbars = map (AddAnn AnnVbar)
-- |Get the location of the last element of a OrdList, or noSrcSpan
-oll :: HasSrcSpan a => OrdList a -> SrcSpan
+oll :: OrdList (Located a) -> SrcSpan
oll l =
if isNilOL l then noSrcSpan
else getLoc (lastOL l)
-- |Add a semicolon annotation in the right place in a list. If the
-- leading list is empty, add it to the tail
-asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P()
-asl [] (dL->L ls _) (dL->L l _) = addAnnotation l AnnSemi ls
-asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
+asl :: [Located a] -> Located b -> Located a -> P ()
+asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls
+asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
}
-- *** See Note [The Naming story] in GHC.Hs.Decls ****
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d)
+mkTyClD (L loc d) = L loc (TyClD noExtField d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkInstD (dL->L loc d) = cL loc (InstD noExtField d)
+mkInstD (L loc d) = L loc (InstD noExtField d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
-mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
+mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
= do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams
; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
- ; return (cL loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt
- , tcdLName = cls, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdFDs = snd (unLoc fds)
- , tcdSigs = mkClassOpSigs sigs
- , tcdMeths = binds
- , tcdATs = ats, tcdATDefs = at_defs
- , tcdDocs = docs })) }
+ ; return (L loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt
+ , tcdLName = cls, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdFDs = snd (unLoc fds)
+ , tcdSigs = mkClassOpSigs sigs
+ , tcdMeths = binds
+ , tcdATs = ats, tcdATDefs = at_defs
+ , tcdDocs = docs })) }
mkTyData :: SrcSpan
-> NewOrData
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
-mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr))
+mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (cL loc (DataDecl { tcdDExt = noExtField,
- tcdLName = tc, tcdTyVars = tyvars,
- tcdFixity = fixity,
- tcdDataDefn = defn })) }
+ ; return (L loc (DataDecl { tcdDExt = noExtField,
+ tcdLName = tc, tcdTyVars = tyvars,
+ tcdFixity = fixity,
+ tcdDataDefn = defn })) }
mkDataDefn :: NewOrData
-> Maybe (Located CType)
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
- ; return (cL loc (SynDecl { tcdSExt = noExtField
- , tcdLName = tc, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdRhs = rhs })) }
+ ; return (L loc (SynDecl { tcdSExt = noExtField
+ , tcdLName = tc, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdRhs = rhs })) }
mkStandaloneKindSig
:: SrcSpan
mkStandaloneKindSig loc lhs rhs =
do { vs <- mapM check_lhs_name (unLoc lhs)
; v <- check_singular_lhs (reverse vs)
- ; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
+ ; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
where
check_lhs_name v@(unLoc->name) =
if isUnqual name && isTcOcc (rdrNameOcc name)
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
+ ; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExtField
, feqn_tycon = tc
, feqn_bndrs = bndrs
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst loc eqn
- = return (cL loc (TyFamInstD noExtField (TyFamInstDecl eqn)))
+ = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
- ; return (cL loc (FamDecl noExtField (FamilyDecl
+ ; return (L loc (FamDecl noExtField (FamilyDecl
{ fdExt = noExtField
, fdInfo = info, fdLName = tc
, fdTyVars = tyvars
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration. See #10945
-mkSpliceDecl lexpr@(dL->L loc expr)
+mkSpliceDecl lexpr@(L loc expr)
| HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
- = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice)
+ = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
| HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
- = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice)
+ = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
| otherwise
- = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice BareSplice lexpr))
+ = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr))
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc tycon roles
= do { roles' <- mapM parse_role roles
- ; return $ cL loc $ RoleAnnotDecl noExtField tycon roles' }
+ ; return $ L loc $ RoleAnnotDecl noExtField tycon roles' }
where
role_data_type = dataTypeOf (undefined :: Role)
all_roles = map fromConstr $ dataTypeConstrs role_data_type
possible_roles = [(fsFromRole role, role) | role <- all_roles]
- parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing
- parse_role (dL->L loc_role (Just role))
+ parse_role (L loc_role Nothing) = return $ L loc_role Nothing
+ parse_role (L loc_role (Just role))
= case lookup role possible_roles of
- Just found_role -> return $ cL loc_role $ Just found_role
+ Just found_role -> return $ L loc_role $ Just found_role
Nothing ->
let nearby = fuzzyLookup (unpackFS role)
(mapFst unpackFS possible_roles)
addFatalError loc_role
(text "Illegal role name" <+> quotes (ppr role) $$
suggestions nearby)
- parse_role _ = panic "parse_role: Impossible Match"
- -- due to #15884
suggestions [] = empty
suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)
where
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [] = []
- go ((dL->L l (ValD x b)) : ds)
- = cL l' (ValD x b') : go ds'
- where (dL->L l' b', ds') = getMonoBind (cL l b) ds
+ go ((L l (ValD x b)) : ds)
+ = L l' (ValD x b') : go ds'
+ where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
-- Declaration list may only contain value bindings and signatures.
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = return (emptyBag, [], [], [], [], [])
- go ((dL->L l (ValD _ b)) : ds)
+ go ((L l (ValD _ b)) : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
where
- (b', ds') = getMonoBind (cL l b) ds
- go ((dL->L l decl) : ds)
+ (b', ds') = getMonoBind (L l b) ds
+ go ((L l decl) : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds
; case decl of
SigD _ s
- -> return (bs, cL l s : ss, ts, tfis, dfis, docs)
+ -> return (bs, L l s : ss, ts, tfis, dfis, docs)
TyClD _ (FamDecl _ t)
- -> return (bs, ss, cL l t : ts, tfis, dfis, docs)
+ -> return (bs, ss, L l t : ts, tfis, dfis, docs)
InstD _ (TyFamInstD { tfid_inst = tfi })
- -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs)
+ -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
InstD _ (DataFamInstD { dfid_inst = dfi })
- -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs)
+ -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
DocD _ d
- -> return (bs, ss, ts, tfis, dfis, cL l d : docs)
+ -> return (bs, ss, ts, tfis, dfis, L l d : docs)
SpliceD _ d
-> addFatalError l $
hang (text "Declaration splices are allowed only" <+>
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
- , fun_matches =
- MG { mg_alts = (dL->L _ mtchs1) } }))
+getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
+ , fun_matches =
+ MG { mg_alts = (L _ mtchs1) } }))
binds
| has_args mtchs1
= go mtchs1 loc1 binds []
where
go mtchs loc
- ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2)
- , fun_matches =
- MG { mg_alts = (dL->L _ mtchs2) } })))
+ ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)
+ , fun_matches =
+ MG { mg_alts = (L _ mtchs2) } })))
: binds) _
| f1 == f2 = go (mtchs2 ++ mtchs)
(combineSrcSpans loc loc2) binds []
- go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls
+ go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
= let doc_decls' = doc_decl : doc_decls
in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
go mtchs loc binds doc_decls
- = ( cL loc (makeFunBind fun_id1 (reverse mtchs))
+ = ( L loc (makeFunBind fun_id1 (reverse mtchs))
, (reverse doc_decls) ++ binds)
-- Reverse the final matches, to get it back in the right order
-- Do the same thing with the trailing doc comments
getMonoBind bind binds = (bind, binds)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
-has_args [] = panic "RdrHsSyn:has_args"
-has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args)
+has_args [] = panic "RdrHsSyn:has_args"
+has_args (L _ (Match { m_pats = args }) : _) = not (null args)
-- Don't group together FunBinds if they have
-- no arguments. This is necessary now that variable bindings
-- with no arguments are now treated as FunBinds rather
-- than pattern bindings (tests/rename/should_fail/rnfail002).
-has_args ((dL->L _ (XMatch nec)) : _) = noExtCon nec
-has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884
+has_args (L _ (XMatch nec) : _) = noExtCon nec
{- **********************************************************************
tyConToDataCon loc tc
| isTcOcc occ || isDataOcc occ
, isLexCon (occNameFS occ)
- = return (cL loc (setRdrNameSpace tc srcDataName))
+ = return (L loc (setRdrNameSpace tc srcDataName))
| otherwise
= Left (loc, msg)
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
-mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
+mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
do { matches <- mapM fromDecl (fromOL decls)
; when (null matches) (wrongNumberErr loc)
; return $ mkMatchGroup FromSource matches }
where
- fromDecl (dL->L loc decl@(ValD _ (PatBind _
- pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details))
- rhs _))) =
+ fromDecl (L loc decl@(ValD _ (PatBind _
+ pat@(L _ (ConPatIn ln@(L _ name) details))
+ rhs _))) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
, mc_strictness = NoSrcStrict }
RecCon{} -> recordPatSynErr loc pat
- ; return $ cL loc match }
- fromDecl (dL->L loc decl) = extraDeclErr loc decl
+ ; return $ L loc match }
+ fromDecl (L loc decl) = extraDeclErr loc decl
extraDeclErr loc decl =
addFatalError loc $
mkGadtDecl names ty
= (ConDeclGADT { con_g_ext = noExtField
, con_names = names
- , con_forall = cL l $ isLHsForAllTy ty'
+ , con_forall = L l $ isLHsForAllTy ty'
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
, con_args = args
, con_doc = Nothing }
, anns1 ++ anns2)
where
- (ty'@(dL->L l _),anns1) = peel_parens ty []
+ (ty'@(L l _),anns1) = peel_parens ty []
(tvs, rho) = splitLHsForAllTyInvis ty'
(mcxt, tau, anns2) = split_rho rho []
- split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
+ split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
= (Just cxt, tau, ann)
- split_rho (dL->L l (HsParTy _ ty)) ann
+ split_rho (L l (HsParTy _ ty)) ann
= split_rho ty (ann++mkParensApiAnn l)
split_rho tau ann
= (Nothing, tau, ann)
(args, res_ty) = split_tau tau
-- See Note [GADT abstract syntax] in GHC.Hs.Decls
- split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
- = (RecCon (cL loc rf), res_ty)
+ split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
+ = (RecCon (L loc rf), res_ty)
split_tau tau
= (PrefixCon [], tau)
- peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty
+ peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
(ann++mkParensApiAnn l)
peel_parens ty ann = (ty, ann)
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddAnn] -> LHsType GhcPs
-> P (LHsTyVarBndr GhcPs, [AddAnn])
- chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l
- ++ acc) ty
+ chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty
chkParens acc ty = do
tv <- chk ty
return (tv, reverse acc)
-- Check that the name space is correct!
chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs)
- chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k))
- | isRdrTyVar tv = return (cL l (KindedTyVar noExtField (cL lv tv) k))
- chk (dL->L l (HsTyVar _ _ (dL->L ltv tv)))
- | isRdrTyVar tv = return (cL l (UserTyVar noExtField (cL ltv tv)))
- chk t@(dL->L loc _)
+ chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
+ | isRdrTyVar tv = return (L l (KindedTyVar noExtField (L lv tv) k))
+ chk (L l (HsTyVar _ _ (L ltv tv)))
+ | isRdrTyVar tv = return (L l (UserTyVar noExtField (L ltv tv)))
+ chk t@(L loc _)
= addFatalError loc $
vcat [ text "Unexpected type" <+> quotes (ppr t)
, text "In the" <+> pp_what
-- See note [Parsing explicit foralls in Rules] in Parser.y
checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
- where check (dL->L loc (Unqual occ)) = do
+ where check (L loc (Unqual occ)) = do
when ((occNameString occ ==) `any` ["forall","family","role"])
(addFatalError loc (text $ "parse error on input "
++ occNameString occ))
check _ = panic "checkRuleTyVarBndrNames"
checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
-checkRecordSyntax lr@(dL->L loc r)
+checkRecordSyntax lr@(L loc r)
= do allowed <- getBit TraditionalRecordSyntaxBit
unless allowed $ addError loc $
text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r
-- `data T where` to avoid affecting existing error message, see #8258.
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
-checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration.
+checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
= do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax
unless gadtSyntax $ addError span $ vcat
[ text "Illegal keyword 'where' in data declaration"
checkTyClHdr is_cls ty
= goL ty [] [] Prefix
where
- goL (dL->L l ty) acc ann fix = go l ty acc ann fix
+ goL (L l ty) acc ann fix = go l ty acc ann fix
-- workaround to define '*' despite StarIsType
- go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix
+ go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
= do { warnStarBndr l
; let name = mkOccName tcClsName (starSym isUni)
- ; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
+ ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
- go _ (HsTyVar _ _ ltc@(dL->L _ tc)) acc ann fix
+ go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix
| isRdrTc tc = return (ltc, acc, fix, ann)
- go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix
+ go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
| isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann)
go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix
go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
- = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann)
+ = return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
HsCmdDo {} -> check "do command" cmd
_ -> return ()
- check :: (HasSrcSpan a, Outputable a) => String -> a -> PV ()
+ check :: Outputable a => String -> Located a -> PV ()
check element a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
-- (((Eq a))) --> [Eq a]
-- @
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
-checkContext (dL->L l orig_t)
- = check [] (cL l orig_t)
+checkContext (L l orig_t)
+ = check [] (L l orig_t)
where
- check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
+ check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
-- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
-- be used as context constraints.
- = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto ()
+ = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
- check anns (dL->L lp1 (HsParTy _ ty))
+ check anns (L lp1 (HsParTy _ ty))
-- to be sure HsParTy doesn't get into the way
= check anns' ty
where anns' = if l == lp1 then anns
else (anns ++ mkParensApiAnn lp1)
-- no need for anns, returning original
- check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t])
+ check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])
msg = text "data constructor context"
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs msg ty = go ty
where
- go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki
- go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
- go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep
+ go (L _ (HsAppKindTy _ ty ki)) = go ty *> go ki
+ go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
+ go (L l (HsDocTy _ t ds)) = addError l $ hsep
[ text "Unexpected haddock", quotes (ppr ds)
, text "on", msg, quotes (ppr t) ]
go _ = pure ()
checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
-checkLPat e@(dL->L l _) = checkPat l e []
+checkLPat e@(L l _) = checkPat l e []
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (LPat GhcPs)
-checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args
- | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
+checkPat loc (L l e@(PatBuilderVar (L _ c))) args
+ | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
| not (null args) && patIsRec c =
localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
patFail l (ppr e)
-checkPat loc (dL->L _ (PatBuilderApp f e)) args
+checkPat loc (L _ (PatBuilderApp f e)) args
= do p <- checkLPat e
checkPat loc f (p : args)
-checkPat loc (dL->L _ e) []
+checkPat loc (L _ e) []
= do p <- checkAPat loc e
- return (cL loc p)
+ return (L loc p)
checkPat loc e _
= patFail loc (ppr e)
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
-- NB. Negative *primitive* literals are already handled by the lexer
- PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing)
+ PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
-- n+k patterns
PatBuilderOpApp
- (dL->L nloc (PatBuilderVar (dL->L _ n)))
- (dL->L _ plus)
- (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
+ (L nloc (PatBuilderVar (L _ n)))
+ (L _ plus)
+ (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| nPlusKPatterns && (plus == plus_RDR)
- -> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
+ -> return (mkNPlusKPat (L nloc n) (L lloc lit))
- PatBuilderOpApp l (dL->L cl c) r
+ PatBuilderOpApp l (L cl c) r
| isRdrDataCon c -> do
l <- checkLPat l
r <- checkLPat r
- return (ConPatIn (cL cl c) (InfixCon l r))
+ return (ConPatIn (L cl c) (InfixCon l r))
PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField))
_ -> patFail loc (ppr e0)
checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
-checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld)
- return (cL l (fld { hsRecFieldArg = p }))
+checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)
+ return (L l (fld { hsRecFieldArg = p }))
patFail :: SrcSpan -> SDoc -> PV a
patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
= do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat
checkPatBind lhs' grhss
-checkValDef lhs Nothing g@(dL->L l (_,grhss))
+checkValDef lhs Nothing g@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
checkFunBind NoSrcStrict ann (getLoc lhs)
- fun is_infix pats (cL l grhss)
+ fun is_infix pats (L l grhss)
Nothing -> do
lhs' <- checkPattern lhs
checkPatBind lhs' g }
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
+checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
= do ps <- mapM checkPattern pats
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
return (ann, makeFunBind fun
- [cL match_span (Match { m_ext = noExtField
- , m_ctxt = FunRhs
- { mc_fun = fun
- , mc_fixity = is_infix
- , mc_strictness = strictness }
- , m_pats = ps
- , m_grhss = grhss })])
+ [L match_span (Match { m_ext = noExtField
+ , m_ctxt = FunRhs
+ { mc_fun = fun
+ , mc_fixity = is_infix
+ , mc_strictness = strictness }
+ , m_pats = ps
+ , m_grhss = grhss })])
-- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now.
checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkPatBind lhs (dL->L match_span (_,grhss))
+checkPatBind lhs (L match_span (_,grhss))
| BangPat _ p <- unLoc lhs
, VarPat _ v <- unLoc p
- = return ([], makeFunBind v [cL match_span (m v)])
+ = return ([], makeFunBind v [L match_span (m v)])
where
m v = Match { m_ext = noExtField
- , m_ctxt = FunRhs { mc_fun = cL (getLoc lhs) (unLoc v)
+ , m_ctxt = FunRhs { mc_fun = L (getLoc lhs) (unLoc v)
, mc_fixity = Prefix
, mc_strictness = SrcStrict }
, m_pats = []
, m_grhss = grhss }
-checkPatBind lhs (dL->L _ (_,grhss))
+checkPatBind lhs (L _ (_,grhss))
= return ([],PatBind noExtField lhs grhss ([],[]))
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
-checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v)))
+checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
| isUnqual v
, not (isDataOcc (rdrNameOcc v))
= return lrdr
-checkValSigLhs lhs@(dL->L l _)
+checkValSigLhs lhs@(L l _)
= addFatalError l ((text "Invalid type signature:" <+>
ppr lhs <+> text ":: ...")
$$ text hint)
-- so check for that, and suggest. cf #3805
-- Sadly 'foreign import' still barfs 'parse error' because
-- 'import' is a keyword
- looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s
- looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs
+ looks_like s (L _ (HsVar _ (L _ v))) = v == s
+ looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
looks_like _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
pattern_RDR = mkUnqual varName (fsLit "pattern")
checkDoAndIfThenElse
- :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
- => a -> Bool -> b -> Bool -> c -> PV ()
+ :: (Outputable a, Outputable b, Outputable c)
+ => Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
isFunLhs e = go e [] []
where
- go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann
- | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann))
- go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann
- go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
- go (dL->L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann
+ go (L loc (PatBuilderVar (L _ f))) es ann
+ | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
+ go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann
+ go (L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
+ go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann
| not (isRdrDataCon op) -- We have found the function!
- = return (Just (cL loc' op, Infix, (l:r:es), ann))
+ = return (Just (L loc' op, Infix, (l:r:es), ann))
| otherwise -- Infix data con; keep going
= do { mb_l <- go l es ann
; case mb_l of
Just (op', Infix, j : k : es', ann')
-> return (Just (op', Infix, j : op_app : es', ann'))
where
- op_app = cL loc (PatBuilderOpApp k
- (cL loc' op) r)
+ op_app = L loc (PatBuilderOpApp k
+ (L loc' op) r)
_ -> return Nothing }
go _ _ _ = return Nothing
, SourceText
, SrcUnpackedness
, [Located TyEl] {- remaining TyEl -})
-pUnpackedness ((dL->L l x1) : xs)
+pUnpackedness (L l x1 : xs)
| TyElUnpackedness (anns, prag, unpk) <- x1
= Just (l, anns, prag, unpk, xs)
pUnpackedness _ = Nothing
, LHsType GhcPs {- the resulting BangTy -}
, P () {- add annotations -}
, [Located TyEl] {- remaining TyEl -})
-pBangTy lt@(dL->L l1 _) xs =
+pBangTy lt@(L l1 _) xs =
case pUnpackedness xs of
Nothing -> (False, lt, pure (), xs)
Just (l2, anns, prag, unpk, xs') ->
let bl = combineSrcSpans l1 l2
bt = addUnpackedness (prag, unpk) lt
- in (True, cL bl bt, addAnnsAt bl anns, xs')
+ in (True, L bl bt, addAnnsAt bl anns, xs')
mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy strictness =
--
-- See Note [Parsing data constructors is hard]
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
-mergeOps ((dL->L l1 (TyElOpd t)) : xs)
- | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs
+mergeOps ((L l1 (TyElOpd t)) : xs)
+ | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs
, null xs' -- We accept a BangTy only when there are no preceding TyEl.
= addAnns >> return t'
mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [unpk]:
-- handle (NO)UNPACK pragmas
- go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
+ go k acc ops_acc ((L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
if not (null acc) && null xs
then do { acc' <- eitherToP $ mergeOpsAcc acc
; let a = ops_acc acc'
bl = combineSrcSpans l (getLoc a)
bt = HsBangTy noExtField strictMark a
; addAnnsAt bl anns
- ; return (cL bl bt) }
+ ; return (L bl bt) }
else addFatalError l unpkError
where
unpkSDoc = case unpkSrc of
-- clause [doc]:
-- we do not expect to encounter any docs
- go _ _ _ ((dL->L l (TyElDocPrev _)):_) =
+ go _ _ _ ((L l (TyElDocPrev _)):_) =
failOpDocPrev l
-- clause [opr]:
-- when we encounter an operator, we must have accumulated
-- something for its rhs, and there must be something left
-- to build its lhs.
- go k acc ops_acc ((dL->L l (TyElOpr op)):xs) =
+ go k acc ops_acc ((L l (TyElOpr op)):xs) =
if null acc || null (filter isTyElOpd xs)
- then failOpFewArgs (cL l op)
+ then failOpFewArgs (L l op)
else do { acc' <- eitherToP (mergeOpsAcc acc)
- ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs }
+ ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc acc')) xs }
where
- isTyElOpd (dL->L _ (TyElOpd _)) = True
+ isTyElOpd (L _ (TyElOpd _)) = True
isTyElOpd _ = False
-- clause [opd]:
-- whenever an operand is encountered, it is added to the accumulator
- go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs
+ go k acc ops_acc ((L l (TyElOpd a)):xs) = go k (HsValArg (L l a):acc) ops_acc xs
-- clause [tyapp]:
-- whenever a type application is encountered, it is added to the accumulator
- go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
+ go k acc ops_acc ((L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
-- clause [end]
-- See Note [Non-empty 'acc' in mergeOps clause [end]]
go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc)
; return (ops_acc acc') }
- go _ _ _ _ = panic "mergeOps.go: Impossible Match"
- -- due to #15884
-
mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = panic "mergeOpsAcc: empty input"
-}
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
-pInfixSide ((dL->L l (TyElOpd t)):xs)
- | (True, t', addAnns, xs') <- pBangTy (cL l t) xs
+pInfixSide ((L l (TyElOpd t)):xs)
+ | (True, t', addAnns, xs') <- pBangTy (L l t) xs
= Just (t', addAnns, xs')
pInfixSide (el:xs1)
| Just t1 <- pLHsTypeArg el
pInfixSide _ = Nothing
pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
-pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a))
-pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
+pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a))
+pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
pLHsTypeArg _ = Nothing
pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev = go Nothing
where
- go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) =
- go (mTrailingDoc `mplus` Just (cL l doc)) xs
+ go mTrailingDoc ((L l (TyElDocPrev doc)):xs) =
+ go (mTrailingDoc `mplus` Just (L l doc)) xs
go mTrailingDoc xs = (mTrailingDoc, xs)
orErr :: Maybe a -> b -> Either b a
-- A -- ^ Comment on A
-- B -- ^ Comment on B (singleDoc == False)
singleDoc = isJust mTrailingDoc &&
- null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ]
+ null [ () | (L _ (TyElDocPrev _)) <- all_xs' ]
-- The result of merging the list of reversed TyEl into a
-- data constructor, along with [AddAnn].
trailingFieldDoc | singleDoc = Nothing
| otherwise = mTrailingDoc
- goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
+ goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) }
- goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs)
+ goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs)
| (mConDoc, xs') <- pDocPrev xs
- , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs'
+ , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs'
= do { data_con <- tyConToDataCon l' tc
; let mDoc = mTrailingDoc `mplus` mConDoc
- ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) }
- goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
+ ; return (pure (), (data_con, RecCon (L l fields), mDoc)) }
+ goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
= return ( pure ()
- , ( cL l (getRdrName (tupleDataCon Boxed (length ts)))
+ , ( L l (getRdrName (tupleDataCon Boxed (length ts)))
, PrefixCon ts
, mTrailingDoc ) )
- goFirst ((dL->L l (TyElOpd t)):xs)
- | (_, t', addAnns, xs') <- pBangTy (cL l t) xs
+ goFirst ((L l (TyElOpd t)):xs)
+ | (_, t', addAnns, xs') <- pBangTy (L l t) xs
= go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs'
goFirst (L l (TyElKindApp _ _):_)
= goInfix Monoid.<> Left (l, kindAppErr)
goFirst xs
= go (pure ()) mTrailingDoc [] xs
- go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
+ go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) }
- go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) =
- go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs
- go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs)
- | (_, t', addAnns', xs') <- pBangTy (cL l t) xs
+ go addAnns mLastDoc ts ((L l (TyElDocPrev doc)):xs) =
+ go addAnns (mLastDoc `mplus` Just (L l doc)) ts xs
+ go addAnns mLastDoc ts ((L l (TyElOpd t)):xs)
+ | (_, t', addAnns', xs') <- pBangTy (L l t) xs
, t'' <- mkLHsDocTyMaybe t' mLastDoc
= go (addAnns >> addAnns') Nothing (t'':ts) xs'
- go _ _ _ ((dL->L _ (TyElOpr _)):_) =
+ go _ _ _ ((L _ (TyElOpr _)):_) =
-- Encountered an operator: backtrack to the beginning and attempt
-- to parse as an infix definition.
goInfix
; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr
; let (mOpDoc, xs2) = pDocPrev xs1
; (op, xs3) <- case xs2 of
- (dL->L l (TyElOpr op)) : xs3 ->
+ (L l (TyElOpr op)) : xs3 ->
do { data_con <- tyConToDataCon l op
; return (data_con, xs3) }
_ -> Left malformedErr
mkHsInfixHolePV :: SrcSpan -> PV (Located b)
instance p ~ GhcPs => DisambInfixOp (HsExpr p) where
- mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExtField v)
- mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExtField v)
- mkHsInfixHolePV l = return $ cL l hsHoleExpr
+ mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)
+ mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)
+ mkHsInfixHolePV l = return $ L l hsHoleExpr
instance DisambInfixOp RdrName where
- mkHsConOpPV (dL->L l v) = return $ cL l v
- mkHsVarOpPV (dL->L l v) = return $ cL l v
+ mkHsConOpPV (L l v) = return $ L l v
+ mkHsVarOpPV (L l v) = return $ L l v
mkHsInfixHolePV l =
addFatalError l $ text "Invalid infix hole, expected an infix operator"
instance p ~ GhcPs => DisambECP (HsCmd p) where
type Body (HsCmd p) = HsCmd
ecpFromCmd' = return
- ecpFromExp' (dL-> L l e) = cmdFail l (ppr e)
- mkHsLamPV l mg = return $ cL l (HsCmdLam noExtField mg)
- mkHsLetPV l bs e = return $ cL l (HsCmdLet noExtField bs e)
+ ecpFromExp' (L l e) = cmdFail l (ppr e)
+ mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg)
+ mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e)
type InfixOp (HsCmd p) = HsExpr p
superInfixOp m = m
mkHsOpAppPV l c1 op c2 = do
- let cmdArg c = cL (getLoc c) $ HsCmdTop noExtField c
- return $ cL l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2]
- mkHsCasePV l c mg = return $ cL l (HsCmdCase noExtField c mg)
+ let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c
+ return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2]
+ mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg)
type FunArg (HsCmd p) = HsExpr p
superFunArg m = m
mkHsAppPV l c e = do
checkCmdBlockArguments c
checkExpBlockArguments e
- return $ cL l (HsCmdApp noExtField c e)
+ return $ L l (HsCmdApp noExtField c e)
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
- return $ cL l (mkHsCmdIf c a b)
- mkHsDoPV l stmts = return $ cL l (HsCmdDo noExtField stmts)
- mkHsParPV l c = return $ cL l (HsCmdPar noExtField c)
- mkHsVarPV (dL->L l v) = cmdFail l (ppr v)
- mkHsLitPV (dL->L l a) = cmdFail l (ppr a)
- mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a)
+ return $ L l (mkHsCmdIf c a b)
+ mkHsDoPV l stmts = return $ L l (HsCmdDo noExtField stmts)
+ mkHsParPV l c = return $ L l (HsCmdPar noExtField c)
+ mkHsVarPV (L l v) = cmdFail l (ppr v)
+ mkHsLitPV (L l a) = cmdFail l (ppr a)
+ mkHsOverLitPV (L l a) = cmdFail l (ppr a)
mkHsWildCardPV l = cmdFail l (text "_")
mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig)
mkHsExplicitListPV l xs = cmdFail l $
brackets (fsep (punctuate comma (map ppr xs)))
- mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp)
+ mkHsSplicePV (L l sp) = cmdFail l (ppr sp)
mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $
ppr a <+> ppr (mk_rec_fields fbinds ddLoc)
mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a)
instance p ~ GhcPs => DisambECP (HsExpr p) where
type Body (HsExpr p) = HsExpr
- ecpFromCmd' (dL -> L l c) = do
+ ecpFromCmd' (L l c) = do
addError l $ vcat
[ text "Arrow command found where an expression was expected:",
nest 2 (ppr c) ]
- return (cL l hsHoleExpr)
+ return (L l hsHoleExpr)
ecpFromExp' = return
- mkHsLamPV l mg = return $ cL l (HsLam noExtField mg)
- mkHsLetPV l bs c = return $ cL l (HsLet noExtField bs c)
+ mkHsLamPV l mg = return $ L l (HsLam noExtField mg)
+ mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c)
type InfixOp (HsExpr p) = HsExpr p
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
- return $ cL l $ OpApp noExtField e1 op e2
- mkHsCasePV l e mg = return $ cL l (HsCase noExtField e mg)
+ return $ L l $ OpApp noExtField e1 op e2
+ mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg)
type FunArg (HsExpr p) = HsExpr p
superFunArg m = m
mkHsAppPV l e1 e2 = do
checkExpBlockArguments e1
checkExpBlockArguments e2
- return $ cL l (HsApp noExtField e1 e2)
+ return $ L l (HsApp noExtField e1 e2)
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
- return $ cL l (mkHsIf c a b)
- mkHsDoPV l stmts = return $ cL l (HsDo noExtField DoExpr stmts)
- mkHsParPV l e = return $ cL l (HsPar noExtField e)
- mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExtField v)
- mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExtField a)
- mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExtField a)
- mkHsWildCardPV l = return $ cL l hsHoleExpr
- mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
- mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExtField Nothing xs)
+ return $ L l (mkHsIf c a b)
+ mkHsDoPV l stmts = return $ L l (HsDo noExtField DoExpr stmts)
+ mkHsParPV l e = return $ L l (HsPar noExtField e)
+ mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v)
+ mkHsLitPV (L l a) = return $ L l (HsLit noExtField a)
+ mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a)
+ mkHsWildCardPV l = return $ L l hsHoleExpr
+ mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
+ mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs)
mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp
mkHsRecordPV l lrec a (fbinds, ddLoc) = do
r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc)
- checkRecordSyntax (cL l r)
- mkHsNegAppPV l a = return $ cL l (NegApp noExtField a noSyntaxExpr)
- mkHsSectionR_PV l op e = return $ cL l (SectionR noExtField op e)
+ checkRecordSyntax (L l r)
+ mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr)
+ mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)
mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty
mkHsAsPatPV l v e =
patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $
sep [text item <+> text "in expression context:",
nest 4 (ppr e)] $$
explanation
- ; return (cL l hsHoleExpr) }
+ ; return (L l hsHoleExpr) }
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")
instance DisambECP (PatBuilder GhcPs) where
type Body (PatBuilder GhcPs) = PatBuilder
- ecpFromCmd' (dL-> L l c) =
+ ecpFromCmd' (L l c) =
addFatalError l $
text "Command syntax in pattern:" <+> ppr c
- ecpFromExp' (dL-> L l e) =
+ ecpFromExp' (L l e) =
addFatalError l $
text "Expression syntax in pattern:" <+> ppr e
mkHsLamPV l _ = addFatalError l $
mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
- mkHsOpAppPV l p1 op p2 = return $ cL l $ PatBuilderOpApp p1 op p2
+ mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2
mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
- mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2)
+ mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern"
- mkHsParPV l p = return $ cL l (PatBuilderPar p)
- mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v)
- mkHsLitPV lit@(dL->L l a) = do
+ mkHsParPV l p = return $ L l (PatBuilderPar p)
+ mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v)
+ mkHsLitPV lit@(L l a) = do
checkUnboxedStringLitPat lit
- return $ cL l (PatBuilderPat (LitPat noExtField a))
- mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a)
- mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExtField))
+ return $ L l (PatBuilderPat (LitPat noExtField a))
+ mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)
+ mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))
mkHsTySigPV l b sig = do
p <- checkLPat b
- return $ cL l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig)))
+ return $ L l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig)))
mkHsExplicitListPV l xs = do
ps <- traverse checkLPat xs
- return (cL l (PatBuilderPat (ListPat noExtField ps)))
- mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExtField sp))
+ return (L l (PatBuilderPat (ListPat noExtField ps)))
+ mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))
mkHsRecordPV l _ a (fbinds, ddLoc) = do
r <- mkPatRec a (mk_rec_fields fbinds ddLoc)
- checkRecordSyntax (cL l r)
- mkHsNegAppPV l (dL->L lp p) = do
+ checkRecordSyntax (L l r)
+ mkHsNegAppPV l (L lp p) = do
lit <- case p of
- PatBuilderOverLit pos_lit -> return (cL lp pos_lit)
+ PatBuilderOverLit pos_lit -> return (L lp pos_lit)
_ -> patFail l (text "-" <> ppr p)
- return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr)))
+ return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr)))
mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)
mkHsViewPatPV l a b = do
p <- checkLPat b
- return $ cL l (PatBuilderPat (ViewPat noExtField a p))
+ return $ L l (PatBuilderPat (ViewPat noExtField a p))
mkHsAsPatPV l v e = do
p <- checkLPat e
- return $ cL l (PatBuilderPat (AsPat noExtField v p))
+ return $ L l (PatBuilderPat (AsPat noExtField v p))
mkHsLazyPatPV l e = do
p <- checkLPat e
- return $ cL l (PatBuilderPat (LazyPat noExtField p))
+ return $ L l (PatBuilderPat (LazyPat noExtField p))
mkHsBangPatPV l e = do
p <- checkLPat e
let pb = BangPat noExtField p
hintBangPat l pb
- return $ cL l (PatBuilderPat pb)
+ return $ L l (PatBuilderPat pb)
mkSumOrTuplePV = mkSumOrTuplePat
checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
-checkUnboxedStringLitPat (dL->L loc lit) =
+checkUnboxedStringLitPat (L loc lit) =
case lit of
HsStringPrim _ _ -- Trac #13260
-> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit)
:: Located (SourceText,Int) -- ^ precedence
-> Located (OrdList (Located RdrName)) -- ^ operators
-> P ()
-checkPrecP (dL->L l (_,i)) (dL->L _ ol)
+checkPrecP (L l (_,i)) (L _ ol)
| 0 <= i, i <= maxPrecedence = pure ()
| all specialOp ol = pure ()
| otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> PV (HsExpr GhcPs)
-mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
- = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd))
+ = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp _ (fs,dd)
| Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
| otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs
- , rec_dotdot = Just (cL s (length fs)) }
+ , rec_dotdot = Just (L s (length fs)) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
-mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun)
+mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
= HsRecField (L loc (Unambiguous noExtField rdr)) arg pun
-mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _)
+mk_rec_upd_field (HsRecField (L _ (XFieldOcc nec)) _ _)
= noExtCon nec
-mk_rec_upd_field (HsRecField _ _ _)
- = panic "mk_rec_upd_field: Impossible Match" -- due to #15884
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
-- name (cf section 8.5.1 in Haskell 2010 report).
mkCImport = do
let e = unpackFS entity
- case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of
+ case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
Nothing -> addFatalError loc (text "Malformed entity string")
Just importSpec -> returnSpec importSpec
then mkExtName (unLoc v)
else entity
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
- importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc)
+ importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
returnSpec spec = return $ ForD noExtField $ ForeignImport
{ fd_i_ext = noExtField
mkExport :: Located CCallConv
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
-mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty)
+mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
= return $ ForD noExtField $
ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty
- , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv))
- (cL le esrc) }
+ , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
+ (L le esrc) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
| ImpExpQcWildcard
mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
-mkModuleImpExp (dL->L l specname) subs =
+mkModuleImpExp (L l specname) subs =
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name)
- -> return $ IEVar noExtField (cL l (ieNameFromSpec specname))
- | otherwise -> IEThingAbs noExtField . cL l <$> nameT
- ImpExpAll -> IEThingAll noExtField . cL l <$> nameT
+ -> return $ IEVar noExtField (L l (ieNameFromSpec specname))
+ | otherwise -> IEThingAbs noExtField . L l <$> nameT
+ ImpExpAll -> IEThingAll noExtField . L l <$> nameT
ImpExpList xs ->
- (\newName -> IEThingWith noExtField (cL l newName)
+ (\newName -> IEThingWith noExtField (L l newName)
NoIEWildcard (wrapped xs) []) <$> nameT
ImpExpAllWith xs ->
do allowed <- getBit PatternSynonymsBit
(findIndex isImpExpQcWildcard withs)
ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
in (\newName
- -> IEThingWith noExtField (cL l newName) pos ies [])
+ -> IEThingWith noExtField (L l newName) pos ies [])
<$> nameT
else addFatalError l
(text "Illegal export form (use PatternSynonyms to enable)")
ieNameFromSpec (ImpExpQcType ln) = IEType ln
ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
- wrapped = map (onHasSrcSpan ieNameFromSpec)
+ wrapped = map (mapLoc ieNameFromSpec)
mkTypeImpExp :: Located RdrName -- TcCls or Var name space
-> P (Located RdrName)
return (fmap (`setRdrNameSpace` tcClsName) name)
checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
-checkImportSpec ie@(dL->L _ specs) =
- case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
+checkImportSpec ie@(L _ specs) =
+ case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
[] -> return ie
(l:_) -> importSpecError l
where
-- In the correct order
mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
-mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] =
+mkImpExpSubSpec [L _ ImpExpQcWildcard] =
return ([], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isImpExpQcWildcard . unLoc) xs)
$$ text " including the definition module, you must qualify it."
failOpFewArgs :: Located RdrName -> P a
-failOpFewArgs (dL->L loc op) =
+failOpFewArgs (L loc op) =
do { star_is_type <- getBit StarIsTypeBit
; let msg = too_few $$ starInfo star_is_type op
; addFatalError loc msg }
-- Tuple
mkSumOrTupleExpr l boxity (Tuple es) =
- return $ cL l (ExplicitTuple noExtField (map toTupArg es) boxity)
+ return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity)
where
toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs
toTupArg = mapLoc (maybe missingTupArg (Present noExtField))
-- Sum
mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
- return $ cL l (ExplicitSum noExtField alt arity e)
+ return $ L l (ExplicitSum noExtField alt arity e)
mkSumOrTupleExpr l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(pprSumOrTuple Boxed a))
-- Tuple
mkSumOrTuplePat l boxity (Tuple ps) = do
ps' <- traverse toTupPat ps
- return $ cL l (PatBuilderPat (TuplePat noExtField ps' boxity))
+ return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity))
where
toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
- toTupPat (dL -> L l p) = case p of
+ toTupPat (L l p) = case p of
Nothing -> addFatalError l (text "Tuple section in pattern context")
Just p' -> checkLPat p'
-- Sum
mkSumOrTuplePat l Unboxed (Sum alt arity p) = do
p' <- checkLPat p
- return $ cL l (PatBuilderPat (SumPat noExtField p' alt arity))
+ return $ L l (PatBuilderPat (SumPat noExtField p' alt arity))
mkSumOrTuplePat l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(pprSumOrTuple Boxed a))
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x op y =
let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
- in cL loc (mkHsOpTy x op y)
+ in L loc (mkHsOpTy x op y)
mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
mkLHsDocTy t doc =
let loc = getLoc t `combineSrcSpans` getLoc doc
- in cL loc (HsDocTy noExtField t doc)
+ in L loc (HsDocTy noExtField t doc)
mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t)
where
(later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
new_stmt | non_rec = head ss
- | otherwise = cL (getLoc (head ss)) rec_stmt
+ | otherwise = L (getLoc (head ss)) rec_stmt
rec_stmt = empty_rec_stmt { recS_stmts = ss
, recS_later_ids = nameSetElemsStable used_later
, recS_rec_ids = nameSetElemsStable fwds }
Nothing -> return Nothing
rnLHsDoc :: LHsDocString -> RnM LHsDocString
-rnLHsDoc (dL->L pos doc) = do
+rnLHsDoc (L pos doc) = do
doc' <- rnHsDoc doc
- return (cL pos doc')
+ return (L pos doc')
rnHsDoc :: HsDocString -> RnM HsDocString
rnHsDoc = pure
; (r,fvs2) <- k v
; return (r, fvs1 `plusFV` fvs2) })
-wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) =>
- (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b
+wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)
-- Set the location, and also wrap it around the value returned
-wrapSrcSpanCps fn (dL->L loc a)
+wrapSrcSpanCps fn (L loc a)
= CpsRn (\k -> setSrcSpan loc $
unCpsRn (fn a) $ \v ->
- k (cL loc v))
+ k (L loc v))
lookupConCps :: Located RdrName -> CpsRn (Located Name)
lookupConCps con_rdr
rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)
newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
-newPatLName name_maker rdr_name@(dL->L loc _)
+newPatLName name_maker rdr_name@(L loc _)
= do { name <- newPatName name_maker rdr_name
- ; return (cL loc name) }
+ ; return (L loc name) }
newPatName :: NameMaker -> Located RdrName -> CpsRn Name
newPatName (LamMk report_unused) rdr_name
; return (LazyPat x pat') }
rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat
; return (BangPat x pat') }
-rnPatAndThen mk (VarPat x (dL->L l rdr))
+rnPatAndThen mk (VarPat x (L l rdr))
= do { loc <- liftCps getSrcSpanM
- ; name <- newPatName mk (cL loc rdr)
- ; return (VarPat x (cL l name)) }
+ ; name <- newPatName mk (L loc rdr)
+ ; return (VarPat x (L l name)) }
-- we need to bind pattern variables for view pattern expressions
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
where
normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
-rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq)
+rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
= do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
; mb_neg' -- See Note [Negative zero]
<- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
(Nothing, Nothing) -> positive
(Just _ , Just _ ) -> positive
; eq' <- liftCpsFV $ lookupSyntaxName eqName
- ; return (NPat x (cL l lit') mb_neg' eq') }
+ ; return (NPat x (L l lit') mb_neg' eq') }
-rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ )
+rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )
= do { new_name <- newPatName mk rdr
; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
-- We skip negateName as
-- sense in n + k patterns
; minus <- liftCpsFV $ lookupSyntaxName minusName
; ge <- liftCpsFV $ lookupSyntaxName geName
- ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name)
- (cL l lit') lit' ge minus) }
+ ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)
+ (L l lit') lit' ge minus) }
-- The Report says that n+k patterns must be in Integral
rnPatAndThen mk (AsPat x rdr pat)
-> Located Name -- Constructor
-> HsRecFields GhcPs (LPat GhcPs)
-> CpsRn (HsRecFields GhcRn (LPat GhcRn))
-rnHsRecPatsAndThen mk (dL->L _ con)
+rnHsRecPatsAndThen mk (L _ con)
hs_rec_fields@(HsRecFields { rec_dotdot = dd })
= do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
hs_rec_fields
; check_unused_wildcard (implicit_binders flds' <$> dd)
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
where
- mkVarPat l n = VarPat noExtField (cL l n)
- rn_field (dL->L l fld, n') =
+ mkVarPat l n = VarPat noExtField (L l n)
+ rn_field (L l fld, n') =
do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)
- ; return (cL l (fld { hsRecFieldArg = arg' })) }
+ ; return (L l (fld { hsRecFieldArg = arg' })) }
loc = maybe noSrcSpan getLoc dd
| HsRecFieldUpd
rnHsRecFields
- :: forall arg. HasSrcSpan arg =>
+ :: forall arg.
HsRecFieldContext
- -> (SrcSpan -> RdrName -> SrcSpanLess arg)
+ -> (SrcSpan -> RdrName -> arg)
-- When punning, use this to build a new field
- -> HsRecFields GhcPs arg
- -> RnM ([LHsRecField GhcRn arg], FreeVars)
+ -> HsRecFields GhcPs (Located arg)
+ -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars)
-- This surprisingly complicated pass
-- a) looks up the field name (possibly using disambiguation)
HsRecFieldPat con -> Just con
_ {- update -} -> Nothing
- rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg
- -> RnM (LHsRecField GhcRn arg)
- rn_fld pun_ok parent (dL->L l
+ rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)
+ -> RnM (LHsRecField GhcRn (Located arg))
+ rn_fld pun_ok parent (L l
(HsRecField
{ hsRecFieldLbl =
- (dL->L loc (FieldOcc _ (dL->L ll lbl)))
+ (L loc (FieldOcc _ (L ll lbl)))
, hsRecFieldArg = arg
, hsRecPun = pun }))
= do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
; arg' <- if pun
- then do { checkErr pun_ok (badPun (cL loc lbl))
+ then do { checkErr pun_ok (badPun (L loc lbl))
-- Discard any module qualifier (#11662)
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
- ; return (cL loc (mk_arg loc arg_rdr)) }
+ ; return (L loc (mk_arg loc arg_rdr)) }
else return arg
- ; return (cL l (HsRecField
- { hsRecFieldLbl = (cL loc (FieldOcc
- sel (cL ll lbl)))
+ ; return (L l (HsRecField
+ { hsRecFieldLbl = (L loc (FieldOcc
+ sel (L ll lbl)))
, hsRecFieldArg = arg'
, hsRecPun = pun })) }
- rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _))
+ rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _))
= panic "rnHsRecFields"
- rn_fld _ _ _ = panic "rn_fld: Impossible Match"
- -- due to #15884
rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat
-> Maybe Name -- The constructor (Nothing for an
-- out of scope constructor)
- -> [LHsRecField GhcRn arg] -- Explicit fields
- -> RnM ([LHsRecField GhcRn arg]) -- Field Labels we need to fill in
- rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match
+ -> [LHsRecField GhcRn (Located arg)] -- Explicit fields
+ -> RnM ([LHsRecField GhcRn (Located arg)]) -- Field Labels we need to fill in
+ rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match
| not (isUnboundName con) -- This test is because if the constructor
-- isn't in scope the constructor lookup will add
-- an error but still return an unbound name. We
_other -> True ]
; addUsedGREs dot_dot_gres
- ; return [ cL loc (HsRecField
- { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))
- , hsRecFieldArg = cL loc (mk_arg loc arg_rdr)
+ ; return [ L loc (HsRecField
+ { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))
+ , hsRecFieldArg = L loc (mk_arg loc arg_rdr)
, hsRecPun = False })
| fl <- dot_dot_fields
, let sel = flSelector fl
rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs
-> RnM (LHsRecUpdField GhcRn, FreeVars)
- rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f
- , hsRecFieldArg = arg
- , hsRecPun = pun }))
+ rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f
+ , hsRecFieldArg = arg
+ , hsRecPun = pun }))
= do { let lbl = rdrNameAmbiguousFieldOcc f
; sel <- setSrcSpan loc $
-- Defer renaming of overloaded fields to the typechecker
Just r -> return r }
else fmap Left $ lookupGlobalOccRn lbl
; arg' <- if pun
- then do { checkErr pun_ok (badPun (cL loc lbl))
+ then do { checkErr pun_ok (badPun (L loc lbl))
-- Discard any module qualifier (#11662)
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
- ; return (cL loc (HsVar noExtField (cL loc arg_rdr))) }
+ ; return (L loc (HsVar noExtField (L loc arg_rdr))) }
else return arg
; (arg'', fvs) <- rnLExpr arg'
Right _ -> fvs
lbl' = case sel of
Left sel_name ->
- cL loc (Unambiguous sel_name (cL loc lbl))
+ L loc (Unambiguous sel_name (L loc lbl))
Right [sel_name] ->
- cL loc (Unambiguous sel_name (cL loc lbl))
- Right _ -> cL loc (Ambiguous noExtField (cL loc lbl))
+
git.haskell.org / ghc.git / commitdiff
