[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Improve documentation for ($) (#22963)

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Fri Apr 7 23:29:27 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
cbbfb283 by Alex Dixon at 2023-04-07T18:27:45-04:00
Improve documentation for ($) (#22963)

- - - - -
5193c2b0 by Alex Dixon at 2023-04-07T18:27:45-04:00
Remove trailing whitespace from ($) commentary

- - - - -
b384523b by Sebastian Graf at 2023-04-07T18:27:45-04:00
Adjust wording wrt representation polymorphism of ($)
- - - - -
551b74c7 by Torsten Schmits at 2023-04-07T19:29:13-04:00
Add structured error messages for GHC.Tc.TyCl.Utils

Tracking ticket: #20117

MR: !10251

This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.

- - - - -
6ff849e2 by sheaf at 2023-04-07T19:29:18-04:00
Renamer: don't call addUsedGRE on an exact Name

When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc,
we could end up calling addUsedGRE on an exact Name, which would then
lead to a panic in the bestImport function: it would be incapable of
processing a GRE which is not local but also not brought into scope
by any imports (as it is referred to by its unique instead).

Fixes #23240

- - - - -


14 changed files:

- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Name/Reader.hs
- libraries/base/GHC/Base.hs
- testsuite/tests/backpack/should_fail/bkpfail29.stderr
- testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr
- testsuite/tests/module/mod27.stderr
- + testsuite/tests/rename/should_compile/T23240.hs
- + testsuite/tests/rename/should_compile/T23240_aux.hs
- testsuite/tests/rename/should_compile/all.T


Changes:

=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -534,30 +534,29 @@ lookupRecFieldOcc mb_con rdr_name
   = return $ mk_unbound_rec_fld con
   | Just con <- mb_con
   = do { let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name)
-       ; res <- lookupExactOrOrig rdr_name ensure_recfld $  -- See Note [Record field names and Template Haskell]
+       ; mb_nm <- lookupExactOrOrig rdr_name ensure_recfld $  -- See Note [Record field names and Template Haskell]
             do { flds <- lookupConstructorFields con
                ; env <- getGlobalRdrEnv
-               ; let lbl    = FieldLabelString $ occNameFS (rdrNameOcc rdr_name)
-                     mb_gre = do fl <- find ((== lbl) . flLabel) flds
+               ; let mb_gre = do fl <- find ((== lbl) . flLabel) flds
                                  -- We have the label, now check it is in scope.  If
                                  -- there is a qualifier, use pickGREs to check that
                                  -- the qualifier is correct, and return the filtered
                                  -- GRE so we get import usage right (see #17853).
                                  gre <- lookupGRE_FieldLabel env fl
                                  if isQual rdr_name
-                                 then listToMaybe (pickGREs rdr_name [gre])
+                                 then listToMaybe $ pickGREs rdr_name [gre]
                                  else return gre
                ; traceRn "lookupRecFieldOcc" $
                    vcat [ text "mb_con:" <+> ppr mb_con
                         , text "rdr_name:" <+> ppr rdr_name
                         , text "flds:" <+> ppr flds
                         , text "mb_gre:" <+> ppr mb_gre ]
-               ; return mb_gre }
-        ; case res of
+               ; mapM_ (addUsedGRE True) mb_gre
+               ; return $ flSelector . fieldGRELabel <$> mb_gre }
+       ; case mb_nm of
           { Nothing  -> do { addErr (badFieldConErr con lbl)
                            ; return $ mk_unbound_rec_fld con }
-          ; Just gre -> do { addUsedGRE True gre
-                           ; return (flSelector $ fieldGRELabel gre) } } }
+          ; Just nm -> return nm } }
 
   | otherwise  -- Can't use the data constructor to disambiguate
   = greName <$> lookupGlobalOccRn' (IncludeFields WantField) rdr_name
@@ -572,7 +571,9 @@ lookupRecFieldOcc mb_con rdr_name
       mkRecFieldOccFS (getOccFS con) (occNameFS occ)
     occ = rdrNameOcc rdr_name
 
