[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Add tests for 25081
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jul 29 15:57:29 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e2f2a56e by Arnaud Spiwack at 2024-07-28T22:21:07-04:00
Add tests for 25081
- - - - -
23f50640 by Arnaud Spiwack at 2024-07-28T22:21:07-04:00
Scale multiplicity in list comprehension
Fixes #25081
- - - - -
46d7ce1d by romes at 2024-07-29T11:57:11-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>
- - - - -
9f8319aa by Matthew Pickering at 2024-07-29T11:57:12-04:00
ghcup-metadata: More metadata fixes
* Incorrect version range on the alpine bindists
* Missing underscore in "unknown_versioning"
Fixes #25119
- - - - -
27 changed files:
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- + 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/Gen/Match.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Fixity.hs
- compiler/GHC/Types/Fixity/Env.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/linear/should_compile/LinearListComprehension.hs
- testsuite/tests/linear/should_compile/all.T
- + testsuite/tests/linear/should_fail/T25081.hs
- + testsuite/tests/linear/should_fail/T25081.stderr
- testsuite/tests/linear/should_fail/all.T
- 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/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/Gen/Match.hs
=====================================
@@ -502,6 +502,32 @@ tcGuardStmt _ stmt _ _
-- coercion matching stuff in them. It's hard to avoid the
-- potential for non-trivial coercions in tcMcStmt
+{-
+Note [Binding in list comprehension isn't linear]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In principle, [ y | () <- xs, y <- [0,1]] could be linear in `xs`.
+But, the way the desugaring works, we get something like
+
+case xs of
+ () : xs ' -> letrec next_stmt = … xs' …
+
+In the current typing rules for letrec in Core, next_stmt is necessarily of
+multiplicity Many and so is every free variable, including xs'. Which, in turns,
+requires xs to be of multiplicity Many.
+
+Rodrigo Mesquita worked out, in his master thesis, how to make letrecs having
+non-Many multiplicities. But it's a fair bit of work to implement.
+
+Since nobody actually cares about [ y | () <- xs, y <- [0,1]] being linear, then
+we just conservatively make it unrestricted instead.
+
+If we're to change that, we have to be careful that [ y | _ <- xs, y <- [0,1]]
+isn't linear in `xs` since the elements of `xs` are ignored. So we'd still have
+to call `tcScalingUsage` on `xs` in `tcLcStmt`, we'd just have to create a fresh
+multiplicity variable. We'd also use the same multiplicity variable in the call
+to `tcCheckPat` instead of `unrestricted`.
+-}
+
tcLcStmt :: TyCon -- The list type constructor ([])
-> TcExprStmtChecker
@@ -513,20 +539,24 @@ tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
-- A generator, pat <- rhs
tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
- ; rhs' <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])
+ -- About the next `tcScalingUsage ManyTy` and unrestricted
+ -- see Note [Binding in list comprehension isn't linear]
+ ; rhs' <- tcScalingUsage ManyTy $ tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
+ tcScalingUsage ManyTy $
thing_inside elt_ty
; return (mkTcBindStmt pat' rhs', thing) }
-- A boolean guard
tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
= do { rhs' <- tcCheckMonoExpr rhs boolTy
- ; thing <- thing_inside elt_ty
+ ; thing <- tcScalingUsage ManyTy $ thing_inside elt_ty
; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- ParStmt: See notes with tcMcStmt and Note [Scoping in parallel list comprehensions]
tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
- = do { env <- getLocalRdrEnv
+ = tcScalingUsage ManyTy $ -- parallel list comprehension never desugars to something linear.
+ do { env <- getLocalRdrEnv
; (pairs', thing) <- loop env [] bndr_stmts_s
; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
where
@@ -552,7 +582,8 @@ tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
, trS_bndrs = bindersMap
, trS_by = by, trS_using = using }) elt_ty thing_inside
- = do { let (bndr_names, n_bndr_names) = unzip bindersMap
+ = tcScalingUsage ManyTy $ -- Transform statements are too complex: just make everything multiplicity Many
+ do { let (bndr_names, n_bndr_names) = unzip bindersMap
unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
-- The inner 'stmts' lack a LastStmt, so the element type
-- passed in to tcStmtsAndThen is never looked at
=====================================
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/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
=====================================
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
=====================================
testsuite/tests/linear/should_compile/LinearListComprehension.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE LinearTypes #-}
+
+module LinearListComprehension where
+
+-- Probably nobody actually cares if monad comprehension realised that it can be
+-- linear in the first statement. But it can, so we might as well.
+
+guard :: a %1 -> (a %1 -> Bool) %1 -> [Int]
+guard x g = [ y | g x, y <- [0,1] ]
+
+-- This isn't correct syntax, but a singleton list comprehension would
+-- presumably work too
+-- last :: a %1 -> [a]
+-- last x = [ x | ]
=====================================
testsuite/tests/linear/should_compile/all.T
=====================================
@@ -45,3 +45,4 @@ test('LinearRecUpd', normal, compile, [''])
test('T23814', normal, compile, [''])
test('LinearLet', normal, compile, [''])
test('LinearLetPoly', normal, compile, [''])
+test('LinearListComprehension', normal, compile, ['-dlinear-core-lint'])
=====================================
testsuite/tests/linear/should_fail/T25081.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE ParallelListComp #-}
+{-# LANGUAGE TransformListComp #-}
+
+module T25081 where
+
+dup_last :: a %1 -> [a]
+dup_last x = [ x | _ <- [0,1]]
+
+dup_bind :: a %1 -> [()]
+dup_bind x = [ () | _ <- [0,1], _ <- [x]]
+
+dup_guard :: a %1 -> (a %1 -> Bool) -> [()]
+dup_guard x g = [ () | _ <- [0,1], g x ]
+
+guard_last :: a %1 -> [a]
+guard_last x = [ x | False]
+
+guard_bind :: a %1 -> [()]
+guard_bind x = [ () | False, _ <- [x]]
+
+guard_guard :: a %1 -> (a %1 -> Bool) %1 -> [()]
+guard_guard x g = [ () | False, g x ]
+
+-- This could, in principle, be linear. But see Note [Binding in list
+-- comprehension isn't linear] in GHC.Tc.Gen.Match.
+first_bind :: [()] %1 -> [Int]
+first_bind xs = [ y | () <- xs, y <- [0,1]]
+
+parallel :: a %1 -> [(a, Bool)]
+parallel x = [(y,z) | y <- [x] | z <- [True]]
+
+parallel_guard :: a %1 -> (a %1 -> Bool) -> [(Int, Bool)]
+parallel_guard x g = [(y, z) | g x, y <- [0,1] | z <- [True, False]]
+
+transform :: a %1 -> (a %1 -> Bool) -> [a]
+transform x g = [y | g x, y <- [0, 1], then take 2]
=====================================
testsuite/tests/linear/should_fail/T25081.stderr
=====================================
@@ -0,0 +1,65 @@
+T25081.hs:8:10: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘dup_last’: dup_last x = [x | _ <- [0, 1]]
+
+T25081.hs:11:10: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘dup_bind’:
+ dup_bind x = [() | _ <- [0, 1], _ <- [x]]
+
+T25081.hs:14:11: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘dup_guard’:
+ dup_guard x g = [() | _ <- [0, 1], g x]
+
+T25081.hs:17:12: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘guard_last’: guard_last x = [x | False]
+
+T25081.hs:20:12: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘guard_bind’:
+ guard_bind x = [() | False, _ <- [x]]
+
+T25081.hs:23:13: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘guard_guard’:
+ guard_guard x g = [() | False, g x]
+
+T25081.hs:23:15: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘g’
+ • In an equation for ‘guard_guard’:
+ guard_guard x g = [() | False, g x]
+
+T25081.hs:28:12: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘xs’
+ • In an equation for ‘first_bind’:
+ first_bind xs = [y | () <- xs, y <- [0, 1]]
+
+T25081.hs:31:10: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘parallel’:
+ parallel x = [(y, z) | y <- [x] | z <- [True]]
+
+T25081.hs:34:16: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘parallel_guard’:
+ parallel_guard x g
+ = [(y, z) | g x, y <- [0, 1] | z <- [True, False]]
+
+T25081.hs:37:11: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘transform’:
+ transform x g = [y | g x, y <- [0, 1], then take 2]
+
=====================================
testsuite/tests/linear/should_fail/all.T
=====================================
@@ -51,3 +51,4 @@ test('LinearLet7', normal, compile_fail, [''])
test('LinearLet8', normal, compile_fail, [''])
test('LinearLet9', normal, compile_fail, [''])
test('LinearLet10', normal, compile_fail, [''])
+test('T25081', normal, compile_fail, [''])
=====================================
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/0844f77469755f3dd72db9f1648b04e5ae2c994b...9f8319aaede9a01ee25d644f178c6b3dd8cd9347
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0844f77469755f3dd72db9f1648b04e5ae2c994b...9f8319aaede9a01ee25d644f178c6b3dd8cd9347
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/20240729/240449af/attachment-0001.html>
More information about the ghc-commits
mailing list