Fix test failureswip/strict-ttg

15 files changed, 52 insertions, 30 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])
 
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
index f794049568..b75cd07114 100644
--- a/testsuite/tests/parser/should_compile/T14189.stderr
+++ b/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}))))]
diff --git a/utils/haddock b/utils/haddock
-Subproject a18c3af7f983f3b6d3cd84093c9079031da5846
+Subproject 7ec18458ab0d289fc5936bb632c2065a7c01db9