-    ensure_recfld gre = do { guard (isRecFldGRE gre) ; return gre }
+    ensure_recfld :: GlobalRdrElt -> Maybe Name
+    ensure_recfld gre = do { guard (isRecFldGRE gre)
+                           ; return $ greName gre }
 
 {- Note [DisambiguateRecordFields]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -1855,7 +1855,10 @@ mkImportMap gres
        RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map
        UnhelpfulLoc _ -> imp_map
        where
-          best_imp_spec = bestImport (bagToList imp_specs)
+          best_imp_spec =
+            case bagToList imp_specs of
+              []     -> pprPanic "mkImportMap: GRE with no ImportSpecs" (ppr gre)
+              is:iss -> bestImport (is NE.:| iss)
           add _ gres = gre : gres
 
 warnUnusedImport :: WarningFlag -> GlobalRdrEnv


=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1716,6 +1716,18 @@ instance Diagnostic TcRnMessage where
       -> mkSimpleDecorated $
            text "Illegal" <+> (text $ levelString typeOrKind) <> colon <+> quotes (ppr thing)
 
+    TcRnTypeSynonymCycle decl_or_tcs
+      -> mkSimpleDecorated $
+           sep [ text "Cycle in type synonym declarations:"
+               , nest 2 (vcat (map ppr_decl decl_or_tcs)) ]
+      where
+        ppr_decl = \case
+          Right (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl
+          Left tc ->
+            let n = tyConName tc
+            in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc)
+                   <+> text "from external module"
+
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -2286,6 +2298,8 @@ instance Diagnostic TcRnMessage where
       -> WarningWithFlag Opt_WarnUnusedForalls
     TcRnDataKindsError{}
       -> ErrorWithoutFlag
+    TcRnTypeSynonymCycle{}
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -2883,6 +2897,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnDataKindsError{}
       -> [suggestExtension LangExt.DataKinds]
+    TcRnTypeSynonymCycle{}
+      -> noHints
 
   diagnosticCode = constructorCode
 


=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -108,6 +108,7 @@ module GHC.Tc.Errors.Types (
   , TyFamsDisabledReason(..)
   , HsTypeOrSigType(..)
   , HsTyVarBndrExistentialFlag(..)
+  , TySynCycleTyCons
   ) where
 
 import GHC.Prelude
@@ -3787,6 +3788,15 @@ data TcRnMessage where
     -> HsExpr GhcPs -- ^ Section
     -> TcRnMessage
 
+  {-| TcRnTypeSynonymCycle is an error indicating that a cycle between type
+    synonyms has occurred.
+
+    Test cases:
+      mod27, ghc-e-fail2, bkpfail29
+  -}
+  TcRnTypeSynonymCycle :: !TySynCycleTyCons -- ^ The tycons involved in the cycle
+                       -> TcRnMessage
+
   deriving Generic
 
 -- | Things forbidden in @type data@ declarations.
@@ -5192,3 +5202,6 @@ data HsTyVarBndrExistentialFlag = forall flag. OutputableBndrFlag flag 'Renamed
 
 instance Outputable HsTyVarBndrExistentialFlag where
   ppr (HsTyVarBndrExistentialFlag hsTyVarBndr) = ppr hsTyVarBndr
+
+type TySynCycleTyCons =
+  [Either TyCon (LTyClDecl GhcRn)]


=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -65,7 +65,6 @@ import GHC.Data.FastString
 import GHC.Unit.Module
 
 import GHC.Types.Basic
-import GHC.Types.Error
 import GHC.Types.FieldLabel
 import GHC.Types.SrcLoc
 import GHC.Types.SourceFile
@@ -168,7 +167,7 @@ synonymTyConsOfType ty
 -- track of the TyCons which are known to be acyclic, or
 -- a failure message reporting that a cycle was found.
 newtype SynCycleM a = SynCycleM {
-    runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
+    runSynCycleM :: SynCycleState -> Either (SrcSpan, TySynCycleTyCons) (a, SynCycleState) }
     deriving (Functor)
 
 -- TODO: TyConSet is implemented as IntMap over uniques.
@@ -188,8 +187,8 @@ instance Monad SynCycleM where
                 runSynCycleM (f x) state'
             Left err -> Left err
 
-failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
-failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)
+failSynCycleM :: SrcSpan -> TySynCycleTyCons -> SynCycleM ()
+failSynCycleM loc seen_tcs = SynCycleM $ \_ -> Left (loc, seen_tcs)
 
 -- | Test if a 'Name' is acyclic, short-circuiting if we've
 -- seen it already.
@@ -209,7 +208,7 @@ checkTyConIsAcyclic tc m = SynCycleM $ \s ->
 checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
 checkSynCycles this_uid tcs tyclds =
     case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of
-        Left (loc, err) -> setSrcSpan loc $ failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err)
+        Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnTypeSynonymCycle err)
         Right _  -> return ()
   where
     -- Try our best to print the LTyClDecl for locally defined things
