Fix not printing data family instances inside a class inst

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

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`

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) =

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
@@ -1730,9 +1733,17 @@ instance Pretty (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where
 
 -- | 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
+  pretty' = pretty' . FamEqnTopLevel
+
+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 +1919,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

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
 

src/HIndent/Pretty/SigBindFamily.hs

@@ -17,13 +17,14 @@ 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)
   | TypeFamily (FamilyDecl GhcPs)
   | TyFamInst (TyFamInstDecl GhcPs)
+  | DataFamInst (DataFamInstDecl GhcPs)
 
 -- | 'SigBindFamily' with the location information.
 type LSigBindFamily = GenLocated SrcSpanAnnA SigBindFamily
@@ -35,22 +36,25 @@ 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 ::
      [LSig GhcPs]
   -> [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]

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,38 @@ 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.
+  }
+
+-- | `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
+
+-- | A wrapper for `FamEqn`.
+data FamEqn' = FamEqn'
+  { famEqnFor :: DataFamInstDeclFor -- ^ Where a data family instance is declared.
+  , 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
+
 -- | `StmtLR` inside a vertically printed list.
 newtype StmtLRInsideVerticalList =
   StmtLRInsideVerticalList (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
@@ -290,3 +329,8 @@ data HsTypeDir
 data CaseOrCases
   = Case
   | Cases
+
+-- | Values indicating where a data family instance is declared.
+data DataFamInstDeclFor
+  = DataFamInstDeclForTopLevel
+  | DataFamInstDeclForInsideClassInst