{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Language.Haskell.Stylish.Step.Squash
( step
) where
import Data.Maybe (listToMaybe)
import qualified GHC.Hs as GHC
import qualified GHC.Types.SrcLoc as GHC
import qualified Language.Haskell.Stylish.Editor as Editor
import Language.Haskell.Stylish.Step
import Language.Haskell.Stylish.Util
squash :: GHC.RealSrcSpan -> GHC.RealSrcSpan -> Editor.Edits
squash :: RealSrcSpan -> RealSrcSpan -> Edits
squash RealSrcSpan
l RealSrcSpan
r
| RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
r = Edits
forall a. Monoid a => a
mempty
| RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
r = Edits
forall a. Monoid a => a
mempty
| Bool
otherwise = Int -> Int -> Int -> String -> Edits
Editor.replace
(RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
l)
(RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
l)
(RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
r)
String
" "
squashFieldDecl :: GHC.ConDeclField GHC.GhcPs -> Editor.Edits
squashFieldDecl :: ConDeclField GhcPs -> Edits
squashFieldDecl (GHC.ConDeclField XConDeclField GhcPs
ext names :: [LFieldOcc GhcPs]
names@(LFieldOcc GhcPs
_ : [LFieldOcc GhcPs]
_) LBangType GhcPs
type' Maybe (LHsDoc GhcPs)
_)
| Just RealSrcSpan
left <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan)
-> (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
-> SrcSpan)
-> GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
-> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
-> Maybe RealSrcSpan)
-> GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
-> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ [GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)]
-> GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
forall a. HasCallStack => [a] -> a
last [LFieldOcc GhcPs]
[GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)]
names
, Just RealSrcSpan
sep <- EpAnn [AddEpAnn] -> Maybe RealSrcSpan
fieldDeclSeparator XConDeclField GhcPs
EpAnn [AddEpAnn]
ext
, Just RealSrcSpan
right <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LBangType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
type' =
RealSrcSpan -> RealSrcSpan -> Edits
squash RealSrcSpan
left RealSrcSpan
sep Edits -> Edits -> Edits
forall a. Semigroup a => a -> a -> a
<> RealSrcSpan -> RealSrcSpan -> Edits
squash RealSrcSpan
sep RealSrcSpan
right
squashFieldDecl ConDeclField GhcPs
_ = Edits
forall a. Monoid a => a
mempty
fieldDeclSeparator :: GHC.EpAnn [GHC.AddEpAnn]-> Maybe GHC.RealSrcSpan
fieldDeclSeparator :: EpAnn [AddEpAnn] -> Maybe RealSrcSpan
fieldDeclSeparator GHC.EpAnn {[AddEpAnn]
EpAnnComments
Anchor
entry :: Anchor
anns :: [AddEpAnn]
comments :: EpAnnComments
entry :: forall ann. EpAnn ann -> Anchor
anns :: forall ann. EpAnn ann -> ann
comments :: forall ann. EpAnn ann -> EpAnnComments
..} = [RealSrcSpan] -> Maybe RealSrcSpan
forall a. [a] -> Maybe a
listToMaybe ([RealSrcSpan] -> Maybe RealSrcSpan)
-> [RealSrcSpan] -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ do
GHC.AddEpAnn AnnKeywordId
GHC.AnnDcolon (GHC.EpaSpan RealSrcSpan
s Maybe BufSpan
_) <- [AddEpAnn]
anns
RealSrcSpan -> [RealSrcSpan]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure RealSrcSpan
s
fieldDeclSeparator EpAnn [AddEpAnn]
_ = Maybe RealSrcSpan
forall a. Maybe a
Nothing
squashMatch
:: GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Editor.Edits
squashMatch :: LMatch GhcPs (LHsExpr GhcPs) -> Edits
squashMatch LMatch GhcPs (LHsExpr GhcPs)
lmatch = case Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body. Match p body -> GRHSs p body
GHC.m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match of
GHC.GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
lgrhs] HsLocalBinds GhcPs
_
| GHC.GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
ext [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
body <- GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall l e. GenLocated l e -> e
GHC.unLoc LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
lgrhs
, Just RealSrcSpan
left <- Maybe RealSrcSpan
mbLeft
, Just RealSrcSpan
sep <- EpAnn GrhsAnn -> Maybe RealSrcSpan
matchSeparator XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnn GrhsAnn
ext
, Just RealSrcSpan
right <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA GenLocated SrcSpanAnnA (HsExpr GhcPs)
body ->
RealSrcSpan -> RealSrcSpan -> Edits
squash RealSrcSpan
left RealSrcSpan
sep Edits -> Edits -> Edits
forall a. Semigroup a => a -> a -> a
<> RealSrcSpan -> RealSrcSpan -> Edits
squash RealSrcSpan
sep RealSrcSpan
right
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ -> Edits
forall a. Monoid a => a
mempty
where
match :: Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match = GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall l e. GenLocated l e -> e
GHC.unLoc LMatch GhcPs (LHsExpr GhcPs)
GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
lmatch
mbLeft :: Maybe RealSrcSpan
mbLeft = case Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match of
GHC.Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ (GHC.FunRhs LIdP (NoGhcTc GhcPs)
name LexicalFixity
_ SrcStrictness
_) [] GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ ->
SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LIdP (NoGhcTc GhcPs)
GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
name
GHC.Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ HsMatchContext GhcPs
_ pats :: [LPat GhcPs]
pats@(LPat GhcPs
_ : [LPat GhcPs]
_) GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ ->
SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan)
-> (GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA (GenLocated SrcSpanAnnA (Pat GhcPs) -> Maybe RealSrcSpan)
-> GenLocated SrcSpanAnnA (Pat GhcPs) -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a. HasCallStack => [a] -> a
last [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats
Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ -> Maybe RealSrcSpan
forall a. Maybe a
Nothing
matchSeparator :: GHC.EpAnn GHC.GrhsAnn -> Maybe GHC.RealSrcSpan
matchSeparator :: EpAnn GrhsAnn -> Maybe RealSrcSpan
matchSeparator GHC.EpAnn {EpAnnComments
Anchor
GrhsAnn
entry :: forall ann. EpAnn ann -> Anchor
anns :: forall ann. EpAnn ann -> ann
comments :: forall ann. EpAnn ann -> EpAnnComments
entry :: Anchor
anns :: GrhsAnn
comments :: EpAnnComments
..}
| GHC.AddEpAnn AnnKeywordId
_ (GHC.EpaSpan RealSrcSpan
s Maybe BufSpan
_) <- GrhsAnn -> AddEpAnn
GHC.ga_sep GrhsAnn
anns = RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
s
matchSeparator EpAnn GrhsAnn
_ = Maybe RealSrcSpan
forall a. Maybe a
Nothing
step :: Step
step :: Step
step = String -> (Lines -> Module -> Lines) -> Step
makeStep String
"Squash" ((Lines -> Module -> Lines) -> Step)
-> (Lines -> Module -> Lines) -> Step
forall a b. (a -> b) -> a -> b
$ \Lines
ls (Module
module') ->
let changes :: Edits
changes =
(ConDeclField GhcPs -> Edits) -> [ConDeclField GhcPs] -> Edits
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ConDeclField GhcPs -> Edits
squashFieldDecl (Module -> [ConDeclField GhcPs]
forall a b. (Data a, Data b) => a -> [b]
everything Module
module') Edits -> Edits -> Edits
forall a. Semigroup a => a -> a -> a
<>
(GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Edits)
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Edits
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LMatch GhcPs (LHsExpr GhcPs) -> Edits
GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Edits
squashMatch (Module
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (Data a, Data b) => a -> [b]
everything Module
module') in
Edits -> Lines -> Lines
Editor.apply Edits
changes Lines
ls