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