--------------------------------------------------------------------------------
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternGuards         #-}
{-# LANGUAGE TypeFamilies          #-}
module Language.Haskell.Stylish.Step.Squash
    ( step
    ) where


--------------------------------------------------------------------------------
import           Control.Monad    (guard)
import           Data.Maybe       (mapMaybe)
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Hs           as GHC


--------------------------------------------------------------------------------
import           Language.Haskell.Stylish.Editor
import           Language.Haskell.Stylish.Step
import           Language.Haskell.Stylish.Util


--------------------------------------------------------------------------------
squash :: GHC.SrcSpan -> GHC.SrcSpan -> Maybe (Change String)
squash :: SrcSpan -> SrcSpan -> Maybe (Change String)
squash SrcSpan
left SrcSpan
right = do
  RealSrcSpan
l <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan SrcSpan
left
  RealSrcSpan
r <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan SrcSpan
right
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$
      RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
r Bool -> Bool -> Bool
||
      RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
r
  Change String -> Maybe (Change String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Change String -> Maybe (Change String))
-> Change String -> Maybe (Change String)
forall a b. (a -> b) -> a -> b
$ Int -> (String -> [String]) -> Change String
forall a. Int -> (a -> [a]) -> Change a
changeLine (RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
l) ((String -> [String]) -> Change String)
-> (String -> [String]) -> Change String
forall a b. (a -> b) -> a -> b
$ \String
str ->
      let (String
pre, String
post) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt (RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
l) String
str
      in [String -> String
trimRight String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
trimLeft String
post]


--------------------------------------------------------------------------------
squashFieldDecl :: GHC.ConDeclField GHC.GhcPs -> Maybe (Change String)
squashFieldDecl :: ConDeclField GhcPs -> Maybe (Change String)
squashFieldDecl (GHC.ConDeclField XConDeclField GhcPs
_ [LFieldOcc GhcPs]
names LBangType GhcPs
type' Maybe LHsDocString
_)
  | [GenLocated SrcSpan (FieldOcc GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LFieldOcc GhcPs]
[GenLocated SrcSpan (FieldOcc GhcPs)]
names = Maybe (Change String)
forall a. Maybe a
Nothing
  | Bool
otherwise  = SrcSpan -> SrcSpan -> Maybe (Change String)
squash (GenLocated SrcSpan (FieldOcc GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
GHC.getLoc (GenLocated SrcSpan (FieldOcc GhcPs) -> SrcSpan)
-> GenLocated SrcSpan (FieldOcc GhcPs) -> SrcSpan
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpan (FieldOcc GhcPs)]
-> GenLocated SrcSpan (FieldOcc GhcPs)
forall a. [a] -> a
last [LFieldOcc GhcPs]
[GenLocated SrcSpan (FieldOcc GhcPs)]
names) (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LBangType GhcPs
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
type')


--------------------------------------------------------------------------------
squashMatch
    :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Maybe (Change String)
squashMatch :: Match GhcPs (LHsExpr GhcPs) -> Maybe (Change String)
squashMatch (GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
_ (GHC.FunRhs LIdP (NoGhcTc GhcPs)
name LexicalFixity
_ SrcStrictness
_) [] GRHSs GhcPs (LHsExpr GhcPs)
grhss) = do
    GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)
body <- GRHSs
  GhcPs (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))
-> Maybe
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))
forall a. GRHSs GhcPs a -> Maybe a
unguardedRhsBody GRHSs GhcPs (LHsExpr GhcPs)
GRHSs
  GhcPs (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))
grhss
    SrcSpan -> SrcSpan -> Maybe (Change String)
squash (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) (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)
body)
squashMatch (GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NoGhcTc GhcPs)
_ [LPat GhcPs]
pats GRHSs GhcPs (LHsExpr GhcPs)
grhss) = do
    GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)
body <- GRHSs
  GhcPs (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))
-> Maybe
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))
forall a. GRHSs GhcPs a -> Maybe a
unguardedRhsBody GRHSs GhcPs (LHsExpr GhcPs)
GRHSs
  GhcPs (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))
grhss
    SrcSpan -> SrcSpan -> Maybe (Change String)
squash (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)
 -> SrcSpan)
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)
-> SrcSpan
forall a b. (a -> b) -> a -> b
$ [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)]
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)
forall a. [a] -> a
last [LPat GhcPs]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)]
pats) (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)
body)


--------------------------------------------------------------------------------
step :: Step
step :: Step
step = String -> ([String] -> Module -> [String]) -> Step
makeStep String
"Squash" (([String] -> Module -> [String]) -> Step)
-> ([String] -> Module -> [String]) -> Step
forall a b. (a -> b) -> a -> b
$ \[String]
ls (Module
module') ->
    let changes :: [Change String]
changes =
            (ConDeclField GhcPs -> Maybe (Change String))
-> [ConDeclField GhcPs] -> [Change String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ConDeclField GhcPs -> Maybe (Change String)
squashFieldDecl (Module -> [ConDeclField GhcPs]
forall a b. (Data a, Data b) => a -> [b]
everything Module
module') [Change String] -> [Change String] -> [Change String]
forall a. [a] -> [a] -> [a]
++
            (Match
   GhcPs (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))
 -> Maybe (Change String))
-> [Match
      GhcPs
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))]
-> [Change String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Match GhcPs (LHsExpr GhcPs) -> Maybe (Change String)
Match
  GhcPs (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))
-> Maybe (Change String)
squashMatch (Module
-> [Match
      GhcPs
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))]
forall a b. (Data a, Data b) => a -> [b]
everything Module
module') in
    [Change String] -> [String] -> [String]
forall a. [Change a] -> [a] -> [a]
applyChanges [Change String]
changes [String]
ls