--------------------------------------------------------------------------------
{-# 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 SrcLoc                          as S


--------------------------------------------------------------------------------
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 S.RealSrcSpan] -> [[Alignable S.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
S.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 = [S.Located (Hs.ConDeclField Hs.GhcPs)]


--------------------------------------------------------------------------------
records :: S.Located (Hs.HsModule Hs.GhcPs) -> [Record]
records :: Located (HsModule GhcPs) -> [Record]
records Located (HsModule GhcPs)
modu = do
  let decls :: [HsDecl GhcPs]
decls           = (LHsDecl GhcPs -> HsDecl GhcPs)
-> [LHsDecl GhcPs] -> [HsDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsDecl GhcPs -> HsDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
S.unLoc (HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
Hs.hsmodDecls (Located (HsModule GhcPs) -> SrcSpanLess (Located (HsModule GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
S.unLoc Located (HsModule GhcPs)
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
_ Located (IdP 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 -> HsConDeclDetails GhcPs
forall pass. ConDecl pass -> HsConDeclDetails pass
Hs.con_args ConDecl GhcPs
d of
      Hs.RecCon Located Record
rec -> [Located Record -> SrcSpanLess (Located Record)
forall a. HasSrcSpan a => a -> SrcSpanLess a
S.unLoc Located Record
rec]
      HsConDeclDetails GhcPs
_             -> []
 where
  getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs]
  getConDecls :: HsDataDefn GhcPs -> [ConDecl GhcPs]
getConDecls d :: HsDataDefn GhcPs
d@Hs.HsDataDefn {} = (LConDecl GhcPs -> ConDecl GhcPs)
-> [LConDecl GhcPs] -> [ConDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LConDecl GhcPs -> ConDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
S.unLoc ([LConDecl GhcPs] -> [ConDecl GhcPs])
-> [LConDecl 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
  getConDecls (Hs.XHsDataDefn XXHsDataDefn GhcPs
x) = NoExtCon -> [ConDecl GhcPs]
forall a. NoExtCon -> a
Hs.noExtCon NoExtCon
XXHsDataDefn GhcPs
x


--------------------------------------------------------------------------------
recordToAlignable :: Config -> Record -> [[Alignable S.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
. (Located (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 Located (ConDeclField GhcPs) -> Maybe (Alignable RealSrcSpan)
fieldDeclToAlignable


--------------------------------------------------------------------------------
fieldDeclToAlignable
    :: S.Located (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable S.RealSrcSpan)
fieldDeclToAlignable :: Located (ConDeclField GhcPs) -> Maybe (Alignable RealSrcSpan)
fieldDeclToAlignable (S.L SrcSpan
_ (Hs.XConDeclField XXConDeclField GhcPs
x)) = NoExtCon -> Maybe (Alignable RealSrcSpan)
forall a. NoExtCon -> a
Hs.noExtCon NoExtCon
XXConDeclField GhcPs
x
fieldDeclToAlignable (S.L SrcSpan
matchLoc (Hs.ConDeclField XConDeclField GhcPs
_ [LFieldOcc GhcPs]
names LBangType GhcPs
ty Maybe LHsDocString
_)) = do
  RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan SrcSpan
matchLoc
  RealSrcSpan
leftPos  <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ LFieldOcc GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc (LFieldOcc GhcPs -> SrcSpan) -> LFieldOcc GhcPs -> SrcSpan
forall a b. (a -> b) -> a -> b
$ [LFieldOcc GhcPs] -> LFieldOcc GhcPs
forall a. [a] -> a
last [LFieldOcc GhcPs]
names
  RealSrcSpan
tyPos    <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ LBangType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc LBangType 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 S.RealSrcSpan]]
matchGroupToAlignable :: Config
-> MatchGroup GhcPs (LHsExpr GhcPs) -> [[Alignable RealSrcSpan]]
matchGroupToAlignable Config
_conf (Hs.XMatchGroup XXMatchGroup GhcPs (LHsExpr GhcPs)
x) = NoExtCon -> [[Alignable RealSrcSpan]]
forall a. NoExtCon -> a
Hs.noExtCon NoExtCon
XXMatchGroup GhcPs (LHsExpr GhcPs)
x
matchGroupToAlignable Config
conf (Hs.MG XMG GhcPs (LHsExpr GhcPs)
_ Located [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
$ (LMatch GhcPs (LHsExpr GhcPs)
 -> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan)))
-> [LMatch GhcPs (LHsExpr 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 LMatch GhcPs (LHsExpr GhcPs)
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
matchToAlignable (Located [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
forall a. HasSrcSpan a => a -> SrcSpanLess a
S.unLoc Located [LMatch GhcPs (LHsExpr 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
    :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
    -> Maybe (Either (Alignable S.RealSrcSpan) (Alignable S.RealSrcSpan))
matchToAlignable :: LMatch GhcPs (LHsExpr GhcPs)
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
matchToAlignable (S.L SrcSpan
matchLoc m :: Match GhcPs (LHsExpr GhcPs)
m@(Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NameOrRdrName (IdP GhcPs))
Hs.CaseAlt pats :: [LPat GhcPs]
pats@(LPat GhcPs
_ : [LPat GhcPs]
_) GRHSs GhcPs (LHsExpr GhcPs)
grhss)) = do
  let patsLocs :: [SrcSpan]
patsLocs   = (Located (Pat GhcPs) -> SrcSpan)
-> [Located (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc [LPat GhcPs]
[Located (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 = (GuardLStmt GhcPs -> SrcSpan) -> [GuardLStmt GhcPs] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GuardLStmt GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc [GuardLStmt 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
S.combineSrcSpans SrcSpan
pat [SrcSpan]
guardsLocs
  LHsExpr GhcPs
body     <- GRHSs GhcPs (LHsExpr GhcPs) -> Maybe (LHsExpr GhcPs)
forall a. GRHSs GhcPs a -> Maybe a
rhsBody GRHSs GhcPs (LHsExpr GhcPs)
grhss
  RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan SrcSpan
matchLoc
  RealSrcSpan
leftPos  <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan SrcSpan
left
  RealSrcSpan
rightPos <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc LHsExpr 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 (S.L SrcSpan
matchLoc (Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
_ (Hs.FunRhs Located (NameOrRdrName (IdP GhcPs))
name LexicalFixity
_ SrcStrictness
_) pats :: [LPat GhcPs]
pats@(LPat GhcPs
_ : [LPat GhcPs]
_) GRHSs GhcPs (LHsExpr GhcPs)
grhss)) = do
  LHsExpr GhcPs
body <- GRHSs GhcPs (LHsExpr GhcPs) -> Maybe (LHsExpr GhcPs)
forall a. GRHSs GhcPs a -> Maybe a
unguardedRhsBody GRHSs GhcPs (LHsExpr GhcPs)
grhss
  let patsLocs :: [SrcSpan]
patsLocs = (Located (Pat GhcPs) -> SrcSpan)
-> [Located (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc [LPat GhcPs]
[Located (Pat GhcPs)]
pats
      nameLoc :: SrcSpan
nameLoc  = Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc Located (NameOrRdrName (IdP GhcPs))
Located 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  = LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc LHsExpr GhcPs
body
  RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan SrcSpan
matchLoc
  RealSrcSpan
leftPos  <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan SrcSpan
left
  RealSrcSpan
bodyPos  <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan 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 (S.L SrcSpan
_ (Hs.XMatch XXMatch GhcPs (LHsExpr GhcPs)
x))      = NoExtCon
-> Maybe (Either (Alignable RealSrcSpan) (Alignable RealSrcSpan))
forall a. NoExtCon -> a
Hs.noExtCon NoExtCon
XXMatch GhcPs (LHsExpr GhcPs)
x
matchToAlignable (S.L SrcSpan
_ (Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NameOrRdrName (IdP 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 S.RealSrcSpan]]
multiWayIfToAlignable :: Config -> LHsExpr GhcPs -> [[Alignable RealSrcSpan]]
multiWayIfToAlignable Config
conf (S.L SrcSpan
_ (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
$ (LGRHS GhcPs (LHsExpr GhcPs) -> Maybe (Alignable RealSrcSpan))
-> [LGRHS GhcPs (LHsExpr GhcPs)] -> Maybe [Alignable RealSrcSpan]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LGRHS GhcPs (LHsExpr GhcPs) -> Maybe (Alignable RealSrcSpan)
grhsToAlignable [LGRHS GhcPs (LHsExpr GhcPs)]
grhss
multiWayIfToAlignable Config
_conf LHsExpr GhcPs
_ = []


--------------------------------------------------------------------------------
grhsToAlignable
    :: S.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
    -> Maybe (Alignable S.RealSrcSpan)
grhsToAlignable :: LGRHS GhcPs (LHsExpr GhcPs) -> Maybe (Alignable RealSrcSpan)
grhsToAlignable (S.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 = (GuardLStmt GhcPs -> SrcSpan) -> [GuardLStmt GhcPs] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GuardLStmt GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc [GuardLStmt GhcPs]
guards
        bodyLoc :: SrcSpan
bodyLoc    = LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
S.getLoc LHsExpr GhcPs
body
        left :: SrcSpan
left       = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a. (a -> a -> a) -> [a] -> a
foldl1' SrcSpan -> SrcSpan -> SrcSpan
S.combineSrcSpans [SrcSpan]
guardsLocs
    RealSrcSpan
matchPos <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan SrcSpan
grhsloc
    RealSrcSpan
leftPos  <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan SrcSpan
left
    RealSrcSpan
bodyPos  <- SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan 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 (S.L SrcSpan
_ (Hs.XGRHS XXGRHS GhcPs (LHsExpr GhcPs)
x)) = NoExtCon -> Maybe (Alignable RealSrcSpan)
forall a. NoExtCon -> a
Hs.noExtCon NoExtCon
XXGRHS GhcPs (LHsExpr GhcPs)
x
grhsToAlignable (S.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 -> 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
            :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a])
            -> (a -> [[Alignable S.RealSrcSpan]])
            -> [Change String]
        changes :: (Located (HsModule GhcPs) -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> [Change String]
changes Located (HsModule GhcPs) -> [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 GhcPs) -> [a]
search (Module -> Located (HsModule GhcPs)
parsedModule Module
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 GhcPs) -> [Record])
-> (Record -> [[Alignable RealSrcSpan]]) -> [Change String]
forall a.
(Located (HsModule GhcPs) -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> [Change String]
changes Located (HsModule GhcPs) -> [Record]
records (Config -> Record -> [[Alignable RealSrcSpan]]
recordToAlignable Config
config)] [[Change String]] -> [[Change String]] -> [[Change String]]
forall a. [a] -> [a] -> [a]
++
            [(Located (HsModule GhcPs) -> [MatchGroup GhcPs (LHsExpr GhcPs)])
-> (MatchGroup GhcPs (LHsExpr GhcPs) -> [[Alignable RealSrcSpan]])
-> [Change String]
forall a.
(Located (HsModule GhcPs) -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> [Change String]
changes Located (HsModule GhcPs) -> [MatchGroup GhcPs (LHsExpr 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 GhcPs) -> [LHsExpr GhcPs])
-> (LHsExpr GhcPs -> [[Alignable RealSrcSpan]]) -> [Change String]
forall a.
(Located (HsModule GhcPs) -> [a])
-> (a -> [[Alignable RealSrcSpan]]) -> [Change String]
changes Located (HsModule GhcPs) -> [LHsExpr 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