[Git][ghc/ghc][wip/strict-ttg] Fix test failures
Vladislav Zavialov
gitlab at gitlab.haskell.org
Wed Sep 30 19:16:55 UTC 2020
Vladislav Zavialov pushed to branch wip/strict-ttg at Glasgow Haskell Compiler / GHC
Commits:
60eff54f by Vladislav Zavialov at 2020-09-30T22:16:43+03:00
Fix test failures
- - - - -
15 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Utils/Misc.hs
- compiler/GHC/Utils/Outputable.hs
- testsuite/tests/parser/should_compile/T14189.stderr
- utils/haddock
Changes:
=====================================
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)
=====================================
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
=====================================
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
=====================================
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 ]
=====================================
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] }
=====================================
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)
]
=====================================
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
=====================================
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
=====================================
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
{-
************************************************************************
=====================================
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
=====================================
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))
=====================================
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)
=====================================
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])
=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -78,7 +78,8 @@
(NoExtField)
[({ T14189.hs:6:33 }
(FieldOcc
- {Name: T14189.f}
+ (Box
+ {Name: T14189.f})
({ T14189.hs:6:33 }
(Unqual
{OccName: f}))))]
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit a18c3af7f983f3b6d3cd84093c9079031da58468
+Subproject commit 7ec18458ab0d289fc5936bb632c2065a7c01db90
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60eff54f397d3b5b29ea4ef50b47d6da6d18c395
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60eff54f397d3b5b29ea4ef50b47d6da6d18c395
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200930/fcd1070d/attachment-0001.html>
More information about the ghc-commits
mailing list