--------------------------------------------------------------------------------
{-# 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.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]])
            -> Editor.Edits
        changes :: (Located HsModule -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> Edits
changes Located HsModule -> [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 <- Located HsModule -> [a]
search Located HsModule
module'
            Edits -> [Edits]
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 (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 =
            (Located HsModule -> [Record])
-> (Record -> [[Alignable RealSrcSpan]]) -> Edits
forall a.
(Located HsModule -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> Edits
changes Located HsModule -> [Record]
records (Config -> Record -> [[Alignable RealSrcSpan]]
recordToAlignable Config
config) Edits -> Edits -> Edits
forall a. Semigroup a => a -> a -> a
<>
            (Located HsModule
 -> [MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> [[Alignable RealSrcSpan]])
-> Edits
forall a.
(Located HsModule -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> Edits
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) Edits -> Edits -> Edits
forall a. Semigroup a => a -> a -> a
<>
            (Located HsModule -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> [[Alignable RealSrcSpan]])
-> Edits
forall a.
(Located HsModule -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> Edits
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
    Edits -> Lines -> Lines
Editor.apply Edits
configured Lines
ls