summaryrefslogtreecommitdiff
path: root/compiler/parser/RdrHsSyn.hs
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2019-01-30 10:05:19 -0500
committerBen Gamari <ben@smart-cactus.org>2019-01-30 10:05:19 -0500
commit172a59335fa6c76b17fb6795e87fbc7fcfd198e6 (patch)
tree6e5e940cb2c6ae9110807fa0d637a280c63b4220 /compiler/parser/RdrHsSyn.hs
parent76c8fd674435a652c75a96c85abbf26f1f221876 (diff)
downloadhaskell-172a59335fa6c76b17fb6795e87fbc7fcfd198e6.tar.gz
Revert "Batch merge"
This reverts commit 76c8fd674435a652c75a96c85abbf26f1f221876.
Diffstat (limited to 'compiler/parser/RdrHsSyn.hs')
-rw-r--r--compiler/parser/RdrHsSyn.hs41
1 files changed, 19 insertions, 22 deletions
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 45fc5a0972..c1777759da 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -151,11 +151,10 @@ mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
= do { (binds, sigs, ats, at_insts, _, 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) <- checkTyVarsP (text "class") whereDots cls tparams
- ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
- ; (at_defs, annsi) <- mapAndUnzipM (eitherToP . mkATDefault) at_insts
- ; sequence_ annsi
+ ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
+ ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
+ ; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts
+ ; sequence_ anns
; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
, tcdLName = cls, tcdTyVars = tyvars
, tcdFixity = fixity
@@ -187,7 +186,7 @@ mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
, feqn_pats = tvs
, feqn_fixity = fixity
, feqn_rhs = rhs })
- ; pure (f, addAnnsAt loc anns) }
+ ; pure (f, anns) }
mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
mkATDefault _ = panic "mkATDefault: Impossible Match"
@@ -204,9 +203,8 @@ mkTyData :: SrcSpan
mkTyData loc new_or_data cType (dL->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) <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
- ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
+ ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
+ ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (cL loc (DataDecl { tcdDExt = noExt,
tcdLName = tc, tcdTyVars = tyvars,
@@ -237,9 +235,8 @@ mkTySynonym :: SrcSpan
-> P (LTyClDecl GhcPs)
mkTySynonym loc lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
- ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
- ; (tyvars, anns) <- checkTyVarsP (text "type") equalsDots tc tparams
- ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
+ ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
+ ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
; return (cL loc (SynDecl { tcdSExt = noExt
, tcdLName = tc, tcdTyVars = tyvars
, tcdFixity = fixity
@@ -296,9 +293,8 @@ mkFamDecl :: SrcSpan
-> P (LTyClDecl GhcPs)
mkFamDecl loc info lhs ksig injAnn
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
- ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
- ; (tyvars, anns) <- checkTyVarsP (ppr info) equals_or_where tc tparams
- ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
+ ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
+ ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
; return (cL loc (FamDecl noExt (FamilyDecl
{ fdExt = noExt
, fdInfo = info, fdLName = tc
@@ -808,11 +804,13 @@ really doesn't matter!
-}
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
- -> P (LHsQTyVars GhcPs, [AddAnn])
+ -> P (LHsQTyVars GhcPs)
-- Same as checkTyVars, but in the P monad
checkTyVarsP pp_what equals_or_where tc tparms
= do { let checkedTvs = checkTyVars pp_what equals_or_where tc tparms
- ; eitherToP checkedTvs }
+ ; (tvs, anns) <- eitherToP checkedTvs
+ ; anns
+ ; pure tvs }
eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
@@ -822,14 +820,14 @@ eitherToP (Right thing) = return thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc)
( LHsQTyVars GhcPs -- the synthesized type variables
- , [AddAnn] ) -- action which adds annotations
+ , P () ) -- action which adds annotations
-- ^ Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
-- We use the Either monad because it's also called (via 'mkATDefault') from
-- "Convert".
checkTyVars pp_what equals_or_where tc tparms
= do { (tvs, anns) <- fmap unzip $ mapM check tparms
- ; return (mkHsQTvs tvs, concat anns) }
+ ; return (mkHsQTvs tvs, sequence_ anns) }
where
check (HsTypeArg ki@(L loc _)) = Left (loc,
vcat [ text "Unexpected type application" <+>
@@ -841,15 +839,14 @@ checkTyVars pp_what equals_or_where tc tparms
<+> text "declaration for" <+> quotes (ppr tc)])
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddAnn] -> LHsType GhcPs
- -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
+ -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ())
chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l
++ acc) ty
chkParens acc ty = case chk ty of
Left err -> Left err
- Right tv -> Right (tv, reverse acc)
+ Right tv@(dL->L l _) -> Right (tv, addAnnsAt l (reverse acc))
-- Check that the name space is correct!
- chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k))
| isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k))
chk (dL->L l (HsTyVar _ _ (dL->L ltv tv)))