[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