{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Ormolu.Diff.ParseResult
( ParseResultDiff (..),
diffParseResult,
)
where
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Generics
import GHC.Hs
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import Ormolu.Imports (normalizeImports)
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import Ormolu.Utils
data ParseResultDiff
=
Same
|
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
diffParseResult ::
ParseResult ->
ParseResult ->
ParseResultDiff
diffParseResult :: ParseResult -> ParseResult -> ParseResultDiff
diffParseResult
ParseResult
{ prCommentStream :: ParseResult -> CommentStream
prCommentStream = CommentStream
cstream0,
prParsedSource :: ParseResult -> HsModule
prParsedSource = HsModule
hs0
}
ParseResult
{ prCommentStream :: ParseResult -> CommentStream
prCommentStream = CommentStream
cstream1,
prParsedSource :: ParseResult -> HsModule
prParsedSource = HsModule
hs1
} =
CommentStream -> CommentStream -> ParseResultDiff
diffCommentStream CommentStream
cstream0 CommentStream
cstream1
forall a. Semigroup a => a -> a -> a
<> forall a. Data a => a -> a -> ParseResultDiff
matchIgnoringSrcSpans
HsModule
hs0 {hsmodImports :: [LImportDecl GhcPs]
hsmodImports = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]]
normalizeImports Bool
False forall a b. (a -> b) -> a -> b
$ HsModule -> [LImportDecl GhcPs]
hsmodImports HsModule
hs0}
HsModule
hs1 {hsmodImports :: [LImportDecl GhcPs]
hsmodImports = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]]
normalizeImports Bool
False forall a b. (a -> b) -> a -> b
$ HsModule -> [LImportDecl GhcPs]
hsmodImports HsModule
hs1}
diffCommentStream :: CommentStream -> CommentStream -> ParseResultDiff
(CommentStream [RealLocated Comment]
cs) (CommentStream [RealLocated Comment]
cs')
| forall {l}. [GenLocated l Comment] -> [String]
commentLines [RealLocated Comment]
cs forall a. Eq a => a -> a -> Bool
== forall {l}. [GenLocated l Comment] -> [String]
commentLines [RealLocated Comment]
cs' = ParseResultDiff
Same
| Bool
otherwise = [RealSrcSpan] -> ParseResultDiff
Different []
where
commentLines :: [GenLocated l Comment] -> [String]
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 String
unComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
matchIgnoringSrcSpans :: Data a => a -> a -> ParseResultDiff
matchIgnoringSrcSpans :: forall a. Data a => a -> a -> ParseResultDiff
matchIgnoringSrcSpans a
a = GenericQ (GenericQ ParseResultDiff)
genericQuery a
a
where
genericQuery :: GenericQ (GenericQ ParseResultDiff)
genericQuery :: GenericQ (GenericQ ParseResultDiff)
genericQuery a
x a
y
| 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` SrcSpan -> GenericQ ParseResultDiff
srcSpanEq
forall d (t :: * -> *) q.
(Data d, Typeable t) =>
(d -> q) -> (forall e. Data e => t e -> q) -> d -> q
`ext1Q` forall a. EpAnn a -> GenericQ ParseResultDiff
epAnnEq
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` SourceText -> GenericQ ParseResultDiff
sourceTextEq
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` HsArrow GhcPs -> GenericQ ParseResultDiff
unicodeArrowStyleEq
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` LayoutInfo -> GenericQ ParseResultDiff
layoutInfoEq
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` EpAnnComments -> GenericQ ParseResultDiff
epaCommentsEq
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
)
a
x
a
y
| Bool
otherwise = [RealSrcSpan] -> ParseResultDiff
Different []
srcSpanEq :: SrcSpan -> GenericQ ParseResultDiff
srcSpanEq :: SrcSpan -> GenericQ ParseResultDiff
srcSpanEq SrcSpan
_ a
_ = ParseResultDiff
Same
epAnnEq :: EpAnn a -> GenericQ ParseResultDiff
epAnnEq :: forall a. EpAnn a -> GenericQ ParseResultDiff
epAnnEq EpAnn a
_ a
_ = ParseResultDiff
Same
sourceTextEq :: SourceText -> GenericQ ParseResultDiff
sourceTextEq :: SourceText -> GenericQ ParseResultDiff
sourceTextEq SourceText
_ a
_ = ParseResultDiff
Same
importDeclQualifiedStyleEq ::
ImportDeclQualifiedStyle ->
GenericQ ParseResultDiff
importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ ParseResultDiff
importDeclQualifiedStyleEq ImportDeclQualifiedStyle
d0 a
d1' =
case (ImportDeclQualifiedStyle
d0, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
d1' :: Maybe ImportDeclQualifiedStyle) of
(ImportDeclQualifiedStyle
x, Just ImportDeclQualifiedStyle
x') | ImportDeclQualifiedStyle
x forall a. Eq a => a -> a -> Bool
== ImportDeclQualifiedStyle
x' -> ParseResultDiff
Same
(ImportDeclQualifiedStyle
QualifiedPre, Just ImportDeclQualifiedStyle
QualifiedPost) -> ParseResultDiff
Same
(ImportDeclQualifiedStyle
QualifiedPost, Just ImportDeclQualifiedStyle
QualifiedPre) -> ParseResultDiff
Same
(ImportDeclQualifiedStyle, Maybe ImportDeclQualifiedStyle)
_ -> [RealSrcSpan] -> ParseResultDiff
Different []
hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff
hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff
hsDocStringEq HsDocString
str0 a
str1' =
case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
str1' :: Maybe HsDocString of
Maybe HsDocString
Nothing -> [RealSrcSpan] -> ParseResultDiff
Different []
Just HsDocString
str1 ->
if HsDocString -> [Text]
splitDocString HsDocString
str0 forall a. Eq a => a -> a -> Bool
== HsDocString -> [Text]
splitDocString HsDocString
str1
then ParseResultDiff
Same
else [RealSrcSpan] -> ParseResultDiff
Different []
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
unicodeArrowStyleEq :: HsArrow GhcPs -> GenericQ ParseResultDiff
unicodeArrowStyleEq :: HsArrow GhcPs -> GenericQ ParseResultDiff
unicodeArrowStyleEq (HsUnrestrictedArrow IsUnicodeSyntax
_) (forall a. Typeable a => a -> Maybe (HsArrow GhcPs)
castArrow -> Just (HsUnrestrictedArrow IsUnicodeSyntax
_)) = ParseResultDiff
Same
unicodeArrowStyleEq (HsLinearArrow IsUnicodeSyntax
_ Maybe AddEpAnn
_) (forall a. Typeable a => a -> Maybe (HsArrow GhcPs)
castArrow -> Just (HsLinearArrow IsUnicodeSyntax
_ Maybe AddEpAnn
_)) = ParseResultDiff
Same
unicodeArrowStyleEq (HsExplicitMult IsUnicodeSyntax
_ Maybe AddEpAnn
_ LHsType GhcPs
t) (forall a. Typeable a => a -> Maybe (HsArrow GhcPs)
castArrow -> Just (HsExplicitMult IsUnicodeSyntax
_ Maybe AddEpAnn
_ LHsType GhcPs
t')) = GenericQ (GenericQ ParseResultDiff)
genericQuery LHsType GhcPs
t LHsType GhcPs
t'
unicodeArrowStyleEq HsArrow GhcPs
_ a
_ = [RealSrcSpan] -> ParseResultDiff
Different []
castArrow :: Typeable a => a -> Maybe (HsArrow GhcPs)
castArrow :: forall a. Typeable a => a -> Maybe (HsArrow GhcPs)
castArrow = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast
layoutInfoEq :: LayoutInfo -> GenericQ ParseResultDiff
layoutInfoEq :: LayoutInfo -> GenericQ ParseResultDiff
layoutInfoEq LayoutInfo
_ (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (LayoutInfo
_ :: LayoutInfo)) = ParseResultDiff
Same
layoutInfoEq LayoutInfo
_ a
_ = [RealSrcSpan] -> ParseResultDiff
Different []
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
LIdP GhcPs
XClassDecl GhcPs
LexicalFixity
LHsBinds 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
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
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
LIdP GhcPs
XClassDecl GhcPs
LexicalFixity
LHsBinds GhcPs
tcdLName :: LIdP GhcPs
tcdTyVars :: LHsQTyVars GhcPs
tcdFixity :: LexicalFixity
tcdCExt :: XClassDecl 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
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'
epaCommentsEq :: EpAnnComments -> GenericQ ParseResultDiff
epaCommentsEq :: EpAnnComments -> GenericQ ParseResultDiff
epaCommentsEq EpAnnComments
_ (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (EpAnnComments
_ :: EpAnnComments)) = ParseResultDiff
Same
epaCommentsEq EpAnnComments
_ a
_ = [RealSrcSpan] -> ParseResultDiff
Different []