summaryrefslogtreecommitdiff
path: root/compiler/parser/RdrHsSyn.hs
diff options
context:
space:
mode:
authorJosh Meredith <joshmeredith2008@gmail.com>2019-12-04 23:39:28 +1100
committerJosh Meredith <joshmeredith2008@gmail.com>2019-12-04 23:39:28 +1100
commita8435165b84c32fd2ebdd1281dd6ee077e07ad5a (patch)
tree791936d014aeaa26174c2dcbef34c14f3329dd04 /compiler/parser/RdrHsSyn.hs
parent7805441b4d5e22eb63a501e1e40383d10380dc92 (diff)
parentf03a41d4bf9418ee028ecb51654c928b2da74edd (diff)
downloadhaskell-wip/binary-readerT.tar.gz
Merge branch 'master' into wip/binary-readerTwip/binary-readerT
Diffstat (limited to 'compiler/parser/RdrHsSyn.hs')
-rw-r--r--compiler/parser/RdrHsSyn.hs916
1 files changed, 359 insertions, 557 deletions
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index cb70078fd3..0ffad547a7 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -56,8 +56,6 @@ module RdrHsSyn (
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
checkPattern_msg,
- isBangRdr,
- isTildeRdr,
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
@@ -68,6 +66,7 @@ module RdrHsSyn (
checkEmptyGADTs,
addFatalError, hintBangPat,
TyEl(..), mergeOps, mergeDataCon,
+ mkBangTy,
-- Help with processing exports
ImpExpSubSpec(..),
@@ -100,7 +99,6 @@ module RdrHsSyn (
ecpFromExp,
ecpFromCmd,
PatBuilder,
- patBuilderBang,
) where
@@ -162,10 +160,10 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
-- *** 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)
@@ -173,21 +171,21 @@ mkClassDecl :: SrcSpan
-> 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
@@ -197,17 +195,17 @@ mkTyData :: SrcSpan
-> [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)
@@ -236,10 +234,10 @@ mkTySynonym loc lhs rhs
; 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
@@ -249,7 +247,7 @@ mkStandaloneKindSig
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)
@@ -294,7 +292,7 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
= 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
@@ -306,7 +304,7 @@ mkTyFamInst :: SrcSpan
-> 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
@@ -319,7 +317,7 @@ mkFamDecl loc info lhs ksig injAnn
; 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
@@ -342,15 +340,15 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
--
-- 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 NoParens lexpr))
+ = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr))
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
@@ -359,16 +357,16 @@ 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)
@@ -376,8 +374,6 @@ mkRoleAnnotDecl loc tycon 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)
@@ -402,9 +398,9 @@ cvTopDecls decls = go (fromOL decls)
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.
@@ -424,24 +420,24 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
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" <+>
@@ -467,25 +463,25 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
--
-- 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
@@ -493,14 +489,13 @@ getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
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
{- **********************************************************************
@@ -564,14 +559,13 @@ declarations and types as a reversed list of TyEl:
data TyEl = TyElOpr RdrName
| TyElOpd (HsType GhcPs)
- | TyElBang | TyElTilde
| ...
-For example, both occurences of (C ! D) in the following example are parsed
+For example, both occurrences of (C ! D) in the following example are parsed
into equal lists of TyEl:
data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D")
- , TyElBang
+ , TyElOpr "!"
, TyElOpd (HsTyVar "C") ]
Note that elements are in reverse order. Also, 'C' is parsed as a type
@@ -592,7 +586,7 @@ tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
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)
@@ -603,14 +597,14 @@ tyConToDataCon loc tc
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
@@ -632,8 +626,8 @@ mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
, 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 $
@@ -675,7 +669,7 @@ mkGadtDecl :: [Located RdrName]
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
@@ -683,13 +677,13 @@ mkGadtDecl names ty
, 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)
@@ -697,12 +691,12 @@ mkGadtDecl names ty
(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)
@@ -826,19 +820,18 @@ checkTyVars pp_what equals_or_where tc tparms
-- 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
@@ -896,14 +889,14 @@ mkRuleTyVarBndrs = fmap (fmap cvt_one)
-- 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
@@ -913,7 +906,7 @@ checkRecordSyntax lr@(dL->L loc 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"
@@ -937,23 +930,23 @@ checkTyClHdr :: Bool -- True <=> class header
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
@@ -990,7 +983,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
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 $
@@ -1010,22 +1003,22 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
-- (((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"
@@ -1034,9 +1027,9 @@ checkContext (dL->L l orig_t)
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 ()
@@ -1079,27 +1072,21 @@ checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
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 e args -- OK to let this happen even if bang-patterns
- -- are not enabled, because there is no valid
- -- non-bang-pattern parse of (C ! e)
- | Just (e', args') <- splitBang e
- = do { args'' <- mapM checkLPat args'
- ; checkPat loc e' (args'' ++ args) }
-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)
@@ -1113,27 +1100,21 @@ checkAPat loc e0 = do
-- 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)
-
- PatBuilderBang lb e -- (! x)
- -> do { hintBangPat loc e0
- ; e' <- checkLPat e
- ; addAnnotation loc AnnBang lb
- ; return (BangPat noExtField e') }
+ 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)
@@ -1148,15 +1129,10 @@ plus_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
-isBangRdr, isTildeRdr :: RdrName -> Bool
-isBangRdr (Unqual occ) = occNameFS occ == fsLit "!"
-isBangRdr _ = False
-isTildeRdr = (==eqTyCon_RDR)
-
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
@@ -1167,23 +1143,22 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
---------------------------------------------------------------------------
-- Check Equation Syntax
-checkValDef :: SrcStrictness
- -> Located (PatBuilder GhcPs)
+checkValDef :: Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkValDef _strictness lhs (Just sig) grhss
+checkValDef lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
= do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat
checkPatBind lhs' grhss
-checkValDef strictness 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 strictness ann (getLoc lhs)
- fun is_infix pats (cL l grhss)
+ checkFunBind NoSrcStrict ann (getLoc lhs)
+ fun is_infix pats (L l grhss)
Nothing -> do
lhs' <- checkPattern lhs
checkPatBind lhs' g }
@@ -1196,19 +1171,19 @@ checkFunBind :: SrcStrictness
-> [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.
@@ -1222,19 +1197,32 @@ makeFunBind fn ms
fun_co_fn = idHsWrapper,
fun_tick = [] }
+-- See Note [FunBind vs PatBind]
checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkPatBind lhs (dL->L _ (_,grhss))
+checkPatBind lhs (L match_span (_,grhss))
+ | BangPat _ p <- unLoc lhs
+ , VarPat _ v <- unLoc p
+ = return ([], makeFunBind v [L match_span (m v)])
+ where
+ m v = Match { m_ext = noExtField
+ , m_ctxt = FunRhs { mc_fun = L (getLoc lhs) (unLoc v)
+ , mc_fixity = Prefix
+ , mc_strictness = SrcStrict }
+ , m_pats = []
+ , m_grhss = 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)
@@ -1252,8 +1240,8 @@ checkValSigLhs lhs@(dL->L l _)
-- 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")
@@ -1261,8 +1249,8 @@ checkValSigLhs lhs@(dL->L l _)
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
@@ -1278,77 +1266,27 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
text "else" <+> ppr elseExpr
-
- -- The parser left-associates, so there should
- -- not be any OpApps inside the e's
-splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
--- Splits (f ! g a b) into (f, [(! g), a, b])
-splitBang (dL->L _ (PatBuilderOpApp l_arg op r_arg))
- | isBangRdr (unLoc op)
- = Just (l_arg, cL l' (PatBuilderBang (getLoc op) arg1) : argns)
- where
- l' = combineLocs op arg1
- (arg1,argns) = split_bang r_arg []
- split_bang (dL->L _ (PatBuilderApp f e)) es = split_bang f (e:es)
- split_bang e es = (e,es)
-splitBang _ = Nothing
-
--- See Note [isFunLhs vs mergeDataCon]
isFunLhs :: Located (PatBuilder GhcPs)
-> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
---
--- The whole LHS is parsed as a single expression.
--- Any infix operators on the LHS will parse left-associatively
--- E.g. f !x y !z
--- will parse (rather strangely) as
--- (f ! x y) ! z
--- It's up to isFunLhs to sort out the mess
---
--- a .!. !b
-
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)
-
- -- Things of the form `!x` are also FunBinds
- -- See Note [FunBind vs PatBind]
- go (dL->L _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] ann
- | not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann))
-
- -- For infix function defns, there should be only one infix *function*
- -- (though there may be infix *datacons* involved too). So we don't
- -- need fixity info to figure out which function is being defined.
- -- a `K1` b `op` c `K2` d
- -- must parse as
- -- (a `K1` b) `op` (c `K2` d)
- -- The renamer checks later that the precedences would yield such a parse.
- --
- -- There is a complication to deal with bang patterns.
- --
- -- ToDo: what about this?
- -- x + 1 `op` y = ...
-
- go e@(L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann
- | Just (e',es') <- splitBang e
- = do { bang_on <- getBit BangPatBit
- ; if bang_on then go e' (es' ++ es) ann
- else return (Just (cL loc' op, Infix, (l:r:es), ann)) }
- -- No bangs; behave just like the next case
+ 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
@@ -1356,7 +1294,6 @@ isFunLhs e = go e [] []
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
| TyElKindApp SrcSpan (LHsType GhcPs)
-- See Note [TyElKindApp SrcSpan interpretation]
- | TyElTilde | TyElBang
| TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
| TyElDocPrev HsDocString
@@ -1379,40 +1316,22 @@ instance Outputable TyEl where
ppr (TyElOpr name) = ppr name
ppr (TyElOpd ty) = ppr ty
ppr (TyElKindApp _ ki) = text "@" <> ppr ki
- ppr TyElTilde = text "~"
- ppr TyElBang = text "!"
ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk
ppr (TyElDocPrev doc) = ppr doc
-tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
-tyElStrictness TyElTilde = Just (AnnTilde, SrcLazy)
-tyElStrictness TyElBang = Just (AnnBang, SrcStrict)
-tyElStrictness _ = Nothing
-
-- | Extract a strictness/unpackedness annotation from the front of a reversed
-- 'TyEl' list.
-pStrictMark
+pUnpackedness
:: [Located TyEl] -- reversed TyEl
- -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -}
+ -> Maybe ( SrcSpan
, [AddAnn]
+ , SourceText
+ , SrcUnpackedness
, [Located TyEl] {- remaining TyEl -})
-pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs)
- | Just (strAnnId, str) <- tyElStrictness x1
- , TyElUnpackedness (unpkAnns, prag, unpk) <- x2
- = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str)
- , unpkAnns ++ [AddAnn strAnnId l1]
- , xs )
-pStrictMark ((dL->L l x1) : xs)
- | Just (strAnnId, str) <- tyElStrictness x1
- = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str)
- , [AddAnn strAnnId l]
- , xs )
-pStrictMark ((dL->L l x1) : xs)
+pUnpackedness (L l x1 : xs)
| TyElUnpackedness (anns, prag, unpk) <- x1
- = Just ( cL l (HsSrcBang prag unpk NoSrcStrict)
- , anns
- , xs )
-pStrictMark _ = Nothing
+ = Just (l, anns, prag, unpk, xs)
+pUnpackedness _ = Nothing
pBangTy
:: LHsType GhcPs -- a type to be wrapped inside HsBangTy
@@ -1421,13 +1340,24 @@ pBangTy
, LHsType GhcPs {- the resulting BangTy -}
, P () {- add annotations -}
, [Located TyEl] {- remaining TyEl -})
-pBangTy lt@(dL->L l1 _) xs =
- case pStrictMark xs of
+pBangTy lt@(L l1 _) xs =
+ case pUnpackedness xs of
Nothing -> (False, lt, pure (), xs)
- Just (dL->L l2 strictMark, anns, xs') ->
+ Just (l2, anns, prag, unpk, xs') ->
let bl = combineSrcSpans l1 l2
- bt = HsBangTy noExtField strictMark lt
- in (True, cL bl bt, addAnnsAt bl anns, xs')
+ bt = addUnpackedness (prag, unpk) lt
+ in (True, L bl bt, addAnnsAt bl anns, xs')
+
+mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
+mkBangTy strictness =
+ HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness)
+
+addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> HsType GhcPs
+addUnpackedness (prag, unpk) (L _ (HsBangTy x bang t))
+ | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang
+ = HsBangTy x (HsSrcBang prag unpk strictness) t
+addUnpackedness (prag, unpk) t
+ = HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t
-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
-- into a type.
@@ -1442,8 +1372,8 @@ pBangTy lt@(dL->L l1 _) xs =
--
-- 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
@@ -1453,7 +1383,7 @@ 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'
@@ -1461,7 +1391,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
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
@@ -1476,68 +1406,35 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [doc]:
-- we do not expect to encounter any docs
- go _ _ _ ((dL->L l (TyElDocPrev _)):_) =
+ go _ _ _ ((L l (TyElDocPrev _)):_) =
failOpDocPrev l
- -- to improve error messages, we do a bit of guesswork to determine if the
- -- user intended a '!' or a '~' as a strictness annotation
- go k acc ops_acc ((dL->L l x) : xs)
- | Just (_, str) <- tyElStrictness x
- , let guess [] = True
- guess ((dL->L _ (TyElOpd _)):_) = False
- guess ((dL->L _ (TyElOpr _)):_) = True
- guess ((dL->L _ (TyElKindApp _ _)):_) = False
- guess ((dL->L _ (TyElTilde)):_) = True
- guess ((dL->L _ (TyElBang)):_) = True
- guess ((dL->L _ (TyElUnpackedness _)):_) = True
- guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs'
- guess _ = panic "mergeOps.go.guess: Impossible Match"
- -- due to #15884
- in guess xs
- = if not (null acc) && (k > 1 || length acc > 1)
- then do { a <- eitherToP (mergeOpsAcc acc)
- ; failOpStrictnessCompound (cL l str) (ops_acc a) }
- else failOpStrictnessPosition (cL l str)
-
-- 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 [opr.1]: interpret 'TyElTilde' as an operator
- go k acc ops_acc ((dL->L l TyElTilde):xs) =
- let op = eqTyCon_RDR
- in go k acc ops_acc (cL l (TyElOpr op):xs)
-
- -- clause [opr.2]: interpret 'TyElBang' as an operator
- go k acc ops_acc ((dL->L l TyElBang):xs) =
- let op = mkUnqual tcClsName (fsLit "!")
- in go k acc ops_acc (cL l (TyElOpr op):xs)
-
-- 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"
@@ -1609,8 +1506,8 @@ Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause
-}
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
@@ -1627,84 +1524,29 @@ pInfixSide (el:xs1)
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
orErr (Just a) _ = Right a
orErr Nothing b = Left b
-{- Note [isFunLhs vs mergeDataCon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When parsing a function LHS, we do not know whether to treat (!) as
-a strictness annotation or an infix operator:
-
- f ! a = ...
-
-Without -XBangPatterns, this parses as (!) f a = ...
- with -XBangPatterns, this parses as f (!a) = ...
-
-So in function declarations we opted to always parse as if -XBangPatterns
-were off, and then rejig in 'isFunLhs'.
-
-There are two downsides to this approach:
-
-1. It is not particularly elegant, as there's a point in our pipeline where
- the representation is awfully incorrect. For instance,
- f !a b !c = ...
- will be first parsed as
- (f ! a b) ! c = ...
-
-2. There are cases that it fails to cover, for instance infix declarations:
- !a + !b = ...
- will trigger an error.
-
-Unfortunately, we cannot define different productions in the 'happy' grammar
-depending on whether -XBangPatterns are enabled.
-
-When parsing data constructors, we face a similar issue:
- (a) data T1 = C ! D
- (b) data T2 = C ! D => ...
-
-In (a) the first bang is a strictness annotation, but in (b) it is a type
-operator. A 'happy'-based parser does not have unlimited lookahead to check for
-=>, so we must first parse (C ! D) into a common representation.
-
-If we tried to mirror the approach used in functions, we would parse both sides
-of => as types, and then rejig. However, we take a different route and use an
-intermediate data structure, a reversed list of 'TyEl'.
-See Note [Parsing data constructors is hard] for details.
-
-This approach does not suffer from the issues of 'isFunLhs':
-
-1. A sequence of 'TyEl' is a dedicated intermediate representation, not an
- incorrectly parsed type. Therefore, we do not have confusing states in our
- pipeline. (Except for representing data constructors as type variables).
-
-2. We can handle infix data constructors with strictness annotations:
- data T a b = !a :+ !b
-
--}
-
-
-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
-- into a data constructor.
--
-- User input: @C !A B -- ^ doc@
--- Input to 'mergeDataCon': ["doc", B, !, A, C]
+-- Input to 'mergeDataCon': ["doc", B, !A, C]
-- Output: (C, PrefixCon [!A, B], "doc")
--
-- See Note [Parsing data constructors is hard]
--- See Note [isFunLhs vs mergeDataCon]
mergeDataCon
:: [Located TyEl]
-> P ( Located RdrName -- constructor name
@@ -1733,7 +1575,7 @@ mergeDataCon all_xs =
-- 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].
@@ -1755,38 +1597,38 @@ mergeDataCon all_xs =
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
@@ -1804,7 +1646,7 @@ mergeDataCon all_xs =
; (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
@@ -1847,6 +1689,17 @@ checkMonadComp = do
-- See Note [Parser-Validator]
-- See Note [Ambiguous syntactic categories]
+--
+-- This newtype is required to avoid impredicative types in monadic
+-- productions. That is, in a production that looks like
+--
+-- | ... {% return (ECP ...) }
+--
+-- we are dealing with
+-- P ECP
+-- whereas without a newtype we would be dealing with
+-- P (forall b. DisambECP b => PV (Located b))
+--
newtype ECP =
ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }
@@ -1866,14 +1719,14 @@ class DisambInfixOp b where
mkHsConOpPV :: Located RdrName -> PV (Located b)
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
+instance DisambInfixOp (HsExpr GhcPs) where
+ 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"
@@ -1893,7 +1746,7 @@ class b ~ (Body b) GhcPs => DisambECP b where
mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b)
-- | Infix operator representation
type InfixOp b
- -- | Bring superclass constraints on FunArg into scope.
+ -- | Bring superclass constraints on InfixOp into scope.
-- See Note [UndecidableSuperClasses for associated types]
superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b)
-- | Disambiguate "f # x" (infix operator)
@@ -1950,11 +1803,15 @@ class b ~ (Body b) GhcPs => DisambECP b where
mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b)
-- | Disambiguate "~a" (lazy pattern)
mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b)
+ -- | Disambiguate "!a" (bang pattern)
+ mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b)
-- | Disambiguate tuple sections and unboxed sums
mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b)
{- Note [UndecidableSuperClasses for associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(This Note is about the code in GHC, not about the user code that we are parsing)
+
Assume we have a class C with an associated type T:
class C a where
@@ -1995,37 +1852,37 @@ PatBuilder, but leads to worse type inference, breaking some code in the
typechecker.
-}
-instance p ~ GhcPs => DisambECP (HsCmd p) where
- type Body (HsCmd p) = HsCmd
+instance DisambECP (HsCmd GhcPs) where
+ type Body (HsCmd GhcPs) = 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)
- type InfixOp (HsCmd p) = HsExpr p
+ 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 GhcPs) = HsExpr GhcPs
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)
- type FunArg (HsCmd p) = HsExpr p
+ 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 GhcPs) = HsExpr GhcPs
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)
@@ -2039,68 +1896,69 @@ instance p ~ GhcPs => DisambECP (HsCmd p) where
pprPrefixOcc (unLoc v) <> text "@" <> ppr c
mkHsLazyPatPV l c = cmdFail l $
text "~" <> ppr c
+ mkHsBangPatPV l c = cmdFail l $
+ text "!" <> ppr c
mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a)
cmdFail :: SrcSpan -> SDoc -> PV a
cmdFail loc e = addFatalError loc $
hang (text "Parse error in command:") 2 (ppr e)
-instance p ~ GhcPs => DisambECP (HsExpr p) where
- type Body (HsExpr p) = HsExpr
- ecpFromCmd' (dL -> L l c) = do
+instance DisambECP (HsExpr GhcPs) where
+ type Body (HsExpr GhcPs) = HsExpr
+ 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)
- type InfixOp (HsExpr p) = HsExpr p
+ mkHsLamPV l mg = return $ L l (HsLam noExtField mg)
+ mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c)
+ type InfixOp (HsExpr GhcPs) = HsExpr GhcPs
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)
- type FunArg (HsExpr p) = HsExpr p
+ return $ L l $ OpApp noExtField e1 op e2
+ mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg)
+ type FunArg (HsExpr GhcPs) = HsExpr GhcPs
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)
- mkHsViewPatPV l a b = patSynErr l (ppr a <+> text "->" <+> ppr b) empty
- mkHsAsPatPV l v e = do
- opt_TypeApplications <- getBit TypeApplicationsBit
- let msg | opt_TypeApplications
- = "Type application syntax requires a space before '@'"
- | otherwise
- = "Did you mean to enable TypeApplications?"
- patSynErr l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) (text msg)
- mkHsLazyPatPV l e = patSynErr l (text "~" <> ppr e) empty
+ 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) $
+ text "Type application syntax requires a space before '@'"
+ mkHsLazyPatPV l e = patSynErr "Lazy pattern" l (text "~" <> ppr e) $
+ text "Did you mean to add a space after the '~'?"
+ mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $
+ text "Did you mean to add a space after the '!'?"
mkSumOrTuplePV = mkSumOrTupleExpr
-patSynErr :: SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
-patSynErr l e explanation =
+patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
+patSynErr item l e explanation =
do { addError l $
- sep [text "Pattern syntax in expression context:",
+ 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 "_")
@@ -2108,21 +1966,14 @@ hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")
-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]
data PatBuilder p
= PatBuilderPat (Pat p)
- | PatBuilderBang SrcSpan (Located (PatBuilder p))
| PatBuilderPar (Located (PatBuilder p))
| PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
| PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
| PatBuilderVar (Located RdrName)
| PatBuilderOverLit (HsOverLit GhcPs)
-patBuilderBang :: SrcSpan -> Located (PatBuilder p) -> Located (PatBuilder p)
-patBuilderBang bang p =
- cL (bang `combineSrcSpans` getLoc p) $
- PatBuilderBang bang p
-
instance Outputable (PatBuilder GhcPs) where
ppr (PatBuilderPat p) = ppr p
- ppr (PatBuilderBang _ (L _ p)) = text "!" <+> ppr p
ppr (PatBuilderPar (L _ p)) = parens (ppr p)
ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2
ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2
@@ -2131,10 +1982,10 @@ instance Outputable (PatBuilder GhcPs) where
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 $
@@ -2143,53 +1994,54 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
- mkHsOpAppPV l p1 op p2 = do
- warnSpaceAfterBang op (getLoc 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)))
- mkHsSectionR_PV l op p
- | isBangRdr (unLoc op) = return $ cL l $ PatBuilderBang (getLoc op) p
- | otherwise = patFail l (pprInfixOcc (unLoc op) <> ppr p)
+ 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 $ 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)
@@ -2206,19 +2058,6 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
mkPatRec p _ =
addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
--- | Warn about missing space after bang
-warnSpaceAfterBang :: Located RdrName -> SrcSpan -> PV ()
-warnSpaceAfterBang (dL->L opLoc op) argLoc = do
- bang_on <- getBit BangPatBit
- when (not bang_on && noSpace && isBangRdr op) $
- addWarning Opt_WarnSpaceAfterBang span msg
- where
- span = combineSrcSpans opLoc argLoc
- noSpace = srcSpanEnd opLoc == srcSpanStart argLoc
- msg = text "Did you forget to enable BangPatterns?" $$
- text "If you mean to bind (!) then perhaps you want" $$
- text "to add a space after the bang for clarity."
-
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2243,12 +2082,12 @@ Guards:
Top-level value/function declarations (FunBind/PatBind):
- f !a -- TH splice
- f !a = ... -- function declaration
+ f ! a -- TH splice
+ f ! a = ... -- function declaration
Until we encounter the = sign, we don't know if it's a top-level
- TemplateHaskell splice where ! is an infix operator, or if it's a function
- declaration where ! is a strictness annotation.
+ TemplateHaskell splice where ! is used, or if it's a function declaration
+ where ! is bound.
There are also places in the grammar where we do not know whether we are
parsing an expression or a command:
@@ -2274,9 +2113,9 @@ or an extra pass over the entire AST, is to parse into an overloaded
parser-validator (a so-called tagless final encoding):
class DisambECP b where ...
- instance p ~ GhcPs => DisambECP (HsCmd p) where ...
- instance p ~ GhcPs => DisambECP (HsExp p) where ...
- instance p ~ GhcPs => DisambECP (PatBuilder p) where ...
+ instance DisambECP (HsCmd GhcPs) where ...
+ instance DisambECP (HsExp GhcPs) where ...
+ instance DisambECP (PatBuilder GhcPs) where ...
The 'DisambECP' class contains functions to build and validate 'b'. For example,
to add parentheses we have:
@@ -2310,6 +2149,12 @@ Compared to the initial definition, the added bits are:
The overhead is constant relative to the size of the rest of the reduction
rule, so this approach scales well to large parser productions.
+Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding
+position and shadows the previous $1. We can do this because internally
+'happy' desugars $n to happy_var_n, and the rationale behind this idiom
+is to be able to write (sLL $1 $>) later on. The alternative would be to
+write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer
+to the last fresh name as $>.
-}
@@ -2337,21 +2182,6 @@ There are several issues with this:
* HsExpr is arbitrarily selected as the extension basis. Why not extend
HsCmd or HsPat with extra constructors instead?
- * We cannot handle corner cases. For instance, the following function
- declaration LHS is not a valid expression (see #1087):
-
- !a + !b = ...
-
- * There are points in the pipeline where the representation was awfully
- incorrect. For instance,
-
- f !a b !c = ...
-
- is first parsed as
-
- (f ! a b) ! c = ...
-
-
Alternative II, extra constructors in GHC.Hs.Expr for GhcPs
-----------------------------------------------------------
We could address some of the problems with Alternative I by using Trees That
@@ -2598,7 +2428,7 @@ tagless final encoding, and there's no need for this complexity.
{- Note [PatBuilder]
~~~~~~~~~~~~~~~~~~~~
-Unlike HsExpr or HsCmd, the Pat type cannot accomodate all intermediate forms,
+Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,
so we introduce the notion of a PatBuilder.
Consider a pattern like this:
@@ -2625,14 +2455,6 @@ Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have
instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for
the intermediate forms.
-Worse yet, some intermediate forms are not valid patterns at all. For example:
-
- Con !a !b c
-
-This is parsed as ((Con ! a) ! (b c)) with ! as an infix operator, and then
-rearranged in 'splitBang'. But of course, neither (b c) nor (Con ! a) are valid
-patterns, so we cannot represent them as Pat.
-
We also need an intermediate representation to postpone disambiguation between
FunBind and PatBind. Consider:
@@ -2657,12 +2479,6 @@ parsing results for patterns and function bindings:
It can represent any pattern via 'PatBuilderPat', but it also has a variety of
other constructors which were added by following a simple principle: we never
pattern match on the pattern stored inside 'PatBuilderPat'.
-
-For example, in 'splitBang' we need to match on space-separated and
-bang-separated patterns, so these are represented with dedicated constructors
-'PatBuilderApp' and 'PatBuilderOpApp'. In 'isFunLhs', we pattern match on
-variables, so we have a dedicated 'PatBuilderVar' constructor for this despite
-the existence of 'VarPat'.
-}
---------------------------------------------------------------------------
@@ -2674,7 +2490,7 @@ checkPrecP
:: 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))
@@ -2688,9 +2504,9 @@ mkRecConstrOrUpdate
-> ([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))
@@ -2708,15 +2524,13 @@ mkRdrRecordCon con flds
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
@@ -2759,7 +2573,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
-- 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
@@ -2771,7 +2585,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
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
@@ -2846,11 +2660,11 @@ parseCImport cconv safety nm str sourceText =
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
@@ -2877,15 +2691,15 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName)
| 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
@@ -2896,7 +2710,7 @@ mkModuleImpExp (dL->L l specname) subs =
(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)")
@@ -2922,7 +2736,7 @@ mkModuleImpExp (dL->L l specname) subs =
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)
@@ -2933,8 +2747,8 @@ mkTypeImpExp name =
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
@@ -2946,7 +2760,7 @@ checkImportSpec ie@(dL->L _ specs) =
-- 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)
@@ -2979,7 +2793,7 @@ failOpNotEnabledImportQualifiedPost loc = addError loc msg
failOpImportQualifiedTwice :: SrcSpan -> P ()
failOpImportQualifiedTwice loc = addError loc msg
where
- msg = text "Multiple occurences of 'qualified'"
+ msg = text "Multiple occurrences of 'qualified'"
warnStarIsType :: SrcSpan -> P ()
warnStarIsType span = addWarning Opt_WarnStarIsType span msg
@@ -3002,7 +2816,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg
$$ 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 }
@@ -3014,18 +2828,6 @@ failOpDocPrev loc = addFatalError loc msg
where
msg = text "Unexpected documentation comment."
-failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a
-failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg
- where
- msg = text "Strictness annotation applied to a compound type." $$
- text "Did you mean to add parentheses?" $$
- nest 2 (ppr str <> parens (ppr ty))
-
-failOpStrictnessPosition :: Located SrcStrictness -> P a
-failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
- where
- msg = text "Strictness annotation cannot appear in this position."
-
-----------------------------------------------------------------------------
-- Misc utils
@@ -3191,11 +2993,11 @@ no effect on the error messages.
-}
-- | Hint about bang patterns, assuming @BangPatterns@ is off.
-hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV ()
+hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
hintBangPat span e = do
bang_on <- getBit BangPatBit
unless bang_on $
- addFatalError span
+ addError span
(text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
data SumOrTuple b
@@ -3221,14 +3023,14 @@ mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExp
-- 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))
@@ -3238,17 +3040,17 @@ mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Loc
-- 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))
@@ -3256,12 +3058,12 @@ mkSumOrTuplePat l Boxed a@Sum{} =
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)
View Lorry Controller Status