[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: TTG HsCmdArrForm: use Fixity via extension point
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Jul 30 16:44:28 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
d2648289 by romes at 2024-07-30T01:38:12-04:00
TTG HsCmdArrForm: use Fixity via extension point
Also migrate Fixity from GHC.Hs to Language.Haskell.Syntax
since it no longer uses any GHC-specific data types.
Fixed arrow desugaring bug. (This was dead code before.)
Remove mkOpFormRn, it is also dead code, only used in the arrow
desugaring now removed.
Co-authored-by: Fabian Kirchner <kirchner at posteo.de>
Co-authored-by: Alan Zimmerman <alan.zimm at gmail.com>
- - - - -
e258ad54 by Matthew Pickering at 2024-07-30T01:38:48-04:00
ghcup-metadata: More metadata fixes
* Incorrect version range on the alpine bindists
* Missing underscore in "unknown_versioning"
Fixes #25119
- - - - -
14ccb98d by Rodrigo Mesquita at 2024-07-30T12:44:09-04:00
Deriving-via one-shot strict state Monad instances
A small refactor to use deriving via GHC.Utils.Monad.State.Strict
Monad instances for state Monads with unboxed/strict results which all
re-implemented the one-shot trick in the instance and used unboxed
tuples:
* CmmOptM in GHC.Cmm.GenericOpt
* RegM in GHC.CmmToAsm.Reg.Linear.State
* UniqSM in GHC.Types.Unique.Supply
- - - - -
2404743c by Matthew Pickering at 2024-07-30T12:44:10-04:00
driver: Fix -Wmissing-home-modules when multiple units have the same module name
It was assumed that module names were unique but that isn't true with
multiple units.
The fix is quite simple, maintain a set of `(ModuleName, UnitId)` and
query that to see whether the module has been specified.
Fixes #25122
- - - - -
30 changed files:
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- compiler/GHC/Cmm/GenericOpt.hs
- compiler/GHC/CmmToAsm/Reg/Linear/State.hs
- compiler/GHC/Driver/Make.hs
- + compiler/GHC/Hs/Basic.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Fixity.hs
- compiler/GHC/Types/Fixity/Env.hs
- compiler/GHC/Types/Unique/Supply.hs
- compiler/GHC/Utils/Monad/State/Strict.hs
- compiler/Language/Haskell/Syntax/Basic.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/driver/multipleHomeUnits/T25122/T25122.hs
- testsuite/tests/driver/multipleHomeUnits/all.T
- + testsuite/tests/driver/multipleHomeUnits/unitSame1
- + testsuite/tests/driver/multipleHomeUnits/unitSame2
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
.gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
=====================================
@@ -234,7 +234,7 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map):
, "Linux_UnknownLinux" : { "unknown_versioning": rocky8 }
, "Darwin" : { "unknown_versioning" : darwin_x86 }
, "Windows" : { "unknown_versioning" : windows }
- , "Linux_Alpine" : { "( >= 3.12 && < 3.18 )": alpine3_12
+ , "Linux_Alpine" : { "( >= 3.12 && < 3.20 )": alpine3_12
, ">= 3.20": alpine3_20
, "unknown_versioning": alpine3_12 }
@@ -242,7 +242,7 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map):
a32 = { "Linux_Debian": { "( >= 10 && < 12 )": deb10_i386
, ">= 12": deb12_i386
- , "unknown versioning": deb10_i386 }
+ , "unknown_versioning": deb10_i386 }
, "Linux_Ubuntu": { "unknown_versioning": deb10_i386 }
, "Linux_Mint" : { "unknown_versioning": deb10_i386 }
, "Linux_UnknownLinux" : { "unknown_versioning": deb10_i386 }
=====================================
compiler/GHC/Cmm/GenericOpt.hs
=====================================
@@ -5,6 +5,7 @@
--
-- -----------------------------------------------------------------------------
+{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedTuples #-}
@@ -26,7 +27,8 @@ import GHC.Cmm.Opt ( cmmMachOpFold )
import GHC.Cmm.CLabel
import GHC.Data.FastString
import GHC.Unit
-import Control.Monad
+import Control.Monad.Trans.Reader
+import GHC.Utils.Monad.State.Strict as Strict
-- -----------------------------------------------------------------------------
-- Generic Cmm optimiser
@@ -67,19 +69,7 @@ pattern OptMResult x y = (# x, y #)
{-# COMPLETE OptMResult #-}
newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)
- deriving (Functor)
-
-instance Applicative CmmOptM where
- pure x = CmmOptM $ \_ imports -> OptMResult x imports
- (<*>) = ap
-
-instance Monad CmmOptM where
- (CmmOptM f) >>= g =
- CmmOptM $ \config imports0 ->
- case f config imports0 of
- OptMResult x imports1 ->
- case g x of
- CmmOptM g' -> g' config imports1
+ deriving (Functor, Applicative, Monad) via (ReaderT NCGConfig (Strict.State [CLabel]))
instance CmmMakeDynamicReferenceM CmmOptM where
addImport = addImportCmmOpt
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/State.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternSynonyms, DeriveFunctor #-}
+{-# LANGUAGE PatternSynonyms, DeriveFunctor, DerivingVia #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
@@ -52,31 +52,24 @@ import GHC.Types.Unique
import GHC.Types.Unique.Supply
import GHC.Exts (oneShot)
-import Control.Monad (ap)
+import GHC.Utils.Monad.State.Strict as Strict
-type RA_Result freeRegs a = (# RA_State freeRegs, a #)
+type RA_Result freeRegs a = (# a, RA_State freeRegs #)
-pattern RA_Result :: a -> b -> (# a, b #)
-pattern RA_Result a b = (# a, b #)
+pattern RA_Result :: a -> b -> (# b, a #)
+pattern RA_Result a b = (# b, a #)
{-# COMPLETE RA_Result #-}
-- | The register allocator monad type.
newtype RegM freeRegs a
= RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
- deriving (Functor)
+ deriving (Functor, Applicative, Monad) via (Strict.State (RA_State freeRegs))
-- | Smart constructor for 'RegM', as described in Note [The one-shot state
-- monad trick] in GHC.Utils.Monad.
mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
mkRegM f = RegM (oneShot f)
-instance Applicative (RegM freeRegs) where
- pure a = mkRegM $ \s -> RA_Result s a
- (<*>) = ap
-
-instance Monad (RegM freeRegs) where
- m >>= k = mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
-
-- | Get native code generator configuration
getConfig :: RegM a NCGConfig
getConfig = mkRegM $ \s -> RA_Result s (ra_config s)
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -329,10 +329,12 @@ warnMissingHomeModules dflags targets mod_graph =
-- Note also that we can't always infer the associated module name
-- directly from the filename argument. See #13727.
is_known_module mod =
- (Map.lookup (moduleName (ms_mod mod)) mod_targets == Just (ms_unitid mod))
+ is_module_target mod
||
maybe False is_file_target (ml_hs_file (ms_location mod))
+ is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets
+
is_file_target file = Set.member (withoutExt file) file_targets
file_targets = Set.fromList (mapMaybe file_target targets)
@@ -343,7 +345,7 @@ warnMissingHomeModules dflags targets mod_graph =
TargetFile file _ ->
Just (withoutExt (augmentByWorkingDirectory dflags file))
- mod_targets = Map.fromList (mod_target <$> targets)
+ mod_targets = Set.fromList (mod_target <$> targets)
mod_target Target {targetUnitId, targetId} =
case targetId of
=====================================
compiler/GHC/Hs/Basic.hs
=====================================
@@ -0,0 +1,56 @@
+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- | Fixity
+module GHC.Hs.Basic
+ ( module Language.Haskell.Syntax.Basic
+ ) where
+
+import GHC.Prelude
+
+import GHC.Utils.Outputable
+import GHC.Utils.Binary
+
+import Data.Data ()
+
+import Language.Haskell.Syntax.Basic
+
+instance Outputable LexicalFixity where
+ ppr Prefix = text "Prefix"
+ ppr Infix = text "Infix"
+
+instance Outputable FixityDirection where
+ ppr InfixL = text "infixl"
+ ppr InfixR = text "infixr"
+ ppr InfixN = text "infix"
+
+instance Outputable Fixity where
+ ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
+
+
+instance Binary Fixity where
+ put_ bh (Fixity aa ab) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (Fixity aa ab)
+
+------------------------
+
+instance Binary FixityDirection where
+ put_ bh InfixL =
+ putByte bh 0
+ put_ bh InfixR =
+ putByte bh 1
+ put_ bh InfixN =
+ putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return InfixL
+ 1 -> return InfixR
+ _ -> return InfixN
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -32,6 +32,7 @@ import Language.Haskell.Syntax.Expr
-- friends:
import GHC.Prelude
+import GHC.Hs.Basic() -- import instances
import GHC.Hs.Decls() -- import instances
import GHC.Hs.Pat
import GHC.Hs.Lit
@@ -1250,8 +1251,10 @@ type instance XCmdArrApp GhcRn = NoExtField
type instance XCmdArrApp GhcTc = Type
type instance XCmdArrForm GhcPs = AnnList
-type instance XCmdArrForm GhcRn = NoExtField
-type instance XCmdArrForm GhcTc = NoExtField
+-- | fixity (filled in by the renamer), for forms that were converted from
+-- OpApp's by the renamer
+type instance XCmdArrForm GhcRn = Maybe Fixity
+type instance XCmdArrForm GhcTc = Maybe Fixity
type instance XCmdApp (GhcPass _) = NoExtField
type instance XCmdLam (GhcPass _) = NoExtField
@@ -1412,7 +1415,7 @@ ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
= hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
-ppr_cmd (HsCmdArrForm _ (L _ op) ps_fix rn_fix args)
+ppr_cmd (HsCmdArrForm rn_fix (L _ op) ps_fix args)
| HsVar _ (L _ v) <- op
= ppr_cmd_infix v
| GhcTc <- ghcPass @p
@@ -1427,7 +1430,10 @@ ppr_cmd (HsCmdArrForm _ (L _ op) ps_fix rn_fix args)
ppr_cmd_infix :: OutputableBndr v => v -> SDoc
ppr_cmd_infix v
| [arg1, arg2] <- args
- , isJust rn_fix || ps_fix == Infix
+ , case ghcPass @p of
+ GhcPs -> ps_fix == Infix
+ GhcRn -> isJust rn_fix || ps_fix == Infix
+ GhcTc -> isJust rn_fix || ps_fix == Infix
= hang (pprCmdArg (unLoc arg1))
4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)])
| otherwise
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -570,6 +570,9 @@ deriving instance Eq (IE GhcTc)
deriving instance Data HsThingRn
deriving instance Data XXExprGhcRn
+
+-- ---------------------------------------------------------------------
+
deriving instance Data XXExprGhcTc
deriving instance Data XXPatGhcTc
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -634,7 +634,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdDo _ (L _ stmts)) env_ids = do
-- -----------------------------------
-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
-dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ args) env_ids = do
let env_ty = mkBigCoreVarTupTy env_ids
core_op <- dsLExpr op
(core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -882,11 +882,10 @@ addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) =
(addTickLHsExpr e2)
(return ty1)
(return lr)
-addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
- liftM4 (HsCmdArrForm x)
+addTickHsCmd (HsCmdArrForm x e f cmdtop) =
+ liftM3 (HsCmdArrForm x)
(addTickLHsExpr e)
(return f)
- (return fix)
(mapM (traverse (addTickHsCmdTop)) cmdtop)
addTickHsCmd (XCmd (HsWrap w cmd)) =
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1510,7 +1510,7 @@ instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where
[ toHie a
, toHie b
]
- HsCmdArrForm _ a _ _ cmdtops ->
+ HsCmdArrForm _ a _ cmdtops ->
[ toHie a
, toHie cmdtops
]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3081,7 +3081,7 @@ aexp2 :: { ECP }
| '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromCmd $
amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) $2 Prefix
- Nothing (reverse $3)) }
+ (reverse $3)) }
projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }
projection
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1765,7 +1765,7 @@ instance DisambECP (HsCmd GhcPs) where
mkHsOpAppPV l c1 op c2 = do
let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c
!cs <- getCommentsFor l
- return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm (AnnList Nothing Nothing Nothing [] []) (reLoc op) Infix Nothing [cmdArg c1, cmdArg c2]
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm (AnnList Nothing Nothing Nothing [] []) (reLoc op) Infix [cmdArg c1, cmdArg c2]
mkHsCasePV l c (L lm m) anns = do
!cs <- getCommentsFor l
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -905,21 +905,10 @@ rnCmd (HsCmdArrApp _ arrow arg ho rtl)
-- Local bindings, inside the enclosing proc, are not in scope
-- inside 'arrow'. In the higher-order case (-<<), they are.
--- infix form
-rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
- = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
- ; let L _ (HsVar _ (L _ op_name)) = op'
- ; (arg1',fv_arg1) <- rnCmdTop arg1
- ; (arg2',fv_arg2) <- rnCmdTop arg2
- -- Deal with fixity
- ; fixity <- lookupFixityRn op_name
- ; final_e <- mkOpFormRn arg1' op' fixity arg2'
- ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
-
-rnCmd (HsCmdArrForm _ op f fixity cmds)
+rnCmd (HsCmdArrForm _ op f cmds)
= do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
; (cmds',fvCmds) <- rnCmdArgs cmds
- ; return ( HsCmdArrForm noExtField op' f fixity cmds'
+ ; return ( HsCmdArrForm Nothing op' f cmds'
, fvOp `plusFV` fvCmds) }
rnCmd (HsCmdApp x fun arg)
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Rename.HsType (
-- Precence related stuff
NegationHandling(..),
- mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
+ mkOpAppRn, mkNegAppRn, mkConOpPatRn,
checkPrecMatch, checkSectionPrec,
-- Binding related stuff
@@ -1455,35 +1455,6 @@ not_op_app :: HsExpr id -> Bool
not_op_app (OpApp {}) = False
not_op_app _ = True
----------------------------
-mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged
- -> LHsExpr GhcRn -> Fixity -- Operator and fixity
- -> LHsCmdTop GhcRn -- Right operand (not an infix)
- -> RnM (HsCmd GhcRn)
-
--- (e1a `op1` e1b) `op2` e2
-mkOpFormRn e1@(L loc
- (HsCmdTop _
- (L _ (HsCmdArrForm x op1 f (Just fix1)
- [e1a,e1b]))))
- op2 fix2 e2
- | nofix_error
- = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
- return (HsCmdArrForm x op2 f (Just fix2) [e1, e2])
-
- | associate_right
- = do new_c <- mkOpFormRn e1a op2 fix2 e2
- return (HsCmdArrForm noExtField op1 f (Just fix1)
- [e1b, L loc (HsCmdTop [] (L (l2l loc) new_c))])
- -- TODO: locs are wrong
- where
- (nofix_error, associate_right) = compareFixity fix1 fix2
-
--- Default case
-mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangement
- = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2])
-
-
--------------------------------------
mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn
-> RnM (Pat GhcRn)
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -290,7 +290,7 @@ tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
-- ----------------------------------------------
-- D; G |-a (| e c1 ... cn |) : stk --> t
-tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsCmdArrForm fixity expr f cmd_args) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd)
do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
-- We use alphaTyVar for 'w'
@@ -298,7 +298,7 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
mkVisFunTysMany cmd_tys $
mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
; expr' <- tcCheckPolyExpr expr e_ty
- ; return (HsCmdArrForm x expr' f fixity cmd_args') }
+ ; return (HsCmdArrForm fixity expr' f cmd_args') }
where
tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1152,10 +1152,10 @@ zonkCmd (HsCmdArrApp ty e1 e2 ho rl)
new_ty <- zonkTcTypeToTypeX ty
return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
-zonkCmd (HsCmdArrForm x op f fixity args)
+zonkCmd (HsCmdArrForm x op fixity args)
= do new_op <- zonkLExpr op
new_args <- mapM zonkCmdTop args
- return (HsCmdArrForm x new_op f fixity new_args)
+ return (HsCmdArrForm x new_op fixity new_args)
zonkCmd (HsCmdApp x c e)
= do new_c <- zonkLCmd c
=====================================
compiler/GHC/Types/Fixity.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_GHC -Wno-dodgy-exports #-} -- For re-export of GHC.Hs.Basic instances
-- | Fixity
module GHC.Types.Fixity
@@ -11,61 +12,17 @@ module GHC.Types.Fixity
, negateFixity
, funTyFixity
, compareFixity
+ , module GHC.Hs.Basic
)
where
import GHC.Prelude
-import GHC.Utils.Outputable
-import GHC.Utils.Binary
-
-import Data.Data hiding (Fixity, Prefix, Infix)
-
-data Fixity = Fixity Int FixityDirection
- deriving Data
-
-instance Outputable Fixity where
- ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
-
-instance Eq Fixity where -- Used to determine if two fixities conflict
- (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
-
-instance Binary Fixity where
- put_ bh (Fixity aa ab) = do
- put_ bh aa
- put_ bh ab
- get bh = do
- aa <- get bh
- ab <- get bh
- return (Fixity aa ab)
+import Language.Haskell.Syntax.Basic (LexicalFixity(..), FixityDirection(..), Fixity(..) )
+import GHC.Hs.Basic () -- For instances only
------------------------
-data FixityDirection
- = InfixL
- | InfixR
- | InfixN
- deriving (Eq, Data)
-instance Outputable FixityDirection where
- ppr InfixL = text "infixl"
- ppr InfixR = text "infixr"
- ppr InfixN = text "infix"
-
-instance Binary FixityDirection where
- put_ bh InfixL =
- putByte bh 0
- put_ bh InfixR =
- putByte bh 1
- put_ bh InfixN =
- putByte bh 2
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return InfixL
- 1 -> return InfixR
- _ -> return InfixN
-
-------------------------
maxPrecedence, minPrecedence :: Int
maxPrecedence = 9
minPrecedence = 0
@@ -103,12 +60,3 @@ compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
right = (False, True)
left = (False, False)
error_please = (True, False)
-
--- |Captures the fixity of declarations as they are parsed. This is not
--- necessarily the same as the fixity declaration, as the normal fixity may be
--- overridden using parens or backticks.
-data LexicalFixity = Prefix | Infix deriving (Data,Eq)
-
-instance Outputable LexicalFixity where
- ppr Prefix = text "Prefix"
- ppr Infix = text "Infix"
=====================================
compiler/GHC/Types/Fixity/Env.hs
=====================================
@@ -43,4 +43,3 @@ mkIfaceFixCache pairs
emptyIfaceFixCache :: OccName -> Maybe Fixity
emptyIfaceFixCache _ = Nothing
-
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -4,6 +4,7 @@
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedTuples #-}
@@ -41,6 +42,7 @@ import Control.Monad
import Data.Word
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
import Foreign.Storable
+import GHC.Utils.Monad.State.Strict as Strict
#include "MachDeps.h"
@@ -304,6 +306,8 @@ uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n
uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)
+{-# INLINE splitUniqSupply #-}
+
{-
************************************************************************
* *
@@ -320,12 +324,7 @@ pattern UniqResult x y = (# x, y #)
-- | A monad which just gives the ability to obtain 'Unique's
newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
-
--- See Note [The one-shot state monad trick] for why we don't derive this.
-instance Functor UniqSM where
- fmap f (USM m) = mkUniqSM $ \us ->
- case m us of
- (# r, us' #) -> UniqResult (f r) us'
+ deriving (Functor, Applicative, Monad) via (Strict.State UniqSupply)
-- | Smart constructor for 'UniqSM', as described in Note [The one-shot state
-- monad trick].
@@ -333,17 +332,6 @@ mkUniqSM :: (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM f = USM (oneShot f)
{-# INLINE mkUniqSM #-}
-instance Monad UniqSM where
- (>>=) = thenUs
- (>>) = (*>)
-
-instance Applicative UniqSM where
- pure = returnUs
- (USM f) <*> (USM x) = mkUniqSM $ \us0 -> case f us0 of
- UniqResult ff us1 -> case x us1 of
- UniqResult xx us2 -> UniqResult (ff xx) us2
- (*>) = thenUs_
-
-- TODO: try to get rid of this instance
instance MonadFail UniqSM where
fail = panic
@@ -356,30 +344,12 @@ initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }
initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r }
-{-# INLINE thenUs #-}
-{-# INLINE returnUs #-}
-{-# INLINE splitUniqSupply #-}
-
--- @thenUs@ is where we split the @UniqSupply at .
-
liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)
instance MonadFix UniqSM where
mfix m = mkUniqSM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)
-thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
-thenUs (USM expr) cont
- = mkUniqSM (\us0 -> case (expr us0) of
- UniqResult result us1 -> unUSM (cont result) us1)
-
-thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
-thenUs_ (USM expr) (USM cont)
- = mkUniqSM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })
-
-returnUs :: a -> UniqSM a
-returnUs result = mkUniqSM (\us -> UniqResult result us)
-
getUs :: UniqSM UniqSupply
getUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)
=====================================
compiler/GHC/Utils/Monad/State/Strict.hs
=====================================
@@ -4,7 +4,7 @@
-- | A state monad which is strict in its state.
module GHC.Utils.Monad.State.Strict
( -- * The State monad
- State(State)
+ State(State, State' {- for deriving via purposes only -})
, state
, evalState
, execState
@@ -78,8 +78,10 @@ pattern State m <- State' m
forceState :: (# a, s #) -> (# a, s #)
forceState (# a, !s #) = (# a, s #)
+-- See Note [The one-shot state monad trick] for why we don't derive this.
instance Functor (State s) where
fmap f m = State $ \s -> case runState' m s of (# x, s' #) -> (# f x, s' #)
+ {-# INLINE fmap #-}
instance Applicative (State s) where
pure x = State $ \s -> (# x, s #)
@@ -87,10 +89,20 @@ instance Applicative (State s) where
case runState' m s of { (# f, s' #) ->
case runState' n s' of { (# x, s'' #) ->
(# f x, s'' #) }}
+ m *> n = State $ \s ->
+ case runState' m s of { (# _, s' #) ->
+ case runState' n s' of { (# x, s'' #) ->
+ (# x, s'' #) }}
+ {-# INLINE pure #-}
+ {-# INLINE (<*>) #-}
+ {-# INLINE (*>) #-}
instance Monad (State s) where
m >>= n = State $ \s -> case runState' m s of
(# r, !s' #) -> runState' (n r) s'
+ (>>) = (*>)
+ {-# INLINE (>>=) #-}
+ {-# INLINE (>>) #-}
state :: (s -> (a, s)) -> State s a
state f = State $ \s -> case f s of (r, s') -> (# r, s' #)
=====================================
compiler/Language/Haskell/Syntax/Basic.hs
=====================================
@@ -114,3 +114,25 @@ data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
| SrcNoUnpack -- ^ {-# NOUNPACK #-} specified
| NoSrcUnpack -- ^ no unpack pragma
deriving (Eq, Data)
+
+{-
+************************************************************************
+* *
+Fixity
+* *
+************************************************************************
+-}
+
+-- | Captures the fixity of declarations as they are parsed. This is not
+-- necessarily the same as the fixity declaration, as the normal fixity may be
+-- overridden using parens or backticks.
+data LexicalFixity = Prefix | Infix deriving (Eq, Data)
+
+data FixityDirection
+ = InfixL
+ | InfixR
+ | InfixN
+ deriving (Eq, Data)
+
+data Fixity = Fixity Int FixityDirection
+ deriving (Eq, Data)
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -31,7 +31,6 @@ import Language.Haskell.Syntax.Type
import Language.Haskell.Syntax.Binds
-- others:
-import GHC.Types.Fixity (LexicalFixity(Infix), Fixity)
import GHC.Types.SourceText (StringLiteral)
import GHC.Data.FastString (FastString)
@@ -831,8 +830,6 @@ data HsCmd id
-- applied to the type of the local environment tuple
LexicalFixity -- Whether the operator appeared prefix or infix when
-- parsed.
- (Maybe Fixity) -- fixity (filled in by the renamer), for forms that
- -- were converted from OpApp's by the renamer
[LHsCmdTop id] -- argument commands
| HsCmdApp (XCmdApp id)
=====================================
compiler/ghc.cabal.in
=====================================
@@ -523,6 +523,7 @@ Library
GHC.Driver.Ppr
GHC.Driver.Session
GHC.Hs
+ GHC.Hs.Basic
GHC.Hs.Binds
GHC.Hs.Decls
GHC.Hs.Doc
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -91,6 +91,7 @@ GHC.Driver.Phases
GHC.Driver.Pipeline.Monad
GHC.Driver.Plugins.External
GHC.Hs
+GHC.Hs.Basic
GHC.Hs.Binds
GHC.Hs.Decls
GHC.Hs.Doc
@@ -217,6 +218,7 @@ GHC.Utils.Lexeme
GHC.Utils.Logger
GHC.Utils.Misc
GHC.Utils.Monad
+GHC.Utils.Monad.State.Strict
GHC.Utils.Outputable
GHC.Utils.Panic
GHC.Utils.Panic.Plain
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -94,6 +94,7 @@ GHC.Driver.Phases
GHC.Driver.Pipeline.Monad
GHC.Driver.Plugins.External
GHC.Hs
+GHC.Hs.Basic
GHC.Hs.Binds
GHC.Hs.Decls
GHC.Hs.Doc
@@ -239,6 +240,7 @@ GHC.Utils.Lexeme
GHC.Utils.Logger
GHC.Utils.Misc
GHC.Utils.Monad
+GHC.Utils.Monad.State.Strict
GHC.Utils.Outputable
GHC.Utils.Panic
GHC.Utils.Panic.Plain
=====================================
testsuite/tests/driver/multipleHomeUnits/T25122/T25122.hs
=====================================
@@ -0,0 +1 @@
+module T25122 where
=====================================
testsuite/tests/driver/multipleHomeUnits/all.T
=====================================
@@ -71,6 +71,11 @@ test('multipleHomeUnits_shared', [extra_files([ 'A.hs', 'unitShared1', 'unitShar
test('multipleHomeUnits_shared_ghci', [extra_files([ 'shared.script', 'A.hs', 'unitShared1', 'unitShared2']), extra_run_opts('-unit @unitShared1 -unit @unitShared2')], ghci_script, ['shared.script'])
+test('T25122',
+ [ extra_files(
+ [ 'T25122', 'unitSame1', 'unitSame2'])
+ ], multiunit_compile, [['unitSame1', 'unitSame2'], '-v0 -fhide-source-paths -Werror -Wmissing-home-modules'])
+
=====================================
testsuite/tests/driver/multipleHomeUnits/unitSame1
=====================================
@@ -0,0 +1,3 @@
+T25122
+-iT25122
+-this-unit-id=s1
=====================================
testsuite/tests/driver/multipleHomeUnits/unitSame2
=====================================
@@ -0,0 +1,3 @@
+T25122
+-iT25122
+-this-unit-id=u2
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3470,7 +3470,7 @@ instance ExactPrint (HsCmd GhcPs) where
arr' <- markAnnotated arr
return (HsCmdArrApp an0 arr' arg' o isRightToLeft)
- exact (HsCmdArrForm an e fixity mf cs) = do
+ exact (HsCmdArrForm an e fixity cs) = do
an0 <- markLensMAA' an lal_open
(e',cs') <- case (fixity, cs) of
(Infix, (arg1:argrest)) -> do
@@ -3484,7 +3484,7 @@ instance ExactPrint (HsCmd GhcPs) where
return (e', cs')
(Infix, []) -> error "Not possible"
an1 <- markLensMAA' an0 lal_close
- return (HsCmdArrForm an1 e' fixity mf cs')
+ return (HsCmdArrForm an1 e' fixity cs')
exact (HsCmdApp an e1 e2) = do
e1' <- markAnnotated e1
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3bfef4909ba1af142ad41d4533595d0f4e9466ff...2404743c2e6ecd00165cb22a09aa619cd3ea0c6f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3bfef4909ba1af142ad41d4533595d0f4e9466ff...2404743c2e6ecd00165cb22a09aa619cd3ea0c6f
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/20240730/897d22f0/attachment-0001.html>
More information about the ghc-commits
mailing list