{-# 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
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
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
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
{ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (RealSrcSpan -> Int
GHC.srcSpanStartLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Alignable a -> a
aLeft) forall a b. (a -> b) -> a -> b
$ [Alignable RealSrcSpan]
xs
Align
Always -> [[Alignable RealSrcSpan]
xs]
where
byLine :: [Alignable RealSrcSpan] -> [[Alignable RealSrcSpan]]
byLine = forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> RealSrcSpan) -> [a] -> [NonEmpty a]
groupByLine 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 = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
GHC.unLoc (forall p. HsModule p -> [LHsDecl p]
Hs.hsmodDecls (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 = forall a b. (a -> b) -> [a] -> [b]
map forall pass. TyClDecl pass -> HsDataDefn pass
Hs.tcdDataDefn [TyClDecl GhcPs]
dataDecls
d :: ConDecl GhcPs
d@Hs.ConDeclH98 {} <- forall l e. GenLocated l e -> e
GHC.unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HsDataDefn GhcPs -> [LConDecl GhcPs]
getConDecls [HsDataDefn GhcPs]
dataDefns
case forall pass. ConDecl pass -> HsConDeclH98Details pass
Hs.con_args ConDecl GhcPs
d of
Hs.RecCon XRec GhcPs [LConDeclField GhcPs]
rec -> [forall l e. GenLocated l e -> e
GHC.unLoc XRec GhcPs [LConDeclField GhcPs]
rec]
HsConDetails
Void
(HsScaled GhcPs (LBangType GhcPs))
(XRec GhcPs [LConDeclField 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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (LHsDoc GhcPs)
_)) = do
RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
matchLoc
RealSrcSpan
leftPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan forall a b. (a -> b) -> a -> b
$ forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [LFieldOcc GhcPs]
names
RealSrcSpan
tyPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan forall a b. (a -> b) -> a -> b
$ forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LBangType GhcPs
ty
forall a. a -> Maybe a
Just 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 = 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' forall a. [a] -> [a] -> [a]
++ [[Alignable RealSrcSpan]]
patterns'
where
alts :: XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
alts = forall p body. MatchGroup p body -> XRec p [LMatch p body]
Hs.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
mg
([Alignable RealSrcSpan]
cases, [Alignable RealSrcSpan]
patterns) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ 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))
matchToAlignable (forall l e. GenLocated l e -> e
GHC.unLoc XRec GhcPs [LMatch 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA [LPat GhcPs]
pats
pat :: SrcSpan
pat = 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA [GuardLStmt GhcPs]
guards
left :: SrcSpan
left = 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 <- forall a. GRHSs GhcPs a -> Maybe a
rhsBody GRHSs GhcPs (LHsExpr GhcPs)
grhss
RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left 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 = 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 <- forall a. GRHSs GhcPs a -> Maybe a
unguardedRhsBody GRHSs GhcPs (LHsExpr GhcPs)
grhss
let patsLocs :: [SrcSpan]
patsLocs = forall a b. (a -> b) -> [a] -> [b]
map forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA [LPat GhcPs]
pats
nameLoc :: SrcSpan
nameLoc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LIdP (NoGhcTc GhcPs)
name
left :: SrcSpan
left = forall a. [a] -> a
last (SrcSpan
nameLoc forall a. a -> [a] -> [a]
: [SrcSpan]
patsLocs)
bodyLoc :: SrcSpan
bodyLoc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan forall a b. (a -> b) -> a -> b
$ 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
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right 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 = 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)
_)) = 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 = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a.
GenLocated (SrcSpanAnn' a) (GRHS GhcPs (LHsExpr GhcPs))
-> Maybe (Alignable RealSrcSpan)
grhsToAlignable [LGRHS GhcPs (LHsExpr 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA [GuardLStmt GhcPs]
guards
bodyLoc :: SrcSpan
bodyLoc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
body
left :: SrcSpan
left = 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
forall a. a -> Maybe a
Just 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
"-> "
}
grhsToAlignable (GHC.L SrcSpanAnn' a
_ GRHS GhcPs (LHsExpr GhcPs)
_) = 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" 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 = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ do
a
item <- Module -> [a]
search Module
module'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 =
forall a.
(Module -> [a]) -> (a -> [[Alignable RealSrcSpan]]) -> Edits
changes Module -> [Record]
records (Config -> Record -> [[Alignable RealSrcSpan]]
recordToAlignable Config
config) forall a. Semigroup a => a -> a -> a
<>
forall a.
(Module -> [a]) -> (a -> [[Alignable RealSrcSpan]]) -> Edits
changes forall a b. (Data a, Data b) => a -> [b]
everything (Config
-> MatchGroup GhcPs (LHsExpr GhcPs) -> [[Alignable RealSrcSpan]]
matchGroupToAlignable Config
config) forall a. Semigroup a => a -> a -> a
<>
forall a.
(Module -> [a]) -> (a -> [[Alignable RealSrcSpan]]) -> Edits
changes 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