{-# LANGUAGE RankNTypes #-}

-- | Diffing GHC ASTs modulo span positions.
module Ormolu.Diff
  ( Diff (..),
    diffParseResult,
    diffText,
  )
where

import Data.ByteString (ByteString)
import Data.Generics
import Data.Text (Text)
import qualified Data.Text as T
import qualified FastString as GHC
import GHC
import Ormolu.Imports (sortImports)
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import Ormolu.Utils

-- | Result of comparing two 'ParseResult's.
data Diff
  = -- | Two parse results are the same
    Same
  | -- | Two parse results differ
    Different [SrcSpan]

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

instance Monoid Diff where
  mempty :: Diff
mempty = Diff
Same

-- | Return 'Diff' of two 'ParseResult's.
diffParseResult :: ParseResult -> ParseResult -> Diff
diffParseResult :: ParseResult -> ParseResult -> Diff
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 -> Diff
forall a. Data a => a -> a -> Diff
matchIgnoringSrcSpans CommentStream
cstream0 CommentStream
cstream1
      Diff -> Diff -> Diff
forall a. Semigroup a => a -> a -> a
<> HsModule GhcPs -> HsModule GhcPs -> Diff
forall a. Data a => a -> a -> Diff
matchIgnoringSrcSpans
        HsModule GhcPs
hs0 {hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs] -> [LImportDecl GhcPs]
sortImports (HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports HsModule GhcPs
hs0)}
        HsModule GhcPs
hs1 {hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs] -> [LImportDecl GhcPs]
sortImports (HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports HsModule GhcPs
hs1)}

-- | Compare two values for equality disregarding differences in 'SrcSpan's
-- and the ordering of import lists.
matchIgnoringSrcSpans :: Data a => a -> a -> Diff
matchIgnoringSrcSpans :: a -> a -> Diff
matchIgnoringSrcSpans = a -> a -> Diff
GenericQ (GenericQ Diff)
genericQuery
  where
    genericQuery :: GenericQ (GenericQ Diff)
    genericQuery :: a -> GenericQ Diff
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' <- a -> Maybe ByteString
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x,
        Just ByteString
y' <- a -> Maybe ByteString
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y =
        if ByteString
x' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== (ByteString
y' :: ByteString)
          then Diff
Same
          else [SrcSpan] -> Diff
Different []
      | a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
x TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
y,
        a -> Constr
forall a. Data a => a -> Constr
toConstr a
x Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Constr
forall a. Data a => a -> Constr
toConstr a
y =
        [Diff] -> Diff
forall a. Monoid a => [a] -> a
mconcat ([Diff] -> Diff) -> [Diff] -> Diff
forall a b. (a -> b) -> a -> b
$
          GenericQ (GenericQ Diff) -> a -> a -> [Diff]
forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
gzipWithQ
            ( a -> a -> Diff
GenericQ (GenericQ Diff)
genericQuery
                (a -> a -> Diff) -> (SrcSpan -> a -> Diff) -> a -> a -> Diff
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` SrcSpan -> a -> Diff
SrcSpan -> GenericQ Diff
srcSpanEq
                (a -> a -> Diff) -> (Comment -> a -> Diff) -> a -> a -> Diff
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Comment -> a -> Diff
Comment -> GenericQ Diff
commentEq
                (a -> a -> Diff) -> (SourceText -> a -> Diff) -> a -> a -> Diff
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` SourceText -> a -> Diff
SourceText -> GenericQ Diff
sourceTextEq
                (a -> a -> Diff) -> (HsDocString -> a -> Diff) -> a -> a -> Diff
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` HsDocString -> a -> Diff
HsDocString -> GenericQ Diff
hsDocStringEq
                (a -> a -> Diff)
-> (ImportDeclQualifiedStyle -> a -> Diff) -> a -> a -> Diff
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` ImportDeclQualifiedStyle -> a -> Diff
ImportDeclQualifiedStyle -> GenericQ Diff
importDeclQualifiedStyleEq
                (a -> a -> Diff)
-> (forall d1 d2.
    (Data d1, Data d2) =>
    GenLocated d1 d2 -> a -> Diff)
-> a
-> a
-> Diff
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 d1 d2. (Data d1, Data d2) => GenLocated d1 d2 -> a -> Diff
forall e0 e1.
(Data e0, Data e1) =>
GenLocated e0 e1 -> GenericQ Diff
forLocated
            )
            a
x
            a
y
      | Bool
otherwise = [SrcSpan] -> Diff
Different []
    srcSpanEq :: SrcSpan -> GenericQ Diff
    srcSpanEq :: SrcSpan -> GenericQ Diff
srcSpanEq SrcSpan
_ a
_ = Diff
Same
    commentEq :: Comment -> GenericQ Diff
    commentEq :: Comment -> GenericQ Diff
commentEq (Comment Bool
_ NonEmpty String
x) a
d =
      case a -> Maybe Comment
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
d :: Maybe Comment of
        Maybe Comment
Nothing -> [SrcSpan] -> Diff
Different []
        Just (Comment Bool
_ NonEmpty String
y) ->
          if NonEmpty String
x NonEmpty String -> NonEmpty String -> Bool
forall a. Eq a => a -> a -> Bool
== NonEmpty String
y
            then Diff
Same
            else [SrcSpan] -> Diff
Different []
    sourceTextEq :: SourceText -> GenericQ Diff
    sourceTextEq :: SourceText -> GenericQ Diff
sourceTextEq SourceText
_ a
_ = Diff
Same
    importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff
    importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff
