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