{-# 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 Language.Haskell.Stylish.Editor
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
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> 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
/= :: Align -> Align -> Bool
$c/= :: Align -> Align -> Bool
== :: Align -> Align -> Bool
$c== :: 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
showList :: [Align] -> ShowS
$cshowList :: [Align] -> ShowS
show :: Align -> String
$cshow :: Align -> String
showsPrec :: Int -> Align -> ShowS
$cshowsPrec :: Int -> Align -> ShowS
Show)
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config :: Align -> Align -> Align -> Align -> Config
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 (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 :: GHC.Located Hs.HsModule -> [Record]
records :: Located HsModule -> [Record]
records Located HsModule
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 -> [LHsDecl GhcPs]
Hs.hsmodDecls (Located HsModule -> HsModule
forall l e. GenLocated l e -> e
GHC.unLoc Located HsModule
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 {} <- (HsDataDefn GhcPs -> [ConDecl GhcPs])
-> [HsDataDefn GhcPs] -> [ConDecl GhcPs]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HsDataDefn GhcPs -> [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
_ -> []
where
getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs]
getConDecls :: HsDataDefn GhcPs -> [ConDecl GhcPs]
getConDecls d :: HsDataDefn GhcPs
d@Hs.HsDataDefn {} = (GenLocated SrcSpanAnnA (ConDecl GhcPs) -> ConDecl GhcPs)
-> [GenLocated SrcSpanAnnA (ConDecl GhcPs)] -> [ConDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map 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 a b. (a -> b) -> a -> b
$ HsDataDefn GhcPs -> [LConDecl GhcPs]
forall pass. HsDataDefn pass -> [LConDecl pass]
Hs.dd_cons HsDataDefn GhcPs
d
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)
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 LHsDocString
_)) = 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 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
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 :: forall a. a -> a -> a -> Int -> Alignable a
Alignable
{ aContainer :: RealSrcSpan
aContainer = RealSrcSpan
matchPos
, aLeft :: RealSrcSpan
aLeft = RealSrcSpan
leftPos
, aRight :: RealSrcSpan
aRight = RealSrcSpan
tyPos
, aRightLead :: Int
aRightLead = String -> 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 (Hs.MG XMG GhcPs (LHsExpr GhcPs)
_ XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]
alts Origin
_) = [[Alignable RealSrcSpan]]
cases' [[Alignable RealSrcSpan]]
-> [[Alignable RealSrcSpan]] -> [[Alignable RealSrcSpan]]
forall a. [a] -> [a] -> [a]
++ [[Alignable RealSrcSpan]]
patterns'
where
([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)
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 (LHsExpr 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 (NoGhcTc 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. [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 (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 :: forall a. a -> a -> a -> Int -> Alignable a
Alignable
{ aContainer :: RealSrcSpan
aContainer = RealSrcSpan
matchPos
, aLeft :: RealSrcSpan
aLeft = RealSrcSpan
leftPos
, aRight :: RealSrcSpan
aRight = RealSrcSpan
rightPos
, aRightLead :: Int
aRightLead = String -> 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. [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 :: forall a. a -> a -> a -> Int -> Alignable a
Alignable
{ aContainer :: RealSrcSpan
aContainer = RealSrcSpan
matchPos
, aLeft :: RealSrcSpan
aLeft = RealSrcSpan
leftPos
, aRight :: RealSrcSpan
aRight = RealSrcSpan
bodyPos
, aRightLead :: Int
aRightLead = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
"= "
}
matchToAlignable (GHC.L SrcSpanAnnA
_ (Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NoGhcTc 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 _ (Hs.HsMultiIf _ 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
$ (Located (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Alignable RealSrcSpan))
-> [Located (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)
traverse Located (GRHS GhcPs (LHsExpr GhcPs))
-> Maybe (Alignable RealSrcSpan)
Located (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Alignable RealSrcSpan)
grhsToAlignable [LGRHS GhcPs (LHsExpr GhcPs)]
[Located (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
grhss
multiWayIfToAlignable Config
_conf LHsExpr GhcPs
_ = []
grhsToAlignable
:: GHC.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
-> Maybe (Alignable GHC.RealSrcSpan)
grhsToAlignable :: Located (GRHS GhcPs (LHsExpr GhcPs))
-> Maybe (Alignable RealSrcSpan)
grhsToAlignable (GHC.L 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. (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 :: forall a. a -> a -> a -> Int -> Alignable a
Alignable
{ aContainer :: RealSrcSpan
aContainer = RealSrcSpan
matchPos
, aLeft :: RealSrcSpan
aLeft = RealSrcSpan
leftPos
, aRight :: RealSrcSpan
aRight = RealSrcSpan
bodyPos
, aRightLead :: Int
aRightLead = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
"-> "
}
grhsToAlignable (GHC.L SrcSpan
_ 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 -> Located HsModule -> Lines) -> Step
makeStep String
"Cases" ((Lines -> Located HsModule -> Lines) -> Step)
-> (Lines -> Located HsModule -> Lines) -> Step
forall a b. (a -> b) -> a -> b
$ \Lines
ls Located HsModule
module' ->
let changes
:: (GHC.Located Hs.HsModule -> [a])
-> (a -> [[Alignable GHC.RealSrcSpan]])
-> [Change String]
changes :: (Located HsModule -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> [Change String]
changes Located HsModule -> [a]
search a -> [[Alignable RealSrcSpan]]
toAlign =
(([[Alignable RealSrcSpan]] -> [Change String])
-> [[[Alignable RealSrcSpan]]] -> [Change String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([[Alignable RealSrcSpan]] -> [Change String])
-> [[[Alignable RealSrcSpan]]] -> [Change String])
-> (([Alignable RealSrcSpan] -> [Change String])
-> [[Alignable RealSrcSpan]] -> [Change String])
-> ([Alignable RealSrcSpan] -> [Change String])
-> [[[Alignable RealSrcSpan]]]
-> [Change String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Alignable RealSrcSpan] -> [Change String])
-> [[Alignable RealSrcSpan]] -> [Change String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap) (Maybe Int -> [Alignable RealSrcSpan] -> [Change String]
align Maybe Int
maxColumns) ([[[Alignable RealSrcSpan]]] -> [Change String])
-> ([a] -> [[[Alignable RealSrcSpan]]]) -> [a] -> [Change String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [[Alignable RealSrcSpan]])
-> [a] -> [[[Alignable RealSrcSpan]]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [[Alignable RealSrcSpan]]
toAlign ([a] -> [Change String]) -> [a] -> [Change String]
forall a b. (a -> b) -> a -> b
$
Located HsModule -> [a]
search Located HsModule
module'
configured :: [Change String]
configured :: [Change String]
configured = [[Change String]] -> [Change String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Change String]] -> [Change String])
-> [[Change String]] -> [Change String]
forall a b. (a -> b) -> a -> b
$
[(Located HsModule -> [Record])
-> (Record -> [[Alignable RealSrcSpan]]) -> [Change String]
forall a.
(Located HsModule -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> [Change String]
changes Located HsModule -> [Record]
records (Config -> Record -> [[Alignable RealSrcSpan]]
recordToAlignable Config
config)] [[Change String]] -> [[Change String]] -> [[Change String]]
forall a. [a] -> [a] -> [a]
++
[(Located HsModule
-> [MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [[Alignable RealSrcSpan]])
-> [Change String]
forall a.
(Located HsModule -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> [Change String]
changes Located HsModule
-> [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)] [[Change String]] -> [[Change String]] -> [[Change String]]
forall a. [a] -> [a] -> [a]
++
[(Located HsModule -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [[Alignable RealSrcSpan]])
-> [Change String]
forall a.
(Located HsModule -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> [Change String]
changes Located HsModule -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (Data a, Data b) => a -> [b]
everything (Config -> LHsExpr GhcPs -> [[Alignable RealSrcSpan]]
multiWayIfToAlignable Config
config)] in
[Change String] -> Lines -> Lines
forall a. [Change a] -> [a] -> [a]
applyChanges [Change String]
configured Lines
ls