diff options
Diffstat (limited to 'lib/Language/Haskell/Stylish/Step/Squash.hs')
| -rw-r--r-- | lib/Language/Haskell/Stylish/Step/Squash.hs | 71 |
1 files changed, 36 insertions, 35 deletions
diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index 0eb4895..23d1e9f 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -1,4 +1,7 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.Squash ( step ) where @@ -6,7 +9,8 @@ module Language.Haskell.Stylish.Step.Squash -------------------------------------------------------------------------------- import Data.Maybe (mapMaybe) -import qualified Language.Haskell.Exts as H +import qualified GHC.Hs as Hs +import qualified SrcLoc as S -------------------------------------------------------------------------------- @@ -17,46 +21,43 @@ import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- squash - :: (H.Annotated l, H.Annotated r) - => l H.SrcSpan -> r H.SrcSpan -> Maybe (Change String) -squash left right - | H.srcSpanEndLine lAnn == H.srcSpanStartLine rAnn = Just $ - changeLine (H.srcSpanEndLine lAnn) $ \str -> - let (pre, post) = splitAt (H.srcSpanEndColumn lAnn) str - in [trimRight pre ++ " " ++ trimLeft post] - | otherwise = Nothing - where - lAnn = H.ann left - rAnn = H.ann right - - --------------------------------------------------------------------------------- -squashFieldDecl :: H.FieldDecl H.SrcSpan -> Maybe (Change String) -squashFieldDecl (H.FieldDecl _ names type') + :: (S.HasSrcSpan l, S.HasSrcSpan r) + => l -> r -> Maybe (Change String) +squash left right = do + lAnn <- toRealSrcSpan $ S.getLoc left + rAnn <- toRealSrcSpan $ S.getLoc right + if S.srcSpanEndLine lAnn == S.srcSpanStartLine rAnn || + S.srcSpanEndLine lAnn + 1 == S.srcSpanStartLine rAnn + then Just $ + changeLine (S.srcSpanEndLine lAnn) $ \str -> + let (pre, post) = splitAt (S.srcSpanEndCol lAnn) str + in [trimRight pre ++ " " ++ trimLeft post] + else Nothing + + +-------------------------------------------------------------------------------- +squashFieldDecl :: Hs.ConDeclField Hs.GhcPs -> Maybe (Change String) +squashFieldDecl (Hs.ConDeclField _ names type' _) | null names = Nothing | otherwise = squash (last names) type' +squashFieldDecl (Hs.XConDeclField x) = Hs.noExtCon x -------------------------------------------------------------------------------- -squashMatch :: H.Match H.SrcSpan -> Maybe (Change String) -squashMatch (H.InfixMatch _ _ _ _ _ _) = Nothing -squashMatch (H.Match _ name pats rhs _) - | null pats = squash name rhs - | otherwise = squash (last pats) rhs - - --------------------------------------------------------------------------------- -squashAlt :: H.Alt H.SrcSpan -> Maybe (Change String) -squashAlt (H.Alt _ pat rhs _) = squash pat rhs +squashMatch :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> Maybe (Change String) +squashMatch (Hs.Match _ (Hs.FunRhs name _ _) [] grhss) = do + body <- unguardedRhsBody grhss + squash name body +squashMatch (Hs.Match _ _ pats grhss) = do + body <- unguardedRhsBody grhss + squash (last pats) body +squashMatch (Hs.XMatch x) = Hs.noExtCon x -------------------------------------------------------------------------------- step :: Step -step = makeStep "Squash" $ \ls (module', _) -> - let module'' = fmap H.srcInfoSpan module' - changes = concat - [ mapMaybe squashAlt (everything module'') - , mapMaybe squashMatch (everything module'') - , mapMaybe squashFieldDecl (everything module'') - ] - in applyChanges changes ls +step = makeStep "Squash" $ \ls (module') -> + let changes = + mapMaybe squashFieldDecl (everything module') ++ + mapMaybe squashMatch (everything module') in + applyChanges changes ls |