1{-# LANGUAGE BangPatterns #-} 2-- needed on GHC 9.0 due to simplified subsumption 3{-# LANGUAGE ImpredicativeTypes #-} 4{-# LANGUAGE LambdaCase #-} 5{-# LANGUAGE NamedFieldPuns #-} 6{-# LANGUAGE RankNTypes #-} 7{-# LANGUAGE RecordWildCards #-} 8{-# LANGUAGE ScopedTypeVariables #-} 9{-# LANGUAGE ViewPatterns #-} 10 11-- | This module allows us to diff two 'ParseResult's. 12module Ormolu.Diff.ParseResult 13 ( ParseResultDiff (..), 14 diffParseResult, 15 ) 16where 17 18import Data.ByteString (ByteString) 19import Data.Foldable 20import Data.Generics 21import GHC.Hs 22import GHC.Types.SourceText 23import GHC.Types.SrcLoc 24import Ormolu.Parser.CommentStream 25import Ormolu.Parser.Result 26import Ormolu.Utils 27 28-- | Result of comparing two 'ParseResult's. 29data ParseResultDiff 30 = -- | Two parse results are the same 31 Same 32 | -- | Two parse results differ 33 Different [SrcSpan] 34 deriving (Show) 35 36instance Semigroup ParseResultDiff where 37 Same <> a = a 38 a <> Same = a 39 Different xs <> Different ys = Different (xs ++ ys) 40 41instance Monoid ParseResultDiff where 42 mempty = Same 43 44-- | Return 'Diff' of two 'ParseResult's. 45diffParseResult :: 46 ParseResult -> 47 ParseResult -> 48 ParseResultDiff 49diffParseResult 50 ParseResult 51 { prCommentStream = cstream0, 52 prParsedSource = hs0 53 } 54 ParseResult 55 { prCommentStream = cstream1, 56 prParsedSource = hs1 57 } = 58 diffCommentStream cstream0 cstream1 59 <> matchIgnoringSrcSpans hs0 hs1 60 61diffCommentStream :: CommentStream -> CommentStream -> ParseResultDiff 62diffCommentStream (CommentStream cs) (CommentStream cs') 63 | commentLines cs == commentLines cs' = Same 64 | otherwise = Different [] 65 where 66 commentLines = concatMap (toList . unComment . unLoc) 67 68-- | Compare two values for equality disregarding the following aspects: 69-- 70-- * 'SrcSpan's 71-- * ordering of import lists 72-- * style (ASCII vs Unicode) of arrows 73-- * LayoutInfo (brace style) in extension fields 74-- * Empty contexts in type classes 75-- * Parens around derived type classes 76matchIgnoringSrcSpans :: Data a => a -> a -> ParseResultDiff 77matchIgnoringSrcSpans a = genericQuery a 78 where 79 genericQuery :: GenericQ (GenericQ ParseResultDiff) 80 genericQuery x y 81 -- 'ByteString' implements 'Data' instance manually and does not 82 -- implement 'toConstr', so we have to deal with it in a special way. 83 | Just x' <- cast x, 84 Just y' <- cast y = 85 if x' == (y' :: ByteString) 86 then Same 87 else Different [] 88 | typeOf x == typeOf y, 89 toConstr x == toConstr y = 90 mconcat $ 91 gzipWithQ 92 ( genericQuery 93 `extQ` srcSpanEq 94 `ext1Q` epAnnEq 95 `extQ` sourceTextEq 96 `extQ` hsDocStringEq 97 `extQ` importDeclQualifiedStyleEq 98 `extQ` unicodeArrowStyleEq 99 `extQ` layoutInfoEq 100 `extQ` classDeclCtxEq 101 `extQ` derivedTyClsParensEq 102 `extQ` epaCommentsEq 103 `ext2Q` forLocated 104 ) 105 x 106 y 107 | otherwise = Different [] 108 srcSpanEq :: SrcSpan -> GenericQ ParseResultDiff 109 srcSpanEq _ _ = Same 110 epAnnEq :: EpAnn a -> GenericQ ParseResultDiff 111 epAnnEq _ _ = Same 112 sourceTextEq :: SourceText -> GenericQ ParseResultDiff 113 sourceTextEq _ _ = Same 114 importDeclQualifiedStyleEq :: 115 ImportDeclQualifiedStyle -> 116 GenericQ ParseResultDiff 117 importDeclQualifiedStyleEq d0 d1' = 118 case (d0, cast d1' :: Maybe ImportDeclQualifiedStyle) of 119 (x, Just x') | x == x' -> Same 120 (QualifiedPre, Just QualifiedPost) -> Same 121 (QualifiedPost, Just QualifiedPre) -> Same 122 _ -> Different [] 123 hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff 124 hsDocStringEq str0 str1' = 125 case cast str1' :: Maybe HsDocString of 126 Nothing -> Different [] 127 Just str1 -> 128 if splitDocString str0 == splitDocString str1 129 then Same 130 else Different [] 131 forLocated :: 132 (Data e0, Data e1) => 133 GenLocated e0 e1 -> 134 GenericQ ParseResultDiff 135 forLocated x@(L mspn _) y = 136 maybe id appendSpan (cast `ext1Q` (Just . locA) $ mspn) (genericQuery x y) 137 appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff 138 appendSpan s (Different ss) | fresh && helpful = Different (s : ss) 139 where 140 fresh = not $ any (`isSubspanOf` s) ss 141 helpful = isGoodSrcSpan s 142 appendSpan _ d = d 143 -- as we normalize arrow styles (e.g. -> vs →), we consider them equal here 144 unicodeArrowStyleEq :: HsArrow GhcPs -> GenericQ ParseResultDiff 145 unicodeArrowStyleEq (HsUnrestrictedArrow _) (castArrow -> Just (HsUnrestrictedArrow _)) = Same 146 unicodeArrowStyleEq (HsLinearArrow _ _) (castArrow -> Just (HsLinearArrow _ _)) = Same 147 unicodeArrowStyleEq (HsExplicitMult _ _ t) (castArrow -> Just (HsExplicitMult _ _ t')) = genericQuery t t' 148 unicodeArrowStyleEq _ _ = Different [] 149 castArrow :: Typeable a => a -> Maybe (HsArrow GhcPs) 150 castArrow = cast 151 -- LayoutInfo ~ XClassDecl GhcPs tracks brace information 152 layoutInfoEq :: LayoutInfo -> GenericQ ParseResultDiff 153 layoutInfoEq _ (cast -> Just (_ :: LayoutInfo)) = Same 154 layoutInfoEq _ _ = Different [] 155 classDeclCtxEq :: TyClDecl GhcPs -> GenericQ ParseResultDiff 156 classDeclCtxEq ClassDecl {tcdCtxt = Just (L _ []), ..} tc' = genericQuery ClassDecl {tcdCtxt = Nothing, ..} tc' 157 classDeclCtxEq tc tc' = genericQuery tc tc' 158 derivedTyClsParensEq :: DerivClauseTys GhcPs -> GenericQ ParseResultDiff 159 derivedTyClsParensEq (DctSingle NoExtField sigTy) dct' = genericQuery (DctMulti NoExtField [sigTy]) dct' 160 derivedTyClsParensEq dct dct' = genericQuery dct dct' 161 -- EpAnnComments ~ XCGRHSs GhcPs 162 epaCommentsEq :: EpAnnComments -> GenericQ ParseResultDiff 163 epaCommentsEq _ (cast -> Just (_ :: EpAnnComments)) = Same 164 epaCommentsEq _ _ = Different [] 165