summaryrefslogtreecommitdiff
path: root/compiler/hsSyn/Convert.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/hsSyn/Convert.hs')
-rw-r--r--compiler/hsSyn/Convert.hs107
1 files changed, 57 insertions, 50 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index c64cb7c662..3b86320aba 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -9,6 +9,7 @@ This module converts Template Haskell syntax into HsSyn
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType,
@@ -108,14 +109,15 @@ getL = CvtM (\loc -> Right (loc,loc))
setL :: SrcSpan -> CvtM ()
setL loc = CvtM (\_ -> Right (loc, ()))
-returnL :: a -> CvtM (Located a)
-returnL x = CvtM (\loc -> Right (loc, L loc x))
+returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
+returnL x = CvtM (\loc -> Right (loc, cL loc x))
-returnJustL :: a -> CvtM (Maybe (Located a))
+returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL = fmap Just . returnL
-wrapParL :: (Located a -> a) -> a -> CvtM a
-wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))
+wrapParL :: HasSrcSpan a =>
+ (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a)
+wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))
wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
-- E.g wrapMsg "declaration" dec thing
@@ -131,10 +133,10 @@ wrapMsg what item (CvtM m)
then text (show item)
else text (pprint item))
-wrapL :: CvtM a -> CvtM (Located a)
+wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (CvtM m) = CvtM (\loc -> case m loc of
Left err -> Left err
- Right (loc',v) -> Right (loc',L loc v))
+ Right (loc',v) -> Right (loc',cL loc v))
-------------------------------------------------------------------
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
@@ -266,14 +268,14 @@ cvtDec (InstanceD o ctxt ty decs)
; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
; ctxt' <- cvtContext ctxt
- ; L loc ty' <- cvtType ty
- ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
+ ; (dL->(loc , ty')) <- cvtType ty
+ ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'
; returnJustL $ InstD noExt $ ClsInstD noExt $
ClsInstDecl { cid_ext = noExt, 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 (L loc . overlap) o } }
+ , cid_overlap_mode = fmap (cL loc . overlap) o } }
where
overlap pragma =
case pragma of
@@ -334,7 +336,7 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc
- ; L _ eqn' <- cvtTySynEqn tc' eqn
+ ; (dL->(_ , eqn')) <- cvtTySynEqn tc' eqn
; returnJustL $ InstD noExt $ TyFamInstD
{ tfid_ext = noExt
, tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
@@ -360,8 +362,8 @@ cvtDec (TH.RoleAnnotD tc roles)
cvtDec (TH.StandaloneDerivD ds cxt ty)
= do { cxt' <- cvtContext cxt
; ds' <- traverse cvtDerivStrategy ds
- ; L loc ty' <- cvtType ty
- ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
+ ; (dL->(loc , ty')) <- cvtType ty
+ ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
; returnJustL $ DerivD noExt $
DerivDecl { deriv_ext =noExt
, deriv_strategy = ds'
@@ -473,28 +475,28 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
-------------------------------------------------------------------
is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
-is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d)
+is_fam_decl (dL->(loc , TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)
is_fam_decl decl = Right decl
is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
- = Left (L loc d)
+is_tyfam_inst (dL->(loc , Hs.InstD _ (TyFamInstD { tfid_inst = d })))
+ = Left (cL loc d)
is_tyfam_inst decl
= Right decl
is_datafam_inst :: LHsDecl GhcPs
-> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_datafam_inst (L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d })))
- = Left (L loc d)
+is_datafam_inst (dL->(loc , Hs.InstD _ (DataFamInstD { dfid_inst = d })))
+ = Left (cL loc d)
is_datafam_inst decl
= Right decl
is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
-is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
+is_sig (dL->(loc , Hs.SigD _ sig)) = Left (cL loc sig)
is_sig decl = Right decl
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
-is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
+is_bind (dL->(loc , Hs.ValD _ bind)) = Left (cL loc bind)
is_bind decl = Right decl
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
@@ -528,11 +530,13 @@ cvtConstr (InfixC st1 c st2)
cvtConstr (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
; ctxt' <- cvtContext ctxt
- ; L _ con' <- cvtConstr con
+ ; (dL->(_ , con')) <- cvtConstr con
; returnL $ add_forall tvs' ctxt' con' }
where
- add_cxt lcxt Nothing = Just lcxt
- add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))
+ add_cxt lcxt Nothing
+ = Just lcxt
+ add_cxt (dL->(loc , cxt1)) (Just (dL->(_ , cxt2)))
+ = Just (cL loc (cxt1 ++ cxt2))
add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
= con { con_forall = noLoc $ not (null all_tvs)
@@ -553,7 +557,7 @@ cvtConstr (ForallC tvs ctxt con)
cvtConstr (GadtC c strtys ty)
= do { c' <- mapM cNameL c
; args <- mapM cvt_arg strtys
- ; L _ ty' <- cvtType ty
+ ; (dL->(_ , ty')) <- cvtType ty
; c_ty <- mk_arr_apps args ty'
; returnL $ fst $ mkGadtDecl c' c_ty}
@@ -585,12 +589,12 @@ cvt_arg (Bang su ss, ty)
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg (i, str, ty)
- = do { L li i' <- vNameL i
+ = do { (dL->(li , i')) <- vNameL i
; ty' <- cvt_arg (str,ty)
; return $ noLoc (ConDeclField
{ cd_fld_ext = noExt
, cd_fld_names
- = [L li $ FieldOcc noExt (L li i')]
+ = [cL li $ FieldOcc noExt (cL li i')]
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
@@ -896,7 +900,7 @@ cvtl e = wrapL (cvt e)
cvt (UInfixE x s y) = do { x' <- cvtl x
; let x'' = case x' of
- L _ (OpApp {}) -> x'
+ (dL->(_ , OpApp {})) -> x'
_ -> mkLHsPar x'
; cvtOpApp x'' s y } -- Note [Converting UInfix]
@@ -1019,8 +1023,8 @@ cvtHsDo do_or_lc stmts
; let Just (stmts'', last') = snocView stmts'
; last'' <- case last' of
- L loc (BodyStmt _ body _ _)
- -> return (L loc (mkLastStmt body))
+ (dL->(loc ,BodyStmt _ body _ _))
+ -> return (cL loc (mkLastStmt body))
_ -> failWith (bad_last last')
; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
@@ -1048,8 +1052,9 @@ cvtMatch :: HsMatchContext RdrName
cvtMatch ctxt (TH.Match p body decs)
= do { p' <- cvtPat p
; let lp = case p' of
- L loc SigPat{} -> L loc (ParPat NoExt p') -- #14875
- _ -> p'
+ (dL->(loc , SigPat{})) ->
+ cL loc (ParPat NoExt p') -- #14875
+ _ -> p'
; g' <- cvtGuard body
; decs' <- cvtLocalDecs (text "a where clause") decs
; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }
@@ -1161,8 +1166,9 @@ cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
cvtp (ParensP p) = do { p' <- cvtPat p;
; case p' of -- may be wrapped ConPatIn
- (L _ (ParPat {})) -> return $ unLoc p'
- _ -> return $ ParPat noExt p' }
+ (dL->(_ , p''@ParPat {})) -> return $ p''
+ _ -> return $
+ ParPat noExt p' }
cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExt p' }
cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExt p' }
cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p
@@ -1181,9 +1187,9 @@ cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
- = do { L ls s' <- vNameL s; p' <- cvtPat p
+ = do { (dL->(ls , s')) <- vNameL s; p' <- cvtPat p
; return (noLoc $ HsRecField { hsRecFieldLbl
- = L ls $ mkFieldOcc (L ls s')
+ = cL ls $ mkFieldOcc (cL ls s')
, hsRecFieldArg = p'
, hsRecPun = False}) }
@@ -1281,13 +1287,13 @@ cvtTypeKind ty_str ty
tys'
ArrowT
| [x',y'] <- tys' -> do
- x'' <- case x' of
- L _ HsFunTy{} -> returnL (HsParTy noExt x')
- L _ HsForAllTy{} -> returnL (HsParTy noExt x')
+ x'' <- case unLoc x' of
+ HsFunTy{} -> returnL (HsParTy noExt x')
+ HsForAllTy{} -> returnL (HsParTy noExt x')
-- #14646
- L _ HsQualTy{} -> returnL (HsParTy noExt x')
+ HsQualTy{} -> returnL (HsParTy noExt x')
-- #15324
- _ -> return x'
+ _ -> return x'
returnL (HsFunTy noExt x'' y')
| otherwise ->
mk_apps (HsTyVar noExt NotPromoted
@@ -1365,7 +1371,7 @@ cvtTypeKind ty_str ty
PromotedConsT -- See Note [Representing concrete syntax in types]
-- in Language.Haskell.TH.Syntax
- | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
+ | [ty1, (dL->(_ , HsExplicitListTy _ ip tys2))] <- tys'
-> returnL (HsExplicitListTy noExt ip (ty1:tys2))
| otherwise
-> mk_apps (HsTyVar noExt Promoted
@@ -1399,13 +1405,13 @@ mk_apps head_ty (ty:tys) =
; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
where
-- See Note [Adding parens for splices]
- add_parens lt@(L _ t)
+ add_parens lt@(dL->(_ , t))
| hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
| otherwise = return lt
wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs)
-wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
-wrap_apps t = return t
+wrap_apps t@(dL->(_ , HsAppTy {})) = returnL (HsParTy noExt t)
+wrap_apps t = return t
-- ---------------------------------------------------------------------
-- Note [Adding parens for splices]
@@ -1499,7 +1505,7 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
| null exis, null provs = cvtType (ForallT univs reqs ty)
| null univs, null reqs = do { l <- getL
; ty' <- cvtType (ForallT exis provs ty)
- ; return $ L l (HsQualTy { hst_ctxt = L l []
+ ; return $ cL l (HsQualTy { hst_ctxt = cL l []
, hst_xqual = noExt
, hst_body = ty' }) }
| null reqs = do { l <- getL
@@ -1507,11 +1513,12 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
; ty' <- cvtType (ForallT exis provs ty)
; let forTy = HsForAllTy { hst_bndrs = univs'
, hst_xforall = noExt
- , hst_body = L l cxtTy }
- cxtTy = HsQualTy { hst_ctxt = L l []
+ , hst_body =
+ cL l cxtTy }
+ cxtTy = HsQualTy { hst_ctxt = cL l []
, hst_xqual = noExt
, hst_body = ty' }
- ; return $ L l forTy }
+ ; return $ cL l forTy }
| otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
cvtPatSynSigTy ty = cvtType ty
@@ -1567,7 +1574,7 @@ mkHsForAllTy :: [TH.TyVarBndr]
-- ^ The complete type, quantified with a forall if necessary
mkHsForAllTy tvs loc tvs' rho_ty
| null tvs = rho_ty
- | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
+ | otherwise = cL loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
, hst_xforall = noExt
, hst_body = rho_ty }
@@ -1591,7 +1598,7 @@ mkHsQualTy :: TH.Cxt
-- ^ The complete type, qualified with a context if necessary
mkHsQualTy ctxt loc ctxt' ty
| null ctxt = ty
- | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+ | otherwise = cL loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
, hst_body = ty }
--------------------------------------------------------------------