{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeepSubsumption #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

-- | This module allows us to diff two 'ParseResult's.
module Ormolu.Diff.ParseResult
  ( ParseResultDiff (..),
    diffParseResult,
  )
where

import Data.ByteString (ByteString)
import Data.Foldable
import Data.Function
import Data.Generics
import GHC.Hs
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import Ormolu.Utils

-- | Result of comparing two 'ParseResult's.
data ParseResultDiff
  = -- | Two parse results are the same
    Same
  | -- | Two parse results differ
    Different [RealSrcSpan]
  deriving (Int -> ParseResultDiff -> ShowS
[ParseResultDiff] -> ShowS
ParseResultDiff -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseResultDiff] -> ShowS
$cshowList :: [ParseResultDiff] -> ShowS
show :: ParseResultDiff -> String
$cshow :: ParseResultDiff -> String
showsPrec :: Int -> ParseResultDiff -> ShowS
$cshowsPrec :: Int -> ParseResultDiff -> ShowS
Show)

instance Semigroup ParseResultDiff where
  ParseResultDiff
Same <> :: ParseResultDiff -> ParseResultDiff -> ParseResultDiff
<> ParseResultDiff
a = ParseResultDiff
a
  ParseResultDiff
a <> ParseResultDiff
Same = ParseResultDiff
a
  Different [RealSrcSpan]
xs <> Different [RealSrcSpan]
ys = [RealSrcSpan] -> ParseResultDiff
Different ([RealSrcSpan]
xs forall a. [a] -> [a] -> [a]
++ [RealSrcSpan]
ys)

instance Monoid ParseResultDiff where
  mempty :: ParseResultDiff
mempty = ParseResultDiff
Same

-- | Return 'Diff' of two 'ParseResult's.
diffParseResult ::
  ParseResult ->
  ParseResult ->
  ParseResultDiff
diffParseResult :: ParseResult -> ParseResult -> ParseResultDiff
diffParseResult
  ParseResult
    { prCommentStream :: ParseResult -> CommentStream
prCommentStream = CommentStream
cstream0,
      prParsedSource :: ParseResult -> HsModule GhcPs
prParsedSource = HsModule GhcPs
hs0
    }
  ParseResult
    { prCommentStream :: ParseResult -> CommentStream
prCommentStream = CommentStream
cstream1,
      prParsedSource :: ParseResult -> HsModule GhcPs
prParsedSource = HsModule GhcPs
hs1
    } =
    CommentStream -> CommentStream -> ParseResultDiff
diffCommentStream CommentStream
cstream0 CommentStream
cstream1
      forall a. Semigroup a => a -> a -> a
<> HsModule GhcPs -> HsModule GhcPs -> ParseResultDiff
diffHsModule HsModule GhcPs
hs0 HsModule GhcPs
hs1

diffCommentStream :: CommentStream -> CommentStream -> ParseResultDiff
diffCommentStream :: CommentStream -> CommentStream -> ParseResultDiff
diffCommentStream (CommentStream [RealLocated Comment]
cs) (CommentStream [RealLocated Comment]
cs')
  | forall {l}. [GenLocated l Comment] -> [Text]
commentLines [RealLocated Comment]
cs forall a. Eq a => a -> a -> Bool
== forall {l}. [GenLocated l Comment] -> [Text]
commentLines [RealLocated Comment]
cs' = ParseResultDiff
Same
  | Bool
otherwise = [RealSrcSpan] -> ParseResultDiff
Different []
  where
    commentLines :: [GenLocated l Comment] -> [Text]
commentLines = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> NonEmpty Text
unComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)

-- | Compare two modules for equality disregarding the following aspects:
--
--     * 'SrcSpan's
--     * ordering of import lists
--     * style (ASCII vs Unicode) of arrows, colons
--     * LayoutInfo (brace style) in extension fields
--     * Empty contexts in type classes
--     * Parens around derived type classes
--     * 'TokenLocation' (in 'LHsToken'/'LHsUniToken')
--     * 'EpaLocation'
diffHsModule :: HsModule GhcPs -> HsModule GhcPs -> ParseResultDiff
diffHsModule :: HsModule GhcPs -> HsModule GhcPs -> ParseResultDiff
diffHsModule = GenericQ (GenericQ ParseResultDiff)
genericQuery
  where
    genericQuery :: GenericQ (GenericQ ParseResultDiff)
    genericQuery :: GenericQ (GenericQ ParseResultDiff)
genericQuery a
x a
y
      -- 'ByteString' implements 'Data' instance manually and does not
      -- implement 'toConstr', so we have to deal with it in a special way.
      | Just ByteString
x' <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x,
        Just ByteString
y' <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y =
          if ByteString
