[Git][ghc/ghc][wip/T24467] Add TypeAnnDataDecl and a draft Outputable instance for it
Artin Ghasivand (@Ei30metry)
gitlab at gitlab.haskell.org
Sat May 4 09:05:25 UTC 2024
Artin Ghasivand pushed to branch wip/T24467 at Glasgow Haskell Compiler / GHC
Commits:
f8aa6a14 by Artin Ghasivand at 2024-05-04T12:34:41+03:30
Add TypeAnnDataDecl and a draft Outputable instance for it
- - - - -
3 changed files:
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Syntax.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC/Iface/Decl.hs
=====================================
@@ -14,6 +14,7 @@ module GHC.Iface.Decl
( coAxiomToIfaceDecl
, tyThingToIfaceDecl -- Converting things to their Iface equivalents
, toIfaceBooleanFormula
+ , tyConToIfaceDecl
)
where
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -44,6 +44,7 @@ module GHC.Iface.Syntax (
-- Pretty printing
pprIfaceExpr,
pprIfaceDecl,
+ pprIfaceConDecl,
AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader
) where
@@ -909,7 +910,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
| gadt = vcat [ pp_roles
, pp_ki_sig
- , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where
+ , pp_nd <+> pp_lhs <+> pp_kind <+> text "where"
, nest 2 (vcat pp_cons)
, nest 2 $ ppShowIface ss pp_extra ]
| otherwise = vcat [ pp_roles
@@ -926,7 +927,6 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders]
cons = visibleIfConDecls condecls
- pp_where = ppWhen (gadt && not (null cons)) $ text "where"
pp_cons = ppr_trim (map show_con cons) :: [SDoc]
pp_kind = ppUnless (ki_sig_printable || isIfaceLiftedTypeKind kind)
(dcolon <+> ppr kind)
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -44,10 +44,12 @@ import GHCi.BreakArray( breakOn, breakOff )
import GHC.ByteCode.Types
import GHC.Core.DataCon
import GHC.Core.ConLike
+import GHC.Core.TyCon
import GHC.Core.PatSyn
import GHC.Driver.Flags
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
+import GHC.Types.Var.Env
import GHC.Driver.Phases
import GHC.Driver.Session as DynFlags
import GHC.Driver.Ppr hiding (printForUser)
@@ -73,7 +75,15 @@ import GHC.Types.SafeHaskell ( getSafeMode )
import GHC.Types.SourceError ( SourceError )
import GHC.Types.Name
import GHC.Types.Var ( varType )
-import GHC.Iface.Syntax ( showToHeader )
+import GHC.Iface.Type
+import GHC.Iface.Syntax ( IfaceConDecls(..)
+ , IfaceDecl(..)
+ , IfaceFamTyConFlav(..)
+ , IfaceTyConParent(..)
+ , showToHeader
+ , pprIfaceConDecl
+ )
+import GHC.Iface.Decl ( tyConToIfaceDecl )
import GHC.Builtin.Names
import GHC.Builtin.Types( stringTyCon_RDR )
import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName )
@@ -1625,41 +1635,93 @@ pprInfo (thing, fixity, cls_insts, fam_insts, docs)
-----------------------------------------------------------------------------
-- :normalize
-normalize :: String -> m ()
-normalize = undefined
+normalize :: GHC.GhcMonad m => String -> m ()
+normalize "" = throwGhcException (CmdLineError "normalize needs arguments to work on!")
+normalize s = do
+ forM_ (words s) $ \str -> do
+ -- stuff <- mapM (GHC.getInfo False) name
+ rendered <- showSDocForUser' (ppr @FastString "blah")
+ liftIO (putStrLn rendered)
+ where
+ isInParenthesis ("(":xs) = True
+ isInParenthesis _ = False
+
+normalizeDecl :: GHC.GhcMonad m => IfaceDecl -> [Name] -> m IfaceDecl
+normalizeDecl decl@(IfaceData {..}) args
+ | null args = pure decl
+ | otherwise = do
+ let dummyIfName = ppr ifName <+> hsep (map ppr args)
+ return undefined
+normalizeDecl _ _ = throwGhcException (CmdLineError "blah")
--- NOTE use namesAreInParenthesis in this
-normalizeType :: String -> m ()
-normalizeType str = do
- names <- GHC.parseName str
- mb_stuff <- mapM (GHC.getInfo False) names
- case mb_stuff of
- Nothing -> undefined
- Just x -> undefined
-pprDummyDataDeclaration :: TyThing -> SDoc
-pprDummyDataDeclaration = undefined
+pprNormalizedDeclaration :: GHC.GhcMonad m => TyCon -> String -> m SDoc
+pprNormalizedDeclaration con str = undefined . snd $ tyConToIfaceDecl emptyTidyEnv con
+ where
+ replaceUniversals = undefined
{- Note [Arguments of the normalize command]
:normalize, like :info, can take multiple arguments; Which is why the arguments
-should always be inside parenthesis. Even if they are type constructors of kind *.
+should always be inside parenthesis. Even if they are type constructors of kind Type.
Here is an example:
Assume type family RetInt a where RetInt a = Int
-:normalize (Bool) (Either String (RetInt Bool))
+:normalize (Bool) (Either String (RetInt Bool)) -- GOOD
results in:
-data Bool = True | False
+Bool = True | False
-data Either String (RetInt Bool) = Left String | Right Int
+Either String (RetInt Bool) = Left String | Right Int
-:normalize Bool
+:normalize Bool -- BAD
-}
-namesAreInParenthesis = undefined
+data TypeAnnDataDecl -- This could probably use a better name
+ =
+ MkTadd
+ { tadTypeCons :: FastString
+ , tadArguments :: [IfaceType]
+ , tadCons :: IfaceConDecls
+ , tadBinders :: [IfaceTyConBinder]
+ , tadCtx :: IfaceContext
+ , tadParent :: IfaceTyConParent
+ , tadGADTSyntax :: Bool
+ }
+
+
+--data TypeAnnConDecl = MkTacd
+
+instance Outputable TypeAnnDataDecl where
+ ppr = pprTypeAnnDataDecl
+
+
+pprTypeAnnDataDecl :: TypeAnnDataDecl -> SDoc
+pprTypeAnnDataDecl (MkTadd {tadTypeCons = tycon,
+ tadArguments = args,
+ tadCons = conss,
+ tadBinders = binders,
+ tadParent = parent,
+ tadCtx = ctx,
+ tadGADTSyntax = gadt})
+
+ | gadt = vcat [pp_tycon_applied <+> pp_where
+ ,nest 2 (vcat pp_conss)]
+ | otherwise = hang pp_tycon_applied 2 (add_bars pp_conss)
+ where
+ pp_tycon_applied = ppr tycon <+> hsep (map ppr args)
+ pp_where = text "where"
+ pp_conss = [text "Blah Cons", text "Cons Blah", text "Foo Bar"] -- map show_con conss
+
+ show_con = undefined --pprIfaceConDecl showToHeader gadt tycon binders parent
+
+ add_bars [] = empty
+ add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs)
+
+ifaceDeclToTypeAnnDataDecl :: IfaceDecl -> Maybe TypeAnnDataDecl
+ifaceDeclToTypeAnnDataDecl = undefined
-----------------------------------------------------------------------------
-- :main
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8aa6a145748602b4b68c836518bd8f8c426862b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8aa6a145748602b4b68c836518bd8f8c426862b
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/20240504/dd348ca7/attachment-0001.html>
More information about the ghc-commits
mailing list