From 4c051c2461f29ae5f8b9ff34db473de2b738cae7 Mon Sep 17 00:00:00 2001 From: Hiroki Tokunaga Date: Mon, 9 Jan 2023 18:54:54 +0900 Subject: [PATCH 1/5] Fix not printing data family instances inside a class inst --- TESTS.md | 11 ++++++ .../ModulePreprocessing/CommentRelocation.hs | 2 +- src/HIndent/Pretty.hs | 24 +++++++++---- src/HIndent/Pretty/NodeComments.hs | 7 ++++ src/HIndent/Pretty/SigBindFamily.hs | 12 ++++--- src/HIndent/Pretty/Types.hs | 36 +++++++++++++++++++ 6 files changed, 81 insertions(+), 11 deletions(-) diff --git a/TESTS.md b/TESTS.md index 9333b9f82..2a82942c5 100644 --- a/TESTS.md +++ b/TESTS.md @@ -540,6 +540,17 @@ instance (Show a) => Show (Foo a) where show = undefined ``` +With associated data types + +```haskell +-- https://github.com/mihaimaruseac/hindent/issues/493 +instance GM 'Practice where + data MatchConfig 'Practice = MatchConfig'Practice + { teamSize :: Int + , ladder :: Ladder + } +``` + #### With overlapping pragmas `OVERLAPPING` diff --git a/src/HIndent/ModulePreprocessing/CommentRelocation.hs b/src/HIndent/ModulePreprocessing/CommentRelocation.hs index 819eb637a..9e02b2cb6 100644 --- a/src/HIndent/ModulePreprocessing/CommentRelocation.hs +++ b/src/HIndent/ModulePreprocessing/CommentRelocation.hs @@ -167,7 +167,7 @@ relocateCommentsTopLevelWhereClause m@HsModule {..} = do bindsSigs' <- mapM addCommentsBeforeEpAnn bindsSigs pure (listToBag $ filterLBind bindsSigs', filterLSig bindsSigs') where - bindsSigs = mkSortedLSigBindFamilyList sigs (bagToList binds) [] [] + bindsSigs = mkSortedLSigBindFamilyList sigs (bagToList binds) [] [] [] addCommentsBeforeEpAnn (L (SrcSpanAnn epa@EpAnn {..} sp) x) = do cs <- get let (notAbove, above) = diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs index 75eff81e9..bbe62c570 100644 --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -286,7 +286,7 @@ prettyTyClDecl ClassDecl {..} = do spacePrefixed $ fmap pretty xs _ -> error "Not enough parameters are given." sigsMethodsFamilies = - mkSortedLSigBindFamilyList tcdSigs (bagToList tcdMeths) tcdATs [] + mkSortedLSigBindFamilyList tcdSigs (bagToList tcdMeths) tcdATs [] [] instance Pretty (InstDecl GhcPs) where pretty' ClsInstD {..} = pretty cid_inst @@ -446,6 +446,7 @@ instance Pretty (ClsInstDecl GhcPs) where (bagToList cid_binds) [] cid_tyfam_insts + cid_datafam_insts instance Pretty (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where pretty' MG {..} = printCommentsAnd mg_alts (lined . fmap pretty) @@ -1330,6 +1331,7 @@ instance Pretty SigBindFamily where pretty' (Bind x) = pretty x pretty' (TypeFamily x) = pretty x pretty' (TyFamInst x) = pretty x + pretty' (DataFamInst x) = pretty $ DataFamInstDeclInsideClassInst x instance Pretty EpaComment where pretty' EpaComment {..} = pretty ac_tok @@ -1344,7 +1346,8 @@ instance Pretty (HsLocalBindsLR GhcPs GhcPs) where instance Pretty (HsValBindsLR GhcPs GhcPs) where pretty' (ValBinds _ methods sigs) = lined $ fmap pretty sigsAndMethods where - sigsAndMethods = mkSortedLSigBindFamilyList sigs (bagToList methods) [] [] + sigsAndMethods = + mkSortedLSigBindFamilyList sigs (bagToList methods) [] [] [] pretty' XValBindsLR {} = notUsedInParsedStage instance Pretty (HsTupArg GhcPs) where @@ -1729,10 +1732,15 @@ instance Pretty (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where pretty feqn_rhs -- | Pretty-print a data instance. -instance Pretty (FamEqn GhcPs (HsDataDefn GhcPs)) where - pretty' FamEqn {..} = do - spaced $ string "data instance" : pretty feqn_tycon : fmap pretty feqn_pats +instance Pretty FamEqn' where + pretty' FamEqn' {famEqn = FamEqn {..}, ..} = do + spaced $ string prefix : pretty feqn_tycon : fmap pretty feqn_pats pretty feqn_rhs + where + prefix = + case famEqnFor of + DataFamInstDeclForTopLevel -> "data instance" + DataFamInstDeclForInsideClassInst -> "data" -- | HsArg (LHsType GhcPs) (LHsType GhcPs) instance Pretty @@ -1908,7 +1916,11 @@ instance Pretty TopLevelTyFamInstDecl where string "type instance " >> pretty tfid_eqn instance Pretty (DataFamInstDecl GhcPs) where - pretty' DataFamInstDecl {..} = pretty dfid_eqn + pretty' = pretty' . DataFamInstDeclTopLevel + +instance Pretty DataFamInstDecl' where + pretty' DataFamInstDecl' {dataFamInstDecl = DataFamInstDecl {..}, ..} = + pretty $ FamEqn' dataFamInstDeclFor dfid_eqn instance Pretty (PatSynBind GhcPs GhcPs) where pretty' PSB {..} = do diff --git a/src/HIndent/Pretty/NodeComments.hs b/src/HIndent/Pretty/NodeComments.hs index 54fda4564..b1b6c05f0 100644 --- a/src/HIndent/Pretty/NodeComments.hs +++ b/src/HIndent/Pretty/NodeComments.hs @@ -374,6 +374,7 @@ instance CommentExtraction SigBindFamily where nodeComments (Bind x) = nodeComments x nodeComments (TypeFamily x) = nodeComments x nodeComments (TyFamInst x) = nodeComments x + nodeComments (DataFamInst x) = nodeComments x instance CommentExtraction EpaComment where nodeComments EpaComment {} = emptyNodeComments @@ -576,6 +577,9 @@ instance CommentExtraction (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where nodeComments FamEqn {..} = nodeComments feqn_ext +instance CommentExtraction FamEqn' where + nodeComments FamEqn' {..} = nodeComments famEqn + -- | Pretty-print a data instance. instance CommentExtraction (FamEqn GhcPs (HsDataDefn GhcPs)) where nodeComments FamEqn {..} = nodeComments feqn_ext @@ -684,6 +688,9 @@ instance CommentExtraction TopLevelTyFamInstDecl where instance CommentExtraction (DataFamInstDecl GhcPs) where nodeComments DataFamInstDecl {} = emptyNodeComments +instance CommentExtraction DataFamInstDecl' where + nodeComments DataFamInstDecl' {..} = nodeComments dataFamInstDecl + instance CommentExtraction (PatSynBind GhcPs GhcPs) where nodeComments PSB {..} = nodeComments psb_ext diff --git a/src/HIndent/Pretty/SigBindFamily.hs b/src/HIndent/Pretty/SigBindFamily.hs index 0955b02d1..5c1c043b4 100644 --- a/src/HIndent/Pretty/SigBindFamily.hs +++ b/src/HIndent/Pretty/SigBindFamily.hs @@ -24,6 +24,7 @@ data SigBindFamily | Bind (HsBindLR GhcPs GhcPs) | TypeFamily (FamilyDecl GhcPs) | TyFamInst (TyFamInstDecl GhcPs) + | DataFamInst (DataFamInstDecl GhcPs) -- | 'SigBindFamily' with the location information. type LSigBindFamily = GenLocated SrcSpanAnnA SigBindFamily @@ -35,10 +36,11 @@ mkSortedLSigBindFamilyList :: -> [LHsBindLR GhcPs GhcPs] -> [LFamilyDecl GhcPs] -> [LTyFamInstDecl GhcPs] + -> [LDataFamInstDecl GhcPs] -> [LSigBindFamily] -mkSortedLSigBindFamilyList sigs binds fams = +mkSortedLSigBindFamilyList sigs binds fams datafams = sortBy (compare `on` realSrcSpan . locA . getLoc) . - mkLSigBindFamilyList sigs binds fams + mkLSigBindFamilyList sigs binds fams datafams -- | Creates a list of 'LSigBindFamily' from arguments. mkLSigBindFamilyList :: @@ -46,11 +48,13 @@ mkLSigBindFamilyList :: -> [LHsBindLR GhcPs GhcPs] -> [LFamilyDecl GhcPs] -> [LTyFamInstDecl GhcPs] + -> [LDataFamInstDecl GhcPs] -> [LSigBindFamily] -mkLSigBindFamilyList sigs binds fams insts = +mkLSigBindFamilyList sigs binds fams insts datafams = fmap (fmap Sig) sigs ++ fmap (fmap Bind) binds ++ - fmap (fmap TypeFamily) fams ++ fmap (fmap TyFamInst) insts + fmap (fmap TypeFamily) fams ++ + fmap (fmap TyFamInst) insts ++ fmap (fmap DataFamInst) datafams -- | Filters out 'Sig's and extract the wrapped values. filterLSig :: [LSigBindFamily] -> [LSig GhcPs] diff --git a/src/HIndent/Pretty/Types.hs b/src/HIndent/Pretty/Types.hs index dd1ffa916..86f03da56 100644 --- a/src/HIndent/Pretty/Types.hs +++ b/src/HIndent/Pretty/Types.hs @@ -25,6 +25,12 @@ module HIndent.Pretty.Types , pattern HsTypeInsideDeclSig , pattern HsTypeInsideInstDecl , pattern HsTypeWithVerticalAppTy + , DataFamInstDecl'(..) + , pattern DataFamInstDeclTopLevel + , pattern DataFamInstDeclInsideClassInst + , FamEqn'(..) + , pattern FamEqnTopLevel + , pattern FamEqnInsideClassInst , StmtLRInsideVerticalList(..) , ParStmtBlockInsideVerticalList(..) , DeclSig(..) @@ -46,6 +52,7 @@ module HIndent.Pretty.Types , HsTypeFor(..) , HsTypeDir(..) , CaseOrCases(..) + , DataFamInstDeclFor(..) ) where import GHC.Hs @@ -156,6 +163,30 @@ pattern HsTypeInsideInstDecl x = HsType' HsTypeForInstDecl HsTypeNoDir x pattern HsTypeWithVerticalAppTy :: HsType GhcPs -> HsType' pattern HsTypeWithVerticalAppTy x = HsType' HsTypeForVerticalAppTy HsTypeVertical x +-- | A wrapper of `DataFamInstDecl`. +data DataFamInstDecl' = DataFamInstDecl' + { dataFamInstDeclFor :: DataFamInstDeclFor -- ^ Where a data family instance is declared. + , dataFamInstDecl :: DataFamInstDecl GhcPs -- ^ The actual value. + } + +pattern DataFamInstDeclTopLevel :: DataFamInstDecl GhcPs -> DataFamInstDecl' +pattern DataFamInstDeclTopLevel x = DataFamInstDecl' DataFamInstDeclForTopLevel x + +pattern DataFamInstDeclInsideClassInst :: DataFamInstDecl GhcPs -> DataFamInstDecl' +pattern DataFamInstDeclInsideClassInst x = DataFamInstDecl' DataFamInstDeclForInsideClassInst x + +-- | A wrapper for `FamEqn`. +data FamEqn' = FamEqn' + { famEqnFor :: DataFamInstDeclFor -- ^ Where a data family instance is declared. + , famEqn :: FamEqn GhcPs (HsDataDefn GhcPs) + } + +pattern FamEqnTopLevel :: FamEqn GhcPs (HsDataDefn GhcPs) -> FamEqn' +pattern FamEqnTopLevel x = FamEqn' DataFamInstDeclForTopLevel x + +pattern FamEqnInsideClassInst :: FamEqn GhcPs (HsDataDefn GhcPs) -> FamEqn' +pattern FamEqnInsideClassInst x = FamEqn' DataFamInstDeclForInsideClassInst x + -- | `StmtLR` inside a vertically printed list. newtype StmtLRInsideVerticalList = StmtLRInsideVerticalList (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) @@ -290,3 +321,8 @@ data HsTypeDir data CaseOrCases = Case | Cases + +-- | Values indicating where a data family instance is declared. +data DataFamInstDeclFor + = DataFamInstDeclForTopLevel + | DataFamInstDeclForInsideClassInst From 9af0444a14283f4433f9c83ba33d108332691756 Mon Sep 17 00:00:00 2001 From: Hiroki Tokunaga Date: Mon, 9 Jan 2023 18:59:57 +0900 Subject: [PATCH 2/5] Keep an instance for the original type --- src/HIndent/Pretty.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs index bbe62c570..74f690fa2 100644 --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -1732,6 +1732,9 @@ instance Pretty (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where pretty feqn_rhs -- | Pretty-print a data instance. +instance Pretty (FamEqn GhcPs (HsDataDefn GhcPs)) where + pretty' = pretty' . FamEqnTopLevel + instance Pretty FamEqn' where pretty' FamEqn' {famEqn = FamEqn {..}, ..} = do spaced $ string prefix : pretty feqn_tycon : fmap pretty feqn_pats From 80e0207baee780dd1054dea1c41ec2cd0d5e1047 Mon Sep 17 00:00:00 2001 From: Hiroki Tokunaga Date: Mon, 9 Jan 2023 19:02:34 +0900 Subject: [PATCH 3/5] Add comments --- src/HIndent/Pretty/Types.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/HIndent/Pretty/Types.hs b/src/HIndent/Pretty/Types.hs index 86f03da56..6fbb03063 100644 --- a/src/HIndent/Pretty/Types.hs +++ b/src/HIndent/Pretty/Types.hs @@ -169,9 +169,13 @@ data DataFamInstDecl' = DataFamInstDecl' , dataFamInstDecl :: DataFamInstDecl GhcPs -- ^ The actual value. } +-- | `DataFamInstDecl'` wrapping a `DataFamInstDecl` representing +-- a top-level data family instance. pattern DataFamInstDeclTopLevel :: DataFamInstDecl GhcPs -> DataFamInstDecl' pattern DataFamInstDeclTopLevel x = DataFamInstDecl' DataFamInstDeclForTopLevel x +-- | `DataFamInstDecl'` wrapping a `DataFamInstDecl` representing a data +-- family instance inside a class instance. pattern DataFamInstDeclInsideClassInst :: DataFamInstDecl GhcPs -> DataFamInstDecl' pattern DataFamInstDeclInsideClassInst x = DataFamInstDecl' DataFamInstDeclForInsideClassInst x @@ -181,9 +185,13 @@ data FamEqn' = FamEqn' , famEqn :: FamEqn GhcPs (HsDataDefn GhcPs) } +-- | `FamEqn'` wrapping a `FamEqn` representing a top-level data family +-- instance. pattern FamEqnTopLevel :: FamEqn GhcPs (HsDataDefn GhcPs) -> FamEqn' pattern FamEqnTopLevel x = FamEqn' DataFamInstDeclForTopLevel x +-- | `FamEqn'` wrapping a `FamEqn` representing a data family instance +-- inside a class instance. pattern FamEqnInsideClassInst :: FamEqn GhcPs (HsDataDefn GhcPs) -> FamEqn' pattern FamEqnInsideClassInst x = FamEqn' DataFamInstDeclForInsideClassInst x From 8d1a98e705d1eb0d46c84c3be22fdbb0afd16448 Mon Sep 17 00:00:00 2001 From: Hiroki Tokunaga Date: Mon, 9 Jan 2023 19:04:41 +0900 Subject: [PATCH 4/5] Update a comment --- src/HIndent/Pretty/SigBindFamily.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/HIndent/Pretty/SigBindFamily.hs b/src/HIndent/Pretty/SigBindFamily.hs index 5c1c043b4..814d3e224 100644 --- a/src/HIndent/Pretty/SigBindFamily.hs +++ b/src/HIndent/Pretty/SigBindFamily.hs @@ -17,8 +17,8 @@ import Data.Maybe import GHC.Hs import GHC.Types.SrcLoc --- | A sum type containing one of those: 'Sig', 'HsBindLR', and --- 'FamilyDecl'. +-- | A sum type containing one of those: function signature, function +-- binding, type family, type family instance, and data family instance. data SigBindFamily = Sig (Sig GhcPs) | Bind (HsBindLR GhcPs GhcPs) From a71f9564e2a1a285115fcc9556fce049fbb7bd0f Mon Sep 17 00:00:00 2001 From: Hiroki Tokunaga Date: Mon, 9 Jan 2023 19:05:39 +0900 Subject: [PATCH 5/5] Add a changelog --- CHANGELOG.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7da998db1..449388c48 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,6 +18,11 @@ - A long type-level list is broken into multiple lines. ([#665]). - Spaces around typed expression brackets are removed ([#666]). +### Fixed + +- Fixed the wrong formatting of data family instances inside class instances + ([#667]). + ### Removed - Test functions except `testAst`. @@ -307,6 +312,7 @@ This version is accidentally pushlished, and is the same as 5.3.3. [@uhbif19]: https://github.com/uhbif19 [@toku-sa-n]: https://github.com/toku-sa-n +[#667]: https://github.com/mihaimaruseac/hindent/pull/667 [#666]: https://github.com/mihaimaruseac/hindent/pull/666 [#665]: https://github.com/mihaimaruseac/hindent/pull/665 [#664]: https://github.com/mihaimaruseac/hindent/pull/664