diff options
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Hs/Expr.hs | 25 | ||||
-rw-r--r-- | compiler/GHC/Hs/Type.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Hs/Utils.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Docs.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Iface/Ext/Ast.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Rename/HsType.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Rename/Pat.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Pat.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl/Utils.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Utils/Misc.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 4 |
13 files changed, 50 insertions, 29 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 1ebacb8314..87c69f8a8e 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -2402,9 +2402,9 @@ pprStmt (LastStmt _ expr m_dollar_stripped _) Just False -> text "return" Nothing -> empty) <+> ppr expr -pprStmt (BindStmt _ pat expr) = hsep [ppr pat, larrow, ppr expr] +pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] -pprStmt (BodyStmt _ expr _ _) = ppr expr +pprStmt (BodyStmt _ expr _ _) = pprBodyStmt expr pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) pprStmt (TransStmt { trS_stmts = stmts, trS_by = by @@ -2439,10 +2439,9 @@ pprStmt (ApplicativeStmt _ args mb_join) flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] flattenArg (_, ApplicativeArgOne _ pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] - [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL))] + [pprBodyStmt expr] | otherwise = - [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))] + [pprBindStmt pat expr] flattenArg (_, ApplicativeArgMany _ stmts _ _ _) = concatMap flattenStmt stmts @@ -2456,6 +2455,11 @@ pprStmt (ApplicativeStmt _ args mb_join) pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc pp_arg (_, applicativeArg) = ppr applicativeArg +pprBodyStmt :: Outputable expr => expr -> SDoc +pprBodyStmt expr = ppr expr + +pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc +pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr] instance (OutputableBndrId idL) => Outputable (ApplicativeArg (GhcPass idL)) where @@ -2464,17 +2468,14 @@ instance (OutputableBndrId idL) pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc pprArg (ApplicativeArgOne _ pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] - ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL)) + pprBodyStmt expr | otherwise = - ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL)) + pprBindStmt pat expr pprArg (ApplicativeArgMany _ stmts return pat ctxt) = ppr pat <+> text "<-" <+> - ppr (HsDo (panic "pprStmt") ctxt (noLoc - (stmts ++ - [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])) - :: HsExpr (GhcPass idL)) + pprDo ctxt (stmts ++ + [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)]) pprTransformStmt :: (OutputableBndrId p) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 599aa566c1..49dcde1aaa 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -102,7 +102,7 @@ import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Data.FastString -import GHC.Utils.Misc ( count ) +import GHC.Utils.Misc ( count, Box ) import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Maybe @@ -1690,7 +1690,8 @@ data FieldOcc pass = FieldOcc { extFieldOcc :: !(XCFieldOcc pass) deriving instance Eq (XCFieldOcc (GhcPass p)) => Eq (FieldOcc (GhcPass p)) type instance XCFieldOcc GhcPs = NoExtField -type instance XCFieldOcc GhcRn = Name +type instance XCFieldOcc GhcRn = Box Name -- the Box is needed due to 'expectJust' in 'rnField' + -- TODO: refactor to remove it type instance XCFieldOcc GhcTc = Id type instance XXFieldOcc (GhcPass _) = NoExtCon diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 5adcc140e2..10930ffd54 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1135,7 +1135,7 @@ hsTyClForeignBinders tycl_decls foreign_decls foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) where getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name] - getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs + getSelectorNames (ns, fs) = map unLoc ns ++ map (unBox . extFieldOcc . unLoc) fs ------------------- hsLTyClDeclBinders :: IsPass p diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 2a82c986e3..e71876b74b 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -24,6 +24,7 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Tc.Types +import GHC.Utils.Misc (unBox) import Control.Applicative import Data.Bifunctor (first) @@ -188,7 +189,7 @@ subordinates instMap decl = case decl of , maybeToList $ fmap unLoc $ con_doc c , conArgDocs c) | c <- cons, cname <- getConNames c ] - fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) + fields = [ (unBox (extFieldOcc n), maybeToList $ fmap unLoc doc, M.empty) | RecCon flds <- map getConArgs cons , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) , (L _ n) <- ns ] diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 0ef8db0efe..cfe8449751 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1633,7 +1633,7 @@ repFields (HsRecFields { rec_flds = flds }) where rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.FieldExp)) - rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) + rep_fld (L _ fld) = do { fn <- lookupLOcc (mapLoc unBox (hsRecFieldSel fld)) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } @@ -1992,7 +1992,7 @@ repP (ConPat NoExtField dc details) } where rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat))) - rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) + rep_fld (L _ fld) = do { MkC v <- lookupLOcc (mapLoc unBox (hsRecFieldSel fld)) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } @@ -2626,7 +2626,7 @@ repConstr (RecCon ips) resTy cons rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType)) - rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) + rep_one_ip t n = do { MkC v <- lookupOcc (unBox (extFieldOcc (unLoc n))) ; MkC ty <- repBangTy t ; rep2 varBangTypeName [v,ty] } diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 68bbc103b5..3a6365615f 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -21,6 +21,7 @@ Main functions for .hie file generation module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where +import GHC.Utils.Misc (Box(Box)) import GHC.Utils.Outputable(ppr) import GHC.Prelude @@ -1278,7 +1279,7 @@ instance ( ToHie (RFContext (Located label)) instance ToHie (RFContext (Located (FieldOcc GhcRn))) where toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc name _ -> + FieldOcc (Box name) _ -> [ toHie $ C (RecField c rhs) (L nspan name) ] diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 79f2bee61f..7fa434c76a 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -1174,7 +1174,7 @@ rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn lookupField (FieldOcc _ (L lr rdr)) = - FieldOcc (flSelector fl) (L lr rdr) + FieldOcc (Box (flSelector fl)) (L lr rdr) where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 72058a2512..8e17eed6af 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -654,7 +654,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) else return arg ; return (L l (HsRecField { hsRecFieldLbl = (L loc (FieldOcc - sel (L ll lbl))) + (Box sel) (L ll lbl))) , hsRecFieldArg = arg' , hsRecPun = pun })) } @@ -697,7 +697,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; addUsedGREs dot_dot_gres ; return [ L loc (HsRecField - { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) + { hsRecFieldLbl = L loc (FieldOcc (Box sel) (L loc arg_rdr)) , hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields @@ -792,7 +792,7 @@ rnHsRecUpdFields flds getFieldIds :: [LHsRecField GhcRn arg] -> [Name] -getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds +getFieldIds flds = map (unBox . unLoc . hsRecFieldSel . unLoc) flds getFieldLbls :: [LHsRecField id arg] -> [RdrName] getFieldLbls flds diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 3b4aa4ec20..f76ccc551c 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -1429,7 +1429,7 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds , hsRecFieldArg = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L loc lbl)) + f = L loc (FieldOcc (Box (idName sel_id)) (L loc lbl)) ; mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing @@ -1444,7 +1444,7 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs +tcRecordField con_like flds_w_tys (L loc (FieldOcc (Box sel_name) lbl)) rhs | Just field_ty <- assocMaybe flds_w_tys sel_name = addErrCtxt (fieldCtxt field_lbl) $ do { rhs' <- tcCheckPolyExprNC rhs field_ty @@ -1506,7 +1506,7 @@ checkMissingFields con_like rbinds field_strs = conLikeImplBangs con_like - fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds + fl `elemField` flds = any (\ fl' -> flSelector fl == unBox fl') flds {- ************************************************************************ diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 27b2b1358b..46e8f122be 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -1142,7 +1142,7 @@ tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTc (LPat GhcTc)) tc_field penv - (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) + (L l (HsRecField (L loc (FieldOcc (Box sel) (L lr rdr))) pat pun)) thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 0528976a6b..c5933a3ad2 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -904,7 +904,7 @@ mkOneRecordSelector all_cons idDetails fl rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField { hsRecFieldLbl - = L loc (FieldOcc sel_name + = L loc (FieldOcc (Box sel_name) (L loc $ mkVarUnqual lbl)) , hsRecFieldArg = L loc (VarPat noExtField (L loc field_var)) diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 7436487739..e6decc3b9d 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -130,6 +131,9 @@ module GHC.Utils.Misc ( -- * Utils for flags OverridingBool(..), overrideWith, + + -- * Box + Box(Box, unBox), ) where #include "HsVersions.h" @@ -1476,3 +1480,12 @@ overrideWith :: Bool -> OverridingBool -> Bool overrideWith b Auto = b overrideWith _ Always = True overrideWith _ Never = False + +-- A wrapper to make a strict field into a lazy one. +data Box a = Box { unBox :: a } + deriving (Eq, Ord, Data) + +instance Show a => Show (Box a) where + showsPrec n (Box a) = showsPrec n a + show (Box a) = show a + showList xs = showList (map unBox xs) diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 6dd5b88fbb..52595eaa3e 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -126,6 +126,7 @@ import qualified Data.List.NonEmpty as NEL import GHC.Fingerprint import GHC.Show ( showMultiLineString ) import GHC.Utils.Exception +import GHC.Utils.Misc (Box(Box)) import GHC.Exts (oneShot) {- @@ -859,6 +860,9 @@ instance (Outputable a) => Outputable (NonEmpty a) where instance (Outputable a) => Outputable (Set a) where ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) +instance Outputable a => Outputable (Box a) where + ppr (Box a) = ppr a + instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) |