Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4ee260cf by sheaf at 2026-03-27T04:46:06-04:00 Fix several oversights in hsExprType This commit fixes several oversights in GHC.Hs.Syn.Type.hsExprType: - The 'RecordCon' case was returning the type of the constructor, instead of the constructor application. This is fixed by using 'splitFunTys'. - The 'ExplicitTuple' case failed to take into account tuple sections, and was also incorrectly handling 1-tuples (e.g. 'Solo') which can be constructed using Template Haskell. - The 'NegApp' case was returning the type of the negation operator, again failing to apply it to the argument. Fixed by using 'funResultTy'. - The 'HsProc' case was computing the result type of the arrow proc block, without taking into account the argument type. Fix that by adding a new field to 'CmdTopTc' that stores the arrow type, so that we can construct the correct result type `arr a b` for `proc (pat :: a) -> (cmd :: b)`. - The 'ArithSeq' and 'NegApp' cases were failing to take into account the result 'HsWrapper', which could e.g. silently drop casts. This is fixed by introducing 'syntaxExpr_wrappedFunResTy' which, on top of taking the result type, applies the result 'HsWrapper'. These fixes are validated by the new GHC API test T26910. Fixes #26910 - - - - - 9 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Zonk/Type.hs - + testsuite/tests/ghc-api/T26910.hs - + testsuite/tests/ghc-api/T26910.stdout - + testsuite/tests/ghc-api/T26910_Input.hs - testsuite/tests/ghc-api/all.T Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1608,9 +1608,16 @@ is Less Cool because -} data CmdTopTc - = CmdTopTc Type -- Nested tuple of inputs on the command's stack - Type -- return type of the command - (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] + = CmdTopTc + -- | Nested tuple of inputs on the command's stack + { ctt_stack :: Type + -- | Arrow type + , ctt_arr_ty :: Type + -- | Return type of the command + , ctt_res_ty :: Type + -- | Command syntax table; see Note [CmdSyntaxTable] + , ctt_table :: CmdSyntaxTable GhcTc + } type instance XCmdTop GhcPs = NoExtField type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -25,6 +25,7 @@ import GHC.Tc.Types.Evidence import GHC.Types.Id import GHC.Types.Var( VarBndr(..) ) import GHC.Types.SrcLoc +import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -114,11 +115,16 @@ hsExprType (HsLam _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_gr hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x hsExprType (OpApp v _ _ _) = dataConCantHappen v -hsExprType (NegApp _ _ se) = syntaxExprType se +hsExprType (NegApp _ _ se) = syntaxExpr_wrappedFunResTy se hsExprType (HsPar _ e) = lhsExprType e hsExprType (SectionL v _ _) = dataConCantHappen v hsExprType (SectionR v _ _) = dataConCantHappen v -hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args +hsExprType (ExplicitTuple _ args box) = + -- Deal with tuple sections: one function arrow per missing argument + mkScaledFunTys [s | Missing s <- args] $ + -- Use 'mkTupleTy1' to avoid flattening 1-tuples, as per + -- Note [Don't flatten tuples from HsSyn] in GHC.Core.Make. + mkTupleTy1 box (map hsTupArgType args) hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group hsExprType (HsIf _ _ t _) = lhsExprType t @@ -126,25 +132,29 @@ hsExprType (HsMultiIf ty _) = ty hsExprType (HsLet _ _ body) = lhsExprType body hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty -hsExprType (RecordCon con_expr _ _) = hsExprType con_expr +hsExprType (RecordCon con_expr _ _) = snd (splitFunTys (hsExprType con_expr)) hsExprType (RecordUpd v _ _) = dataConCantHappen v hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v hsExprType (ExprWithTySig _ e _) = lhsExprType e -hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of - Just op -> piResultTy (syntaxExprType op) asi_ty - Nothing -> asi_ty - where - asi_ty = arithSeqInfoType asi +hsExprType (ArithSeq _ mb_overloaded_op asi) = + case mb_overloaded_op of + Just se -> syntaxExpr_wrappedFunResTy se + Nothing -> arithSeqInfoType asi hsExprType (HsTypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty -hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice" - (ppr e) - -- Typed splices should have been eliminated during zonking, but we - -- can't use `dataConCantHappen` since they are still present before - -- than in the typechecked AST. +hsExprType e@(HsTypedSplice{}) = + -- Typed splices should have been eliminated during zonking, but we + -- can't use `dataConCantHappen` since they are still present before + -- then in the typechecked AST. + pprPanic "hsExprType: Unexpected HsTypedSplice" + (ppr e) hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext -hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top +hsExprType (HsProc _ pat (L _ (HsCmdTop cmd_top_tc _))) = + let CmdTopTc { ctt_arr_ty = arr_ty, ctt_res_ty = res_ty } = cmd_top_tc + in + -- (proc (pat :: a) -> (cmd :: b)) :: arr a b + mkAppTys arr_ty [hsLPatType pat, res_ty] hsExprType (HsStatic (ty,_) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e hsExprType (HsEmbTy x _) = dataConCantHappen x @@ -178,6 +188,13 @@ hsTupArgType :: HsTupArg GhcTc -> Type hsTupArgType (Present _ e) = lhsExprType e hsTupArgType (Missing (Scaled _ ty)) = ty +-- | The result type of a @SyntaxExpr GhcTc@ for a unary function, +-- including the result 'HsWrapper'. +syntaxExpr_wrappedFunResTy :: HasDebugCallStack => SyntaxExpr GhcTc -> Type +syntaxExpr_wrappedFunResTy (SyntaxExprTc { syn_expr = e, syn_res_wrap = wrap }) = + hsWrapperType wrap (funResultTy (hsExprType e)) +syntaxExpr_wrappedFunResTy NoSyntaxExprTc = + panic "syntaxExpr_wrappedFunResTy: unexpected NoSyntaxExprTc" -- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas)) type PRType = (Type, [Type]) @@ -191,7 +208,7 @@ liftPRType :: (Type -> Type) -> PRType -> PRType liftPRType f pty = (f (prTypeType pty), []) hsWrapperType :: HsWrapper -> Type -> Type --- Return the type of (WrapExpr wrap e), given that e :: ty +-- ^ Return the type of @WrapExpr wrap e@, given that @e :: ty@ hsWrapperType wrap ty = prTypeType $ go wrap (ty,[]) where go WpHole = id @@ -209,12 +226,5 @@ hsWrapperType wrap ty = prTypeType $ go wrap (ty,[]) go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas) go (WpLet _) = id -lhsCmdTopType :: LHsCmdTop GhcTc -> Type -lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty - matchGroupTcType :: MatchGroupTc -> Type matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res - -syntaxExprType :: SyntaxExpr GhcTc -> Type -syntaxExprType (SyntaxExprTc e _ _) = hsExprType e -syntaxExprType NoSyntaxExprTc = panic "syntaxExprType: Unexpected NoSyntaxExprTc" ===================================== compiler/GHC/HsToCore/Arrows.hs ===================================== @@ -284,7 +284,7 @@ dsProcExpr :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc { ctt_res_ty = cmd_ty, ctt_table = ids }) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders CollWithDictBinders pat) (core_cmd, _free_vars, env_ids) @@ -656,8 +656,15 @@ dsTrimCmdArg -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids - (L _ (HsCmdTop - (CmdTopTc stack_ty cmd_ty ids) cmd )) = do + (L _ + (HsCmdTop + (CmdTopTc + { ctt_stack = stack_ty + , ctt_res_ty = cmd_ty + , ctt_table = ids + }) + cmd) + ) = do (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd ===================================== compiler/GHC/Tc/Gen/Arrow.hs ===================================== @@ -136,7 +136,11 @@ tcCmdTop :: CmdEnv tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty) = setSrcSpanA loc $ do { cmd' <- tcCmd env cmd cmd_ty - ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') } + ; let cmd_top = CmdTopTc { ctt_stack = cmd_stk + , ctt_arr_ty = cmd_arr env + , ctt_res_ty = res_ty + , ctt_table = names } + ; return (L loc $ HsCmdTop cmd_top cmd') } ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc) ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1211,10 +1211,14 @@ zonkCmdTop :: LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc) zonkCmdTop cmd = wrapLocZonkMA (zonk_cmd_top) cmd zonk_cmd_top :: HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc) -zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) +zonk_cmd_top (HsCmdTop (CmdTopTc { ctt_stack = stack_tys + , ctt_arr_ty = arr_ty + , ctt_res_ty = res_ty + , ctt_table = ids }) cmd) = do new_cmd <- zonkLCmd cmd new_stack_tys <- zonkTcTypeToTypeX stack_tys - new_ty <- zonkTcTypeToTypeX ty + new_arr_ty <- zonkTcTypeToTypeX arr_ty + new_res_ty <- zonkTcTypeToTypeX res_ty new_ids <- mapSndM zonkExpr ids massert (definitelyLiftedType new_stack_tys) @@ -1222,7 +1226,13 @@ zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) -- but indeed it should always be lifted due to the typing -- rules for arrows - return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) + let new_cmd_top = + CmdTopTc { ctt_stack = new_stack_tys + , ctt_arr_ty = new_arr_ty + , ctt_res_ty = new_res_ty + , ctt_table = new_ids } + + return (HsCmdTop new_cmd_top new_cmd) ------------------------------------------------------------------------- zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper ===================================== testsuite/tests/ghc-api/T26910.hs ===================================== @@ -0,0 +1,113 @@ +module Main where + +-- base +import Control.Applicative +import Control.Monad.IO.Class + ( liftIO ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import System.Environment + ( getArgs ) + +-- directory +import System.Directory + ( removeFile ) + +-- ghc +import GHC +import GHC.Data.Bag + ( bagToList ) +import GHC.Driver.Ppr + ( showSDoc ) +import GHC.Driver.Session +import GHC.Hs +import GHC.Hs.Syn.Type + ( hsExprType ) +import GHC.Types.Name + ( nameOccName, occNameString ) +import GHC.Types.Var + ( varName ) +import GHC.Unit.Types + ( GenUnit (..), Definite (..) ) +import GHC.Utils.Outputable + ( ppr ) + +-------------------------------------------------------------------------------- + +findBindBody :: String -> LHsBinds GhcTc -> Maybe (HsExpr GhcTc) +findBindBody name = asum . map go + where + go (L _ FunBind { fun_id = L _ fid + , fun_matches = MG { mg_alts = L _ (m:_) } }) + | occNameString (nameOccName (varName fid)) == name + = case m_grhss (unLoc m) of + GRHSs { grhssGRHSs = L _ (GRHS _ _ bodyL) :| _ } -> Just (unLoc bodyL) + go (L _ (XHsBindsLR AbsBinds { abs_binds })) = findBindBody name abs_binds + go _ = Nothing + +checkBinding :: DynFlags -> String -> LHsBinds GhcTc -> IO () +checkBinding dflags name tcSrc = + case findBindBody name tcSrc of + Nothing -> + putStrLn $ name ++ " NOT FOUND" + Just body -> + putStrLn $ + "(<body of " ++ name ++ ">) :: " ++ showSDoc dflags (ppr (hsExprType body)) + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + logger <- getLogger + + -- Add 'template-haskell' dependency + (dflags, _, _) <- parseDynamicFlags logger dflags [noLoc "-package template-haskell"] + setSessionDynFlags dflags + + let modName = mkModuleName "T26910_Input" + m = mkModule (RealUnit (Definite (homeUnitId_ dflags))) modName + addTarget Target + { targetId = TargetModule modName + , targetAllowObjCode = True + , targetUnitId = homeUnitId_ dflags + , targetContents = Nothing + } + _ <- load LoadAllTargets + modSum <- getModSummary m + parsed <- parseModule modSum + tc <- typecheckModule parsed + + let tcSrc = tm_typechecked_source tc + check name = liftIO $ checkBinding dflags name tcSrc + + check "e_reccon" -- RecordCon + check "e_negapp" -- NegApp + check "e_proc" -- HsProc + check "e_arith_ol" -- ArithSeq + + check "e_var" -- ConLikeTc + check "e_lit" -- HsLit + check "e_overlit" -- HsOverLit + check "e_lam" -- HsLam + check "e_app" -- HsApp + check "e_apptype" -- HsAppType + check "e_par" -- HsPar + check "e_tuple1" -- ExplicitTuple + check "e_tuple2" -- ExplicitTuple + TupleSections + check "e_tuple3" -- ExplicitTuple 1-tuple (with Template Haskell) + check "e_utuple1" -- ExplicitTuple (unboxed) + check "e_utuple2" -- ExplicitTuple + TupleSections (unboxed) + check "e_usum" -- Unboxed sums + check "e_case" -- HsCase + check "e_if" -- HsIf + check "e_multiif" -- HsMultiIf + check "e_let" -- HsLet + check "e_list" -- ExplicitList + OverloadedLists + check "e_arith" -- ArithSeq + check "e_tysig" -- ExprWithTySig + check "e_listcomp" -- HsDo (ListComp) + check "e_recsel" -- HsRecSelTc + check "e_ubracket" -- HsUntypedBracket + check "e_tbracket" -- HsTypedBracket + check "e_static" -- HsStatic ===================================== testsuite/tests/ghc-api/T26910.stdout ===================================== @@ -0,0 +1,29 @@ +(<body of e_reccon>) :: MyRec +(<body of e_negapp>) :: T Word +(<body of e_proc>) :: Int -> Int +(<body of e_arith_ol>) :: MyList Int +(<body of e_var>) :: Either Int Bool +(<body of e_lit>) :: Char +(<body of e_overlit>) :: T Word +(<body of e_lam>) :: Bool -> Bool +(<body of e_app>) :: Bool +(<body of e_apptype>) :: Bool -> Bool +(<body of e_par>) :: Bool +(<body of e_tuple1>) :: (Int, Bool) +(<body of e_tuple2>) :: Int -> (Int, Bool) +(<body of e_tuple3>) :: Solo Char +(<body of e_utuple1>) :: (# Int, Int# #) +(<body of e_utuple2>) :: Int -> Int# -> (# Int, Int# #) +(<body of e_usum>) :: (# Int# | Word# #) +(<body of e_case>) :: Bool +(<body of e_if>) :: Char +(<body of e_multiif>) :: Int +(<body of e_let>) :: Int +(<body of e_list>) :: [Int] +(<body of e_arith>) :: MyList Int +(<body of e_tysig>) :: Bool +(<body of e_listcomp>) :: [Int] +(<body of e_recsel>) :: MyRec -> Int +(<body of e_ubracket>) :: Q Exp +(<body of e_tbracket>) :: Code Q Char +(<body of e_static>) :: StaticPtr Bool ===================================== testsuite/tests/ghc-api/T26910_Input.hs ===================================== @@ -0,0 +1,187 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +module T26910_Input where + +-- base +import Prelude + hiding ( negate, fromInteger ) +import qualified Prelude +import Control.Arrow + ( (>>>), arr, first, returnA ) +import Data.Kind + ( Type ) +import Data.Tuple + ( Solo(..) ) +import GHC.Exts + ( TYPE, RuntimeRep(..), LiftedRep + , IsList (..) + , Int#, Word# + ) +import GHC.StaticPtr + ( StaticPtr ) + +-- template-haskell +import qualified Language.Haskell.TH as TH + +-------------------------------------------------------------------------------- + +ifThenElse :: Bool -> a -> a -> a +ifThenElse c t f = + case c of + True -> t + False -> f + +data MyRec = MyRec { recInt :: Int, recBool :: Bool } + +-- Used to test ArithSeq with overloaded fromList (OverloadedLists) +newtype MyList a = MyList [a] +instance IsList (MyList a) where + type Item (MyList a) = a + fromList = MyList + toList (MyList xs) = xs + +-- RecordCon +e_reccon :: MyRec +e_reccon = MyRec { recInt = 1, recBool = True } + +-- NegApp +e_negapp :: T Word +e_negapp = -(1 :: Int) + +type R :: Type -> RuntimeRep +type family R a where + R Word = LiftedRep + +type T :: forall (a :: Type) -> TYPE (R a) +type family T a where + T Word = Int + +-- Weird RebindableSyntax negation that involves casts +negate :: T Word -> T Word +negate = Prelude.negate + +-- HsProc +e_proc :: Int -> Int +e_proc = proc x -> returnA -< x + +-- ArithSeq (with OverloadedLists) +e_arith_ol :: MyList Int +e_arith_ol = [1..10 :: Int] + +-- XExpr (ConLikeTc) +e_var :: Either Int Bool +e_var = Left 3 + +-- HsLit +e_lit :: Char +e_lit = 'x' + +-- HsOverLit +e_overlit :: T Word +e_overlit = 42 + +fromInteger :: Integer -> T Word +fromInteger = Prelude.fromInteger + +-- HsLam +e_lam :: Bool -> Bool +e_lam = \ x -> not x + +-- HsApp +e_app :: Bool +e_app = not True + +-- HsAppType +e_apptype :: Bool -> Bool +e_apptype = id @Bool + +-- HsPar +e_par :: Bool +e_par = (True) + +-- ExplicitTuple +e_tuple1 :: (Int, Bool) +e_tuple1 = (1 :: Int, True) + +-- ExplicitTuple + TupleSections +e_tuple2 :: Int -> (Int, Bool) +e_tuple2 = (, True) + +-- ExplicitTuple one-tuple +e_tuple3 :: Solo Char +e_tuple3 = + $( return $ TH.TupE [ Just $ TH.LitE ( TH.CharL 'x' ) ] ) + +-- Unboxed tuple +e_utuple1 :: () -> (# Int, Int# #) +e_utuple1 _ = (# 1, 1# #) + +-- Unboxed tuple + TupleSections +e_utuple2 :: Int -> Int# -> (# Int, Int# #) +e_utuple2 = (# , #) + +-- Unboxed sums +e_usum :: () -> (# Int# | Word# #) +e_usum _ = (# 1# | #) + +-- HsCase +e_case :: Bool +e_case = case id True of { True -> False; False -> True } + +-- HsIf +e_if :: Char +e_if = if id True then 'x' else 'y' + +-- HsMultiIf +e_multiif :: Int +e_multiif = if | id True -> (1 :: Int) + | otherwise -> (2 :: Int) + +-- HsLet +e_let :: Int +e_let = let x = 1 :: Int in x + +-- ExplicitList +e_list :: [Int] +e_list = [1 :: Int, 2, 3] + +-- ArithSeq with overloaded fromList +e_arith :: MyList Int +e_arith = [1 :: Int ..] + +-- ExprWithTySig +e_tysig :: Bool +e_tysig = (True :: Bool) + +-- HsDo ListComp +e_listcomp :: [Int] +e_listcomp = [x | x <- [1 :: Int, 2, 3]] + +-- HsRecSelTc +e_recsel :: MyRec -> Int +e_recsel = recInt + +-- HsUntypedBracket +e_ubracket :: TH.Q TH.Exp +e_ubracket = [| 'y' |] + +-- HsTypedBracket +e_tbracket :: TH.Code TH.Q Char +e_tbracket = [|| 'z' ||] + +-- HsStatic +e_static :: StaticPtr Bool +e_static = static True ===================================== testsuite/tests/ghc-api/all.T ===================================== @@ -74,4 +74,8 @@ test('T25577', [ extra_run_opts(f'"{config.libdir}"') test('T26120', [], compile_and_run, ['-package ghc']) test('T26264', normal, compile_and_run, ['-package ghc']) +test('T26910', [ extra_run_opts(f'"{config.libdir}"') + # doesn't work in wasm/js due to lack of pipe(2) support + , when(arch('wasm32') or arch('javascript'), skip) + ], compile_and_run, ['-package ghc -package template-haskell']) test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ee260cfaebd3fb6c2ceb757a0a02672... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ee260cfaebd3fb6c2ceb757a0a02672... You're receiving this email because of your account on gitlab.haskell.org.