From f07e0f8ea30c9e8f6fd74083e0ac7891ef7f145c Mon Sep 17 00:00:00 2001 From: Hiroki Tokunaga Date: Sat, 8 Jun 2024 01:20:53 +0900 Subject: [PATCH] Implement `OverlapMode` (#908) --- hindent.cabal | 1 + src/HIndent/Ast/Declaration/Instance/Class.hs | 9 +++-- .../Declaration/Instance/Class/OverlapMode.hs | 36 +++++++++++++++++++ src/HIndent/Pretty.hs | 28 --------------- src/HIndent/Pretty.hs-boot | 3 -- 5 files changed, 43 insertions(+), 34 deletions(-) create mode 100644 src/HIndent/Ast/Declaration/Instance/Class/OverlapMode.hs diff --git a/hindent.cabal b/hindent.cabal index bc0817187..80c259823 100644 --- a/hindent.cabal +++ b/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 diff --git a/src/HIndent/Ast/Declaration/Instance/Class.hs b/src/HIndent/Ast/Declaration/Instance/Class.hs index 96f70ba72..7d4a8d34a 100644 --- a/src/HIndent/Ast/Declaration/Instance/Class.hs +++ b/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 diff --git a/src/HIndent/Ast/Declaration/Instance/Class/OverlapMode.hs b/src/HIndent/Ast/Declaration/Instance/Class/OverlapMode.hs new file mode 100644 index 000000000..4d1cc0383 --- /dev/null +++ b/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 diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs index e0245a9b0..3277cd599 100644 --- a/src/HIndent/Pretty.hs +++ b/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 diff --git a/src/HIndent/Pretty.hs-boot b/src/HIndent/Pretty.hs-boot index b1ed1a336..66c5776ca 100644 --- a/src/HIndent/Pretty.hs-boot +++ b/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