--------------------------------------------------------------------------------
{-# 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


--------------------------------------------------------------------------------
-- | Removes anything between two RealSrcSpans, providing they are on the same
-- line.
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