{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Language.Haskell.Stylish.Step.SimpleAlign
( Config (..)
, Align (..)
, defaultConfig
, step
) where
import Data.Either (partitionEithers)
import Data.Foldable (toList)
import Data.List (foldl', foldl1', sortOn)
import Data.Maybe (fromMaybe)
import qualified GHC.Hs as Hs
import qualified GHC.Parser.Annotation as GHC
import qualified GHC.Types.SrcLoc as GHC
import Language.Haskell.Stylish.Align
import qualified Language.Haskell.Stylish.Editor as Editor
import Language.Haskell.Stylish.GHC
import Language.Haskell.Stylish.Module
import Language.Haskell.Stylish.Step
import Language.Haskell.Stylish.Util
data Config = Config
{ Config -> Align
cCases :: Align
, Config -> Align
cTopLevelPatterns :: Align
, Config -> Align
cRecords :: Align
, Config -> Align
cMultiWayIf :: Align
} deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)
data Align
= Always
| Adjacent
| Never
deriving (Align -> Align -> Bool
(Align -> Align -> Bool) -> (Align -> Align -> Bool) -> Eq Align
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Align -> Align -> Bool
== :: Align -> Align -> Bool
$c/= :: Align -> Align -> Bool
/= :: Align -> Align -> Bool
Eq, Int -> Align -> ShowS
[Align] -> ShowS
Align -> String
(Int -> Align -> ShowS)
-> (Align -> String) -> ([Align] -> ShowS) -> Show Align
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Align -> ShowS
showsPrec :: Int -> Align -> ShowS
$cshow :: Align -> String
show :: Align -> String
$cshowList :: [Align] -> ShowS
showList :: [Align] -> ShowS
Show)
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config
{ cCases :: Align
cCases = Align
Always
, cTopLevelPatterns :: Align
cTopLevelPatterns = Align
Always
, cRecords :: Align
cRecords = Align
Always
, cMultiWayIf :: Align
cMultiWayIf = Align
Always
}
groupAlign :: Align -> [Alignable GHC.RealSrcSpan] -> [[Alignable GHC.RealSrcSpan]]
groupAlign :: Align -> [Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]]
groupAlign Align
a [Alignable RealSrcSpan]
xs = case Align
a of
Align
Never -> []
Align
Adjacent -> [Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]]
byLine ([Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]])
-> ([Alignable RealSrcSpan] -> [Alignable RealSrcSpan])
-> [Alignable RealSrcSpan]
-> [[Alignable RealSrcSpan]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Alignable RealSrcSpan -> Int)
-> [Alignable RealSrcSpan] -> [Alignable RealSrcSpan]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (RealSrcSpan -> Int
GHC.srcSpanStartLine (RealSrcSpan -> Int)
-> (Alignable RealSrcSpan -> RealSrcSpan)
-> Alignable RealSrcSpan
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alignable RealSrcSpan -> RealSrcSpan
forall a. Alignable a -> a
aLeft) ([Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]])
-> [Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]]
forall a b. (a -> b) -> a -> b
$ [Alignable RealSrcSpan]
xs
Align
Always -> [[Alignable RealSrcSpan]
xs]
where
byLine :: [Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]]
byLine = (NonEmpty (Alignable RealSrcSpan) -> [Alignable RealSrcSpan])
-> [NonEmpty (Alignable RealSrcSpan)] -> [[Alignable RealSrcSpan]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty (Alignable RealSrcSpan) -> [Alignable RealSrcSpan]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([NonEmpty (Alignable RealSrcSpan)] -> [[Alignable RealSrcSpan]])
-> ([Alignable RealSrcSpan] -> [NonEmpty (Alignable RealSrcSpan)])
-> [Alignable RealSrcSpan]
-> [[Alignable RealSrcSpan]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Alignable RealSrcSpan -> RealSrcSpan)
-> [Alignable RealSrcSpan] -> [NonEmpty (Alignable RealSrcSpan)]
forall a. (a -> RealSrcSpan) -> [a] -> [NonEmpty a]
groupByLine Alignable RealSrcSpan -> RealSrcSpan
forall a. Alignable a -> a
aLeft
type Record = [GHC.LocatedA (Hs.ConDeclField Hs.GhcPs)]
records :: Module -> [Record]
records :: Module -> [Record]
records Module
modu = do
let decls :: [HsDecl GhcPs]
decls = (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [HsDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsDecl GhcPs) -> HsDecl GhcPs
forall l e. GenLocated l e -> e
GHC.unLoc (HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
Hs.hsmodDecls (Module -> HsModule GhcPs
forall l e. GenLocated l e -> e
GHC.unLoc Module
modu))
tyClDecls :: [TyClDecl GhcPs]
tyClDecls = [ TyClDecl GhcPs
tyClDecl | Hs.TyClD XTyClD GhcPs
_ TyClDecl GhcPs
tyClDecl <- [HsDecl GhcPs]
decls ]
dataDecls :: [TyClDecl GhcPs]
dataDecls = [ TyClDecl GhcPs
d | d :: TyClDecl GhcPs
d@(Hs.DataDecl XDataDecl GhcPs
_ LIdP GhcPs
_ LHsQTyVars GhcPs
_ LexicalFixity
_ HsDataDefn GhcPs
_) <- [TyClDecl GhcPs]
tyClDecls ]
dataDefns :: [HsDataDefn GhcPs]
dataDefns = (TyClDecl GhcPs -> HsDataDefn GhcPs)
-> [TyClDecl GhcPs] -> [HsDataDefn GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map TyClDecl GhcPs -> HsDataDefn GhcPs
forall pass. TyClDecl pass -> HsDataDefn pass
Hs.tcdDataDefn [TyClDecl GhcPs]
dataDecls
d :: ConDecl GhcPs
d@Hs.ConDeclH98 {} <- GenLocated SrcSpanAnnA (ConDecl GhcPs) -> ConDecl GhcPs
forall l e. GenLocated l e -> e
GHC.unLoc (GenLocated SrcSpanAnnA (ConDecl GhcPs) -> ConDecl GhcPs)
-> [GenLocated SrcSpanAnnA (ConDecl GhcPs)] -> [ConDecl GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HsDataDefn GhcPs -> [GenLocated SrcSpanAnnA (ConDecl GhcPs)])
-> [HsDataDefn GhcPs] -> [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HsDataDefn GhcPs -> [LConDecl GhcPs]
HsDataDefn GhcPs -> [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
getConDecls [HsDataDefn GhcPs]
dataDefns
case ConDecl GhcPs -> HsConDeclH98Details GhcPs
forall pass. ConDecl pass -> HsConDeclH98Details pass
Hs.con_args ConDecl GhcPs
d of
Hs.RecCon XRec GhcPs [LConDeclField GhcPs]
rec -> [GenLocated SrcSpanAnnL Record -> Record
forall l e. GenLocated l e -> e
GHC.unLoc XRec GhcPs [LConDeclField GhcPs]
GenLocated SrcSpanAnnL Record
rec]
HsConDeclH98Details GhcPs
_ -> []
recordToAlignable :: Config -> Record -> [[Alignable GHC.RealSrcSpan]]
recordToAlignable :: Config -> Record -> [[Alignable RealSrcSpan]]
recordToAlignable Config
conf = Align -> [Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]]
groupAlign (Config -> Align
cRecords Config
conf) ([Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]])
-> (Record -> [Alignable RealSrcSpan])
-> Record
-> [[Alignable RealSrcSpan]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Alignable RealSrcSpan]
-> Maybe [Alignable RealSrcSpan] -> [Alignable RealSrcSpan]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Alignable RealSrcSpan] -> [Alignable RealSrcSpan])
-> (Record -> Maybe [Alignable RealSrcSpan])
-> Record
-> [Alignable RealSrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocatedA (ConDeclField GhcPs) -> Maybe (Alignable RealSrcSpan))
-> Record -> Maybe [Alignable RealSrcSpan]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LocatedA (ConDeclField GhcPs) -> Maybe (Alignable RealSrcSpan)
fieldDeclToAlignable
fieldDeclToAlignable
:: GHC.LocatedA (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable GHC.RealSrcSpan)
fieldDeclToAlignable :: LocatedA (ConDeclField GhcPs) -> Maybe (Alignable RealSrcSpan)
fieldDeclToAlignable (GHC.L SrcSpanAnnA
matchLoc (Hs.ConDeclField XConDeclField GhcPs
_ [LFieldOcc GhcPs]
names LBangType GhcPs
ty Maybe (LHsDoc GhcPs)
_)) = do
RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
matchLoc
RealSrcSpan
leftPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
-> SrcSpan)
-> GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
-> SrcSpan
forall a b. (a -> b) -> a -> b
$ [GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)]
-> GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
forall a. HasCallStack => [a] -> a
last [LFieldOcc GhcPs]
[GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)]
names
RealSrcSpan
tyPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LBangType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty
Alignable RealSrcSpan -> Maybe (Alignable RealSrcSpan)
forall a. a -> Maybe a
Just (Alignable RealSrcSpan -> Maybe (Alignable RealSrcSpan))
-> Alignable RealSrcSpan -> Maybe (Alignable RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ Alignable
{ aContainer :: RealSrcSpan
aContainer = RealSrcSpan
matchPos
, aLeft :: RealSrcSpan
aLeft = RealSrcSpan
leftPos
, aRight :: RealSrcSpan
aRight = RealSrcSpan
tyPos
, aRightLead :: Int
aRightLead = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
":: "
}
matchGroupToAlignable
:: Config
-> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)
-> [[Alignable GHC.RealSrcSpan]]
matchGroupToAlignable :: Config
-> MatchGroup GhcPs (LHsExpr GhcPs) -> [[Alignable RealSrcSpan]]
matchGroupToAlignable Config
conf MatchGroup GhcPs (LHsExpr GhcPs)
mg = [[Alignable RealSrcSpan]]
cases' [[Alignable RealSrcSpan]]
-> [[Alignable RealSrcSpan]] -> [[Alignable RealSrcSpan]]
forall a. [a] -> [a] -> [a]
++ [[Alignable RealSrcSpan]]
patterns'
where
alts :: XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
alts = MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec
GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall p body. MatchGroup p body -> XRec p [LMatch p body]
Hs.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mg
([Alignable RealSrcSpan]
cases, [Alignable RealSrcSpan]
patterns) = [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
-> ([Alignable RealSrcSpan], [Alignable RealSrcSpan])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
-> ([Alignable RealSrcSpan], [Alignable RealSrcSpan]))
-> (Maybe [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
-> [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)])
-> Maybe [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
-> ([Alignable RealSrcSpan], [Alignable RealSrcSpan])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
-> Maybe [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
-> [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
-> ([Alignable RealSrcSpan], [Alignable RealSrcSpan]))
-> Maybe [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
-> ([Alignable RealSrcSpan], [Alignable RealSrcSpan])
forall a b. (a -> b) -> a -> b
$ (LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)))
-> [LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe [Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LocatedA (Match GhcPs (LHsExpr GhcPs))
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
matchToAlignable (GenLocated
SrcSpanAnnL
[LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. GenLocated l e -> e
GHC.unLoc XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
GenLocated
SrcSpanAnnL
[LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts)
cases' :: [[Alignable RealSrcSpan]]
cases' = Align -> [Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]]
groupAlign (Config -> Align
cCases Config
conf) [Alignable RealSrcSpan]
cases
patterns' :: [[Alignable RealSrcSpan]]
patterns' = Align -> [Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]]
groupAlign (Config -> Align
cTopLevelPatterns Config
conf) [Alignable RealSrcSpan]
patterns
matchToAlignable
:: GHC.LocatedA (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
-> Maybe (Either (Alignable GHC.RealSrcSpan) (Alignable GHC.RealSrcSpan))
matchToAlignable :: LocatedA (Match GhcPs (LHsExpr GhcPs))
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
matchToAlignable (GHC.L SrcSpanAnnA
matchLoc m :: Match GhcPs (LHsExpr GhcPs)
m@(Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext GhcPs
Hs.CaseAlt pats :: [LPat GhcPs]
pats@(LPat GhcPs
_ : [LPat GhcPs]
_) GRHSs GhcPs (LHsExpr GhcPs)
grhss)) = do
let patsLocs :: [SrcSpan]
patsLocs = (GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats
pat :: SrcSpan
pat = [SrcSpan] -> SrcSpan
forall a. HasCallStack => [a] -> a
last [SrcSpan]
patsLocs
guards :: [GuardLStmt GhcPs]
guards = Match GhcPs (LHsExpr GhcPs) -> [GuardLStmt GhcPs]
getGuards Match GhcPs (LHsExpr GhcPs)
m
guardsLocs :: [SrcSpan]
guardsLocs = (GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> SrcSpan)
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA [GuardLStmt GhcPs]
[GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
guards
left :: SrcSpan
left = (SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SrcSpan -> SrcSpan -> SrcSpan
GHC.combineSrcSpans SrcSpan
pat [SrcSpan]
guardsLocs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body <- GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. GRHSs GhcPs a -> Maybe a
rhsBody GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss
RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
matchLoc
RealSrcSpan
leftPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan SrcSpan
left
RealSrcSpan
rightPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
forall a. a -> Maybe a
Just (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)))
-> (Alignable RealSrcSpan
-> Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
-> Alignable RealSrcSpan
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alignable RealSrcSpan
-> Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)
forall a b. a -> Either a b
Left (Alignable RealSrcSpan
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)))
-> Alignable RealSrcSpan
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
forall a b. (a -> b) -> a -> b
$ Alignable
{ aContainer :: RealSrcSpan
aContainer = RealSrcSpan
matchPos
, aLeft :: RealSrcSpan
aLeft = RealSrcSpan
leftPos
, aRight :: RealSrcSpan
aRight = RealSrcSpan
rightPos
, aRightLead :: Int
aRightLead = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
"-> "
}
matchToAlignable (GHC.L SrcSpanAnnA
matchLoc (Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
_ (Hs.FunRhs LIdP (NoGhcTc GhcPs)
name LexicalFixity
_ SrcStrictness
_) pats :: [LPat GhcPs]
pats@(LPat GhcPs
_ : [LPat GhcPs]
_) GRHSs GhcPs (LHsExpr GhcPs)
grhss)) = do
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body <- GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. GRHSs GhcPs a -> Maybe a
unguardedRhsBody GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss
let patsLocs :: [SrcSpan]
patsLocs = (GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats
nameLoc :: SrcSpan
nameLoc = 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
left :: SrcSpan
left = [SrcSpan] -> SrcSpan
forall a. HasCallStack => [a] -> a
last (SrcSpan
nameLoc SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: [SrcSpan]
patsLocs)
bodyLoc :: SrcSpan
bodyLoc = GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
matchLoc
RealSrcSpan
leftPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan SrcSpan
left
RealSrcSpan
bodyPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan SrcSpan
bodyLoc
Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
forall a. a -> Maybe a
Just (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)))
-> (Alignable RealSrcSpan
-> Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
-> Alignable RealSrcSpan
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alignable RealSrcSpan
-> Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)
forall a b. b -> Either a b
Right (Alignable RealSrcSpan
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)))
-> Alignable RealSrcSpan
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
forall a b. (a -> b) -> a -> b
$ Alignable
{ aContainer :: RealSrcSpan
aContainer = RealSrcSpan
matchPos
, aLeft :: RealSrcSpan
aLeft = RealSrcSpan
leftPos
, aRight :: RealSrcSpan
aRight = RealSrcSpan
bodyPos
, aRightLead :: Int
aRightLead = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
"= "
}
matchToAlignable (GHC.L SrcSpanAnnA
_ (Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext GhcPs
_ [LPat GhcPs]
_ GRHSs GhcPs (LHsExpr GhcPs)
_)) = Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
forall a. Maybe a
Nothing
multiWayIfToAlignable
:: Config
-> Hs.LHsExpr Hs.GhcPs
-> [[Alignable GHC.RealSrcSpan]]
multiWayIfToAlignable :: Config -> LHsExpr GhcPs -> [[Alignable RealSrcSpan]]
multiWayIfToAlignable Config
conf (GHC.L SrcSpanAnnA
_ (Hs.HsMultiIf XMultiIf GhcPs
_ [LGRHS GhcPs (LHsExpr GhcPs)]
grhss)) =
Align -> [Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]]
groupAlign (Config -> Align
cMultiWayIf Config
conf) [Alignable RealSrcSpan]
as
where
as :: [Alignable RealSrcSpan]
as = [Alignable RealSrcSpan]
-> Maybe [Alignable RealSrcSpan] -> [Alignable RealSrcSpan]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Alignable RealSrcSpan] -> [Alignable RealSrcSpan])
-> Maybe [Alignable RealSrcSpan] -> [Alignable RealSrcSpan]
forall a b. (a -> b) -> a -> b
$ (GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Alignable RealSrcSpan))
-> [GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe [Alignable RealSrcSpan]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns)) (GRHS GhcPs (LHsExpr GhcPs))
-> Maybe (Alignable RealSrcSpan)
GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Alignable RealSrcSpan)
forall a.
GenLocated (SrcSpanAnn' a) (GRHS GhcPs (LHsExpr GhcPs))
-> Maybe (Alignable RealSrcSpan)
grhsToAlignable [LGRHS GhcPs (LHsExpr GhcPs)]
[GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
grhss
multiWayIfToAlignable Config
_conf LHsExpr GhcPs
_ = []
grhsToAlignable
:: GHC.GenLocated (GHC.SrcSpanAnn' a) (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
-> Maybe (Alignable GHC.RealSrcSpan)
grhsToAlignable :: forall a.
GenLocated (SrcSpanAnn' a) (GRHS GhcPs (LHsExpr GhcPs))
-> Maybe (Alignable RealSrcSpan)
grhsToAlignable (GHC.L (GHC.SrcSpanAnn a
_ SrcSpan
grhsloc) (Hs.GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ guards :: [GuardLStmt GhcPs]
guards@(GuardLStmt GhcPs
_ : [GuardLStmt GhcPs]
_) LHsExpr GhcPs
body)) = do
let guardsLocs :: [SrcSpan]
guardsLocs = (GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> SrcSpan)
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA [GuardLStmt GhcPs]
[GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
guards
bodyLoc :: SrcSpan
bodyLoc = GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
left :: SrcSpan
left = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' SrcSpan -> SrcSpan -> SrcSpan
GHC.combineSrcSpans [SrcSpan]
guardsLocs
RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan SrcSpan
grhsloc
RealSrcSpan
leftPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan SrcSpan
left
RealSrcSpan
bodyPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan SrcSpan
bodyLoc
Alignable RealSrcSpan -> Maybe (Alignable RealSrcSpan)
forall a. a -> Maybe a
Just (Alignable RealSrcSpan -> Maybe (Alignable RealSrcSpan))
-> Alignable RealSrcSpan -> Maybe (Alignable RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ Alignable
{ aContainer :: RealSrcSpan
aContainer = RealSrcSpan
matchPos
, aLeft :: RealSrcSpan
aLeft = RealSrcSpan
leftPos
, aRight :: RealSrcSpan
aRight = RealSrcSpan
bodyPos
, aRightLead :: Int
aRightLead = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
"-> "
}
grhsToAlignable (GHC.L SrcSpanAnn' a
_ GRHS GhcPs (LHsExpr GhcPs)
_) = Maybe (Alignable RealSrcSpan)
forall a. Maybe a
Nothing
step :: Maybe Int -> Config -> Step
step :: Maybe Int -> Config -> Step
step Maybe Int
maxColumns Config
config = String -> (Lines -> Module -> Lines) -> Step
makeStep String
"Cases" ((Lines -> Module -> Lines) -> Step)
-> (Lines -> Module -> Lines) -> Step
forall a b. (a -> b) -> a -> b
$ \Lines
ls Module
module' ->
let changes
:: (Module -> [a])
-> (a -> [[Alignable GHC.RealSrcSpan]])
-> Editor.Edits
changes :: forall a.
(Module -> [a]) -> (a -> [[Alignable RealSrcSpan]]) -> Edits
changes Module -> [a]
search a -> [[Alignable RealSrcSpan]]
toAlign = [Edits] -> Edits
forall a. Monoid a => [a] -> a
mconcat ([Edits] -> Edits) -> [Edits] -> Edits
forall a b. (a -> b) -> a -> b
$ do
a
item <- Module -> [a]
search Module
module'
Edits -> [Edits]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Edits -> [Edits]) -> Edits -> [Edits]
forall a b. (a -> b) -> a -> b
$ ([Alignable RealSrcSpan] -> Edits)
-> [[Alignable RealSrcSpan]] -> Edits
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe Int -> [Alignable RealSrcSpan] -> Edits
align Maybe Int
maxColumns) (a -> [[Alignable RealSrcSpan]]
toAlign a
item)
configured :: Editor.Edits
configured :: Edits
configured =
(Module -> [Record])
-> (Record -> [[Alignable RealSrcSpan]]) -> Edits
forall a.
(Module -> [a]) -> (a -> [[Alignable RealSrcSpan]]) -> Edits
changes Module -> [Record]
records (Config -> Record -> [[Alignable RealSrcSpan]]
recordToAlignable Config
config) Edits -> Edits -> Edits
forall a. Semigroup a => a -> a -> a
<>
(Module
-> [MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [[Alignable RealSrcSpan]])
-> Edits
forall a.
(Module -> [a]) -> (a -> [[Alignable RealSrcSpan]]) -> Edits
changes Module
-> [MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a b. (Data a, Data b) => a -> [b]
everything (Config
-> MatchGroup GhcPs (LHsExpr GhcPs) -> [[Alignable RealSrcSpan]]
matchGroupToAlignable Config
config) Edits -> Edits -> Edits
forall a. Semigroup a => a -> a -> a
<>
(Module -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [[Alignable RealSrcSpan]])
-> Edits
forall a.
(Module -> [a]) -> (a -> [[Alignable RealSrcSpan]]) -> Edits
changes Module -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (Data a, Data b) => a -> [b]
everything (Config -> LHsExpr GhcPs -> [[Alignable RealSrcSpan]]
multiWayIfToAlignable Config
config) in
Edits -> Lines -> Lines
Editor.apply Edits
configured Lines
ls