1{-# LANGUAGE LambdaCase #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE PatternSynonyms #-} 4{-# LANGUAGE RecordWildCards #-} 5{-# LANGUAGE ViewPatterns #-} 6 7-- | Rendering of declarations. 8module Ormolu.Printer.Meat.Declaration 9 ( p_hsDecls, 10 p_hsDeclsRespectGrouping, 11 ) 12where 13 14import Data.List (sort) 15import Data.List.NonEmpty (NonEmpty (..), (<|)) 16import qualified Data.List.NonEmpty as NE 17import GHC.Hs 18import GHC.Types.Name.Occurrence (occNameFS) 19import GHC.Types.Name.Reader 20import GHC.Types.SrcLoc 21import Ormolu.Config (SourceType (SignatureSource)) 22import Ormolu.Printer.Combinators 23import Ormolu.Printer.Internal (askSourceType) 24import Ormolu.Printer.Meat.Common 25import Ormolu.Printer.Meat.Declaration.Annotation 26import Ormolu.Printer.Meat.Declaration.Class 27import Ormolu.Printer.Meat.Declaration.Data 28import Ormolu.Printer.Meat.Declaration.Default 29import Ormolu.Printer.Meat.Declaration.Foreign 30import Ormolu.Printer.Meat.Declaration.Instance 31import Ormolu.Printer.Meat.Declaration.RoleAnnotation 32import Ormolu.Printer.Meat.Declaration.Rule 33import Ormolu.Printer.Meat.Declaration.Signature 34import Ormolu.Printer.Meat.Declaration.Splice 35import Ormolu.Printer.Meat.Declaration.Type 36import Ormolu.Printer.Meat.Declaration.TypeFamily 37import Ormolu.Printer.Meat.Declaration.Value 38import Ormolu.Printer.Meat.Declaration.Warning 39import Ormolu.Printer.Meat.Type 40import Ormolu.Utils 41 42data UserGrouping 43 = -- | Always put newlines where we think they should be 44 Disregard 45 | -- | Respect user preferences regarding grouping 46 Respect 47 deriving (Eq, Show) 48 49p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R () 50p_hsDecls = p_hsDecls' Disregard 51 52-- | Like 'p_hsDecls' but respects user choices regarding grouping. If the 53-- user omits newlines between declarations, we also omit them in most 54-- cases, except when said declarations have associated Haddocks. 55-- 56-- Does some normalization (compress subsequent newlines into a single one) 57p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R () 58p_hsDeclsRespectGrouping = p_hsDecls' Respect 59 60p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R () 61p_hsDecls' grouping style decls = do 62 isSig <- (== SignatureSource) <$> askSourceType 63 sepSemi id $ 64 -- Return a list of rendered declarations, adding a newline to separate 65 -- groups. 66 case groupDecls isSig decls of 67 [] -> [] 68 (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs) 69 where 70 renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style) 71 renderGroupWithPrev prev curr = 72 -- We can omit a blank line when the user didn't add one, but we must 73 -- ensure we always add blank lines around documented declarations 74 case grouping of 75 Disregard -> 76 breakpoint : renderGroup curr 77 Respect -> 78 if separatedByBlankNE getLocA prev curr 79 || isDocumented prev 80 || isDocumented curr 81 then breakpoint : renderGroup curr 82 else renderGroup curr 83 84-- | Is a declaration group documented? 85isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool 86isDocumented = any (isHaddock . unLoc) 87 where 88 isHaddock DocNext = True 89 isHaddock DocPrev = True 90 isHaddock _ = False 91 92-- | Group relevant declarations together. 93groupDecls :: 94 -- | Is the source a signature file? 95 Bool -> 96 -- | List of declarations 97 [LHsDecl GhcPs] -> 98 [NonEmpty (LHsDecl GhcPs)] 99groupDecls _ [] = [] 100groupDecls isSig (l@(L _ DocNext) : xs) = 101 -- If the first element is a doc string for next element, just include it 102 -- in the next block: 103 case groupDecls isSig xs of 104 [] -> [l :| []] 105 (x : xs') -> (l <| x) : xs' 106groupDecls isSig (header : xs) = 107 let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) -> 108 let relevantToHdr = groupedDecls header current 109 relevantToPrev = groupedDecls previous current 110 isDeclSeries = not isSig && declSeries previous current 111 in isDeclSeries || relevantToHdr || relevantToPrev 112 in (header :| map snd grp) : groupDecls isSig (map snd rest) 113 114p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R () 115p_hsDecl style = \case 116 TyClD _ x -> p_tyClDecl style x 117 ValD _ x -> p_valDecl x 118 SigD _ x -> p_sigDecl x 119 InstD _ x -> p_instDecl style x 120 DerivD _ x -> p_standaloneDerivDecl x 121 DefD _ x -> p_defaultDecl x 122 ForD _ x -> p_foreignDecl x 123 WarningD _ x -> p_warnDecls x 124 AnnD _ x -> p_annDecl x 125 RuleD _ x -> p_ruleDecls x 126 SpliceD _ x -> p_spliceDecl x 127 DocD _ docDecl -> 128 case docDecl of 129 DocCommentNext str -> p_hsDocString Pipe False (noLoc str) 130 DocCommentPrev str -> p_hsDocString Caret False (noLoc str) 131 DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str) 132 DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str) 133 RoleAnnotD _ x -> p_roleAnnot x 134 KindSigD _ s -> p_standaloneKindSig s 135 136p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R () 137p_tyClDecl style = \case 138 FamDecl _ x -> p_famDecl style x 139 SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs 140 DataDecl {..} -> 141 p_dataDecl 142 Associated 143 tcdLName 144 (tyVarsToTyPats tcdTyVars) 145 tcdFixity 146 tcdDataDefn 147 ClassDecl {..} -> 148 p_classDecl 149 tcdCtxt 150 tcdLName 151 tcdTyVars 152 tcdFixity 153 tcdFDs 154 tcdSigs 155 tcdMeths 156 tcdATs 157 tcdATDefs 158 tcdDocs 159 160p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R () 161p_instDecl style = \case 162 ClsInstD _ x -> p_clsInstDecl x 163 TyFamInstD _ x -> p_tyFamInstDecl style x 164 DataFamInstD _ x -> p_dataFamInstDecl style x 165 166-- | Determine if these declarations should be grouped together. 167groupedDecls :: 168 LHsDecl GhcPs -> 169 LHsDecl GhcPs -> 170 Bool 171groupedDecls (L (locA -> l_x) x') (L (locA -> l_y) y') = 172 case (x', y') of 173 (TypeSignature ns, FunctionBody ns') -> ns `intersects` ns' 174 (TypeSignature ns, DefaultSignature ns') -> ns `intersects` ns' 175 (DefaultSignature ns, TypeSignature ns') -> ns `intersects` ns' 176 (DefaultSignature ns, FunctionBody ns') -> ns `intersects` ns' 177 (x, FunctionBody ns) | Just ns' <- isPragma x -> ns `intersects` ns' 178 (FunctionBody ns, x) | Just ns' <- isPragma x -> ns `intersects` ns' 179 (x, DataDeclaration n) | Just ns <- isPragma x -> n `elem` ns 180 (DataDeclaration n, x) 181 | Just ns <- isPragma x -> 182 let f = occNameFS . rdrNameOcc in f n `elem` map f ns 183 (x, y) 184 | Just ns <- isPragma x, 185 Just ns' <- isPragma y -> 186 ns `intersects` ns' 187 (x, TypeSignature ns) | Just ns' <- isPragma x -> ns `intersects` ns' 188 (TypeSignature ns, x) | Just ns' <- isPragma x -> ns `intersects` ns' 189 (PatternSignature ns, Pattern n) -> n `elem` ns 190 (KindSignature n, DataDeclaration n') -> n == n' 191 (KindSignature n, ClassDeclaration n') -> n == n' 192 (KindSignature n, FamilyDeclaration n') -> n == n' 193 (KindSignature n, TypeSynonym n') -> n == n' 194 -- Special case for TH splices, we look at locations 195 (Splice, Splice) -> not (separatedByBlank id l_x l_y) 196 -- This looks only at Haddocks, normal comments are handled elsewhere 197 (DocNext, _) -> True 198 (_, DocPrev) -> True 199 _ -> False 200 201-- | Detect declaration series that should not have blanks between them. 202declSeries :: 203 LHsDecl GhcPs -> 204 LHsDecl GhcPs -> 205 Bool 206declSeries (L _ x) (L _ y) = 207 case (x, y) of 208 ( SigD _ (TypeSig _ _ _), 209 SigD _ (TypeSig _ _ _) 210 ) -> True 211 _ -> False 212 213intersects :: Ord a => [a] -> [a] -> Bool 214intersects a b = go (sort a) (sort b) 215 where 216 go :: Ord a => [a] -> [a] -> Bool 217 go _ [] = False 218 go [] _ = False 219 go (x : xs) (y : ys) 220 | x < y = go xs (y : ys) 221 | x > y = go (x : xs) ys 222 | otherwise = True 223 224isPragma :: 225 HsDecl GhcPs -> 226 Maybe [RdrName] 227isPragma = \case 228 InlinePragma n -> Just [n] 229 SpecializePragma n -> Just [n] 230 SCCPragma n -> Just [n] 231 AnnTypePragma n -> Just [n] 232 AnnValuePragma n -> Just [n] 233 WarningPragma n -> Just n 234 _ -> Nothing 235 236-- Declarations that do not refer to names 237 238pattern Splice :: HsDecl GhcPs 239pattern Splice <- SpliceD _ (SpliceDecl _ _ _) 240 241-- Declarations referring to a single name 242 243pattern 244 InlinePragma, 245 SpecializePragma, 246 SCCPragma, 247 AnnTypePragma, 248 AnnValuePragma, 249 Pattern, 250 DataDeclaration, 251 ClassDeclaration, 252 KindSignature, 253 FamilyDeclaration, 254 TypeSynonym :: 255 RdrName -> HsDecl GhcPs 256pattern InlinePragma n <- SigD _ (InlineSig _ (L _ n) _) 257pattern SpecializePragma n <- SigD _ (SpecSig _ (L _ n) _ _) 258pattern SCCPragma n <- SigD _ (SCCFunSig _ _ (L _ n) _) 259pattern AnnTypePragma n <- AnnD _ (HsAnnotation _ _ (TypeAnnProvenance (L _ n)) _) 260pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ _ (ValueAnnProvenance (L _ n)) _) 261pattern Pattern n <- ValD _ (PatSynBind _ (PSB _ (L _ n) _ _ _)) 262pattern DataDeclaration n <- TyClD _ (DataDecl _ (L _ n) _ _ _) 263pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _) 264pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _) 265pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _)) 266pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _) 267 268-- Declarations which can refer to multiple names 269 270pattern 271 TypeSignature, 272 DefaultSignature, 273 FunctionBody, 274 PatternSignature, 275 WarningPragma :: 276 [RdrName] -> HsDecl GhcPs 277pattern TypeSignature n <- (sigRdrNames -> Just n) 278pattern DefaultSignature n <- (defSigRdrNames -> Just n) 279pattern FunctionBody n <- (funRdrNames -> Just n) 280pattern PatternSignature n <- (patSigRdrNames -> Just n) 281pattern WarningPragma n <- (warnSigRdrNames -> Just n) 282 283pattern DocNext, DocPrev :: HsDecl GhcPs 284pattern DocNext <- (DocD _ (DocCommentNext _)) 285pattern DocPrev <- (DocD _ (DocCommentPrev _)) 286 287sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] 288sigRdrNames (SigD _ (TypeSig _ ns _)) = Just $ map unLoc ns 289sigRdrNames (SigD _ (ClassOpSig _ _ ns _)) = Just $ map unLoc ns 290sigRdrNames (SigD _ (PatSynSig _ ns _)) = Just $ map unLoc ns 291sigRdrNames _ = Nothing 292 293defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] 294defSigRdrNames (SigD _ (ClassOpSig _ True ns _)) = Just $ map unLoc ns 295defSigRdrNames _ = Nothing 296 297funRdrNames :: HsDecl GhcPs -> Maybe [RdrName] 298funRdrNames (ValD _ (FunBind _ (L _ n) _ _)) = Just [n] 299funRdrNames (ValD _ (PatBind _ (L _ n) _ _)) = Just $ patBindNames n 300funRdrNames _ = Nothing 301 302patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] 303patSigRdrNames (SigD _ (PatSynSig _ ns _)) = Just $ map unLoc ns 304patSigRdrNames _ = Nothing 305 306warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] 307warnSigRdrNames (WarningD _ (Warnings _ _ ws)) = Just $ 308 flip concatMap ws $ \(L _ (Warning _ ns _)) -> map unLoc ns 309warnSigRdrNames _ = Nothing 310 311patBindNames :: Pat GhcPs -> [RdrName] 312patBindNames (TuplePat _ ps _) = concatMap (patBindNames . unLoc) ps 313patBindNames (VarPat _ (L _ n)) = [n] 314patBindNames (WildPat _) = [] 315patBindNames (LazyPat _ (L _ p)) = patBindNames p 316patBindNames (BangPat _ (L _ p)) = patBindNames p 317patBindNames (ParPat _ (L _ p)) = patBindNames p 318patBindNames (ListPat _ ps) = concatMap (patBindNames . unLoc) ps 319patBindNames (AsPat _ (L _ n) (L _ p)) = n : patBindNames p 320patBindNames (SumPat _ (L _ p) _ _) = patBindNames p 321patBindNames (ViewPat _ _ (L _ p)) = patBindNames p 322patBindNames (SplicePat _ _) = [] 323patBindNames (LitPat _ _) = [] 324patBindNames (SigPat _ (L _ p) _) = patBindNames p 325patBindNames (NPat _ _ _ _) = [] 326patBindNames (NPlusKPat _ (L _ n) _ _ _ _) = [n] 327patBindNames (ConPat _ _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d) 328