[Git][ghc/ghc][wip/T24467] Argument types are being reduced now
Artin Ghasivand (@Ei30metry)
gitlab at gitlab.haskell.org
Sun Jul 28 09:48:58 UTC 2024
Artin Ghasivand pushed to branch wip/T24467 at Glasgow Haskell Compiler / GHC
Commits:
319543bd by Artin Ghasivand at 2024-07-28T13:18:17+03:30
Argument types are being reduced now
- - - - -
2 changed files:
- compiler/GHC/Core/DataCon.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -87,6 +87,8 @@ import {-# SOURCE #-} GHC.Types.TyThing
import GHC.Types.FieldLabel
import GHC.Types.SourceText
import GHC.Core.Class
+import {-# SOURCE #-} GHC.Core.FamInstEnv
+import GHC.Core.Reduction
import GHC.Types.Name
import GHC.Builtin.Names
import GHC.Core.Predicate
@@ -103,6 +105,7 @@ import GHC.Data.Graph.UnVar -- UnVarSet and operations
import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars )
+
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -1918,33 +1921,33 @@ dataConUserTyVarsNeedWrapper dc@(MkData { dcUnivTyVars = univ_tvs
-}
-- See Note [Why do we normalize a DataCon instead of an IfaceConDecl]
-- FIXME better name
-normalizeDataConAt :: [Type] -> DataCon -> DataCon
-normalizeDataConAt args con@(MkData { dcUnivTyVars = univ_tvs
- , dcExTyCoVars = ex_tvs
- , dcEqSpec = eq_spec
- , dcOtherTheta = other_theta
- , dcStupidTheta = stupid_theta
- , dcOrigArgTys = orig_arg_tys
- , dcOrigResTy = orig_res_ty })
+normalizeDataConAt :: FamInstEnvs -> [Type] -> DataCon -> DataCon
+normalizeDataConAt famEnv args con@(MkData { dcUnivTyVars = univ_tvs
+ , dcExTyCoVars = ex_tvs
+ , dcEqSpec = eq_spec
+ , dcOtherTheta = other_theta
+ , dcStupidTheta = stupid_theta
+ , dcOrigArgTys = orig_arg_tys
+ , dcOrigResTy = orig_res_ty })
= con { dcUnivTyVars = i_univ_ty_vars
, dcExTyCoVars = i_ex_tyco_vars
- , dcEqSpec = i_eq_spec
+ , dcEqSpec = eq_spec
, dcOtherTheta = i_other_theta
, dcStupidTheta = i_stupid_theta
, dcOrigArgTys = i_arg_tys
, dcOrigResTy = i_res_ty }
where
univ_subst = zipTvSubst univ_tvs args
- i_eq_spec = eq_spec
+ i_eq_spec = filter undefined eq_spec -- (elem x "things in scope")
i_univ_ty_vars = filter (flip elemSubst univ_subst) univ_tvs
i_other_theta = substTheta subst other_theta
i_stupid_theta = substTheta subst stupid_theta
- i_arg_tys = substScaledTys subst orig_arg_tys
+ i_arg_tys = map (mapScaledType (reductionReducedType . normaliseType famEnv Nominal))
+ $ substScaledTys subst orig_arg_tys
i_res_ty = substTy subst orig_res_ty
(subst,i_ex_tyco_vars) = substVarBndrs univ_subst ex_tvs
-
{-
%************************************************************************
%* *
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -45,6 +45,7 @@ import GHCi.BreakArray( breakOn, breakOff )
import GHC.ByteCode.Types
import GHC.Core.DataCon
import GHC.Core.TyCon
+import GHC.Core.FamInstEnv
import GHC.Core.ConLike
import GHC.Core.PatSyn
import GHC.CoreToIface
@@ -55,7 +56,7 @@ import GHC.Driver.Phases
import GHC.Driver.Session as DynFlags
import GHC.Driver.Ppr hiding (printForUser)
import GHC.Utils.Error hiding (traceCmd)
-import GHC.Driver.Monad ( modifySession )
+import GHC.Driver.Monad ( modifySession, withSession )
import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) )
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Diagnostic
@@ -64,7 +65,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
Resume, SingleStep, Ghc,
GetDocsFailure(..), pushLogHookM,
getModuleGraph, handleSourceError, ms_mod )
-import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation)
+import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation, getHscEnv)
import GHC.Hs.ImpExp
import GHC.Hs
import GHC.Driver.Env
@@ -108,6 +109,8 @@ import GHC.Utils.Logger
-- Other random utilities
import GHC.Types.Basic hiding ( isTopLevel )
+import GHC.Tc.Instance.Family
+import GHC.Tc.Utils.Monad ( initTcInteractive )
import GHC.Settings.Config
import GHC.Data.Graph.Directed
import GHC.Utils.Encoding
@@ -1648,31 +1651,38 @@ normalize s = handleSourceError printGhciException $ do
actArgs (_:xs) = actArgs xs
trim = let f = reverse . dropWhile isSpace in f . f
+lab :: GHC.GhcMonad m => String -> m SDoc
lab str = do
(ty,kind) <- GHC.typeKind True str
+ rendered <- showSDocForUser' (ppr kind)
+ liftIO (putStrLn rendered)
case splitTyConApp_maybe ty of
Nothing -> throwGhcException (CmdLineError "Something Bad happend!")
- Just (head,args) -> pure . pprIfaceDecl showToIface $ toNormalizedIfaceDecl head args kind
+ Just (head,args) -> do
+ (_,famInstEnvs) <- withSession $ \hsc_env0 -> do
+ hsc_env <- GHC.getSession
+ liftIO $ initTcInteractive hsc_env tcGetFamInstEnvs
+ case famInstEnvs of
+ Just fie -> pure . pprIfaceDecl showToIface $ toNormalizedIfaceDecl fie head args kind
+ Nothing -> throwGhcException (CmdLineError "Couldn't retrieve family instances")
--- TODO we may also need to apply the substitution to our TyCon.
-- NOTE we'll have to make sure that stheta in TyCon and stheta in DataCon are the same.
-toNormalizedIfaceDecl :: TyCon -> [Type] -> Kind -> IfaceDecl
-toNormalizedIfaceDecl tyCon args resKind = (snd . tyConToIfaceDecl emptyTidyEnv) newTyCon
+toNormalizedIfaceDecl :: FamInstEnvs -> TyCon -> [Type] -> Kind -> IfaceDecl
+toNormalizedIfaceDecl famInstEnvs tyCon args resKind = (snd . tyConToIfaceDecl emptyTidyEnv) newTyCon
where
dataCons = tyConDataCons tyCon
- normalizedCons = map (normalizeDataConAt args) dataCons
+ normalizedCons = map (normalizeDataConAt famInstEnvs args) dataCons
newRhs = mkDataTyConRhs normalizedCons
- newKind = mkTyConKind (tyConBinders tyCon) resKind
- newStupidTheta = tyConStupidTheta tyCon -- FIXME
+ newStupidTheta = tyConStupidTheta tyCon
newRoles = tyConRoles tyCon -- FIXME
newCType = tyConCType_maybe tyCon
+ newTyConBinders = drop (length args) (tyConBinders tyCon)
flavour = algTyConFlavour tyCon
newTyCon
- = mkAlgTyCon (tyConName tyCon) (tyConBinders tyCon) resKind newRoles
+ = mkAlgTyCon (tyConName tyCon) newTyConBinders resKind newRoles
newCType newStupidTheta newRhs flavour
(isGadtSyntaxTyCon tyCon)
-
{- Note [Why do we normalize a DataCon instead of an IfaceConDecl]
TODO
summary because we'll have to reduce and do all other sorts of stuff. Otherwise
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/319543bde563a4d99cdb05c23f52a46137dd12a8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/319543bde563a4d99cdb05c23f52a46137dd12a8
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/20240728/792c81f7/attachment-0001.html>
More information about the ghc-commits
mailing list