Implement OverlapMode (#908)

hindent.cabal

@@ -68,6 +68,7 @@ library
       HIndent.Ast.Declaration.Foreign.CallingConvention
       HIndent.Ast.Declaration.Foreign.Safety
       HIndent.Ast.Declaration.Instance.Class
+      HIndent.Ast.Declaration.Instance.Class.OverlapMode
       HIndent.Ast.Declaration.Instance.Family.Data
       HIndent.Ast.Declaration.Instance.Family.Type
       HIndent.Ast.Declaration.Rule

src/HIndent/Ast/Declaration/Instance/Class.hs

@@ -7,9 +7,10 @@ module HIndent.Ast.Declaration.Instance.Class
 
 import Control.Monad
 import qualified GHC.Data.Bag as GHC
-import qualified GHC.Types.Basic as GHc
 import HIndent.Applicative
+import HIndent.Ast.Declaration.Instance.Class.OverlapMode
 import HIndent.Ast.NodeComments
+import HIndent.Ast.WithComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import {-# SOURCE #-} HIndent.Pretty
 import HIndent.Pretty.Combinators
@@ -18,7 +19,7 @@ import HIndent.Pretty.SigBindFamily
 import HIndent.Pretty.Types
 
 data ClassInstance = ClassInstance
-  { cid_overlap_mode :: Maybe (GHC.XRec GHC.GhcPs GHc.OverlapMode)
+  { overlapMode :: Maybe (WithComments OverlapMode)
   , cid_sigs :: [GHC.LSig GHC.GhcPs]
   , cid_binds :: GHC.LHsBinds GHC.GhcPs
   , cid_tyfam_insts :: [GHC.LTyFamInstDecl GHC.GhcPs]
@@ -32,7 +33,7 @@ instance CommentExtraction ClassInstance where
 instance Pretty ClassInstance where
   pretty' (ClassInstance {..}) = do
     string "instance " |=> do
-      whenJust cid_overlap_mode $ \x -> do
+      whenJust overlapMode $ \x -> do
         pretty x
         space
       pretty (fmap HsSigTypeInsideInstDecl cid_poly_ty)
@@ -52,4 +53,6 @@ instance Pretty ClassInstance where
 mkClassInstance :: GHC.InstDecl GHC.GhcPs -> Maybe ClassInstance
 mkClassInstance GHC.ClsInstD {cid_inst = GHC.ClsInstDecl {..}} =
   Just $ ClassInstance {..}
+  where
+    overlapMode = fmap (fmap mkOverlapMode . fromGenLocated) cid_overlap_mode
 mkClassInstance _ = Nothing

src/HIndent/Ast/Declaration/Instance/Class/OverlapMode.hs

@@ -0,0 +1,36 @@
+module HIndent.Ast.Declaration.Instance.Class.OverlapMode
+  ( OverlapMode
+  , mkOverlapMode
+  ) where
+
+import qualified GHC.Types.Basic as GHC
+import HIndent.Ast.NodeComments
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators.String
+import HIndent.Pretty.NodeComments
+
+data OverlapMode
+  = Overlappable
+  | Overlapping
+  | Overlaps
+  | Incoherent
+
+instance CommentExtraction OverlapMode where
+  nodeComments Overlappable = NodeComments [] [] []
+  nodeComments Overlapping = NodeComments [] [] []
+  nodeComments Overlaps = NodeComments [] [] []
+  nodeComments Incoherent = NodeComments [] [] []
+
+instance Pretty OverlapMode where
+  pretty' Overlappable = string "{-# OVERLAPPABLE #-}"
+  pretty' Overlapping = string "{-# OVERLAPPING #-}"
+  pretty' Overlaps = string "{-# OVERLAPS #-}"
+  pretty' Incoherent = string "{-# INCOHERENT #-}"
+
+mkOverlapMode :: GHC.OverlapMode -> OverlapMode
+mkOverlapMode GHC.NoOverlap {} =
+  error "This AST node should never appear in the tree"
+mkOverlapMode GHC.Overlappable {} = Overlappable
+mkOverlapMode GHC.Overlapping {} = Overlapping
+mkOverlapMode GHC.Overlaps {} = Overlaps
+mkOverlapMode GHC.Incoherent {} = Incoherent

src/HIndent/Pretty.hs

@@ -35,7 +35,6 @@ import qualified GHC.Types.Name as GHC
 import qualified GHC.Types.Name.Reader as GHC
 import qualified GHC.Types.SourceText as GHC
 import qualified GHC.Types.SrcLoc as GHC
-import HIndent.Applicative
 import HIndent.Ast.Declaration
 import HIndent.Ast.Declaration.Bind
 import HIndent.Ast.Declaration.Data.Body
@@ -134,26 +133,6 @@ class CommentExtraction a =>
 instance (CommentExtraction l, Pretty e) => Pretty (GHC.GenLocated l e) where
   pretty' (GHC.L _ e) = pretty e
 
-instance Pretty (GHC.ClsInstDecl GHC.GhcPs) where
-  pretty' GHC.ClsInstDecl {..} = do
-    string "instance " |=> do
-      whenJust cid_overlap_mode $ \x -> do
-        pretty x
-        space
-      pretty (fmap HsSigTypeInsideInstDecl cid_poly_ty)
-        |=> unless (null sigsAndMethods) (string " where")
-    unless (null sigsAndMethods) $ do
-      newline
-      indentedBlock $ lined $ fmap pretty sigsAndMethods
-    where
-      sigsAndMethods =
-        SBF.mkSortedLSigBindFamilyList
-          cid_sigs
-          (GHC.bagToList cid_binds)
-          []
-          cid_tyfam_insts
-          cid_datafam_insts
-
 instance Pretty
            (GHC.MatchGroup
               GHC.GhcPs
@@ -1215,13 +1194,6 @@ instance Pretty (GHC.DerivClauseTys GHC.GhcPs) where
   pretty' (GHC.DctSingle _ ty) = parens $ pretty ty
   pretty' (GHC.DctMulti _ ts) = hvTuple $ fmap pretty ts
 
-instance Pretty GHC.OverlapMode where
-  pretty' GHC.NoOverlap {} = notUsedInParsedStage
-  pretty' GHC.Overlappable {} = string "{-# OVERLAPPABLE #-}"
-  pretty' GHC.Overlapping {} = string "{-# OVERLAPPING #-}"
-  pretty' GHC.Overlaps {} = string "{-# OVERLAPS #-}"
-  pretty' GHC.Incoherent {} = string "{-# INCOHERENT #-}"
-
 instance Pretty GHC.StringLiteral where
   pretty' = output
 

src/HIndent/Pretty.hs-boot

@@ -8,7 +8,6 @@ module HIndent.Pretty
   ) where
 
 import           Data.Void
-import qualified GHC.Types.Basic                    as GHC
 import qualified GHC.Types.Name.Reader              as GHC
 import qualified GHC.Types.SourceText               as GHC
 import qualified GHC.Types.SrcLoc                   as GHC
@@ -47,8 +46,6 @@ instance Pretty SigBindFamily
 
 instance Pretty InfixOp
 
-instance Pretty GHC.OverlapMode
-
 instance Pretty HsSigType'
 
 instance Pretty