@@ -226,9 +225,7 @@ checkSynCycles this_uid tcs tyclds =
     go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
     go' so_far seen_tcs tc
         | tc `elemTyConSet` so_far
-            = failSynCycleM (getSrcSpan (head seen_tcs)) $
-                  sep [ text "Cycle in type synonym declarations:"
-                      , nest 2 (vcat (map ppr_decl seen_tcs)) ]
+            = failSynCycleM (getSrcSpan (head seen_tcs)) (lookup_decl <$> seen_tcs)
         -- Optimization: we don't allow cycles through external packages,
         -- so once we find a non-local name we are guaranteed to not
         -- have a cycle.
@@ -245,13 +242,10 @@ checkSynCycles this_uid tcs tyclds =
       where
         n = tyConName tc
         mod = nameModule n
-        ppr_decl tc =
-          case lookupNameEnv lcl_decls n of
-            Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl
-            Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n
-                       <+> text "from external module"
-         where
-          n = tyConName tc
+        lookup_decl tc =
+          case lookupNameEnv lcl_decls (tyConName tc) of
+            Just decl -> Right decl
+            Nothing -> Left tc
 
     go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM ()
     go_ty so_far seen_tcs ty =


=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -578,6 +578,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnRoleAnnotationsDisabled"                   = 17779
   GhcDiagnosticCode "TcRnIncoherentRoles"                           = 18273
   GhcDiagnosticCode "TcRnTyFamNameMismatch"                         = 88221
+  GhcDiagnosticCode "TcRnTypeSynonymCycle"                          = 97522
 
   -- TcRnBadFieldAnnotation/BadFieldAnnotationReason
   GhcDiagnosticCode "LazyFieldsDisabled"                            = 81601


=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -126,7 +126,6 @@ import GHC.Utils.Panic
 import Control.DeepSeq
 import Control.Monad ( guard )
 import Data.Data
-import Data.List ( sortBy )
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import qualified Data.Semigroup as S
@@ -1654,12 +1653,9 @@ data ImpItemSpec
         -- only @T@ is named explicitly.
   deriving (Eq, Data)
 
-bestImport :: [ImportSpec] -> ImportSpec
+bestImport :: NE.NonEmpty ImportSpec -> ImportSpec
 -- See Note [Choosing the best import declaration]
-bestImport iss
-  = case sortBy best iss of
-      (is:_) -> is
-      []     -> pprPanic "bestImport" (ppr iss)
+bestImport iss = NE.head $ NE.sortBy best iss
   where
     best :: ImportSpec -> ImportSpec -> Ordering
     -- Less means better


=====================================
libraries/base/GHC/Base.hs
=====================================
@@ -1606,18 +1606,69 @@ flip f x y              =  f y x
 -- (\x -> undefined x) `seq` () and thus would just evaluate to (), but now
 -- it is equivalent to undefined `seq` () which diverges.
 
