[Git][ghc/ghc][wip/T24467] 2 commits: Delete redundant stuff
Artin Ghasivand (@Ei30metry)
gitlab at gitlab.haskell.org
Sat Jul 27 12:56:14 UTC 2024
Artin Ghasivand pushed to branch wip/T24467 at Glasgow Haskell Compiler / GHC
Commits:
cad0cc5e by Artin Ghasivand at 2024-07-26T09:03:06+03:30
Delete redundant stuff
- - - - -
33c3106f by Artin Ghasivand at 2024-07-27T16:25:58+03:30
Some progress
- - - - -
3 changed files:
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/TyCon.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -27,6 +27,9 @@ module GHC.Core.DataCon (
-- ** Type construction
mkHsSrcBang, mkDataCon, fIRST_TAG,
+ -- ** Creating an instantiated dummy data constructor for the normalize command
+ normalizeDataConAt,
+
-- ** Type deconstruction
dataConRepType, dataConInstSig, dataConFullSig,
dataConName, dataConIdentity, dataConTag, dataConTagZ,
@@ -484,7 +487,7 @@ data DataCon
-- The next two fields give the type context of the data constructor
-- (aside from the GADT constraints,
- -- which are given by the dcExpSpec)
+ -- which are given by the dcEqSpec)
-- In GADT form, this is *exactly* what the programmer writes, even if
-- the context constrains only universally quantified variables
-- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b
@@ -1910,6 +1913,38 @@ dataConUserTyVarsNeedWrapper dc@(MkData { dcUnivTyVars = univ_tvs
-- Worker tyvars Wrapper tyvars
+{- Note [Creating dummy constructors for the normalize command]
+
+-}
+-- 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 })
+ = con { dcUnivTyVars = i_univ_ty_vars
+ , dcExTyCoVars = i_ex_tyco_vars
+ , dcEqSpec = i_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_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_res_ty = substTy subst orig_res_ty
+ (subst,i_ex_tyco_vars) = substVarBndrs univ_subst ex_tvs
+
+
+
{-
%************************************************************************
%* *
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -100,6 +100,7 @@ module GHC.Core.TyCon(
synTyConDefn_maybe, synTyConRhs_maybe,
famTyConFlav_maybe,
algTyConRhs,
+ algTyConFlavour, -- FIXME
newTyConRhs, newTyConEtadArity, newTyConEtadRhs,
unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,
newTyConDataCon_maybe,
@@ -1252,6 +1253,11 @@ isNoParent :: AlgTyConFlav -> Bool
isNoParent (VanillaAlgTyCon {}) = True
isNoParent _ = False
+algTyConFlavour :: TyCon -> AlgTyConFlav
+algTyConFlavour tc@(TyCon { tyConDetails = details })
+ | AlgTyCon {algTcFlavour = flavour} <- details = flavour
+ | otherwise = pprPanic "algTyConFlavour" (ppr tc)
+
--------------------
data Injectivity
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -44,6 +44,7 @@ import GHCi.RemoteTypes
import GHCi.BreakArray( breakOn, breakOff )
import GHC.ByteCode.Types
import GHC.Core.DataCon
+import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.PatSyn
import GHC.CoreToIface
@@ -70,7 +71,6 @@ import GHC.Driver.Env
import GHC.Runtime.Context
import GHC.Types.TyThing
import GHC.Types.TyThing.Ppr
-import GHC.Tc.Utils.Monad
import GHC.Core.TyCo.Ppr
import GHC.Core.Type
import GHC.Types.SafeHaskell ( getSafeMode )
@@ -78,7 +78,7 @@ import GHC.Types.SourceError ( SourceError )
import GHC.Types.Name
import GHC.Types.Breakpoint
import GHC.Types.Var ( varType )
-import GHC.Types.Var.Env ( emptyTidyEnv )
+import GHC.Types.Var.Env ( emptyTidyEnv, TidyEnv )
import GHC.Iface.Syntax ( showToHeader, showToIface, pprIfaceDecl
, IfaceDecl(..), IfaceEqSpec, IfaceConDecls(..)
, IfaceConDecl(..), visibleIfConDecls, IfaceAppArgs
@@ -1630,7 +1630,6 @@ pprInfo (thing, fixity, cls_insts, fam_insts, docs)
-----------------------------------------------------------------------------
-- :normalize
--- NOTE we could also call this :members or something like that.
normalize :: GHC.GhcMonad m => String -> m ()
nomralize "" = throwGhcException (CmdLineError "syntax ':n <(constructor arguments)>'")
normalize s = handleSourceError printGhciException $ do
@@ -1649,45 +1648,36 @@ normalize s = handleSourceError printGhciException $ do
actArgs (_:xs) = actArgs xs
trim = let f = reverse . dropWhile isSpace in f . f
-
--- TODO redefine all these using foldr and an accumulator
-buildNormSubst :: IfaceAppArgs -> [IfaceType] -> IfaceTySubst
-buildNormSubst args userArgs
- = mkIfaceTySubst $ zip (freeVarsOfIfAppArgs args) userArgs
- where
- freeVarsOfIfAppArgs = freeVarsOfIfTypes . appArgsIfaceTypes
- freeVarsOfIfTypes = concatMap freeVarsOfIfType
- freeVarsOfIfType (IfaceTyVar l) = [l]
- freeVarsOfIfType (IfaceTupleTy _ _ args) = freeVarsOfIfAppArgs args
- freeVarsOfIfType (IfaceAppTy _ args) = freeVarsOfIfAppArgs args
- freeVarsOfIfType (IfaceFunTy fun_flag _ arg res) = (freeVarsOfIfType arg) `union` (freeVarsOfIfType res)
- freeVarsOfIfType (IfaceForAllTy bndr ty) = delete (ifForAllBndrName bndr) (freeVarsOfIfType ty)
- freeVarsOfIfType _ = []
-
-lab :: GHC.GhcMonad m => String -> m SDoc
lab str = do
(ty,kind) <- GHC.typeKind True str
case splitTyConApp_maybe ty of
Nothing -> throwGhcException (CmdLineError "Something Bad happend!")
- Just (head,args) -> do
- let ifaceArgs = map toIfaceType args
- iDecl = snd $ tyConToIfaceDecl emptyTidyEnv head
- pure (enlightenUs iDecl)
- where
- enlightenUs decl
- = vcat [pprIfaceDecl showToIface decl
- ,nest 2 $ vcat [text "ifConArgTys:" <+> (nest 2 . vcat) (map (ppr . ifConArgTys) conDecls)
- ,text "ifEqSpec:" <+> (nest 2 . vcat) (map (ppr . ifConEqSpec) conDecls)
- ,text "ifConUserTvBinders:" <+> (nest 2 . vcat) (map (ppr . ifConUserTvBinders) conDecls)
- ,text "ifConExTcvs:" <+> (nest 2 . vcat) (map (ppr . ifConExTCvs) conDecls)]
- ,text "free variables:" <+> freeVarsOfIfType (retType (ifName ))
- ,text "--------------------------"]
- where
- conDecls = (visibleIfConDecls . ifCons) decl
- retType name binders = undefined
+ Just (head,args) -> pure . pprIfaceDecl showToIface $ toNormalizedIfaceDecl head args kind
- substIfaceConDecl :: GHC.GhcMonad m => m IfaceTySubst -> IfaceConDecl -> m IfaceConDecl
- substIfaceConDecl = undefined
+-- 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
+ where
+ dataCons = tyConDataCons tyCon
+ normalizedCons = map (normalizeDataConAt args) dataCons
+ newRhs = mkDataTyConRhs normalizedCons
+ newKind = mkTyConKind (tyConBinders tyCon) resKind
+ newStupidTheta = tyConStupidTheta tyCon -- FIXME
+ newRoles = tyConRoles tyCon -- FIXME
+ newCType = tyConCType_maybe tyCon
+ flavour = algTyConFlavour tyCon
+ newTyCon
+ = mkAlgTyCon (tyConName tyCon) (tyConBinders tyCon) 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
+we'll have to convert back and forth between IfaceConDecl and DataCon.
+-}
-----------------------------------------------------------------------------
-- :main
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21d7e98ef641860ead1cb62a6e3c61c0c5bda4b1...33c3106f1ec75c057b17cf2f7675c20809a89c40
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21d7e98ef641860ead1cb62a6e3c61c0c5bda4b1...33c3106f1ec75c057b17cf2f7675c20809a89c40
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/20240727/4da125d5/attachment-0001.html>
More information about the ghc-commits
mailing list