[Git][ghc/ghc][wip/kirchner/ttg-zurich] TTG HsCmdArrForm: use Fixity via extension point
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon Jul 29 12:54:22 UTC 2024
Rodrigo Mesquita pushed to branch wip/kirchner/ttg-zurich at Glasgow Haskell Compiler / GHC
Commits:
e633ed46 by romes at 2024-07-29T13:54:04+01: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>
- - - - -
20 changed files:
- + 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/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
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
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/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
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3469,7 +3469,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
@@ -3483,7 +3483,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/-/commit/e633ed4600aed7f9391d24554e3a189b896fbb77
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e633ed4600aed7f9391d24554e3a189b896fbb77
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/1d71068d/attachment-0001.html>
More information about the ghc-commits
mailing list