--- | Application operator.  This operator is redundant, since ordinary
--- application @(f x)@ means the same as @(f '$' x)@. However, '$' has
--- low, right-associative binding precedence, so it sometimes allows
--- parentheses to be omitted; for example:
---
--- > f $ g $ h x  =  f (g (h x))
---
--- It is also useful in higher-order situations, such as @'map' ('$' 0) xs@,
--- or @'Data.List.zipWith' ('$') fs xs at .
---
--- Note that @('$')@ is representation-polymorphic, so that
--- @foo '$' 4#@ where @foo :: Int# -> Int#@ is well-typed.
+{- | @($)@ is the __function application__ operator.
+
+Applying @($)@ to a function @f@ and an argument @x@ gives the same result as applying @f@ to @x@ directly. The definition is akin to this:
+
+@
+($) :: (a -> b) -> a -> b
+($) f x = f x
+@
+
+On the face of it, this may appear pointless! But it's actually one of the most useful and important operators in Haskell.
+
+The order of operations is very different between @($)@ and normal function application. Normal function application has precedence 10 - higher than any operator - and associates to the left. So these two definitions are equivalent:
+
+@
+expr = min 5 1 + 5
+expr = ((min 5) 1) + 5
+@
+
+@($)@ has precedence 0 (the lowest) and associates to the right, so these are equivalent:
+
+@
+expr = min 5 $ 1 + 5
+expr = (min 5) (1 + 5)
+@
+
+=== Uses
+
+A common use cases of @($)@ is to avoid parentheses in complex expressions.
+
+For example, instead of using nested parentheses in the following
+ Haskell function:
+
+@
+-- | Sum numbers in a string: strSum "100  5 -7" == 98
+strSum :: 'String' -> 'Int'
+strSum s = 'sum' ('Data.Maybe.mapMaybe' 'Text.Read.readMaybe' ('words' s))
+@
+
+we can deploy the function application operator:
+
+@
+-- | Sum numbers in a string: strSum "100  5 -7" == 98
+strSum :: 'String' -> 'Int'
+strSum s = 'sum' '$' 'Data.Maybe.mapMaybe' 'Text.Read.readMaybe' '$' 'words' s
+@
+
+@($)@ is also used as a section (a partially applied operator), in order to indicate that we wish to apply some yet-unspecified function to a given value. For example, to apply the argument @5@ to a list of functions:
+
+@
+applyFive :: [Int]
+applyFive = map ($ 5) [(+1), (2^)]
+>>> [6, 32]
+@
+
+=== Technical Remark (Representation Polymorphism)
+
+@($)@ is fully representation-polymorphic. This allows it to also be used with arguments of unlifted and even unboxed kinds, such as unboxed integers:
+
+@
+fastMod :: Int -> Int -> Int
+fastMod (I# x) (I# m) = I# $ remInt# x m
+@
+-}
 {-# INLINE ($) #-}
 ($) :: forall repa repb (a :: TYPE repa) (b :: TYPE repb). (a -> b) -> a -> b
 ($) f = f


=====================================
testsuite/tests/backpack/should_fail/bkpfail29.stderr
=====================================
@@ -5,7 +5,7 @@
 [3 of 3] Processing r
   [1 of 4] Compiling A[sig]           ( r/A.hsig, nothing )
 
-bkpfail29.bkp:8:9: error:
+bkpfail29.bkp:8:9: error: [GHC-97522]
     • Cycle in type synonym declarations:
         bkpfail29.bkp:8:9-18: S from external module
         bkpfail29.bkp:7:9-14: T from external module


=====================================
testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr
=====================================
@@ -1,5 +1,5 @@
 
-<interactive>:0:1: error:
+<interactive>:0:1: error: [GHC-97522]
     Cycle in type synonym declarations:
       <interactive>:0:1-10: type A = A
 1


=====================================
testsuite/tests/module/mod27.stderr
=====================================
@@ -1,5 +1,5 @@
 
-mod27.hs:3:1: error:
+mod27.hs:3:1: error: [GHC-97522]
     Cycle in type synonym declarations:
       mod27.hs:3:1-18: type T1 = (Int, T2)
       mod27.hs:4:1-18: type T2 = (Int, T1)


=====================================
testsuite/tests/rename/should_compile/T23240.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- Crucial to triggering the bug.
+{-# LANGUAGE DisambiguateRecordFields #-}
+
+-- Need to enable the unused imports warning to trigger the bug.
+{-# OPTIONS_GHC -Wunused-imports #-}
+
+module T23240 ( test ) where
+import T23240_aux ( D, mkD )
+
+test :: D
+test = $$mkD


=====================================
testsuite/tests/rename/should_compile/T23240_aux.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T23240_aux where
+
+import Language.Haskell.TH ( CodeQ )
+
+data D = MkD { myFld :: () }
+mkD :: CodeQ D
+mkD = [|| MkD { myFld = () } ||]


=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -209,3 +209,4 @@ test('ImportNullaryRecordWildcard', [extra_files(['NullaryRecordWildcard.hs', 'N
 test('GHCINullaryRecordWildcard', combined_output, ghci_script, ['GHCINullaryRecordWildcard.script'])
 test('GHCIImplicitImportNullaryRecordWildcard', combined_output, ghci_script, ['GHCIImplicitImportNullaryRecordWildcard.script'])
 test('T22122', [expect_broken(22122), extra_files(['T22122_aux.hs'])], multimod_compile, ['T22122', '-v0'])
+test('T23240', [req_th, extra_files(['T23240_aux.hs'])], multimod_compile, ['T23240', '-v0'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9fe52a1dbb53f07971f172a8502565109d2385e6...6ff849e25c4a5cf4d56611482014c9ddd46c4fa6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9fe52a1dbb53f07971f172a8502565109d2385e6...6ff849e25c4a5cf4d56611482014c9ddd46c4fa6
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/20230407/d0593c9c/attachment-0001.html>


More information about the ghc-commits mailing list