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


--------------------------------------------------------------------------------
import           Data.Maybe                      (mapMaybe)
import qualified GHC.Hs                          as Hs
import qualified SrcLoc                          as S


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


--------------------------------------------------------------------------------
squash
    :: (S.HasSrcSpan l, S.HasSrcSpan r)
    => l -> r -> Maybe (Change String)
squash :: l -> r -> Maybe (Change String)
squash l
left r
right = do
  RealSrcSpan
lAnn <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ l -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc l
left
  RealSrcSpan
rAnn <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ r -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc r
right
  if RealSrcSpan -> Int
S.srcSpanEndLine RealSrcSpan
lAnn Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
S.srcSpanStartLine RealSrcSpan
rAnn Bool -> Bool -> Bool
||
      RealSrcSpan -> Int
S.srcSpanEndLine RealSrcSpan
lAnn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
S.srcSpanStartLine RealSrcSpan
rAnn
    then Change String -> Maybe (Change String)
forall a. a -> Maybe a
Just (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
S.srcSpanEndLine RealSrcSpan
lAnn) ((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
S.srcSpanEndCol RealSrcSpan
lAnn) 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]
    else Maybe (Change String)
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
squashFieldDecl :: Hs.ConDeclField Hs.GhcPs -> Maybe (Change String)
squashFieldDecl :: ConDeclField GhcPs -> Maybe (Change String)
squashFieldDecl (Hs.ConDeclField XConDeclField GhcPs
_ [LFieldOcc GhcPs]
names LBangType GhcPs
type' Maybe LHsDocString
_)
  | [LFieldOcc GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LFieldOcc GhcPs]
names = Maybe (Change String)
forall a. Maybe a
Nothing
  | Bool
otherwise  = LFieldOcc GhcPs -> LBangType GhcPs -> Maybe (Change String)
forall l r.
(HasSrcSpan l, HasSrcSpan r) =>
l -> r -> Maybe (Change String)
squash ([LFieldOcc GhcPs] -> LFieldOcc GhcPs
forall a. [a] -> a
last [LFieldOcc GhcPs]
names) LBangType GhcPs
type'
squashFieldDecl (Hs.XConDeclField XXConDeclField GhcPs
x) = NoExtCon -> Maybe (Change String)
forall a. NoExtCon -> a
Hs.noExtCon NoExtCon
XXConDeclField GhcPs
x


--------------------------------------------------------------------------------
squashMatch :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> Maybe (Change String)
squashMatch :: Match GhcPs (LHsExpr GhcPs) -> Maybe (Change String)
squashMatch (Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
_ (Hs.FunRhs Located (NameOrRdrName (IdP GhcPs))
name LexicalFixity
_ SrcStrictness
_) [] GRHSs GhcPs (LHsExpr GhcPs)
grhss) = do
    LHsExpr GhcPs
body <- GRHSs GhcPs (LHsExpr GhcPs) -> Maybe (LHsExpr GhcPs)
forall a. GRHSs GhcPs a -> Maybe a
unguardedRhsBody GRHSs GhcPs (LHsExpr GhcPs)
grhss
    Located RdrName -> LHsExpr GhcPs -> Maybe (Change String)
forall l r.
(HasSrcSpan l, HasSrcSpan r) =>
l -> r -> Maybe (Change String)
squash Located (NameOrRdrName (IdP GhcPs))
Located RdrName
name LHsExpr GhcPs
body
squashMatch (Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NameOrRdrName (IdP GhcPs))
_ [LPat GhcPs]
pats GRHSs GhcPs (LHsExpr GhcPs)
grhss) = do
    LHsExpr GhcPs
body <- GRHSs GhcPs (LHsExpr GhcPs) -> Maybe (LHsExpr GhcPs)
forall a. GRHSs GhcPs a -> Maybe a
unguardedRhsBody GRHSs GhcPs (LHsExpr GhcPs)
grhss
    Located (Pat GhcPs) -> LHsExpr GhcPs -> Maybe (Change String)
forall l r.
(HasSrcSpan l, HasSrcSpan r) =>
l -> r -> Maybe (Change String)
squash ([Located (Pat GhcPs)] -> Located (Pat GhcPs)
forall a. [a] -> a
last [LPat GhcPs]
[Located (Pat GhcPs)]
pats) LHsExpr GhcPs
body
squashMatch (Hs.XMatch XXMatch GhcPs (LHsExpr GhcPs)
x) = NoExtCon -> Maybe (Change String)
forall a. NoExtCon -> a
Hs.noExtCon NoExtCon
XXMatch GhcPs (LHsExpr GhcPs)
x


--------------------------------------------------------------------------------
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 (LHsExpr GhcPs) -> Maybe (Change String))
-> [Match GhcPs (LHsExpr GhcPs)] -> [Change String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Match GhcPs (LHsExpr GhcPs) -> Maybe (Change String)
squashMatch (Module -> [Match GhcPs (LHsExpr 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