Add RecordConstructor

mihaimaruseac · Mar 15, 2024 · 65ba306 · 65ba306
1 parent a388c14
commit 65ba306
Showing 1 changed file with 36 additions and 24 deletions.
diff --git a/src/HIndent/Ast/Declaration/Data/Body.hs b/src/HIndent/Ast/Declaration/Data/Body.hs
@@ -1,37 +1,49 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP             #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns    #-}
 
 module HIndent.Ast.Declaration.Data.Body
   ( DataBody
   , mkDataBody
   ) where
 
-import Control.Monad
-import Data.Maybe
-import qualified GHC.Types.SrcLoc as GHC
-import HIndent.Applicative
-import HIndent.Ast.Declaration.Data.GADT.Constructor
-import HIndent.Ast.NodeComments
-import HIndent.Ast.Type
-import HIndent.Ast.WithComments
-import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
-import {-# SOURCE #-} HIndent.Pretty
-import HIndent.Pretty.Combinators
-import HIndent.Pretty.NodeComments
+import                          Control.Monad
+import                          Data.Maybe
+import                qualified GHC.Types.SrcLoc                              as GHC
+import                          HIndent.Applicative
+import                          HIndent.Ast.Declaration.Data.GADT.Constructor
+import                          HIndent.Ast.NodeComments
+import                          HIndent.Ast.Type
+import                          HIndent.Ast.WithComments
+import                qualified HIndent.GhcLibParserWrapper.GHC.Hs            as GHC
+import {-# SOURCE #-}           HIndent.Pretty
+import                          HIndent.Pretty.Combinators
+import                          HIndent.Pretty.NodeComments
+
+newtype RecordConstructor =
+  RecordConstructor (GHC.LConDecl GHC.GhcPs)
+
+instance CommentExtraction RecordConstructor where
+  nodeComments RecordConstructor {} = NodeComments [] [] []
+
+instance Pretty RecordConstructor where
+  pretty' (RecordConstructor x) = pretty x
+
+mkRecordConstructor :: GHC.LConDecl GHC.GhcPs -> RecordConstructor
+mkRecordConstructor = RecordConstructor
 
 data DataBody
   = GADT
-      { kind :: Maybe (WithComments Type)
+      { kind         :: Maybe (WithComments Type)
       , constructors :: [WithComments GADTConstructor]
       }
   | Record
-      { dd_cons :: [GHC.LConDecl GHC.GhcPs]
+      { dd_cons   :: [RecordConstructor]
       , dd_derivs :: GHC.HsDeriving GHC.GhcPs
       }
 
 instance CommentExtraction DataBody where
-  nodeComments GADT {} = NodeComments [] [] []
+  nodeComments GADT {}   = NodeComments [] [] []
   nodeComments Record {} = NodeComments [] [] []
 
 instance Pretty DataBody where
@@ -42,7 +54,7 @@ instance Pretty DataBody where
   pretty' Record {..} = do
     case dd_cons of
       [] -> indentedBlock derivingsAfterNewline
-      [x@(GHC.L _ GHC.ConDeclH98 {con_args = GHC.RecCon {}})] -> do
+      [RecordConstructor (x@(GHC.L _ GHC.ConDeclH98 {con_args = GHC.RecCon {}}))] -> do
         string " = "
         pretty x
         unless (null dd_derivs) $ space |=> printDerivings
@@ -67,24 +79,24 @@ mkDataBody defn@GHC.HsDataDefn {..} =
   if isGADT defn
     then GADT
            { constructors =
-               fromMaybe (error "Some constructors are not GADT ones.")
-                 $ mapM (traverse mkGADTConstructor . fromGenLocated)
-                 $ getConDecls defn
+               fromMaybe (error "Some constructors are not GADT ones.") $
+               mapM (traverse mkGADTConstructor . fromGenLocated) $
+               getConDecls defn
            , ..
            }
-    else Record {dd_cons = getConDecls defn, ..}
+    else Record {dd_cons = fmap mkRecordConstructor $ getConDecls defn, ..}
   where
     kind = fmap mkType . fromGenLocated <$> dd_kindSig
 
 isGADT :: GHC.HsDataDefn GHC.GhcPs -> Bool
 isGADT (getConDecls -> (GHC.L _ GHC.ConDeclGADT {}:_)) = True
-isGADT _ = False
+isGADT _                                               = False
 
 getConDecls :: GHC.HsDataDefn GHC.GhcPs -> [GHC.LConDecl GHC.GhcPs]
 #if MIN_VERSION_ghc_lib_parser(9, 6, 0)
 getConDecls GHC.HsDataDefn {..} =
   case dd_cons of
-    GHC.NewTypeCon x -> [x]
+    GHC.NewTypeCon x      -> [x]
     GHC.DataTypeCons _ xs -> xs
 #else
 getConDecls GHC.HsDataDefn {..} = dd_cons