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