importDeclQualifiedStyleEq ImportDeclQualifiedStyle
d0 a
d1' =
      case (ImportDeclQualifiedStyle
d0, a -> Maybe ImportDeclQualifiedStyle
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
d1' :: Maybe ImportDeclQualifiedStyle) of
        (ImportDeclQualifiedStyle
x, Just ImportDeclQualifiedStyle
x') | ImportDeclQualifiedStyle
x ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ImportDeclQualifiedStyle
x' -> Diff
Same
        (ImportDeclQualifiedStyle
QualifiedPre, Just ImportDeclQualifiedStyle
QualifiedPost) -> Diff
Same
        (ImportDeclQualifiedStyle
QualifiedPost, Just ImportDeclQualifiedStyle
QualifiedPre) -> Diff
Same
        (ImportDeclQualifiedStyle, Maybe ImportDeclQualifiedStyle)
_ -> [SrcSpan] -> Diff
Different []
    hsDocStringEq :: HsDocString -> GenericQ Diff
    hsDocStringEq :: HsDocString -> GenericQ Diff
hsDocStringEq HsDocString
str0 a
str1' =
      case a -> Maybe HsDocString
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
str1' :: Maybe HsDocString of
        Maybe HsDocString
Nothing -> [SrcSpan] -> Diff
Different []
        Just HsDocString
str1 ->
          if HsDocString -> [Text]
splitDocString HsDocString
str0 [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== HsDocString -> [Text]
splitDocString HsDocString
str1
            then Diff
Same
            else [SrcSpan] -> Diff
Different []
    forLocated ::
      (Data e0, Data e1) =>
      GenLocated e0 e1 ->
      GenericQ Diff
    forLocated :: GenLocated e0 e1 -> GenericQ Diff
forLocated x :: GenLocated e0 e1
x@(L e0
mspn e1
_) a
y =
      (Diff -> Diff)
-> (SrcSpan -> Diff -> Diff) -> Maybe SrcSpan -> Diff -> Diff
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Diff -> Diff
forall a. a -> a
id SrcSpan -> Diff -> Diff
appendSpan (e0 -> Maybe SrcSpan
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e0
mspn) (GenLocated e0 e1 -> a -> Diff
GenericQ (GenericQ Diff)
genericQuery GenLocated e0 e1
x a
y)
    appendSpan :: SrcSpan -> Diff -> Diff
    appendSpan :: SrcSpan -> Diff -> Diff
appendSpan SrcSpan
s (Different [SrcSpan]
ss) | Bool
fresh Bool -> Bool -> Bool
&& Bool
helpful = [SrcSpan] -> Diff
Different (SrcSpan
s SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: [SrcSpan]
ss)
      where
        fresh :: Bool
fresh = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> Bool) -> [SrcSpan] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
s) [SrcSpan]
ss
        helpful :: Bool
helpful = SrcSpan -> Bool
isGoodSrcSpan SrcSpan
s
    appendSpan SrcSpan
_ Diff
d = Diff
d

-- | Diff two texts and return the location they start to differ, alongside
-- with excerpts around that location.
diffText ::
  -- | Text before
  Text ->
  -- | Text after
  Text ->
  -- | Path to use to construct 'GHC.RealSrcLoc'
  FilePath ->
  Maybe (GHC.RealSrcLoc, Text, Text)
diffText :: Text -> Text -> String -> Maybe (RealSrcLoc, Text, Text)
diffText Text
left Text
right String
fp =
  case (Int, Int, Int) -> Text -> Text -> Maybe (Int, Int, Int)
forall a b c.
(Num a, Num b, Num c) =>
(a, b, c) -> Text -> Text -> Maybe (a, b, c)
go (Int
0, Int
0, Int
0) Text
left Text
right of
    Maybe (Int, Int, Int)
Nothing -> Maybe (RealSrcLoc, Text, Text)
forall a. Maybe a
Nothing
    Just (Int
row, Int
col, Int
loc) ->
      (RealSrcLoc, Text, Text) -> Maybe (RealSrcLoc, Text, Text)
forall a. a -> Maybe a
Just
        ( FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (String -> FastString
GHC.mkFastString String
fp) Int
row Int
col,
          Int -> Text -> Text
getSpan Int
loc Text
left,
          Int -> Text -> Text
getSpan Int
loc Text
right
        )
  where
    go :: (a, b, c) -> Text -> Text -> Maybe (a, b, c)
go (a
row, b
col, c
loc) Text
t1 Text
t2 =
      case (Text -> Maybe (Char, Text)
T.uncons Text
t1, Text -> Maybe (Char, Text)
T.uncons Text
t2) of
        -- both text empty, all good
        (Maybe (Char, Text)
Nothing, Maybe (Char, Text)
Nothing) ->
          Maybe (a, b, c)
forall a. Maybe a
Nothing
        -- first chars are the same, adjust position and recurse
        (Just (Char
c1, Text
r1), Just (Char
c2, Text
r2))
          | Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c2 ->
            let (a
row', b
col', c
loc') =
                  if Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'
                    then (a
row a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, b
0, c
loc c -> c -> c
forall a. Num a => a -> a -> a
+ c
1)
                    else (a
row, b
col b -> b -> b
forall a. Num a => a -> a -> a
+ b
1, c
loc c -> c -> c
forall a. Num a => a -> a -> a
+ c
1)
             in (a, b, c) -> Text -> Text -> Maybe (a, b, c)
go (a
row', b
col', c
loc') Text
r1 Text
r2
        -- something is different, return the position
        (Maybe (Char, Text), Maybe (Char, Text))
_ ->
          (a, b, c) -> Maybe (a, b, c)
forall a. a -> Maybe a
Just (a
row, b
col, c
loc)
    getSpan :: Int -> Text -> Text
getSpan Int
loc = Int -> Text -> Text
T.take Int
20 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop (Int
loc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10)