x' forall a. Eq a => a -> a -> Bool
== (ByteString
y' :: ByteString)
            then ParseResultDiff
Same
            else [RealSrcSpan] -> ParseResultDiff
Different []
      | forall a. Typeable a => a -> TypeRep
typeOf a
x forall a. Eq a => a -> a -> Bool
== forall a. Typeable a => a -> TypeRep
typeOf a
y,
        forall a. Data a => a -> Constr
toConstr a
x forall a. Eq a => a -> a -> Bool
== forall a. Data a => a -> Constr
toConstr a
y =
          forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
            forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
gzipWithQ
              ( GenericQ (GenericQ ParseResultDiff)
genericQuery
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual @SrcSpan
                  forall d (t :: * -> *) q.
(Data d, Typeable t) =>
(d -> q) -> (forall e. Data e => t e -> q) -> d -> q
`ext1Q` forall a b. EpAnn a -> b -> ParseResultDiff
epAnnEq
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual @SourceText
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` HsDocString -> GenericQ ParseResultDiff
hsDocStringEq
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` ImportDeclQualifiedStyle -> GenericQ ParseResultDiff
importDeclQualifiedStyleEq
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual @(LayoutInfo GhcPs)
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` TyClDecl GhcPs -> GenericQ ParseResultDiff
classDeclCtxEq
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` DerivClauseTys GhcPs -> GenericQ ParseResultDiff
derivedTyClsParensEq
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual @EpAnnComments -- ~ XCGRHSs GhcPs
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual @TokenLocation -- in LHs(Uni)Token
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual @EpaLocation
                  forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` forall e0 e1.
(Data e0, Data e1) =>
GenLocated e0 e1 -> GenericQ ParseResultDiff
forLocated
                  -- unicode-related
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual @(HsUniToken "->" "→")
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual @(HsUniToken "::" "∷")
                  forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual @(HsLinearArrowTokens GhcPs)
              )
              a
x
              a
y
      | Bool
otherwise = [RealSrcSpan] -> ParseResultDiff
Different []

    considerEqualVia ::
      forall a.
      (Typeable a) =>
      (a -> a -> ParseResultDiff) ->
      a ->
      GenericQ ParseResultDiff
    considerEqualVia :: forall a.
Typeable a =>
(a -> a -> ParseResultDiff) -> a -> GenericQ ParseResultDiff
considerEqualVia a -> a -> ParseResultDiff
f a
x (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just a
x') = a -> a -> ParseResultDiff
f a
x a
x'
    considerEqualVia a -> a -> ParseResultDiff
_ a
_ a
_ = [RealSrcSpan] -> ParseResultDiff
Different []

    considerEqualVia' :: (t -> t -> Bool) -> t -> GenericQ ParseResultDiff
considerEqualVia' t -> t -> Bool
f =
      forall a.
Typeable a =>
(a -> a -> ParseResultDiff) -> a -> GenericQ ParseResultDiff
considerEqualVia forall a b. (a -> b) -> a -> b
$ \t
x t
x' -> if t -> t -> Bool
f t
x t
x' then ParseResultDiff
Same else [RealSrcSpan] -> ParseResultDiff
Different []

    considerEqual :: forall a. (Typeable a) => a -> GenericQ ParseResultDiff
    considerEqual :: forall a. Typeable a => a -> GenericQ ParseResultDiff
considerEqual = forall a.
Typeable a =>
(a -> a -> ParseResultDiff) -> a -> GenericQ ParseResultDiff
considerEqualVia forall a b. (a -> b) -> a -> b
$ \a
_ a
_ -> ParseResultDiff
Same

    epAnnEq :: EpAnn a -> b -> ParseResultDiff
    epAnnEq :: forall a b. EpAnn a -> b -> ParseResultDiff
epAnnEq EpAnn a
_ b
_ = ParseResultDiff
Same

    importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ ParseResultDiff
importDeclQualifiedStyleEq = forall {t}.
Typeable t =>
(t -> t -> Bool) -> t -> GenericQ ParseResultDiff
considerEqualVia' ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
f
      where
        f :: ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
f ImportDeclQualifiedStyle
QualifiedPre ImportDeclQualifiedStyle
QualifiedPost = Bool
True
        f ImportDeclQualifiedStyle
QualifiedPost ImportDeclQualifiedStyle
QualifiedPre = Bool
True
        f ImportDeclQualifiedStyle
x ImportDeclQualifiedStyle
x' = ImportDeclQualifiedStyle
x forall a. Eq a => a -> a -> Bool
== ImportDeclQualifiedStyle
x'

    hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff
    hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff
hsDocStringEq = forall {t}.
Typeable t =>
(t -> t -> Bool) -> t -> GenericQ ParseResultDiff
considerEqualVia' (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` HsDocString -> [Text]
splitDocString)

    forLocated ::
      (Data e0, Data e1) =>
      GenLocated e0 e1 ->
      GenericQ ParseResultDiff
    forLocated :: forall e0 e1.
(Data e0, Data e1) =>
GenLocated e0 e1 -> GenericQ ParseResultDiff
forLocated x :: GenLocated e0 e1
x@(L e0
mspn e1
_) a
y =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id SrcSpan -> ParseResultDiff -> ParseResultDiff
appendSpan (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast forall d (t :: * -> *) q.
(Data d, Typeable t) =>
(d -> q) -> (forall e. Data e => t e -> q) -> d -> q
`ext1Q` (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SrcSpanAnn' a -> SrcSpan
locA) forall a b. (a -> b) -> a -> b
$ e0
mspn) (GenericQ (GenericQ ParseResultDiff)
genericQuery GenLocated e0 e1
x a
y)
    appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff
    appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff
appendSpan SrcSpan
s' d :: ParseResultDiff
d@(Different [RealSrcSpan]
ss) =
      case SrcSpan
s' of
        RealSrcSpan RealSrcSpan
s Maybe BufSpan
_ ->
          if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (RealSrcSpan -> RealSrcSpan -> Bool
`isRealSubspanOf` RealSrcSpan
s) [RealSrcSpan]
ss
            then [RealSrcSpan] -> ParseResultDiff
Different (RealSrcSpan
s forall a. a -> [a] -> [a]
: [RealSrcSpan]
ss)
            else ParseResultDiff
d
        UnhelpfulSpan UnhelpfulSpanReason
_ -> ParseResultDiff
d
    appendSpan SrcSpan
_ ParseResultDiff
d = ParseResultDiff
d

    classDeclCtxEq :: TyClDecl GhcPs -> GenericQ ParseResultDiff
    classDeclCtxEq :: TyClDecl GhcPs -> GenericQ ParseResultDiff
classDeclCtxEq ClassDecl {tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt = Just (L SrcSpanAnnC
_ []), [LHsFunDep GhcPs]
[LFamilyDecl GhcPs]
[LTyFamDefltDecl GhcPs]
[LDocDecl GhcPs]
[LSig GhcPs]
LHsQTyVars GhcPs
LexicalFixity
LHsBinds GhcPs
LayoutInfo GhcPs
LIdP GhcPs
XClassDecl GhcPs
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdCExt :: forall pass. TyClDecl pass -> XClassDecl pass
tcdLayout :: forall pass. TyClDecl pass -> LayoutInfo pass
tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass]
tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltDecl pass]
tcdDocs :: forall pass. TyClDecl pass -> [LDocDecl pass]
tcdDocs :: [LDocDecl GhcPs]
tcdATDefs :: [LTyFamDefltDecl GhcPs]
tcdATs :: [LFamilyDecl GhcPs]
tcdMeths :: LHsBinds GhcPs
tcdSigs :: [LSig GhcPs]
tcdFDs :: [LHsFunDep GhcPs]
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars GhcPs
tcdLName :: LIdP GhcPs
tcdLayout :: LayoutInfo GhcPs
tcdCExt :: XClassDecl GhcPs
..} a
tc' = GenericQ (GenericQ ParseResultDiff)
genericQuery ClassDecl {tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt = forall a. Maybe a
Nothing, [LHsFunDep GhcPs]
[LFamilyDecl GhcPs]
[LTyFamDefltDecl GhcPs]
[LDocDecl GhcPs]
[LSig GhcPs]
LHsQTyVars GhcPs
LexicalFixity
LHsBinds GhcPs
LayoutInfo GhcPs
LIdP GhcPs
XClassDecl GhcPs
tcdLName :: LIdP GhcPs
tcdTyVars :: LHsQTyVars GhcPs
tcdFixity :: LexicalFixity
tcdCExt :: XClassDecl GhcPs
tcdLayout :: LayoutInfo GhcPs
tcdFDs :: [LHsFunDep GhcPs]
tcdSigs :: [LSig GhcPs]
tcdMeths :: LHsBinds GhcPs
tcdATs :: [LFamilyDecl GhcPs]
tcdATDefs :: [LTyFamDefltDecl GhcPs]
tcdDocs :: [LDocDecl GhcPs]
tcdDocs :: [LDocDecl GhcPs]
tcdATDefs :: [LTyFamDefltDecl GhcPs]
tcdATs :: [LFamilyDecl GhcPs]
tcdMeths :: LHsBinds GhcPs
tcdSigs :: [LSig GhcPs]
tcdFDs :: [LHsFunDep GhcPs]
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars GhcPs
tcdLName :: LIdP GhcPs
tcdLayout :: LayoutInfo GhcPs
tcdCExt :: XClassDecl GhcPs
..} a
tc'
    classDeclCtxEq TyClDecl GhcPs
tc a
tc' = GenericQ (GenericQ ParseResultDiff)
genericQuery TyClDecl GhcPs
tc a
tc'

    derivedTyClsParensEq :: DerivClauseTys GhcPs -> GenericQ ParseResultDiff
    derivedTyClsParensEq :: DerivClauseTys GhcPs -> GenericQ ParseResultDiff
derivedTyClsParensEq (DctSingle NoExtField
XDctSingle GhcPs
NoExtField LHsSigType GhcPs
sigTy) a
dct' = GenericQ (GenericQ ParseResultDiff)
genericQuery (forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti NoExtField
NoExtField [LHsSigType GhcPs
sigTy]) a
dct'
    derivedTyClsParensEq DerivClauseTys GhcPs
dct a
dct' = GenericQ (GenericQ ParseResultDiff)
genericQuery DerivClauseTys GhcPs
dct a
dct'