diff options
Diffstat (limited to 'compiler/hsSyn/Convert.hs')
-rw-r--r-- | compiler/hsSyn/Convert.hs | 107 |
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 } -------------------------------------------------------------------- |