{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Ormolu.Printer.Meat.Declaration.Value
  ( p_valDecl,
    p_pat,
    p_hsExpr,
    p_hsSplice,
    p_stringLit,
  )
where

import Bag (bagToList)
import BasicTypes
import Control.Monad
import Ctype (is_space)
import Data.Bool (bool)
import Data.Char (isPunctuation, isSymbol)
import Data.Data hiding (Infix, Prefix)
import Data.Functor ((<&>))
import Data.List (intersperse, sortOn)
import Data.List.NonEmpty ((<|), NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as Text
import GHC
import OccName (mkVarOcc)
import Ormolu.Printer.Combinators
import Ormolu.Printer.Internal
import Ormolu.Printer.Meat.Common
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
import Ormolu.Printer.Meat.Declaration.Signature
import Ormolu.Printer.Meat.Type
import Ormolu.Printer.Operators
import Ormolu.Utils
import RdrName (RdrName (..), rdrNameOcc)
import SrcLoc (combineSrcSpans, isOneLineSpan)

-- | Style of a group of equations.
data MatchGroupStyle
  = Function (Located RdrName)
  | PatternBind
  | Case
  | Lambda
  | LambdaCase

-- | Style of equations in a group.
data GroupStyle
  = EqualSign
  | RightArrow

-- | Expression placement. This marks the places where expressions that
-- implement handing forms may use them.
data Placement
  = -- | Multi-line layout should cause
    -- insertion of a newline and indentation
    -- bump
    Normal
  | -- | Expressions that have hanging form
    -- should use it and avoid bumping one level
    -- of indentation
    Hanging
  deriving (Placement -> Placement -> Bool
(Placement -> Placement -> Bool)
-> (Placement -> Placement -> Bool) -> Eq Placement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Placement -> Placement -> Bool
$c/= :: Placement -> Placement -> Bool
== :: Placement -> Placement -> Bool
$c== :: Placement -> Placement -> Bool
Eq)

p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
p_valDecl = \case
  FunBind NoExt funId :: Located (IdP GhcPs)
funId funMatches :: MatchGroup GhcPs (LHsExpr GhcPs)
funMatches _ _ -> Located RdrName -> MatchGroup GhcPs (LHsExpr GhcPs) -> R ()
p_funBind Located (IdP GhcPs)
Located RdrName
funId MatchGroup GhcPs (LHsExpr GhcPs)
funMatches
  PatBind NoExt pat :: LPat GhcPs
pat grhss :: GRHSs GhcPs (LHsExpr GhcPs)
grhss _ -> MatchGroupStyle
-> Bool
-> SrcStrictness
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> R ()
p_match MatchGroupStyle
PatternBind Bool
False SrcStrictness
NoSrcStrict [LPat GhcPs
pat] GRHSs GhcPs (LHsExpr GhcPs)
grhss
  VarBind {} -> String -> R ()
forall a. String -> a
notImplemented "VarBinds" -- introduced by the type checker
  AbsBinds {} -> String -> R ()
forall a. String -> a
notImplemented "AbsBinds" -- introduced by the type checker
  PatSynBind NoExt psb :: PatSynBind GhcPs GhcPs
psb -> PatSynBind GhcPs GhcPs -> R ()
p_patSynBind PatSynBind GhcPs GhcPs
psb
  XHsBindsLR NoExt -> String -> R ()
forall a. String -> a
notImplemented "XHsBindsLR"

p_funBind ::
  Located RdrName ->
  MatchGroup GhcPs (LHsExpr GhcPs) ->
  R ()
p_funBind :: Located RdrName -> MatchGroup GhcPs (LHsExpr GhcPs) -> R ()
p_funBind name :: Located RdrName
name = MatchGroupStyle -> MatchGroup GhcPs (LHsExpr GhcPs) -> R ()
p_matchGroup (Located RdrName -> MatchGroupStyle
Function Located RdrName
name)

p_matchGroup ::
  MatchGroupStyle ->
  MatchGroup GhcPs (LHsExpr GhcPs) ->
  R ()
p_matchGroup :: MatchGroupStyle -> MatchGroup GhcPs (LHsExpr GhcPs) -> R ()
p_matchGroup = (HsExpr GhcPs -> Placement)
-> (HsExpr GhcPs -> R ())
-> MatchGroupStyle
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> MatchGroupStyle
-> MatchGroup GhcPs (Located body)
-> R ()
p_matchGroup' HsExpr GhcPs -> Placement
exprPlacement HsExpr GhcPs -> R ()
p_hsExpr

p_matchGroup' ::
  Data body =>
  -- | How to get body placement
  (body -> Placement) ->
  -- | How to print body
  (body -> R ()) ->
  -- | Style of this group of equations
  MatchGroupStyle ->
  -- | Match group
  MatchGroup GhcPs (Located body) ->
  R ()
p_matchGroup' :: (body -> Placement)
-> (body -> R ())
-> MatchGroupStyle
-> MatchGroup GhcPs (Located body)
-> R ()
p_matchGroup' placer :: body -> Placement
placer render :: body -> R ()
render style :: MatchGroupStyle
style MG {..} = do
  let ob :: R () -> R ()
ob = case MatchGroupStyle
style of
        Case -> R () -> R ()
forall a. a -> a
id
        LambdaCase -> R () -> R ()
forall a. a -> a
id
        _ -> R () -> R ()
dontUseBraces
  -- Since we are forcing braces on 'sepSemi' based on 'ob', we have to
  -- restore the brace state inside the sepsemi.
  R () -> R ()
ub <- (R () -> R ()) -> (R () -> R ()) -> Bool -> R () -> R ()
forall a. a -> a -> Bool -> a
bool R () -> R ()
dontUseBraces R () -> R ()
useBraces (Bool -> R () -> R ()) -> R Bool -> R (R () -> R ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R Bool
canUseBraces
  R () -> R ()
ob (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ (LMatch GhcPs (Located body) -> R ())
-> [LMatch GhcPs (Located body)] -> R ()
forall a. (a -> R ()) -> [a] -> R ()
sepSemi ((Match GhcPs (Located body) -> R ())
-> LMatch GhcPs (Located body) -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' (R () -> R ()
ub (R () -> R ())
-> (Match GhcPs (Located body) -> R ())
-> Match GhcPs (Located body)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match GhcPs (Located body) -> R ()
p_Match)) (Located [LMatch GhcPs (Located body)]
-> SrcSpanLess (Located [LMatch GhcPs (Located body)])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [LMatch GhcPs (Located body)]
mg_alts)
  where
    p_Match :: Match GhcPs (Located body) -> R ()
p_Match m :: Match GhcPs (Located body)
m@Match {..} =
      (body -> Placement)
-> (body -> R ())
-> MatchGroupStyle
-> Bool
-> SrcStrictness
-> [LPat GhcPs]
-> GRHSs GhcPs (Located body)
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> MatchGroupStyle
-> Bool
-> SrcStrictness
-> [LPat GhcPs]
-> GRHSs GhcPs (Located body)
-> R ()
p_match'
        body -> Placement
placer
        body -> R ()
render
        (Match GhcPs (Located body) -> MatchGroupStyle -> MatchGroupStyle
forall body. Match GhcPs body -> MatchGroupStyle -> MatchGroupStyle
adjustMatchGroupStyle Match GhcPs (Located body)
m MatchGroupStyle
style)
        (Match GhcPs (Located body) -> Bool
forall id body. Match id body -> Bool
isInfixMatch Match GhcPs (Located body)
m)
        (Match GhcPs (Located body) -> SrcStrictness
forall id body. Match id body -> SrcStrictness
matchStrictness Match GhcPs (Located body)
m)
        [LPat GhcPs]
m_pats
        GRHSs GhcPs (Located body)
m_grhss
    p_Match _ = String -> R ()
forall a. String -> a
notImplemented "XMatch"
p_matchGroup' _ _ _ (XMatchGroup NoExt) = String -> R ()
forall a. String -> a
notImplemented "XMatchGroup"

-- | Function id obtained through pattern matching on 'FunBind' should not
-- be used to print the actual equations because the different ‘RdrNames’
-- used in the equations may have different “decorations” (such as backticks
-- and paretheses) associated with them. It is necessary to use per-equation
-- names obtained from 'm_ctxt' of 'Match'. This function replaces function
-- name inside of 'Function' accordingly.
adjustMatchGroupStyle ::
  Match GhcPs body ->
  MatchGroupStyle ->
  MatchGroupStyle
adjustMatchGroupStyle :: Match GhcPs body -> MatchGroupStyle -> MatchGroupStyle
adjustMatchGroupStyle m :: Match GhcPs body
m = \case
  Function _ -> (Located RdrName -> MatchGroupStyle
Function (Located RdrName -> MatchGroupStyle)
-> (Match GhcPs body -> Located RdrName)
-> Match GhcPs body
-> MatchGroupStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsMatchContext RdrName -> Located RdrName
forall id. HsMatchContext id -> Located id
mc_fun (HsMatchContext RdrName -> Located RdrName)
-> (Match GhcPs body -> HsMatchContext RdrName)
-> Match GhcPs body
-> Located RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match GhcPs body -> HsMatchContext RdrName
forall p body.
Match p body -> HsMatchContext (NameOrRdrName (IdP p))
m_ctxt) Match GhcPs body
m
  style :: MatchGroupStyle
style -> MatchGroupStyle
style

matchStrictness :: Match id body -> SrcStrictness
matchStrictness :: Match id body -> SrcStrictness
matchStrictness match :: Match id body
match =
  case Match id body -> HsMatchContext (NameOrRdrName (IdP id))
forall p body.
Match p body -> HsMatchContext (NameOrRdrName (IdP p))
m_ctxt Match id body
match of
    FunRhs {mc_strictness :: forall id. HsMatchContext id -> SrcStrictness
mc_strictness = SrcStrictness
s} -> SrcStrictness
s
    _ -> SrcStrictness
NoSrcStrict

p_match ::
  -- | Style of the group
  MatchGroupStyle ->
  -- | Is this an infix match?
  Bool ->
  -- | Strictness prefix (FunBind)
  SrcStrictness ->
  -- | Argument patterns
  [LPat GhcPs] ->
  -- | Equations
  GRHSs GhcPs (LHsExpr GhcPs) ->
  R ()
p_match :: MatchGroupStyle
-> Bool
-> SrcStrictness
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> R ()
p_match = (HsExpr GhcPs -> Placement)
-> (HsExpr GhcPs -> R ())
-> MatchGroupStyle
-> Bool
-> SrcStrictness
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> MatchGroupStyle
-> Bool
-> SrcStrictness
-> [LPat GhcPs]
-> GRHSs GhcPs (Located body)
-> R ()
p_match' HsExpr GhcPs -> Placement
exprPlacement HsExpr GhcPs -> R ()
p_hsExpr

p_match' ::
  Data body =>
  -- | How to get body placement
  (body -> Placement) ->
  -- | How to print body
  (body -> R ()) ->
  -- | Style of this group of equations
  MatchGroupStyle ->
  -- | Is this an infix match?
  Bool ->
  -- | Strictness prefix (FunBind)
  SrcStrictness ->
  -- | Argument patterns
  [LPat GhcPs] ->
  -- | Equations
  GRHSs GhcPs (Located body) ->
  R ()
p_match' :: (body -> Placement)
-> (body -> R ())
-> MatchGroupStyle
-> Bool
-> SrcStrictness
-> [LPat GhcPs]
-> GRHSs GhcPs (Located body)
-> R ()
p_match' placer :: body -> Placement
placer render :: body -> R ()
render style :: MatchGroupStyle
style isInfix :: Bool
isInfix strictness :: SrcStrictness
strictness m_pats :: [LPat GhcPs]
m_pats GRHSs {..} = do
  -- Normally, since patterns may be placed in a multi-line layout, it is
  -- necessary to bump indentation for the pattern group so it's more
  -- indented than function name. This in turn means that indentation for
  -- the body should also be bumped. Normally this would mean that bodies
  -- would start with two indentation steps applied, which is ugly, so we
  -- need to be a bit more clever here and bump indentation level only when
  -- pattern group is multiline.
  case SrcStrictness
strictness of
    NoSrcStrict -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    SrcStrict -> Text -> R ()
txt "!"
    SrcLazy -> Text -> R ()
txt "~"
  R () -> R ()
inci' <- case [LPat GhcPs] -> Maybe (NonEmpty (LPat GhcPs))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [LPat GhcPs]
m_pats of
    Nothing -> R () -> R ()
forall a. a -> a
id (R () -> R ()) -> R () -> R (R () -> R ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case MatchGroupStyle
style of
      Function name :: Located RdrName
name -> Located RdrName -> R ()
p_rdrName Located RdrName
name
      _ -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just ne_pats :: NonEmpty (LPat GhcPs)
ne_pats -> do
      let combinedSpans :: SrcSpan
combinedSpans =
            NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (NonEmpty SrcSpan -> SrcSpan) -> NonEmpty SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$
              LPat GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LPat GhcPs -> SrcSpan)
-> NonEmpty (LPat GhcPs) -> NonEmpty SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (LPat GhcPs)
ne_pats
          inci' :: R () -> R ()
inci' =
            if SrcSpan -> Bool
isOneLineSpan SrcSpan
combinedSpans
              then R () -> R ()
forall a. a -> a
id
              else R () -> R ()
inci
      [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan
combinedSpans] (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        let stdCase :: R ()
stdCase = R () -> (LPat GhcPs -> R ()) -> [LPat GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint LPat GhcPs -> R ()
p_pat [LPat GhcPs]
m_pats
        case MatchGroupStyle
style of
          Function name :: Located RdrName
name ->
            Bool -> (R () -> R ()) -> R () -> [R ()] -> R ()
p_infixDefHelper
              Bool
isInfix
              R () -> R ()
inci'
              (Located RdrName -> R ()
p_rdrName Located RdrName
name)
              (LPat GhcPs -> R ()
p_pat (LPat GhcPs -> R ()) -> [LPat GhcPs] -> [R ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LPat GhcPs]
m_pats)
          PatternBind -> R ()
stdCase
          Case -> R ()
stdCase
          Lambda -> do
            let needsSpace :: Bool
needsSpace = case LPat GhcPs -> SrcSpanLess (LPat GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (NonEmpty (LPat GhcPs) -> LPat GhcPs
forall a. NonEmpty a -> a
NE.head NonEmpty (LPat GhcPs)
ne_pats) of
                  LazyPat _ _ -> Bool
True
                  BangPat _ _ -> Bool
True
                  SplicePat _ _ -> Bool
True
                  _ -> Bool
False
            Text -> R ()
txt "\\"
            Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsSpace R ()
space
            R () -> R ()
sitcc R ()
stdCase
          LambdaCase -> R ()
stdCase
      (R () -> R ()) -> R (R () -> R ())
forall (m :: * -> *) a. Monad m => a -> m a
return R () -> R ()
inci'
  let -- Calculate position of end of patterns. This is useful when we decide
      -- about putting certain constructions in hanging positions.
      endOfPats :: Maybe SrcLoc
endOfPats = case [LPat GhcPs] -> Maybe (NonEmpty (LPat GhcPs))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [LPat GhcPs]
m_pats of
        Nothing -> case MatchGroupStyle
style of
          Function name :: Located RdrName
name -> (SrcLoc -> Maybe SrcLoc
forall a. a -> Maybe a
Just (SrcLoc -> Maybe SrcLoc)
-> (Located RdrName -> SrcLoc) -> Located RdrName -> Maybe SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcLoc
srcSpanEnd (SrcSpan -> SrcLoc)
-> (Located RdrName -> SrcSpan) -> Located RdrName -> SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc) Located RdrName
name
          _ -> Maybe SrcLoc
forall a. Maybe a
Nothing
        Just pats :: NonEmpty (LPat GhcPs)
pats -> (SrcLoc -> Maybe SrcLoc
forall a. a -> Maybe a
Just (SrcLoc -> Maybe SrcLoc)
-> (NonEmpty (LPat GhcPs) -> SrcLoc)
-> NonEmpty (LPat GhcPs)
-> Maybe SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcLoc
srcSpanEnd (SrcSpan -> SrcLoc)
-> (NonEmpty (LPat GhcPs) -> SrcSpan)
-> NonEmpty (LPat GhcPs)
-> SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LPat GhcPs -> SrcSpan)
-> (NonEmpty (LPat GhcPs) -> LPat GhcPs)
-> NonEmpty (LPat GhcPs)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (LPat GhcPs) -> LPat GhcPs
forall a. NonEmpty a -> a
NE.last) NonEmpty (LPat GhcPs)
pats
      isCase :: MatchGroupStyle -> Bool
isCase = \case
        Case -> Bool
True
        LambdaCase -> Bool
True
        _ -> Bool
False
  let hasGuards :: Bool
hasGuards = [LGRHS GhcPs (Located body)] -> Bool
forall body. [LGRHS GhcPs (Located body)] -> Bool
withGuards [LGRHS GhcPs (Located body)]
grhssGRHSs
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LGRHS GhcPs (Located body)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LGRHS GhcPs (Located body)]
grhssGRHSs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
    case MatchGroupStyle
style of
      Function _ | Bool
hasGuards -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Function _ -> R ()
space R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt "="
      PatternBind -> R ()
space R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt "="
      s :: MatchGroupStyle
s | MatchGroupStyle -> Bool
isCase MatchGroupStyle
s Bool -> Bool -> Bool
&& Bool
hasGuards -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      _ -> R ()
space R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt "->"
  let grhssSpan :: SrcSpan
grhssSpan =
        NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (NonEmpty SrcSpan -> SrcSpan) -> NonEmpty SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$
          GRHS GhcPs (Located body) -> SrcSpan
forall body. GRHS GhcPs (Located body) -> SrcSpan
getGRHSSpan (GRHS GhcPs (Located body) -> SrcSpan)
-> (LGRHS GhcPs (Located body) -> GRHS GhcPs (Located body))
-> LGRHS GhcPs (Located body)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LGRHS GhcPs (Located body) -> GRHS GhcPs (Located body)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LGRHS GhcPs (Located body) -> SrcSpan)
-> NonEmpty (LGRHS GhcPs (Located body)) -> NonEmpty SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LGRHS GhcPs (Located body)]
-> NonEmpty (LGRHS GhcPs (Located body))
forall a. [a] -> NonEmpty a
NE.fromList [LGRHS GhcPs (Located body)]
grhssGRHSs
      patGrhssSpan :: SrcSpan
patGrhssSpan =
        SrcSpan -> (SrcLoc -> SrcSpan) -> Maybe SrcLoc -> SrcSpan
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          SrcSpan
grhssSpan
          (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
grhssSpan (SrcSpan -> SrcSpan) -> (SrcLoc -> SrcSpan) -> SrcLoc -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> SrcSpan
srcLocSpan)
          Maybe SrcLoc
endOfPats
      placement :: Placement
placement =
        case Maybe SrcLoc
endOfPats of
          Nothing -> (body -> Placement) -> [LGRHS GhcPs (Located body)] -> Placement
forall body.
(body -> Placement) -> [LGRHS GhcPs (Located body)] -> Placement
blockPlacement body -> Placement
placer [LGRHS GhcPs (Located body)]
grhssGRHSs
          Just spn :: SrcLoc
spn ->
            if SrcSpan -> Bool
isOneLineSpan
              (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
spn (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
grhssSpan))
              then (body -> Placement) -> [LGRHS GhcPs (Located body)] -> Placement
forall body.
(body -> Placement) -> [LGRHS GhcPs (Located body)] -> Placement
blockPlacement body -> Placement
placer [LGRHS GhcPs (Located body)]
grhssGRHSs
              else Placement
Normal
      p_body :: R ()
p_body = do
        let groupStyle :: GroupStyle
groupStyle =
              if MatchGroupStyle -> Bool
isCase MatchGroupStyle
style Bool -> Bool -> Bool
&& Bool
hasGuards
                then GroupStyle
RightArrow
                else GroupStyle
EqualSign
        R ()
-> (LGRHS GhcPs (Located body) -> R ())
-> [LGRHS GhcPs (Located body)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
newline ((GRHS GhcPs (Located body) -> R ())
-> LGRHS GhcPs (Located body) -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' ((body -> Placement)
-> (body -> R ())
-> GroupStyle
-> GRHS GhcPs (Located body)
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> GroupStyle
-> GRHS GhcPs (Located body)
-> R ()
p_grhs' body -> Placement
placer body -> R ()
render GroupStyle
groupStyle)) [LGRHS GhcPs (Located body)]
grhssGRHSs
      p_where :: R ()
p_where = do
        let whereIsEmpty :: Bool
whereIsEmpty = HsLocalBindsLR GhcPs GhcPs -> Bool
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
GHC.isEmptyLocalBindsPR (LHsLocalBinds GhcPs -> SrcSpanLess (LHsLocalBinds GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsLocalBinds GhcPs
grhssLocalBinds)
        Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HsLocalBindsLR GhcPs GhcPs -> Bool
forall a b. HsLocalBindsLR a b -> Bool
GHC.eqEmptyLocalBinds (LHsLocalBinds GhcPs -> SrcSpanLess (LHsLocalBinds GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsLocalBinds GhcPs
grhssLocalBinds)) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          R ()
breakpoint
          Text -> R ()
txt "where"
          Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
whereIsEmpty R ()
breakpoint
          R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsLocalBinds GhcPs -> (HsLocalBindsLR GhcPs GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsLocalBinds GhcPs
grhssLocalBinds HsLocalBindsLR GhcPs GhcPs -> R ()
p_hsLocalBinds
  R () -> R ()
inci' (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan
patGrhssSpan] (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      Placement -> R () -> R ()
placeHanging Placement
placement R ()
p_body
    R () -> R ()
inci R ()
p_where
p_match' _ _ _ _ _ _ XGRHSs {} = String -> R ()
forall a. String -> a
notImplemented "XGRHSs"

p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
p_grhs = (HsExpr GhcPs -> Placement)
-> (HsExpr GhcPs -> R ())
-> GroupStyle
-> GRHS GhcPs (LHsExpr GhcPs)
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> GroupStyle
-> GRHS GhcPs (Located body)
-> R ()
p_grhs' HsExpr GhcPs -> Placement
exprPlacement HsExpr GhcPs -> R ()
p_hsExpr

p_grhs' ::
  Data body =>
  -- | How to get body placement
  (body -> Placement) ->
  -- | How to print body
  (body -> R ()) ->
  GroupStyle ->
  GRHS GhcPs (Located body) ->
  R ()
p_grhs' :: (body -> Placement)
-> (body -> R ())
-> GroupStyle
-> GRHS GhcPs (Located body)
-> R ()
p_grhs' placer :: body -> Placement
placer render :: body -> R ()
render style :: GroupStyle
style (GRHS NoExt guards :: [GuardLStmt GhcPs]
guards body :: Located body
body) =
  case [GuardLStmt GhcPs]
guards of
    [] -> R ()
p_body
    xs :: [GuardLStmt GhcPs]
xs -> do
      Text -> R ()
txt "|"
      R ()
space
      R () -> R ()
sitcc (R () -> (GuardLStmt GhcPs -> R ()) -> [GuardLStmt GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) (R () -> R ()
sitcc (R () -> R ())
-> (GuardLStmt GhcPs -> R ()) -> GuardLStmt GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stmt GhcPs (LHsExpr GhcPs) -> R ()) -> GuardLStmt GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' Stmt GhcPs (LHsExpr GhcPs) -> R ()
p_stmt) [GuardLStmt GhcPs]
xs)
      R ()
space
      Text -> R ()
txt (Text -> R ()) -> Text -> R ()
forall a b. (a -> b) -> a -> b
$ case GroupStyle
style of
        EqualSign -> "="
        RightArrow -> "->"
      Placement -> R () -> R ()
placeHanging Placement
placement R ()
p_body
  where
    placement :: Placement
placement =
      case Maybe SrcLoc
endOfGuards of
        Nothing -> body -> Placement
placer (Located body -> SrcSpanLess (Located body)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located body
body)
        Just spn :: SrcLoc
spn ->
          if SrcSpan -> Bool
isOneLineSpan (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
spn (SrcSpan -> SrcLoc
srcSpanStart (Located body -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located body
body)))
            then body -> Placement
placer (Located body -> SrcSpanLess (Located body)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located body
body)
            else Placement
Normal
    endOfGuards :: Maybe SrcLoc
endOfGuards =
      case [GuardLStmt GhcPs] -> Maybe (NonEmpty (GuardLStmt GhcPs))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [GuardLStmt GhcPs]
guards of
        Nothing -> Maybe SrcLoc
forall a. Maybe a
Nothing
        Just gs :: NonEmpty (GuardLStmt GhcPs)
gs -> (SrcLoc -> Maybe SrcLoc
forall a. a -> Maybe a
Just (SrcLoc -> Maybe SrcLoc)
-> (NonEmpty (GuardLStmt GhcPs) -> SrcLoc)
-> NonEmpty (GuardLStmt GhcPs)
-> Maybe SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcLoc
srcSpanEnd (SrcSpan -> SrcLoc)
-> (NonEmpty (GuardLStmt GhcPs) -> SrcSpan)
-> NonEmpty (GuardLStmt GhcPs)
-> SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GuardLStmt GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (GuardLStmt GhcPs -> SrcSpan)
-> (NonEmpty (GuardLStmt GhcPs) -> GuardLStmt GhcPs)
-> NonEmpty (GuardLStmt GhcPs)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (GuardLStmt GhcPs) -> GuardLStmt GhcPs
forall a. NonEmpty a -> a
NE.last) NonEmpty (GuardLStmt GhcPs)
gs
    p_body :: R ()
p_body = Located body -> (body -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located body
body body -> R ()
render
p_grhs' _ _ _ (XGRHS NoExt) = String -> R ()
forall a. String -> a
notImplemented "XGRHS"

p_hsCmd :: HsCmd GhcPs -> R ()
p_hsCmd :: HsCmd GhcPs -> R ()
p_hsCmd = \case
  HsCmdArrApp NoExt body :: LHsExpr GhcPs
body input :: LHsExpr GhcPs
input arrType :: HsArrAppType
arrType _ -> do
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
body HsExpr GhcPs -> R ()
p_hsExpr
    R ()
space
    case HsArrAppType
arrType of
      HsFirstOrderApp -> Text -> R ()
txt "-<"
      HsHigherOrderApp -> Text -> R ()
txt "-<<"
    Placement -> R () -> R ()
placeHanging (HsExpr GhcPs -> Placement
exprPlacement (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
input)) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
input HsExpr GhcPs -> R ()
p_hsExpr
  HsCmdArrForm NoExt form :: LHsExpr GhcPs
form Prefix _ cmds :: [LHsCmdTop GhcPs]
cmds -> R () -> R ()
banana (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
form HsExpr GhcPs -> R ()
p_hsExpr
    Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LHsCmdTop GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsCmdTop GhcPs]
cmds) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      R ()
breakpoint
      R () -> R ()
inci ([R ()] -> R ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (R () -> [R ()] -> [R ()]
forall a. a -> [a] -> [a]
intersperse R ()
breakpoint ((HsCmdTop GhcPs -> R ()) -> LHsCmdTop GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' HsCmdTop GhcPs -> R ()
p_hsCmdTop (LHsCmdTop GhcPs -> R ()) -> [LHsCmdTop GhcPs] -> [R ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsCmdTop GhcPs]
cmds)))
  HsCmdArrForm NoExt form :: LHsExpr GhcPs
form Infix _ [left :: LHsCmdTop GhcPs
left, right :: LHsCmdTop GhcPs
right] -> do
    LHsCmdTop GhcPs -> (HsCmdTop GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsCmdTop GhcPs
left HsCmdTop GhcPs -> R ()
p_hsCmdTop
    R ()
space
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
form HsExpr GhcPs -> R ()
p_hsExpr
    Placement -> R () -> R ()
placeHanging (HsCmdTop GhcPs -> Placement
cmdTopPlacement (LHsCmdTop GhcPs -> SrcSpanLess (LHsCmdTop GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsCmdTop GhcPs
right)) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      LHsCmdTop GhcPs -> (HsCmdTop GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsCmdTop GhcPs
right HsCmdTop GhcPs -> R ()
p_hsCmdTop
  HsCmdArrForm NoExt _ Infix _ _ -> String -> R ()
forall a. String -> a
notImplemented "HsCmdArrForm"
  HsCmdApp {} ->
    -- XXX Does this ever occur in the syntax tree? It does not seem like it
    -- does. Open an issue and ping @yumiova if this ever occurs in output.
    String -> R ()
forall a. String -> a
notImplemented "HsCmdApp"
  HsCmdLam NoExt mgroup :: MatchGroup GhcPs (LHsCmd GhcPs)
mgroup -> (HsCmd GhcPs -> Placement)
-> (HsCmd GhcPs -> R ())
-> MatchGroupStyle
-> MatchGroup GhcPs (LHsCmd GhcPs)
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> MatchGroupStyle
-> MatchGroup GhcPs (Located body)
-> R ()
p_matchGroup' HsCmd GhcPs -> Placement
cmdPlacement HsCmd GhcPs -> R ()
p_hsCmd MatchGroupStyle
Lambda MatchGroup GhcPs (LHsCmd GhcPs)
mgroup
  HsCmdPar NoExt c :: LHsCmd GhcPs
c -> BracketStyle -> R () -> R ()
parens BracketStyle
N (LHsCmd GhcPs -> (HsCmd GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsCmd GhcPs
c HsCmd GhcPs -> R ()
p_hsCmd)
  HsCmdCase NoExt e :: LHsExpr GhcPs
e mgroup :: MatchGroup GhcPs (LHsCmd GhcPs)
mgroup ->
    (HsCmd GhcPs -> Placement)
-> (HsCmd GhcPs -> R ())
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsCmd GhcPs)
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> LHsExpr GhcPs
-> MatchGroup GhcPs (Located body)
-> R ()
p_case HsCmd GhcPs -> Placement
cmdPlacement HsCmd GhcPs -> R ()
p_hsCmd LHsExpr GhcPs
e MatchGroup GhcPs (LHsCmd GhcPs)
mgroup
  HsCmdIf NoExt _ if' :: LHsExpr GhcPs
if' then' :: LHsCmd GhcPs
then' else' :: LHsCmd GhcPs
else' ->
    (HsCmd GhcPs -> Placement)
-> (HsCmd GhcPs -> R ())
-> LHsExpr GhcPs
-> LHsCmd GhcPs
-> LHsCmd GhcPs
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> LHsExpr GhcPs
-> Located body
-> Located body
-> R ()
p_if HsCmd GhcPs -> Placement
cmdPlacement HsCmd GhcPs -> R ()
p_hsCmd LHsExpr GhcPs
if' LHsCmd GhcPs
then' LHsCmd GhcPs
else'
  HsCmdLet NoExt localBinds :: LHsLocalBinds GhcPs
localBinds c :: LHsCmd GhcPs
c ->
    (HsCmd GhcPs -> R ())
-> LHsLocalBinds GhcPs -> LHsCmd GhcPs -> R ()
forall body.
Data body =>
(body -> R ()) -> LHsLocalBinds GhcPs -> Located body -> R ()
p_let HsCmd GhcPs -> R ()
p_hsCmd LHsLocalBinds GhcPs
localBinds LHsCmd GhcPs
c
  HsCmdDo NoExt es :: Located [CmdLStmt GhcPs]
es -> do
    Text -> R ()
txt "do"
    R ()
newline
    R () -> R ()
inci (R () -> R ())
-> (([CmdLStmt GhcPs] -> R ()) -> R ())
-> ([CmdLStmt GhcPs] -> R ())
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located [CmdLStmt GhcPs] -> ([CmdLStmt GhcPs] -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located [CmdLStmt GhcPs]
es (([CmdLStmt GhcPs] -> R ()) -> R ())
-> ([CmdLStmt GhcPs] -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$
      R () -> R ()
sitcc (R () -> R ())
-> ([CmdLStmt GhcPs] -> R ()) -> [CmdLStmt GhcPs] -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> (CmdLStmt GhcPs -> R ()) -> [CmdLStmt GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
newline ((Stmt GhcPs (LHsCmd GhcPs) -> R ()) -> CmdLStmt GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' (R () -> R ()
sitcc (R () -> R ())
-> (Stmt GhcPs (LHsCmd GhcPs) -> R ())
-> Stmt GhcPs (LHsCmd GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsCmd GhcPs -> Placement)
-> (HsCmd GhcPs -> R ()) -> Stmt GhcPs (LHsCmd GhcPs) -> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ()) -> Stmt GhcPs (Located body) -> R ()
p_stmt' HsCmd GhcPs -> Placement
cmdPlacement HsCmd GhcPs -> R ()
p_hsCmd))
  HsCmdWrap {} -> String -> R ()
forall a. String -> a
notImplemented "HsCmdWrap"
  XCmd {} -> String -> R ()
forall a. String -> a
notImplemented "XCmd"

p_hsCmdTop :: HsCmdTop GhcPs -> R ()
p_hsCmdTop :: HsCmdTop GhcPs -> R ()
p_hsCmdTop = \case
  HsCmdTop NoExt cmd :: LHsCmd GhcPs
cmd -> LHsCmd GhcPs -> (HsCmd GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsCmd GhcPs
cmd HsCmd GhcPs -> R ()
p_hsCmd
  XCmdTop {} -> String -> R ()
forall a. String -> a
notImplemented "XHsCmdTop"

p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
p_stmt = (HsExpr GhcPs -> Placement)
-> (HsExpr GhcPs -> R ()) -> Stmt GhcPs (LHsExpr GhcPs) -> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ()) -> Stmt GhcPs (Located body) -> R ()
p_stmt' HsExpr GhcPs -> Placement
exprPlacement HsExpr GhcPs -> R ()
p_hsExpr

p_stmt' ::
  Data body =>
  -- | Placer
  (body -> Placement) ->
  -- | Render
  (body -> R ()) ->
  -- | Statement to render
  Stmt GhcPs (Located body) ->
  R ()
p_stmt' :: (body -> Placement)
-> (body -> R ()) -> Stmt GhcPs (Located body) -> R ()
p_stmt' placer :: body -> Placement
placer render :: body -> R ()
render = \case
  LastStmt NoExt body :: Located body
body _ _ -> Located body -> (body -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located body
body body -> R ()
render
  BindStmt NoExt p :: LPat GhcPs
p f :: Located body
f _ _ -> do
    LPat GhcPs -> R ()
p_pat LPat GhcPs
p
    R ()
space
    Text -> R ()
txt "<-"
    -- https://gitlab.haskell.org/ghc/ghc/issues/17330
    let loc :: SrcSpan
loc = case LPat GhcPs
p of
          XPat pat :: XXPat GhcPs
pat -> Located (LPat GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc XXPat GhcPs
Located (LPat GhcPs)
pat
          _ -> String -> SrcSpan
forall a. HasCallStack => String -> a
error "p_stmt': BindStmt: Pat does not contain a location"
    let placement :: Placement
placement =
          case Located body
f of
            L l' :: SrcSpan
l' x :: body
x ->
              if SrcSpan -> Bool
isOneLineSpan
                (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
loc) (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
l'))
                then body -> Placement
placer body
x
                else Placement
Normal
    [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan
loc, Located body -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located body
f] (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      Placement -> R () -> R ()
placeHanging Placement
placement (Located body -> (body -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located body
f body -> R ()
render)
  ApplicativeStmt {} -> String -> R ()
forall a. String -> a
notImplemented "ApplicativeStmt" -- generated by renamer
  BodyStmt NoExt body :: Located body
body _ _ -> Located body -> (body -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located body
body body -> R ()
render
  LetStmt NoExt binds :: LHsLocalBinds GhcPs
binds -> do
    Text -> R ()
txt "let"
    R ()
space
    R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsLocalBinds GhcPs -> (HsLocalBindsLR GhcPs GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsLocalBinds GhcPs
binds HsLocalBindsLR GhcPs GhcPs -> R ()
p_hsLocalBinds
  ParStmt {} ->
    -- 'ParStmt' should always be eliminated in 'gatherStmt' already, such
    -- that it never occurs in 'p_stmt''. Consequently, handling it here
    -- would be redundant.
    String -> R ()
forall a. String -> a
notImplemented "ParStmt"
  TransStmt {..} ->
    -- 'TransStmt' only needs to account for render printing itself, since
    -- pretty printing of relevant statements (e.g., in 'trS_stmts') is
    -- handled through 'gatherStmt'.
    case (TransForm
trS_form, Maybe (LHsExpr GhcPs)
trS_by) of
      (ThenForm, Nothing) -> do
        Text -> R ()
txt "then"
        R ()
breakpoint
        R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
trS_using HsExpr GhcPs -> R ()
p_hsExpr
      (ThenForm, Just e :: LHsExpr GhcPs
e) -> do
        Text -> R ()
txt "then"
        R ()
breakpoint
        R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
trS_using HsExpr GhcPs -> R ()
p_hsExpr
        R ()
breakpoint
        Text -> R ()
txt "by"
        R ()
breakpoint
        R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
e HsExpr GhcPs -> R ()
p_hsExpr
      (GroupForm, Nothing) -> do
        Text -> R ()
txt "then group using"
        R ()
breakpoint
        R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
trS_using HsExpr GhcPs -> R ()
p_hsExpr
      (GroupForm, Just e :: LHsExpr GhcPs
e) -> do
        Text -> R ()
txt "then group by"
        R ()
breakpoint
        R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
e HsExpr GhcPs -> R ()
p_hsExpr
        R ()
breakpoint
        Text -> R ()
txt "using"
        R ()
breakpoint
        R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
trS_using HsExpr GhcPs -> R ()
p_hsExpr
  RecStmt {..} -> do
    Text -> R ()
txt "rec"
    R ()
space
    R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ (LStmtLR GhcPs GhcPs (Located body) -> R ())
-> [LStmtLR GhcPs GhcPs (Located body)] -> R ()
forall a. (a -> R ()) -> [a] -> R ()
sepSemi ((Stmt GhcPs (Located body) -> R ())
-> LStmtLR GhcPs GhcPs (Located body) -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' ((body -> Placement)
-> (body -> R ()) -> Stmt GhcPs (Located body) -> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ()) -> Stmt GhcPs (Located body) -> R ()
p_stmt' body -> Placement
placer body -> R ()
render)) [LStmtLR GhcPs GhcPs (Located body)]
recS_stmts
  XStmtLR {} -> String -> R ()
forall a. String -> a
notImplemented "XStmtLR"

gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
gatherStmt :: GuardLStmt GhcPs -> [[GuardLStmt GhcPs]]
gatherStmt (L _ (ParStmt NoExt block :: [ParStmtBlock GhcPs GhcPs]
block _ _)) =
  (ParStmtBlock GhcPs GhcPs
 -> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]])
-> [[GuardLStmt GhcPs]]
-> [ParStmtBlock GhcPs GhcPs]
-> [[GuardLStmt GhcPs]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([[GuardLStmt GhcPs]]
-> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]]
forall a. Semigroup a => a -> a -> a
(<>) ([[GuardLStmt GhcPs]]
 -> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]])
-> (ParStmtBlock GhcPs GhcPs -> [[GuardLStmt GhcPs]])
-> ParStmtBlock GhcPs GhcPs
-> [[GuardLStmt GhcPs]]
-> [[GuardLStmt GhcPs]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParStmtBlock GhcPs GhcPs -> [[GuardLStmt GhcPs]]
gatherStmtBlock) [] [ParStmtBlock GhcPs GhcPs]
block
gatherStmt (L s :: SrcSpan
s stmt :: Stmt GhcPs (LHsExpr GhcPs)
stmt@TransStmt {..}) =
  ([[GuardLStmt GhcPs]]
 -> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]])
-> [[GuardLStmt GhcPs]]
-> [[[GuardLStmt GhcPs]]]
-> [[GuardLStmt GhcPs]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [[GuardLStmt GhcPs]]
-> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]]
forall a. Semigroup a => [a] -> [a] -> [a]
liftAppend [] ((GuardLStmt GhcPs -> [[GuardLStmt GhcPs]]
gatherStmt (GuardLStmt GhcPs -> [[GuardLStmt GhcPs]])
-> [GuardLStmt GhcPs] -> [[[GuardLStmt GhcPs]]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GuardLStmt GhcPs]
trS_stmts) [[[GuardLStmt GhcPs]]]
-> [[[GuardLStmt GhcPs]]] -> [[[GuardLStmt GhcPs]]]
forall a. Semigroup a => a -> a -> a
<> [[GuardLStmt GhcPs]] -> [[[GuardLStmt GhcPs]]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> GuardLStmt GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
s Stmt GhcPs (LHsExpr GhcPs)
stmt]])
gatherStmt stmt :: GuardLStmt GhcPs
stmt = [[GuardLStmt GhcPs
stmt]]

gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[GuardLStmt GhcPs]]
gatherStmtBlock (ParStmtBlock _ stmts :: [GuardLStmt GhcPs]
stmts _ _) =
  (GuardLStmt GhcPs -> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]])
-> [[GuardLStmt GhcPs]]
-> [GuardLStmt GhcPs]
-> [[GuardLStmt GhcPs]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([[GuardLStmt GhcPs]]
-> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]]
forall a. Semigroup a => [a] -> [a] -> [a]
liftAppend ([[GuardLStmt GhcPs]]
 -> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]])
-> (GuardLStmt GhcPs -> [[GuardLStmt GhcPs]])
-> GuardLStmt GhcPs
-> [[GuardLStmt GhcPs]]
-> [[GuardLStmt GhcPs]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GuardLStmt GhcPs -> [[GuardLStmt GhcPs]]
gatherStmt) [] [GuardLStmt GhcPs]
stmts
gatherStmtBlock XParStmtBlock {} = String -> [[GuardLStmt GhcPs]]
forall a. String -> a
notImplemented "XParStmtBlock"

p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
p_hsLocalBinds = \case
  HsValBinds NoExt (ValBinds NoExt bag :: LHsBindsLR GhcPs GhcPs
bag lsigs :: [LSig GhcPs]
lsigs) -> do
    let ssStart :: Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs) -> SrcLoc
ssStart =
          (LHsBindLR GhcPs GhcPs -> SrcLoc)
-> (LSig GhcPs -> SrcLoc)
-> Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)
-> SrcLoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (SrcSpan -> SrcLoc
srcSpanStart (SrcSpan -> SrcLoc)
-> (LHsBindLR GhcPs GhcPs -> SrcSpan)
-> LHsBindLR GhcPs GhcPs
-> SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBindLR GhcPs GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc)
            (SrcSpan -> SrcLoc
srcSpanStart (SrcSpan -> SrcLoc)
-> (LSig GhcPs -> SrcSpan) -> LSig GhcPs -> SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LSig GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc)
        items :: [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
items =
          (LHsBindLR GhcPs GhcPs
-> Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)
forall a b. a -> Either a b
Left (LHsBindLR GhcPs GhcPs
 -> Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs))
-> [LHsBindLR GhcPs GhcPs]
-> [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsBindsLR GhcPs GhcPs -> [LHsBindLR GhcPs GhcPs]
forall a. Bag a -> [a]
bagToList LHsBindsLR GhcPs GhcPs
bag) [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
-> [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
-> [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
forall a. [a] -> [a] -> [a]
++ (LSig GhcPs -> Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)
forall a b. b -> Either a b
Right (LSig GhcPs -> Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs))
-> [LSig GhcPs] -> [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LSig GhcPs]
lsigs)
        p_item :: Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs) -> R ()
p_item (Left x :: LHsBindLR GhcPs GhcPs
x) = LHsBindLR GhcPs GhcPs -> (HsBindLR GhcPs GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsBindLR GhcPs GhcPs
x HsBindLR GhcPs GhcPs -> R ()
p_valDecl
        p_item (Right x :: LSig GhcPs
x) = LSig GhcPs -> (Sig GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LSig GhcPs
x Sig GhcPs -> R ()
p_sigDecl
        -- Assigns 'False' to the last element, 'True' to the rest.
        markInit :: [a] -> [(Bool, a)]
        markInit :: [a] -> [(Bool, a)]
markInit [] = []
        markInit [x :: a
x] = [(Bool
False, a
x)]
        markInit (x :: a
x : xs :: [a]
xs) = (Bool
True, a
x) (Bool, a) -> [(Bool, a)] -> [(Bool, a)]
forall a. a -> [a] -> [a]
: [a] -> [(Bool, a)]
forall a. [a] -> [(Bool, a)]
markInit [a]
xs
    -- When in a single-line layout, there is a chance that the inner
    -- elements will also contain semicolons and they will confuse the
    -- parser. so we request braces around every element except the last.
    R () -> R ()
br <- Layout -> R () -> R ()
layoutToBraces (Layout -> R () -> R ()) -> R Layout -> R (R () -> R ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R Layout
getLayout
    R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      ((Bool, Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)) -> R ())
-> [(Bool, Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs))] -> R ()
forall a. (a -> R ()) -> [a] -> R ()
sepSemi
        (\(m :: Bool
m, i :: Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)
i) -> (if Bool
m then R () -> R ()
br else R () -> R ()
forall a. a -> a
id) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs) -> R ()
p_item Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)
i)
        ([Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
-> [(Bool, Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs))]
forall a. [a] -> [(Bool, a)]
markInit ([Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
 -> [(Bool, Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs))])
-> [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
-> [(Bool, Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs))]
forall a b. (a -> b) -> a -> b
$ (Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs) -> SrcLoc)
-> [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
-> [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs) -> SrcLoc
ssStart [Either (LHsBindLR GhcPs GhcPs) (LSig GhcPs)]
items)
  HsValBinds NoExt _ -> String -> R ()
forall a. String -> a
notImplemented "HsValBinds"
  HsIPBinds NoExt (IPBinds NoExt xs :: [LIPBind GhcPs]
xs) ->
    -- Second argument of IPBind is always Left before type-checking.
    let p_ipBind :: IPBind GhcPs -> R ()
p_ipBind (IPBind NoExt (Left name :: Located HsIPName
name) expr :: LHsExpr GhcPs
expr) = do
          Located HsIPName -> R ()
forall a. Outputable a => a -> R ()
atom Located HsIPName
name
          R ()
space
          Text -> R ()
txt "="
          R ()
breakpoint
          R () -> R ()
useBraces (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
expr HsExpr GhcPs -> R ()
p_hsExpr
        p_ipBind _ = String -> R ()
forall a. String -> a
notImplemented "XHsIPBinds"
     in (LIPBind GhcPs -> R ()) -> [LIPBind GhcPs] -> R ()
forall a. (a -> R ()) -> [a] -> R ()
sepSemi ((IPBind GhcPs -> R ()) -> LIPBind GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' IPBind GhcPs -> R ()
p_ipBind) [LIPBind GhcPs]
xs
  HsIPBinds NoExt _ -> String -> R ()
forall a. String -> a
notImplemented "HsIpBinds"
  EmptyLocalBinds NoExt -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  XHsLocalBindsLR _ -> String -> R ()
forall a. String -> a
notImplemented "XHsLocalBindsLR"

p_hsRecField ::
  HsRecField' RdrName (LHsExpr GhcPs) ->
  R ()
p_hsRecField :: HsRecField' RdrName (LHsExpr GhcPs) -> R ()
p_hsRecField HsRecField {..} = do
  Located RdrName -> R ()
p_rdrName Located RdrName
hsRecFieldLbl
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hsRecPun (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    R ()
space
    Text -> R ()
txt "="
    let placement :: Placement
placement = HsExpr GhcPs -> Placement
exprPlacement (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
hsRecFieldArg)
    Placement -> R () -> R ()
placeHanging Placement
placement (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
hsRecFieldArg HsExpr GhcPs -> R ()
p_hsExpr

p_hsTupArg :: HsTupArg GhcPs -> R ()
p_hsTupArg :: HsTupArg GhcPs -> R ()
p_hsTupArg = \case
  Present NoExt x :: LHsExpr GhcPs
x -> LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
x HsExpr GhcPs -> R ()
p_hsExpr
  Missing NoExt -> () -> R ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  XTupArg {} -> String -> R ()
forall a. String -> a
notImplemented "XTupArg"

p_hsExpr :: HsExpr GhcPs -> R ()
p_hsExpr :: HsExpr GhcPs -> R ()
p_hsExpr = BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' BracketStyle
N

p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' s :: BracketStyle
s = \case
  HsVar NoExt name :: Located (IdP GhcPs)
name -> Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
name
  HsUnboundVar NoExt _ -> String -> R ()
forall a. String -> a
notImplemented "HsUnboundVar"
  HsConLikeOut NoExt _ -> String -> R ()
forall a. String -> a
notImplemented "HsConLikeOut"
  HsRecFld NoExt x :: AmbiguousFieldOcc GhcPs
x ->
    case AmbiguousFieldOcc GhcPs
x of
      Unambiguous NoExt name :: Located RdrName
name -> Located RdrName -> R ()
p_rdrName Located RdrName
name
      Ambiguous NoExt name :: Located RdrName
name -> Located RdrName -> R ()
p_rdrName Located RdrName
name
      XAmbiguousFieldOcc NoExt -> String -> R ()
forall a. String -> a
notImplemented "XAmbiguousFieldOcc"
  HsOverLabel NoExt _ v :: FastString
v -> do
    Text -> R ()
txt "#"
    FastString -> R ()
forall a. Outputable a => a -> R ()
atom FastString
v
  HsIPVar NoExt (HsIPName name :: FastString
name) -> do
    Text -> R ()
txt "?"
    FastString -> R ()
forall a. Outputable a => a -> R ()
atom FastString
name
  HsOverLit NoExt v :: HsOverLit GhcPs
v -> OverLitVal -> R ()
forall a. Outputable a => a -> R ()
atom (HsOverLit GhcPs -> OverLitVal
forall p. HsOverLit p -> OverLitVal
ol_val HsOverLit GhcPs
v)
  HsLit NoExt lit :: HsLit GhcPs
lit ->
    case HsLit GhcPs
lit of
      HsString (SourceText stxt) _ -> String -> R ()
p_stringLit String
stxt
      HsStringPrim (SourceText stxt) _ -> String -> R ()
p_stringLit String
stxt
      r :: HsLit GhcPs
r -> HsLit GhcPs -> R ()
forall a. Outputable a => a -> R ()
atom HsLit GhcPs
r
  HsLam NoExt mgroup :: MatchGroup GhcPs (LHsExpr GhcPs)
mgroup ->
    MatchGroupStyle -> MatchGroup GhcPs (LHsExpr GhcPs) -> R ()
p_matchGroup MatchGroupStyle
Lambda MatchGroup GhcPs (LHsExpr GhcPs)
mgroup
  HsLamCase NoExt mgroup :: MatchGroup GhcPs (LHsExpr GhcPs)
mgroup -> do
    Text -> R ()
txt "\\case"
    R ()
breakpoint
    R () -> R ()
inci (MatchGroupStyle -> MatchGroup GhcPs (LHsExpr GhcPs) -> R ()
p_matchGroup MatchGroupStyle
LambdaCase MatchGroup GhcPs (LHsExpr GhcPs)
mgroup)
  HsApp NoExt f :: LHsExpr GhcPs
f x :: LHsExpr GhcPs
x -> do
    let -- In order to format function applications with multiple parameters
        -- nicer, traverse the AST to gather the function and all the
        -- parameters together.
        gatherArgs :: LHsExpr p
-> NonEmpty (LHsExpr p) -> (LHsExpr p, NonEmpty (LHsExpr p))
gatherArgs f' :: LHsExpr p
f' knownArgs :: NonEmpty (LHsExpr p)
knownArgs =
          case LHsExpr p
f' of
            L _ (HsApp _ l :: LHsExpr p
l r :: LHsExpr p
r) -> LHsExpr p
-> NonEmpty (LHsExpr p) -> (LHsExpr p, NonEmpty (LHsExpr p))
gatherArgs LHsExpr p
l (LHsExpr p
r LHsExpr p -> NonEmpty (LHsExpr p) -> NonEmpty (LHsExpr p)
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (LHsExpr p)
knownArgs)
            _ -> (LHsExpr p
f', NonEmpty (LHsExpr p)
knownArgs)
        (func :: LHsExpr GhcPs
func, args :: NonEmpty (LHsExpr GhcPs)
args) = LHsExpr GhcPs
-> NonEmpty (LHsExpr GhcPs)
-> (LHsExpr GhcPs, NonEmpty (LHsExpr GhcPs))
forall p.
LHsExpr p
-> NonEmpty (LHsExpr p) -> (LHsExpr p, NonEmpty (LHsExpr p))
gatherArgs LHsExpr GhcPs
f (LHsExpr GhcPs
x LHsExpr GhcPs -> [LHsExpr GhcPs] -> NonEmpty (LHsExpr GhcPs)
forall a. a -> [a] -> NonEmpty a
:| [])
        -- We need to handle the last argument specially if it is a
        -- hanging construct, so separate it from the rest.
        (initp :: [LHsExpr GhcPs]
initp, lastp :: LHsExpr GhcPs
lastp) = (NonEmpty (LHsExpr GhcPs) -> [LHsExpr GhcPs]
forall a. NonEmpty a -> [a]
NE.init NonEmpty (LHsExpr GhcPs)
args, NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. NonEmpty a -> a
NE.last NonEmpty (LHsExpr GhcPs)
args)
        initSpan :: SrcSpan
initSpan =
          NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (NonEmpty SrcSpan -> SrcSpan) -> NonEmpty SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
f SrcSpan -> [SrcSpan] -> NonEmpty SrcSpan
forall a. a -> [a] -> NonEmpty a
:| [(SrcLoc -> SrcSpan
srcLocSpan (SrcLoc -> SrcSpan)
-> (LHsExpr GhcPs -> SrcLoc) -> LHsExpr GhcPs -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcLoc
srcSpanStart (SrcSpan -> SrcLoc)
-> (LHsExpr GhcPs -> SrcSpan) -> LHsExpr GhcPs -> SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc) LHsExpr GhcPs
lastp]
        -- Hang the last argument only if the initial arguments span one
        -- line.
        placement :: Placement
placement =
          if SrcSpan -> Bool
isOneLineSpan SrcSpan
initSpan
            then HsExpr GhcPs -> Placement
exprPlacement (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
lastp)
            else Placement
Normal
    -- If the last argument is not hanging, just separate every argument as
    -- usual. If it is hanging, print the initial arguments and hang the
    -- last one. Also, use braces around the every argument except the last
    -- one.
    case Placement
placement of
      Normal -> do
        let -- Usually we want to bump indentation for arguments for the
            -- sake of readability. However, when the function itself is a
            -- do-block or case expression it is not a good idea. It seems
            -- to be safe to always bump indentation when the function
            -- expression is parenthesised.
            indent :: R () -> R ()
indent =
              case LHsExpr GhcPs
func of
                L _ (HsPar NoExt _) -> R () -> R ()
inci
                L _ (HsAppType NoExt _ _) -> R () -> R ()
inci
                L _ (HsMultiIf NoExt _) -> R () -> R ()
inci
                L spn :: SrcSpan
spn _ ->
                  if SrcSpan -> Bool
isOneLineSpan SrcSpan
spn
                    then R () -> R ()
inci
                    else R () -> R ()
forall a. a -> a
id
        R () -> R ()
ub <- R Layout
getLayout R Layout -> (Layout -> R () -> R ()) -> R (R () -> R ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          SingleLine -> R () -> R ()
useBraces
          MultiLine -> R () -> R ()
forall a. a -> a
id
        R () -> R ()
ub (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
func (BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' BracketStyle
s)
          R ()
breakpoint
          R () -> R ()
indent (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (LHsExpr GhcPs -> R ()) -> [LHsExpr GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint ((HsExpr GhcPs -> R ()) -> LHsExpr GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' HsExpr GhcPs -> R ()
p_hsExpr) [LHsExpr GhcPs]
initp
        R () -> R ()
indent (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsExpr GhcPs]
initp) R ()
breakpoint
          LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
lastp HsExpr GhcPs -> R ()
p_hsExpr
      Hanging -> do
        R () -> R ()
useBraces (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan
initSpan] (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
func (BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' BracketStyle
s)
          R ()
breakpoint
          R () -> (LHsExpr GhcPs -> R ()) -> [LHsExpr GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint ((HsExpr GhcPs -> R ()) -> LHsExpr GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' HsExpr GhcPs -> R ()
p_hsExpr) [LHsExpr GhcPs]
initp
        Placement -> R () -> R ()
placeHanging Placement
placement (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
          LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
lastp HsExpr GhcPs -> R ()
p_hsExpr
  HsAppType NoExt e :: LHsExpr GhcPs
e a :: LHsWcType (NoGhcTc GhcPs)
a -> do
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
e HsExpr GhcPs -> R ()
p_hsExpr
    R ()
breakpoint
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> R ()
txt "@"
      Located (HsType GhcPs) -> (HsType GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located (HsWildCardBndrs GhcPs (Located (HsType GhcPs))
-> Located (HsType GhcPs)
forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body HsWildCardBndrs GhcPs (Located (HsType GhcPs))
LHsWcType (NoGhcTc GhcPs)
a) HsType GhcPs -> R ()
p_hsType
  OpApp NoExt x :: LHsExpr GhcPs
x op :: LHsExpr GhcPs
op y :: LHsExpr GhcPs
y -> do
    let opTree :: OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
opTree = OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
-> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
forall ty op. OpTree ty op -> op -> OpTree ty op -> OpTree ty op
OpBranch (LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
exprOpTree LHsExpr GhcPs
x) LHsExpr GhcPs
op (LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
exprOpTree LHsExpr GhcPs
y)
    Bool
-> BracketStyle -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> R ()
p_exprOpTree Bool
True BracketStyle
s ((HsExpr GhcPs -> Maybe RdrName)
-> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
-> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
forall op ty.
(op -> Maybe RdrName)
-> OpTree (Located ty) (Located op)
-> OpTree (Located ty) (Located op)
reassociateOpTree HsExpr GhcPs -> Maybe RdrName
getOpName OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
opTree)
  NegApp NoExt e :: LHsExpr GhcPs
e _ -> do
    Text -> R ()
txt "-"
    R ()
space
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
e HsExpr GhcPs -> R ()
p_hsExpr
  HsPar NoExt e :: LHsExpr GhcPs
e ->
    BracketStyle -> R () -> R ()
parens BracketStyle
s (LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
e (R () -> R ()
dontUseBraces (R () -> R ()) -> (HsExpr GhcPs -> R ()) -> HsExpr GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> R ()
p_hsExpr))
  SectionL NoExt x :: LHsExpr GhcPs
x op :: LHsExpr GhcPs
op -> do
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
x HsExpr GhcPs -> R ()
p_hsExpr
    R ()
breakpoint
    R () -> R ()
inci (LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
op HsExpr GhcPs -> R ()
p_hsExpr)
  SectionR NoExt op :: LHsExpr GhcPs
op x :: LHsExpr GhcPs
x -> do
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
op HsExpr GhcPs -> R ()
p_hsExpr
    Bool
useRecordDot' <- R Bool
useRecordDot
    let isRecordDot' :: Bool
isRecordDot' = HsExpr GhcPs -> SrcSpan -> Bool
isRecordDot (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
op) (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
x)
    Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
useRecordDot' Bool -> Bool -> Bool
&& Bool
isRecordDot') R ()
breakpoint
    R () -> R ()
inci (LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
x HsExpr GhcPs -> R ()
p_hsExpr)
  ExplicitTuple NoExt args :: [LHsTupArg GhcPs]
args boxity :: Boxity
boxity -> do
    let isSection :: Bool
isSection = (LHsTupArg GhcPs -> Bool) -> [LHsTupArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HsTupArg GhcPs -> Bool
isMissing (HsTupArg GhcPs -> Bool)
-> (LHsTupArg GhcPs -> HsTupArg GhcPs) -> LHsTupArg GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTupArg GhcPs -> HsTupArg GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LHsTupArg GhcPs]
args
        isMissing :: HsTupArg GhcPs -> Bool
isMissing = \case
          Missing NoExt -> Bool
True
          _ -> Bool
False
    let parens' :: BracketStyle -> R () -> R ()
parens' =
          case Boxity
boxity of
            Boxed -> BracketStyle -> R () -> R ()
parens
            Unboxed -> BracketStyle -> R () -> R ()
parensHash
    if Bool
isSection
      then
        [SrcSpan] -> R () -> R ()
switchLayout [] (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BracketStyle -> R () -> R ()
parens' BracketStyle
s (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
          R () -> (LHsTupArg GhcPs -> R ()) -> [LHsTupArg GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
comma ((HsTupArg GhcPs -> R ()) -> LHsTupArg GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' HsTupArg GhcPs -> R ()
p_hsTupArg) [LHsTupArg GhcPs]
args
      else
        [SrcSpan] -> R () -> R ()
switchLayout (LHsTupArg GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsTupArg GhcPs -> SrcSpan) -> [LHsTupArg GhcPs] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTupArg GhcPs]
args) (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BracketStyle -> R () -> R ()
parens' BracketStyle
s (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
          R () -> (LHsTupArg GhcPs -> R ()) -> [LHsTupArg GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) (R () -> R ()
sitcc (R () -> R ())
-> (LHsTupArg GhcPs -> R ()) -> LHsTupArg GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsTupArg GhcPs -> R ()) -> LHsTupArg GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' HsTupArg GhcPs -> R ()
p_hsTupArg) [LHsTupArg GhcPs]
args
  ExplicitSum NoExt tag :: Int
tag arity :: Int
arity e :: LHsExpr GhcPs
e ->
    BracketStyle -> Int -> Int -> R () -> R ()
p_unboxedSum BracketStyle
N Int
tag Int
arity (LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
e HsExpr GhcPs -> R ()
p_hsExpr)
  HsCase NoExt e :: LHsExpr GhcPs
e mgroup :: MatchGroup GhcPs (LHsExpr GhcPs)
mgroup ->
    (HsExpr GhcPs -> Placement)
-> (HsExpr GhcPs -> R ())
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> LHsExpr GhcPs
-> MatchGroup GhcPs (Located body)
-> R ()
p_case HsExpr GhcPs -> Placement
exprPlacement HsExpr GhcPs -> R ()
p_hsExpr LHsExpr GhcPs
e MatchGroup GhcPs (LHsExpr GhcPs)
mgroup
  HsIf NoExt _ if' :: LHsExpr GhcPs
if' then' :: LHsExpr GhcPs
then' else' :: LHsExpr GhcPs
else' ->
    (HsExpr GhcPs -> Placement)
-> (HsExpr GhcPs -> R ())
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> LHsExpr GhcPs
-> Located body
-> Located body
-> R ()
p_if HsExpr GhcPs -> Placement
exprPlacement HsExpr GhcPs -> R ()
p_hsExpr LHsExpr GhcPs
if' LHsExpr GhcPs
then' LHsExpr GhcPs
else'
  HsMultiIf NoExt guards :: [LGRHS GhcPs (LHsExpr GhcPs)]
guards -> do
    Text -> R ()
txt "if "
    R () -> R ()
inci (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
inci (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R ()
-> (LGRHS GhcPs (LHsExpr GhcPs) -> R ())
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
newline ((GRHS GhcPs (LHsExpr GhcPs) -> R ())
-> LGRHS GhcPs (LHsExpr GhcPs) -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' (GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
p_grhs GroupStyle
RightArrow)) [LGRHS GhcPs (LHsExpr GhcPs)]
guards
  HsLet NoExt localBinds :: LHsLocalBinds GhcPs
localBinds e :: LHsExpr GhcPs
e ->
    (HsExpr GhcPs -> R ())
-> LHsLocalBinds GhcPs -> LHsExpr GhcPs -> R ()
forall body.
Data body =>
(body -> R ()) -> LHsLocalBinds GhcPs -> Located body -> R ()
p_let HsExpr GhcPs -> R ()
p_hsExpr LHsLocalBinds GhcPs
localBinds LHsExpr GhcPs
e
  HsDo NoExt ctx :: HsStmtContext Name
ctx es :: Located [GuardLStmt GhcPs]
es -> do
    let doBody :: Text -> R ()
doBody header :: Text
header = do
          Text -> R ()
txt Text
header
          R ()
breakpoint
          R () -> R ()
ub <- Layout -> R () -> R ()
layoutToBraces (Layout -> R () -> R ()) -> R Layout -> R (R () -> R ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R Layout
getLayout
          R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
            (GuardLStmt GhcPs -> R ()) -> [GuardLStmt GhcPs] -> R ()
forall a. (a -> R ()) -> [a] -> R ()
sepSemi
              ((Stmt GhcPs (LHsExpr GhcPs) -> R ()) -> GuardLStmt GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' (R () -> R ()
ub (R () -> R ())
-> (Stmt GhcPs (LHsExpr GhcPs) -> R ())
-> Stmt GhcPs (LHsExpr GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsExpr GhcPs -> Placement)
-> (HsExpr GhcPs -> R ()) -> Stmt GhcPs (LHsExpr GhcPs) -> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ()) -> Stmt GhcPs (Located body) -> R ()
p_stmt' HsExpr GhcPs -> Placement
exprPlacement (BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' BracketStyle
S)))
              (Located [GuardLStmt GhcPs]
-> SrcSpanLess (Located [GuardLStmt GhcPs])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [GuardLStmt GhcPs]
es)
        compBody :: R ()
compBody = BracketStyle -> R () -> R ()
brackets BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ Located [GuardLStmt GhcPs] -> ([GuardLStmt GhcPs] -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located [GuardLStmt GhcPs]
es (([GuardLStmt GhcPs] -> R ()) -> R ())
-> ([GuardLStmt GhcPs] -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \xs :: [GuardLStmt GhcPs]
xs -> do
          let p_parBody :: [[GuardLStmt GhcPs]] -> R ()
p_parBody =
                R ()
-> ([GuardLStmt GhcPs] -> R ()) -> [[GuardLStmt GhcPs]] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
                  (R ()
breakpoint R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt "| ")
                  [GuardLStmt GhcPs] -> R ()
p_seqBody
              p_seqBody :: [GuardLStmt GhcPs] -> R ()
p_seqBody =
                R () -> R ()
sitcc
                  (R () -> R ())
-> ([GuardLStmt GhcPs] -> R ()) -> [GuardLStmt GhcPs] -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> (GuardLStmt GhcPs -> R ()) -> [GuardLStmt GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
                    (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint)
                    ((Stmt GhcPs (LHsExpr GhcPs) -> R ()) -> GuardLStmt GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' (R () -> R ()
sitcc (R () -> R ())
-> (Stmt GhcPs (LHsExpr GhcPs) -> R ())
-> Stmt GhcPs (LHsExpr GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stmt GhcPs (LHsExpr GhcPs) -> R ()
p_stmt))
              stmts :: [GuardLStmt GhcPs]
stmts = [GuardLStmt GhcPs] -> [GuardLStmt GhcPs]
forall a. [a] -> [a]
init [GuardLStmt GhcPs]
xs
              yield :: GuardLStmt GhcPs
yield = [GuardLStmt GhcPs] -> GuardLStmt GhcPs
forall a. [a] -> a
last [GuardLStmt GhcPs]
xs
              lists :: [[GuardLStmt GhcPs]]
lists = (GuardLStmt GhcPs -> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]])
-> [[GuardLStmt GhcPs]]
-> [GuardLStmt GhcPs]
-> [[GuardLStmt GhcPs]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([[GuardLStmt GhcPs]]
-> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]]
forall a. Semigroup a => [a] -> [a] -> [a]
liftAppend ([[GuardLStmt GhcPs]]
 -> [[GuardLStmt GhcPs]] -> [[GuardLStmt GhcPs]])
-> (GuardLStmt GhcPs -> [[GuardLStmt GhcPs]])
-> GuardLStmt GhcPs
-> [[GuardLStmt GhcPs]]
-> [[GuardLStmt GhcPs]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GuardLStmt GhcPs -> [[GuardLStmt GhcPs]]
gatherStmt) [] [GuardLStmt GhcPs]
stmts
          GuardLStmt GhcPs -> (Stmt GhcPs (LHsExpr GhcPs) -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located GuardLStmt GhcPs
yield Stmt GhcPs (LHsExpr GhcPs) -> R ()
p_stmt
          R ()
breakpoint
          Text -> R ()
txt "|"
          R ()
space
          [[GuardLStmt GhcPs]] -> R ()
p_parBody [[GuardLStmt GhcPs]]
lists
    case HsStmtContext Name
ctx of
      DoExpr -> Text -> R ()
doBody "do"
      MDoExpr -> Text -> R ()
doBody "mdo"
      ListComp -> R ()
compBody
      MonadComp -> String -> R ()
forall a. String -> a
notImplemented "MonadComp"
      ArrowExpr -> String -> R ()
forall a. String -> a
notImplemented "ArrowExpr"
      GhciStmtCtxt -> String -> R ()
forall a. String -> a
notImplemented "GhciStmtCtxt"
      PatGuard _ -> String -> R ()
forall a. String -> a
notImplemented "PatGuard"
      ParStmtCtxt _ -> String -> R ()
forall a. String -> a
notImplemented "ParStmtCtxt"
      TransStmtCtxt _ -> String -> R ()
forall a. String -> a
notImplemented "TransStmtCtxt"
  ExplicitList _ _ xs :: [LHsExpr GhcPs]
xs ->
    BracketStyle -> R () -> R ()
brackets BracketStyle
s (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      R () -> (LHsExpr GhcPs -> R ()) -> [LHsExpr GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) (R () -> R ()
sitcc (R () -> R ()) -> (LHsExpr GhcPs -> R ()) -> LHsExpr GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsExpr GhcPs -> R ()) -> LHsExpr GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' HsExpr GhcPs -> R ()
p_hsExpr) [LHsExpr GhcPs]
xs
  RecordCon {..} -> do
    Located RdrName -> (RdrName -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located (IdP GhcPs)
Located RdrName
rcon_con_name RdrName -> R ()
forall a. Outputable a => a -> R ()
atom
    R ()
breakpoint
    let HsRecFields {..} = HsRecordBinds GhcPs
rcon_flds
        updName :: HsRecField' (FieldOcc pass) arg -> HsRecField' RdrName arg
updName f :: HsRecField' (FieldOcc pass) arg
f =
          HsRecField' (FieldOcc pass) arg
f
            { hsRecFieldLbl :: Located RdrName
hsRecFieldLbl = case Located (FieldOcc pass) -> SrcSpanLess (Located (FieldOcc pass))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located (FieldOcc pass) -> SrcSpanLess (Located (FieldOcc pass)))
-> Located (FieldOcc pass) -> SrcSpanLess (Located (FieldOcc pass))
forall a b. (a -> b) -> a -> b
$ HsRecField' (FieldOcc pass) arg -> Located (FieldOcc pass)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl HsRecField' (FieldOcc pass) arg
f of
                FieldOcc _ n -> Located RdrName
n
                XFieldOcc _ -> String -> Located RdrName
forall a. String -> a
notImplemented "XFieldOcc"
            }
        fields :: [R ()]
fields = (HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs) -> R ())
-> LHsRecField GhcPs (LHsExpr GhcPs) -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' (HsRecField' RdrName (LHsExpr GhcPs) -> R ()
p_hsRecField (HsRecField' RdrName (LHsExpr GhcPs) -> R ())
-> (HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)
    -> HsRecField' RdrName (LHsExpr GhcPs))
-> HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)
-> HsRecField' RdrName (LHsExpr GhcPs)
forall pass arg.
HsRecField' (FieldOcc pass) arg -> HsRecField' RdrName arg
updName) (LHsRecField GhcPs (LHsExpr GhcPs) -> R ())
-> [LHsRecField GhcPs (LHsExpr GhcPs)] -> [R ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsRecField GhcPs (LHsExpr GhcPs)]
rec_flds
        dotdot :: [R ()]
dotdot =
          case Maybe Int
rec_dotdot of
            Just {} -> [Text -> R ()
txt ".."]
            Nothing -> []
    R () -> R ()
inci (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BracketStyle -> R () -> R ()
braces BracketStyle
N (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      R () -> (R () -> R ()) -> [R ()] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) R () -> R ()
sitcc ([R ()]
fields [R ()] -> [R ()] -> [R ()]
forall a. Semigroup a => a -> a -> a
<> [R ()]
dotdot)
  RecordUpd {..} -> do
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
rupd_expr HsExpr GhcPs -> R ()
p_hsExpr
    Bool
useRecordDot' <- R Bool
useRecordDot
    let mrs :: a -> Maybe RealSrcSpan
mrs sp :: a
sp = case a -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc a
sp of
          RealSrcSpan r :: RealSrcSpan
r -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
r
          _ -> Maybe RealSrcSpan
forall a. Maybe a
Nothing
    let isPluginForm :: Bool
isPluginForm =
          ((1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (RealSrcSpan -> Int) -> RealSrcSpan -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> Int
srcSpanEndCol (RealSrcSpan -> Int) -> Maybe RealSrcSpan -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcPs -> Maybe RealSrcSpan
forall a. HasSrcSpan a => a -> Maybe RealSrcSpan
mrs LHsExpr GhcPs
rupd_expr)
            Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== (RealSrcSpan -> Int
srcSpanStartCol (RealSrcSpan -> Int) -> Maybe RealSrcSpan -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsRecUpdField GhcPs -> Maybe RealSrcSpan
forall a. HasSrcSpan a => a -> Maybe RealSrcSpan
mrs ([LHsRecUpdField GhcPs] -> LHsRecUpdField GhcPs
forall a. [a] -> a
head [LHsRecUpdField GhcPs]
rupd_flds))
    Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
useRecordDot' Bool -> Bool -> Bool
&& Bool
isPluginForm) R ()
breakpoint
    let updName :: HsRecField' (AmbiguousFieldOcc pass) arg -> HsRecField' RdrName arg
updName f :: HsRecField' (AmbiguousFieldOcc pass) arg
f =
          HsRecField' (AmbiguousFieldOcc pass) arg
f
            { hsRecFieldLbl :: Located RdrName
hsRecFieldLbl = case Located (AmbiguousFieldOcc pass)
-> SrcSpanLess (Located (AmbiguousFieldOcc pass))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located (AmbiguousFieldOcc pass)
 -> SrcSpanLess (Located (AmbiguousFieldOcc pass)))
-> Located (AmbiguousFieldOcc pass)
-> SrcSpanLess (Located (AmbiguousFieldOcc pass))
forall a b. (a -> b) -> a -> b
$ HsRecField' (AmbiguousFieldOcc pass) arg
-> Located (AmbiguousFieldOcc pass)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl HsRecField' (AmbiguousFieldOcc pass) arg
f of
                Ambiguous _ n -> Located RdrName
n
                Unambiguous _ n -> Located RdrName
n
                XAmbiguousFieldOcc _ -> String -> Located RdrName
forall a. String -> a
notImplemented "XAmbiguousFieldOcc"
            }
    R () -> R ()
inci (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BracketStyle -> R () -> R ()
braces BracketStyle
N (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      R ()
-> (LHsRecUpdField GhcPs -> R ()) -> [LHsRecUpdField GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
        (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint)
        (R () -> R ()
sitcc (R () -> R ())
-> (LHsRecUpdField GhcPs -> R ()) -> LHsRecUpdField GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs) -> R ())
-> LHsRecUpdField GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' (HsRecField' RdrName (LHsExpr GhcPs) -> R ()
p_hsRecField (HsRecField' RdrName (LHsExpr GhcPs) -> R ())
-> (HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)
    -> HsRecField' RdrName (LHsExpr GhcPs))
-> HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)
-> HsRecField' RdrName (LHsExpr GhcPs)
forall pass arg.
HsRecField' (AmbiguousFieldOcc pass) arg -> HsRecField' RdrName arg
updName))
        [LHsRecUpdField GhcPs]
rupd_flds
  ExprWithTySig NoExt x :: LHsExpr GhcPs
x HsWC {hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = HsIB {..}} -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
x HsExpr GhcPs -> R ()
p_hsExpr
    R ()
space
    Text -> R ()
txt "::"
    R ()
breakpoint
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ Located (HsType GhcPs) -> (HsType GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located (HsType GhcPs)
LHsType (NoGhcTc GhcPs)
hsib_body HsType GhcPs -> R ()
p_hsType
  ExprWithTySig NoExt _ HsWC {hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = XHsImplicitBndrs {}} ->
    String -> R ()
forall a. String -> a
notImplemented "XHsImplicitBndrs"
  ExprWithTySig NoExt _ XHsWildCardBndrs {} -> String -> R ()
forall a. String -> a
notImplemented "XHsWildCardBndrs"
  ArithSeq NoExt _ x :: ArithSeqInfo GhcPs
x ->
    case ArithSeqInfo GhcPs
x of
      From from :: LHsExpr GhcPs
from -> BracketStyle -> R () -> R ()
brackets BracketStyle
s (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
from HsExpr GhcPs -> R ()
p_hsExpr
        R ()
breakpoint
        Text -> R ()
txt ".."
      FromThen from :: LHsExpr GhcPs
from next :: LHsExpr GhcPs
next -> BracketStyle -> R () -> R ()
brackets BracketStyle
s (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (LHsExpr GhcPs -> R ()) -> [LHsExpr GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) ((HsExpr GhcPs -> R ()) -> LHsExpr GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' HsExpr GhcPs -> R ()
p_hsExpr) [LHsExpr GhcPs
from, LHsExpr GhcPs
next]
        R ()
breakpoint
        Text -> R ()
txt ".."
      FromTo from :: LHsExpr GhcPs
from to :: LHsExpr GhcPs
to -> BracketStyle -> R () -> R ()
brackets BracketStyle
s (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
from HsExpr GhcPs -> R ()
p_hsExpr
        R ()
breakpoint
        Text -> R ()
txt ".."
        R ()
space
        LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
to HsExpr GhcPs -> R ()
p_hsExpr
      FromThenTo from :: LHsExpr GhcPs
from next :: LHsExpr GhcPs
next to :: LHsExpr GhcPs
to -> BracketStyle -> R () -> R ()
brackets BracketStyle
s (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (LHsExpr GhcPs -> R ()) -> [LHsExpr GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) ((HsExpr GhcPs -> R ()) -> LHsExpr GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' HsExpr GhcPs -> R ()
p_hsExpr) [LHsExpr GhcPs
from, LHsExpr GhcPs
next]
        R ()
breakpoint
        Text -> R ()
txt ".."
        R ()
space
        LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
to HsExpr GhcPs -> R ()
p_hsExpr
  HsSCC NoExt _ name :: StringLiteral
name x :: LHsExpr GhcPs
x -> do
    Text -> R ()
txt "{-# SCC "
    StringLiteral -> R ()
forall a. Outputable a => a -> R ()
atom StringLiteral
name
    Text -> R ()
txt " #-}"
    R ()
breakpoint
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
x HsExpr GhcPs -> R ()
p_hsExpr
  HsCoreAnn NoExt _ value :: StringLiteral
value x :: LHsExpr GhcPs
x -> do
    Text -> R ()
txt "{-# CORE "
    StringLiteral -> R ()
forall a. Outputable a => a -> R ()
atom StringLiteral
value
    Text -> R ()
txt " #-}"
    R ()
breakpoint
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
x HsExpr GhcPs -> R ()
p_hsExpr
  HsBracket NoExt x :: HsBracket GhcPs
x -> HsBracket GhcPs -> R ()
p_hsBracket HsBracket GhcPs
x
  HsRnBracketOut {} -> String -> R ()
forall a. String -> a
notImplemented "HsRnBracketOut"
  HsTcBracketOut {} -> String -> R ()
forall a. String -> a
notImplemented "HsTcBracketOut"
  HsSpliceE NoExt splice :: HsSplice GhcPs
splice -> HsSplice GhcPs -> R ()
p_hsSplice HsSplice GhcPs
splice
  HsProc NoExt p :: LPat GhcPs
p e :: LHsCmdTop GhcPs
e -> do
    Text -> R ()
txt "proc"
    LPat GhcPs -> (LPat GhcPs -> R ()) -> R ()
forall pass.
(Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>
Pat pass -> (Pat pass -> R ()) -> R ()
locatedPat LPat GhcPs
p ((LPat GhcPs -> R ()) -> R ()) -> (LPat GhcPs -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \x :: LPat GhcPs
x -> do
      R ()
breakpoint
      R () -> R ()
inci (LPat GhcPs -> R ()
p_pat LPat GhcPs
x)
      R ()
breakpoint
    Text -> R ()
txt "->"
    Placement -> R () -> R ()
placeHanging (HsCmdTop GhcPs -> Placement
cmdTopPlacement (LHsCmdTop GhcPs -> SrcSpanLess (LHsCmdTop GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsCmdTop GhcPs
e)) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      LHsCmdTop GhcPs -> (HsCmdTop GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsCmdTop GhcPs
e HsCmdTop GhcPs -> R ()
p_hsCmdTop
  HsStatic _ e :: LHsExpr GhcPs
e -> do
    Text -> R ()
txt "static"
    R ()
breakpoint
    R () -> R ()
inci (LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
e HsExpr GhcPs -> R ()
p_hsExpr)
  HsArrApp NoExt body :: LHsExpr GhcPs
body input :: LHsExpr GhcPs
input arrType :: HsArrAppType
arrType cond :: Bool
cond ->
    HsCmd GhcPs -> R ()
p_hsCmd (XCmdArrApp GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> HsArrAppType
-> Bool
-> HsCmd GhcPs
forall id.
XCmdArrApp id
-> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id
HsCmdArrApp NoExt
XCmdArrApp GhcPs
NoExt LHsExpr GhcPs
body LHsExpr GhcPs
input HsArrAppType
arrType Bool
cond)
  HsArrForm NoExt form :: LHsExpr GhcPs
form mfixity :: Maybe Fixity
mfixity cmds :: [LHsCmdTop GhcPs]
cmds ->
    HsCmd GhcPs -> R ()
p_hsCmd (XCmdArrForm GhcPs
-> LHsExpr GhcPs
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcPs]
-> HsCmd GhcPs
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm NoExt
XCmdArrForm GhcPs
NoExt LHsExpr GhcPs
form LexicalFixity
Prefix Maybe Fixity
mfixity [LHsCmdTop GhcPs]
cmds)
  HsTick {} -> String -> R ()
forall a. String -> a
notImplemented "HsTick"
  HsBinTick {} -> String -> R ()
forall a. String -> a
notImplemented "HsBinTick"
  HsTickPragma {} -> String -> R ()
forall a. String -> a
notImplemented "HsTickPragma"
  -- These four constructs should never appear in correct programs.
  -- See: https://github.com/tweag/ormolu/issues/343
  EWildPat NoExt -> Text -> R ()
txt "_"
  EAsPat NoExt n :: Located (IdP GhcPs)
n p :: LHsExpr GhcPs
p -> do
    Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
n
    Text -> R ()
txt "@"
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
p HsExpr GhcPs -> R ()
p_hsExpr
  EViewPat NoExt p :: LHsExpr GhcPs
p e :: LHsExpr GhcPs
e -> do
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
p HsExpr GhcPs -> R ()
p_hsExpr
    R ()
space
    Text -> R ()
txt "->"
    R ()
breakpoint
    R () -> R ()
inci (LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
e HsExpr GhcPs -> R ()
p_hsExpr)
  ELazyPat NoExt p :: LHsExpr GhcPs
p -> do
    Text -> R ()
txt "~"
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
p HsExpr GhcPs -> R ()
p_hsExpr
  HsWrap {} -> String -> R ()
forall a. String -> a
notImplemented "HsWrap"
  XExpr {} -> String -> R ()
forall a. String -> a
notImplemented "XExpr"

p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
p_patSynBind PSB {..} = do
  let rhs :: R ()
rhs = do
        R ()
space
        case HsPatSynDir GhcPs
psb_dir of
          Unidirectional -> do
            Text -> R ()
txt "<-"
            R ()
breakpoint
            LPat GhcPs -> R ()
p_pat LPat GhcPs
psb_def
          ImplicitBidirectional -> do
            Text -> R ()
txt "="
            R ()
breakpoint
            LPat GhcPs -> R ()
p_pat LPat GhcPs
psb_def
          ExplicitBidirectional mgroup :: MatchGroup GhcPs (LHsExpr GhcPs)
mgroup -> do
            Text -> R ()
txt "<-"
            R ()
breakpoint
            LPat GhcPs -> R ()
p_pat LPat GhcPs
psb_def
            R ()
newline
            Text -> R ()
txt "where"
            R ()
newline
            R () -> R ()
inci (MatchGroupStyle -> MatchGroup GhcPs (LHsExpr GhcPs) -> R ()
p_matchGroup (Located RdrName -> MatchGroupStyle
Function Located (IdP GhcPs)
Located RdrName
psb_id) MatchGroup GhcPs (LHsExpr GhcPs)
mgroup)
  Text -> R ()
txt "pattern"
  case HsPatSynDetails (Located (IdP GhcPs))
psb_args of
    PrefixCon xs :: [Located (IdP GhcPs)]
xs -> do
      R ()
space
      Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
psb_id
      R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        [SrcSpan] -> R () -> R ()
switchLayout (Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (Located RdrName -> SrcSpan) -> [Located RdrName] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located (IdP GhcPs)]
[Located RdrName]
xs) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Located RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (IdP GhcPs)]
[Located RdrName]
xs) R ()
breakpoint
          R () -> R ()
sitcc (R () -> (Located RdrName -> R ()) -> [Located RdrName] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint Located RdrName -> R ()
p_rdrName [Located (IdP GhcPs)]
[Located RdrName]
xs)
        R ()
rhs
    RecCon xs :: [RecordPatSynField (Located (IdP GhcPs))]
xs -> do
      R ()
space
      Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
psb_id
      R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        [SrcSpan] -> R () -> R ()
switchLayout (Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (Located RdrName -> SrcSpan)
-> (RecordPatSynField (Located RdrName) -> Located RdrName)
-> RecordPatSynField (Located RdrName)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordPatSynField (Located RdrName) -> Located RdrName
forall a. RecordPatSynField a -> a
recordPatSynPatVar (RecordPatSynField (Located RdrName) -> SrcSpan)
-> [RecordPatSynField (Located RdrName)] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RecordPatSynField (Located (IdP GhcPs))]
[RecordPatSynField (Located RdrName)]
xs) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RecordPatSynField (Located RdrName)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RecordPatSynField (Located (IdP GhcPs))]
[RecordPatSynField (Located RdrName)]
xs) R ()
breakpoint
          BracketStyle -> R () -> R ()
braces BracketStyle
N (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
            R ()
-> (RecordPatSynField (Located RdrName) -> R ())
-> [RecordPatSynField (Located RdrName)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) (Located RdrName -> R ()
p_rdrName (Located RdrName -> R ())
-> (RecordPatSynField (Located RdrName) -> Located RdrName)
-> RecordPatSynField (Located RdrName)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordPatSynField (Located RdrName) -> Located RdrName
forall a. RecordPatSynField a -> a
recordPatSynPatVar) [RecordPatSynField (Located (IdP GhcPs))]
[RecordPatSynField (Located RdrName)]
xs
        R ()
rhs
    InfixCon l :: Located (IdP GhcPs)
l r :: Located (IdP GhcPs)
r -> do
      [SrcSpan] -> R () -> R ()
switchLayout [Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located (IdP GhcPs)
Located RdrName
l, Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located (IdP GhcPs)
Located RdrName
r] (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        R ()
space
        Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
l
        R ()
breakpoint
        R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
psb_id
          R ()
space
          Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
r
      R () -> R ()
inci R ()
rhs
p_patSynBind (XPatSynBind NoExt) = String -> R ()
forall a. String -> a
notImplemented "XPatSynBind"

p_case ::
  Data body =>
  -- | Placer
  (body -> Placement) ->
  -- | Render
  (body -> R ()) ->
  -- | Expression
  LHsExpr GhcPs ->
  -- | Match group
  MatchGroup GhcPs (Located body) ->
  R ()
p_case :: (body -> Placement)
-> (body -> R ())
-> LHsExpr GhcPs
-> MatchGroup GhcPs (Located body)
-> R ()
p_case placer :: body -> Placement
placer render :: body -> R ()
render e :: LHsExpr GhcPs
e mgroup :: MatchGroup GhcPs (Located body)
mgroup = do
  Text -> R ()
txt "case"
  R ()
space
  LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
e HsExpr GhcPs -> R ()
p_hsExpr
  R ()
space
  Text -> R ()
txt "of"
  R ()
breakpoint
  R () -> R ()
inci ((body -> Placement)
-> (body -> R ())
-> MatchGroupStyle
-> MatchGroup GhcPs (Located body)
-> R ()
forall body.
Data body =>
(body -> Placement)
-> (body -> R ())
-> MatchGroupStyle
-> MatchGroup GhcPs (Located body)
-> R ()
p_matchGroup' body -> Placement
placer body -> R ()
render MatchGroupStyle
Case MatchGroup GhcPs (Located body)
mgroup)

p_if ::
  Data body =>
  -- | Placer
  (body -> Placement) ->
  -- | Render
  (body -> R ()) ->
  -- | If
  LHsExpr GhcPs ->
  -- | Then
  Located body ->
  -- | Else
  Located body ->
  R ()
p_if :: (body -> Placement)
-> (body -> R ())
-> LHsExpr GhcPs
-> Located body
-> Located body
-> R ()
p_if placer :: body -> Placement
placer render :: body -> R ()
render if' :: LHsExpr GhcPs
if' then' :: Located body
then' else' :: Located body
else' = do
  Text -> R ()
txt "if"
  R ()
space
  LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
if' HsExpr GhcPs -> R ()
p_hsExpr
  R ()
breakpoint
  R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> R ()
txt "then"
    Located body -> (body -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located body
then' ((body -> R ()) -> R ()) -> (body -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \x :: body
x ->
      Placement -> R () -> R ()
placeHanging (body -> Placement
placer body
x) (body -> R ()
render body
x)
    R ()
breakpoint
    Text -> R ()
txt "else"
    Located body -> (body -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located body
else' ((body -> R ()) -> R ()) -> (body -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \x :: body
x ->
      Placement -> R () -> R ()
placeHanging (body -> Placement
placer body
x) (body -> R ()
render body
x)

p_let ::
  Data body =>
  -- | Render
  (body -> R ()) ->
  Located (HsLocalBindsLR GhcPs GhcPs) ->
  Located body ->
  R ()
p_let :: (body -> R ()) -> LHsLocalBinds GhcPs -> Located body -> R ()
p_let render :: body -> R ()
render localBinds :: LHsLocalBinds GhcPs
localBinds e :: Located body
e = R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
  Text -> R ()
txt "let"
  R ()
space
  R () -> R ()
dontUseBraces (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> R ()
sitcc (LHsLocalBinds GhcPs -> (HsLocalBindsLR GhcPs GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsLocalBinds GhcPs
localBinds HsLocalBindsLR GhcPs GhcPs -> R ()
p_hsLocalBinds)
  R () -> R () -> R ()
forall a. R a -> R a -> R a
vlayout R ()
space (R ()
newline R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt " ")
  Text -> R ()
txt "in"
  R ()
space
  R () -> R ()
sitcc (Located body -> (body -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located body
e body -> R ()
render)

p_pat :: Pat GhcPs -> R ()
p_pat :: LPat GhcPs -> R ()
p_pat = \case
  -- Note: starting from GHC 8.8, 'LPat' == 'Pat'. Located 'Pat's are always
  -- constructed with the 'XPat' constructor, containing a @Located Pat@.
  XPat pat :: XXPat GhcPs
pat -> Located (LPat GhcPs) -> (LPat GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located XXPat GhcPs
Located (LPat GhcPs)
pat LPat GhcPs -> R ()
p_pat
  WildPat NoExt -> Text -> R ()
txt "_"
  VarPat NoExt name :: Located (IdP GhcPs)
name -> Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
name
  LazyPat NoExt pat :: LPat GhcPs
pat -> do
    Text -> R ()
txt "~"
    LPat GhcPs -> R ()
p_pat LPat GhcPs
pat
  AsPat NoExt name :: Located (IdP GhcPs)
name pat :: LPat GhcPs
pat -> do
    Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
name
    Text -> R ()
txt "@"
    LPat GhcPs -> R ()
p_pat LPat GhcPs
pat
  ParPat NoExt pat :: LPat GhcPs
pat ->
    LPat GhcPs -> (LPat GhcPs -> R ()) -> R ()
forall pass.
(Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>
Pat pass -> (Pat pass -> R ()) -> R ()
locatedPat LPat GhcPs
pat (BracketStyle -> R () -> R ()
parens BracketStyle
S (R () -> R ()) -> (LPat GhcPs -> R ()) -> LPat GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcPs -> R ()
p_pat)
  BangPat NoExt pat :: LPat GhcPs
pat -> do
    Text -> R ()
txt "!"
    LPat GhcPs -> R ()
p_pat LPat GhcPs
pat
  ListPat NoExt pats :: [LPat GhcPs]
pats ->
    BracketStyle -> R () -> R ()
brackets BracketStyle
S (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (LPat GhcPs -> R ()) -> [LPat GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) LPat GhcPs -> R ()
p_pat [LPat GhcPs]
pats
  TuplePat NoExt pats :: [LPat GhcPs]
pats boxing :: Boxity
boxing -> do
    let f :: R () -> R ()
f =
          case Boxity
boxing of
            Boxed -> BracketStyle -> R () -> R ()
parens BracketStyle
S
            Unboxed -> BracketStyle -> R () -> R ()
parensHash BracketStyle
S
    R () -> R ()
f (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (LPat GhcPs -> R ()) -> [LPat GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) (R () -> R ()
sitcc (R () -> R ()) -> (LPat GhcPs -> R ()) -> LPat GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcPs -> R ()
p_pat) [LPat GhcPs]
pats
  SumPat NoExt pat :: LPat GhcPs
pat tag :: Int
tag arity :: Int
arity ->
    BracketStyle -> Int -> Int -> R () -> R ()
p_unboxedSum BracketStyle
S Int
tag Int
arity (LPat GhcPs -> R ()
p_pat LPat GhcPs
pat)
  ConPatIn pat :: Located (IdP GhcPs)
pat details :: HsConPatDetails GhcPs
details ->
    case HsConPatDetails GhcPs
details of
      PrefixCon xs :: [LPat GhcPs]
xs -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
pat
        Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LPat GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
xs) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          R ()
breakpoint
          R () -> R ()
inci (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (LPat GhcPs -> R ()) -> [LPat GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint (R () -> R ()
sitcc (R () -> R ()) -> (LPat GhcPs -> R ()) -> LPat GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcPs -> R ()
p_pat) [LPat GhcPs]
xs
      RecCon (HsRecFields fields :: [LHsRecField GhcPs (LPat GhcPs)]
fields dotdot :: Maybe Int
dotdot) -> do
        Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
pat
        R ()
breakpoint
        let f :: Maybe (LHsRecField GhcPs (LPat GhcPs)) -> R ()
f = \case
              Nothing -> Text -> R ()
txt ".."
              Just x :: LHsRecField GhcPs (LPat GhcPs)
x -> LHsRecField GhcPs (LPat GhcPs)
-> (HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsRecField GhcPs (LPat GhcPs)
x HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
p_pat_hsRecField
        R () -> R ()
inci (R () -> R ())
-> ([Maybe (LHsRecField GhcPs (LPat GhcPs))] -> R ())
-> [Maybe (LHsRecField GhcPs (LPat GhcPs))]
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BracketStyle -> R () -> R ()
braces BracketStyle
N (R () -> R ())
-> ([Maybe (LHsRecField GhcPs (LPat GhcPs))] -> R ())
-> [Maybe (LHsRecField GhcPs (LPat GhcPs))]
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ())
-> ([Maybe (LHsRecField GhcPs (LPat GhcPs))] -> R ())
-> [Maybe (LHsRecField GhcPs (LPat GhcPs))]
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R ()
-> (Maybe (LHsRecField GhcPs (LPat GhcPs)) -> R ())
-> [Maybe (LHsRecField GhcPs (LPat GhcPs))]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) Maybe (LHsRecField GhcPs (LPat GhcPs)) -> R ()
f ([Maybe (LHsRecField GhcPs (LPat GhcPs))] -> R ())
-> [Maybe (LHsRecField GhcPs (LPat GhcPs))] -> R ()
forall a b. (a -> b) -> a -> b
$
          case Maybe Int
dotdot of
            Nothing -> LHsRecField GhcPs (LPat GhcPs)
-> Maybe (LHsRecField GhcPs (LPat GhcPs))
forall a. a -> Maybe a
Just (LHsRecField GhcPs (LPat GhcPs)
 -> Maybe (LHsRecField GhcPs (LPat GhcPs)))
-> [LHsRecField GhcPs (LPat GhcPs)]
-> [Maybe (LHsRecField GhcPs (LPat GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsRecField GhcPs (LPat GhcPs)]
fields
            Just n :: Int
n -> (LHsRecField GhcPs (LPat GhcPs)
-> Maybe (LHsRecField GhcPs (LPat GhcPs))
forall a. a -> Maybe a
Just (LHsRecField GhcPs (LPat GhcPs)
 -> Maybe (LHsRecField GhcPs (LPat GhcPs)))
-> [LHsRecField GhcPs (LPat GhcPs)]
-> [Maybe (LHsRecField GhcPs (LPat GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> [LHsRecField GhcPs (LPat GhcPs)]
-> [LHsRecField GhcPs (LPat GhcPs)]
forall a. Int -> [a] -> [a]
take Int
n [LHsRecField GhcPs (LPat GhcPs)]
fields) [Maybe (LHsRecField GhcPs (LPat GhcPs))]
-> [Maybe (LHsRecField GhcPs (LPat GhcPs))]
-> [Maybe (LHsRecField GhcPs (LPat GhcPs))]
forall a. [a] -> [a] -> [a]
++ [Maybe (LHsRecField GhcPs (LPat GhcPs))
forall a. Maybe a
Nothing]
      InfixCon x :: LPat GhcPs
x y :: LPat GhcPs
y -> do
        LPat GhcPs -> R ()
p_pat LPat GhcPs
x
        R ()
space
        Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
pat
        R ()
breakpoint
        R () -> R ()
inci (LPat GhcPs -> R ()
p_pat LPat GhcPs
y)
  ConPatOut {} -> String -> R ()
forall a. String -> a
notImplemented "ConPatOut" -- presumably created by renamer?
  ViewPat NoExt expr :: LHsExpr GhcPs
expr pat :: LPat GhcPs
pat -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
expr HsExpr GhcPs -> R ()
p_hsExpr
    R ()
space
    Text -> R ()
txt "->"
    R ()
breakpoint
    R () -> R ()
inci (LPat GhcPs -> R ()
p_pat LPat GhcPs
pat)
  SplicePat NoExt splice :: HsSplice GhcPs
splice -> HsSplice GhcPs -> R ()
p_hsSplice HsSplice GhcPs
splice
  LitPat NoExt p :: HsLit GhcPs
p -> HsLit GhcPs -> R ()
forall a. Outputable a => a -> R ()
atom HsLit GhcPs
p
  NPat NoExt v :: Located (HsOverLit GhcPs)
v _ _ -> Located (HsOverLit GhcPs) -> (HsOverLit GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located (HsOverLit GhcPs)
v (OverLitVal -> R ()
forall a. Outputable a => a -> R ()
atom (OverLitVal -> R ())
-> (HsOverLit GhcPs -> OverLitVal) -> HsOverLit GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsOverLit GhcPs -> OverLitVal
forall p. HsOverLit p -> OverLitVal
ol_val)
  NPlusKPat NoExt n :: Located (IdP GhcPs)
n k :: Located (HsOverLit GhcPs)
k _ _ _ -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
n
    R ()
breakpoint
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> R ()
txt "+"
      R ()
space
      Located (HsOverLit GhcPs) -> (HsOverLit GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located (HsOverLit GhcPs)
k (OverLitVal -> R ()
forall a. Outputable a => a -> R ()
atom (OverLitVal -> R ())
-> (HsOverLit GhcPs -> OverLitVal) -> HsOverLit GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsOverLit GhcPs -> OverLitVal
forall p. HsOverLit p -> OverLitVal
ol_val)
  SigPat NoExt pat :: LPat GhcPs
pat hswc :: LHsSigWcType (NoGhcTc GhcPs)
hswc -> do
    LPat GhcPs -> R ()
p_pat LPat GhcPs
pat
    LHsSigWcType GhcPs -> R ()
p_typeAscription LHsSigWcType GhcPs
LHsSigWcType (NoGhcTc GhcPs)
hswc
  CoPat {} -> String -> R ()
forall a. String -> a
notImplemented "CoPat" -- apparently created at some later stage

p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
p_pat_hsRecField HsRecField {..} = do
  Located (FieldOcc GhcPs) -> (FieldOcc GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located (FieldOcc GhcPs)
hsRecFieldLbl ((FieldOcc GhcPs -> R ()) -> R ())
-> (FieldOcc GhcPs -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \x :: FieldOcc GhcPs
x ->
    Located RdrName -> R ()
p_rdrName (FieldOcc GhcPs -> Located RdrName
forall pass. FieldOcc pass -> Located RdrName
rdrNameFieldOcc FieldOcc GhcPs
x)
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hsRecPun (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    R ()
space
    Text -> R ()
txt "="
    R ()
breakpoint
    R () -> R ()
inci (LPat GhcPs -> R ()
p_pat LPat GhcPs
hsRecFieldArg)

p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()
p_unboxedSum :: BracketStyle -> Int -> Int -> R () -> R ()
p_unboxedSum s :: BracketStyle
s tag :: Int
tag arity :: Int
arity m :: R ()
m = do
  let before :: Int
before = Int
tag Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
      after :: Int
after = Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
before Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
      args :: [Maybe (R ())]
args = Int -> Maybe (R ()) -> [Maybe (R ())]
forall a. Int -> a -> [a]
replicate Int
before Maybe (R ())
forall a. Maybe a
Nothing [Maybe (R ())] -> [Maybe (R ())] -> [Maybe (R ())]
forall a. Semigroup a => a -> a -> a
<> [R () -> Maybe (R ())
forall a. a -> Maybe a
Just R ()
m] [Maybe (R ())] -> [Maybe (R ())] -> [Maybe (R ())]
forall a. Semigroup a => a -> a -> a
<> Int -> Maybe (R ()) -> [Maybe (R ())]
forall a. Int -> a -> [a]
replicate Int
after Maybe (R ())
forall a. Maybe a
Nothing
      f :: (Maybe (R ()), Int) -> R ()
f (x :: Maybe (R ())
x, i :: Int
i) = do
        let isFirst :: Bool
isFirst = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
            isLast :: Bool
isLast = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
        case Maybe (R ())
x :: Maybe (R ()) of
          Nothing ->
            Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isFirst Bool -> Bool -> Bool
|| Bool
isLast) R ()
space
          Just m' :: R ()
m' -> do
            Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isFirst R ()
space
            R ()
m'
            Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isLast R ()
space
  BracketStyle -> R () -> R ()
parensHash BracketStyle
s (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R ()
-> ((Maybe (R ()), Int) -> R ()) -> [(Maybe (R ()), Int)] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt "|") (Maybe (R ()), Int) -> R ()
f ([Maybe (R ())] -> [Int] -> [(Maybe (R ()), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe (R ())]
args [0 ..])

p_hsSplice :: HsSplice GhcPs -> R ()
p_hsSplice :: HsSplice GhcPs -> R ()
p_hsSplice = \case
  HsTypedSplice NoExt deco :: SpliceDecoration
deco _ expr :: LHsExpr GhcPs
expr -> Bool -> LHsExpr GhcPs -> SpliceDecoration -> R ()
p_hsSpliceTH Bool
True LHsExpr GhcPs
expr SpliceDecoration
deco
  HsUntypedSplice NoExt deco :: SpliceDecoration
deco _ expr :: LHsExpr GhcPs
expr -> Bool -> LHsExpr GhcPs -> SpliceDecoration -> R ()
p_hsSpliceTH Bool
False LHsExpr GhcPs
expr SpliceDecoration
deco
  HsQuasiQuote NoExt _ quoterName :: IdP GhcPs
quoterName srcSpan :: SrcSpan
srcSpan str :: FastString
str -> do
    Text -> R ()
txt "["
    Located RdrName -> R ()
p_rdrName (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
srcSpan IdP GhcPs
RdrName
quoterName)
    Text -> R ()
txt "|"
    -- QuasiQuoters often rely on precise custom strings. We cannot do any
    -- formatting here without potentially breaking someone's code.
    FastString -> R ()
forall a. Outputable a => a -> R ()
atom FastString
str
    Text -> R ()
txt "|]"
  HsSpliced {} -> String -> R ()
forall a. String -> a
notImplemented "HsSpliced"
  HsSplicedT {} -> String -> R ()
forall a. String -> a
notImplemented "HsSplicedT"
  XSplice {} -> String -> R ()
forall a. String -> a
notImplemented "XSplice"

p_hsSpliceTH ::
  -- | Typed splice?
  Bool ->
  -- | Splice expression
  LHsExpr GhcPs ->
  -- | Splice decoration
  SpliceDecoration ->
  R ()
p_hsSpliceTH :: Bool -> LHsExpr GhcPs -> SpliceDecoration -> R ()
p_hsSpliceTH isTyped :: Bool
isTyped expr :: LHsExpr GhcPs
expr = \case
  HasParens -> do
    Text -> R ()
txt Text
decoSymbol
    BracketStyle -> R () -> R ()
parens BracketStyle
N (LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
expr (R () -> R ()
sitcc (R () -> R ()) -> (HsExpr GhcPs -> R ()) -> HsExpr GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> R ()
p_hsExpr))
  HasDollar -> do
    Text -> R ()
txt Text
decoSymbol
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
expr (R () -> R ()
sitcc (R () -> R ()) -> (HsExpr GhcPs -> R ()) -> HsExpr GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> R ()
p_hsExpr)
  NoParens ->
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
expr (R () -> R ()
sitcc (R () -> R ()) -> (HsExpr GhcPs -> R ()) -> HsExpr GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> R ()
p_hsExpr)
  where
    decoSymbol :: Text
decoSymbol = if Bool
isTyped then "$$" else "$"

p_hsBracket :: HsBracket GhcPs -> R ()
p_hsBracket :: HsBracket GhcPs -> R ()
p_hsBracket = \case
  ExpBr NoExt expr :: LHsExpr GhcPs
expr -> do
    [AnnKeywordId]
anns <- R [AnnKeywordId]
getEnclosingAnns
    let name :: Text
name = case [AnnKeywordId]
anns of
          AnnOpenEQ : _ -> ""
          _ -> "e"
    Text -> R () -> R ()
quote Text
name (LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
expr HsExpr GhcPs -> R ()
p_hsExpr)
  PatBr NoExt pat :: LPat GhcPs
pat -> Text -> R () -> R ()
quote "p" (LPat GhcPs -> R ()
p_pat LPat GhcPs
pat)
  DecBrL NoExt decls :: [LHsDecl GhcPs]
decls -> Text -> R () -> R ()
quote "d" (FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls FamilyStyle
Free [LHsDecl GhcPs]
decls)
  DecBrG NoExt _ -> String -> R ()
forall a. String -> a
notImplemented "DecBrG" -- result of renamer
  TypBr NoExt ty :: Located (HsType GhcPs)
ty -> Text -> R () -> R ()
quote "t" (Located (HsType GhcPs) -> (HsType GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located (HsType GhcPs)
ty HsType GhcPs -> R ()
p_hsType)
  VarBr NoExt isSingleQuote :: Bool
isSingleQuote name :: IdP GhcPs
name -> do
    Text -> R ()
txt (Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool "''" "'" Bool
isSingleQuote)
    -- HACK As you can see we use 'noLoc' here to be able to pass name into
    -- 'p_rdrName' since the latter expects a "located" thing. The problem
    -- is that 'VarBr' doesn't provide us with location of the name. This in
    -- turn makes it impossible to detect if there are parentheses around
    -- it, etc. So we have to add parentheses manually assuming they are
    -- necessary for all operators.
    let isOperator :: Bool
isOperator =
          (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
            (\i :: Char
i -> Char -> Bool
isPunctuation Char
i Bool -> Bool -> Bool
|| Char -> Bool
isSymbol Char
i)
            (OccName -> String
forall o. Outputable o => o -> String
showOutputable (RdrName -> OccName
rdrNameOcc IdP GhcPs
RdrName
name))
            Bool -> Bool -> Bool
&& Bool -> Bool
not (RdrName -> Bool
doesNotNeedExtraParens IdP GhcPs
RdrName
name)
        wrapper :: R () -> R ()
wrapper = if Bool
isOperator then BracketStyle -> R () -> R ()
parens BracketStyle
N else R () -> R ()
forall a. a -> a
id
    R () -> R ()
wrapper (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ Located RdrName -> R ()
p_rdrName (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc IdP GhcPs
SrcSpanLess (Located RdrName)
name)
  TExpBr NoExt expr :: LHsExpr GhcPs
expr -> do
    Text -> R ()
txt "[||"
    R ()
breakpoint'
    LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
expr HsExpr GhcPs -> R ()
p_hsExpr
    R ()
breakpoint'
    Text -> R ()
txt "||]"
  XBracket {} -> String -> R ()
forall a. String -> a
notImplemented "XBracket"
  where
    quote :: Text -> R () -> R ()
    quote :: Text -> R () -> R ()
quote name :: Text
name body :: R ()
body = do
      Text -> R ()
txt "["
      Text -> R ()
txt Text
name
      Text -> R ()
txt "|"
      R ()
breakpoint'
      R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        R () -> R ()
dontUseBraces R ()
body
        R ()
breakpoint'
        Text -> R ()
txt "|]"

-- Print the source text of a string literal while indenting
-- gaps correctly.

p_stringLit :: String -> R ()
p_stringLit :: String -> R ()
p_stringLit src :: String
src =
  let s :: [String]
s = String -> [String]
splitGaps String
src
      singleLine :: R ()
singleLine =
        Text -> R ()
txt (Text -> R ()) -> Text -> R ()
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack ([String] -> String
forall a. Monoid a => [a] -> a
mconcat [String]
s)
      multiLine :: R ()
multiLine =
        R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (String -> R ()) -> [String] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint (Text -> R ()
txt (Text -> R ()) -> (String -> Text) -> String -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) ([String] -> [String]
backslashes [String]
s)
   in R () -> R () -> R ()
forall a. R a -> R a -> R a
vlayout R ()
singleLine R ()
multiLine
  where
    -- Split a string on gaps (backslash delimited whitespaces)
    --
    -- > splitGaps "bar\\  \\fo\\&o" == ["bar", "fo\\&o"]
    splitGaps :: String -> [String]
    splitGaps :: String -> [String]
splitGaps "" = []
    splitGaps s :: String
s =
      let -- A backslash and a whitespace starts a "gap"
          p :: (Maybe Char, Char, Maybe Char) -> Bool
p (Just '\\', _, _) = Bool
True
          p (_, '\\', Just c :: Char
c) | Char -> Bool
ghcSpace Char
c = Bool
False
          p _ = Bool
True
       in case ((Maybe Char, Char, Maybe Char) -> Bool)
-> [(Maybe Char, Char, Maybe Char)]
-> ([(Maybe Char, Char, Maybe Char)],
    [(Maybe Char, Char, Maybe Char)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Maybe Char, Char, Maybe Char) -> Bool
p (String -> [(Maybe Char, Char, Maybe Char)]
forall a. [a] -> [(Maybe a, a, Maybe a)]
zipPrevNext String
s) of
            (l :: [(Maybe Char, Char, Maybe Char)]
l, r :: [(Maybe Char, Char, Maybe Char)]
r) ->
              let -- drop the initial '\', any amount of 'ghcSpace', and another '\'
                  r' :: String
r' = Int -> String -> String
forall a. Int -> [a] -> [a]
drop 1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
ghcSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop 1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ((Maybe Char, Char, Maybe Char) -> Char)
-> [(Maybe Char, Char, Maybe Char)] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Char, Char, Maybe Char) -> Char
forall a b c. (a, b, c) -> b
orig [(Maybe Char, Char, Maybe Char)]
r
               in ((Maybe Char, Char, Maybe Char) -> Char)
-> [(Maybe Char, Char, Maybe Char)] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Char, Char, Maybe Char) -> Char
forall a b c. (a, b, c) -> b
orig [(Maybe Char, Char, Maybe Char)]
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
splitGaps String
r'
    -- GHC's definition of whitespaces in strings
    -- See: https://gitlab.haskell.org/ghc/ghc/blob/86753475/compiler/parser/Lexer.x#L1653
    ghcSpace :: Char -> Bool
    ghcSpace :: Char -> Bool
ghcSpace c :: Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\x7f' Bool -> Bool -> Bool
&& Char -> Bool
is_space Char
c
    -- Add backslashes to the inner side of the strings
    --
    -- > backslashes ["a", "b", "c"] == ["a\\", "\\b\\", "\\c"]
    backslashes :: [String] -> [String]
    backslashes :: [String] -> [String]
backslashes (x :: String
x : y :: String
y : xs :: [String]
xs) = (String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\\") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
backslashes (('\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String
y) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs)
    backslashes xs :: [String]
xs = [String]
xs
    -- Attaches previous and next items to each list element
    zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
    zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
zipPrevNext xs :: [a]
xs =
      let z :: [((Maybe a, a), Maybe a)]
z =
            [(Maybe a, a)] -> [Maybe a] -> [((Maybe a, a), Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip
              ([Maybe a] -> [a] -> [(Maybe a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Maybe a
forall a. Maybe a
Nothing Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: (a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe a
forall a. a -> Maybe a
Just [a]
xs) [a]
xs)
              ((a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe a
forall a. a -> Maybe a
Just ([a] -> [a]
forall a. [a] -> [a]
tail [a]
xs) [Maybe a] -> [Maybe a] -> [Maybe a]
forall a. [a] -> [a] -> [a]
++ Maybe a -> [Maybe a]
forall a. a -> [a]
repeat Maybe a
forall a. Maybe a
Nothing)
       in (((Maybe a, a), Maybe a) -> (Maybe a, a, Maybe a))
-> [((Maybe a, a), Maybe a)] -> [(Maybe a, a, Maybe a)]
forall a b. (a -> b) -> [a] -> [b]
map (\((p :: Maybe a
p, x :: a
x), n :: Maybe a
n) -> (Maybe a
p, a
x, Maybe a
n)) [((Maybe a, a), Maybe a)]
z
    orig :: (a, b, c) -> b
orig (_, x :: b
x, _) = b
x

----------------------------------------------------------------------------
-- Helpers

-- | Return the wrapping function controlling the use of braces according to
-- the current layout.
layoutToBraces :: Layout -> R () -> R ()
layoutToBraces :: Layout -> R () -> R ()
layoutToBraces = \case
  SingleLine -> R () -> R ()
useBraces
  MultiLine -> R () -> R ()
forall a. a -> a
id

-- | Append each element in both lists with semigroups. If one list is shorter
-- than the other, return the rest of the longer list unchanged.
liftAppend :: Semigroup a => [a] -> [a] -> [a]
liftAppend :: [a] -> [a] -> [a]
liftAppend [] [] = []
liftAppend [] (y :: a
y : ys :: [a]
ys) = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys
liftAppend (x :: a
x : xs :: [a]
xs) [] = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
liftAppend (x :: a
x : xs :: [a]
xs) (y :: a
y : ys :: [a]
ys) = a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. Semigroup a => [a] -> [a] -> [a]
liftAppend [a]
xs [a]
ys

getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
getGRHSSpan (GRHS NoExt guards :: [GuardLStmt GhcPs]
guards body :: Located body
body) =
  NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (NonEmpty SrcSpan -> SrcSpan) -> NonEmpty SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ Located body -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located body
body SrcSpan -> [SrcSpan] -> NonEmpty SrcSpan
forall a. a -> [a] -> NonEmpty a
:| (GuardLStmt GhcPs -> SrcSpan) -> [GuardLStmt GhcPs] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GuardLStmt GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc [GuardLStmt GhcPs]
guards
getGRHSSpan (XGRHS NoExt) = String -> SrcSpan
forall a. String -> a
notImplemented "XGRHS"

-- | Place a thing that may have a hanging form. This function handles how
-- to separate it from preceding expressions and whether to bump indentation
-- depending on what sort of expression we have.
placeHanging :: Placement -> R () -> R ()
placeHanging :: Placement -> R () -> R ()
placeHanging placement :: Placement
placement m :: R ()
m =
  case Placement
placement of
    Hanging -> do
      R ()
space
      R ()
m
    Normal -> do
      R ()
breakpoint
      R () -> R ()
inci R ()
m

-- | Check if given block contains single expression which has a hanging
-- form.
blockPlacement ::
  (body -> Placement) ->
  [LGRHS GhcPs (Located body)] ->
  Placement
blockPlacement :: (body -> Placement) -> [LGRHS GhcPs (Located body)] -> Placement
blockPlacement placer :: body -> Placement
placer [L _ (GRHS NoExt _ (L _ x :: body
x))] = body -> Placement
placer body
x
blockPlacement _ _ = Placement
Normal

-- | Check if given command has a hanging form.
cmdPlacement :: HsCmd GhcPs -> Placement
cmdPlacement :: HsCmd GhcPs -> Placement
cmdPlacement = \case
  HsCmdLam NoExt _ -> Placement
Hanging
  HsCmdCase NoExt _ _ -> Placement
Hanging
  HsCmdDo NoExt _ -> Placement
Hanging
  _ -> Placement
Normal

cmdTopPlacement :: HsCmdTop GhcPs -> Placement
cmdTopPlacement :: HsCmdTop GhcPs -> Placement
cmdTopPlacement = \case
  HsCmdTop NoExt (L _ x :: HsCmd GhcPs
x) -> HsCmd GhcPs -> Placement
cmdPlacement HsCmd GhcPs
x
  XCmdTop {} -> String -> Placement
forall a. String -> a
notImplemented "XCmdTop"

-- | Check if given expression has a hanging form.
exprPlacement :: HsExpr GhcPs -> Placement
exprPlacement :: HsExpr GhcPs -> Placement
exprPlacement = \case
  -- Only hang lambdas with single line parameter lists
  HsLam NoExt mg :: MatchGroup GhcPs (LHsExpr GhcPs)
mg -> case MatchGroup GhcPs (LHsExpr GhcPs)
mg of
    MG _ (L _ [L _ (Match NoExt _ (x :: LPat GhcPs
x : xs :: [LPat GhcPs]
xs) _)]) _
      | SrcSpan -> Bool
isOneLineSpan (NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (NonEmpty SrcSpan -> SrcSpan) -> NonEmpty SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ (LPat GhcPs -> SrcSpan)
-> NonEmpty (LPat GhcPs) -> NonEmpty SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LPat GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LPat GhcPs
x LPat GhcPs -> [LPat GhcPs] -> NonEmpty (LPat GhcPs)
forall a. a -> [a] -> NonEmpty a
:| [LPat GhcPs]
xs)) ->
        Placement
Hanging
    _ -> Placement
Normal
  HsLamCase NoExt _ -> Placement
Hanging
  HsCase NoExt _ _ -> Placement
Hanging
  HsDo NoExt DoExpr _ -> Placement
Hanging
  HsDo NoExt MDoExpr _ -> Placement
Hanging
  -- If the rightmost expression in an operator chain is hanging, make the
  -- whole block hanging; so that we can use the common @f = foo $ do@
  -- style.
  OpApp NoExt _ _ y :: LHsExpr GhcPs
y -> HsExpr GhcPs -> Placement
exprPlacement (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
y)
  -- Same thing for function applications (usually with -XBlockArguments)
  HsApp NoExt _ y :: LHsExpr GhcPs
y -> HsExpr GhcPs -> Placement
exprPlacement (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
y)
  HsProc NoExt p :: LPat GhcPs
p _ ->
    -- https://gitlab.haskell.org/ghc/ghc/issues/17330
    let loc :: SrcSpan
loc = case LPat GhcPs
p of
          XPat pat :: XXPat GhcPs
pat -> Located (LPat GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc XXPat GhcPs
Located (LPat GhcPs)
pat
          _ -> String -> SrcSpan
forall a. HasCallStack => String -> a
error "exprPlacement: HsProc: Pat does not contain a location"
     in -- Indentation breaks if pattern is longer than one line and left
        -- hanging. Consequently, only apply hanging when it is safe.
        if SrcSpan -> Bool
isOneLineSpan SrcSpan
loc
          then Placement
Hanging
          else Placement
Normal
  _ -> Placement
Normal

withGuards :: [LGRHS GhcPs (Located body)] -> Bool
withGuards :: [LGRHS GhcPs (Located body)] -> Bool
withGuards = (LGRHS GhcPs (Located body) -> Bool)
-> [LGRHS GhcPs (Located body)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (GRHS GhcPs (Located body) -> Bool
forall body. GRHS GhcPs (Located body) -> Bool
checkOne (GRHS GhcPs (Located body) -> Bool)
-> (LGRHS GhcPs (Located body) -> GRHS GhcPs (Located body))
-> LGRHS GhcPs (Located body)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LGRHS GhcPs (Located body) -> GRHS GhcPs (Located body)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
  where
    checkOne :: GRHS GhcPs (Located body) -> Bool
    checkOne :: GRHS GhcPs (Located body) -> Bool
checkOne (GRHS NoExt [] _) = Bool
False
    checkOne _ = Bool
True

exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
exprOpTree (L _ (OpApp NoExt x :: LHsExpr GhcPs
x op :: LHsExpr GhcPs
op y :: LHsExpr GhcPs
y)) = OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
-> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
forall ty op. OpTree ty op -> op -> OpTree ty op -> OpTree ty op
OpBranch (LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
exprOpTree LHsExpr GhcPs
x) LHsExpr GhcPs
op (LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
exprOpTree LHsExpr GhcPs
y)
exprOpTree n :: LHsExpr GhcPs
n = LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
forall ty op. ty -> OpTree ty op
OpNode LHsExpr GhcPs
n

getOpName :: HsExpr GhcPs -> Maybe RdrName
getOpName :: HsExpr GhcPs -> Maybe RdrName
getOpName = \case
  HsVar NoExt (L _ a :: IdP GhcPs
a) -> RdrName -> Maybe RdrName
forall a. a -> Maybe a
Just IdP GhcPs
RdrName
a
  _ -> Maybe RdrName
forall a. Maybe a
Nothing

p_exprOpTree ::
  -- | Can use special handling of dollar?
  Bool ->
  -- | Bracket style to use
  BracketStyle ->
  OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
  R ()
p_exprOpTree :: Bool
-> BracketStyle -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> R ()
p_exprOpTree _ s :: BracketStyle
s (OpNode x :: LHsExpr GhcPs
x) = LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
x (BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' BracketStyle
s)
p_exprOpTree isDollarSpecial :: Bool
isDollarSpecial s :: BracketStyle
s (OpBranch x :: OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
x op :: LHsExpr GhcPs
op y :: OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
y) = do
  -- If the beginning of the first argument and the second argument are on
  -- the same line, and the second argument has a hanging form, use hanging
  -- placement.
  let placement :: Placement
placement =
        if SrcSpan -> Bool
isOneLineSpan
          (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (SrcSpan -> SrcLoc
srcSpanStart (OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> SrcSpan
forall a b. OpTree (Located a) b -> SrcSpan
opTreeLoc OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
x)) (SrcSpan -> SrcLoc
srcSpanStart (OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> SrcSpan
forall a b. OpTree (Located a) b -> SrcSpan
opTreeLoc OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
y)))
          then case OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
y of
            OpNode (L _ n :: HsExpr GhcPs
n) -> HsExpr GhcPs -> Placement
exprPlacement HsExpr GhcPs
n
            _ -> Placement
Normal
          else Placement
Normal
      opWrapper :: R () -> R ()
opWrapper = case LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
op of
        EWildPat NoExt -> R () -> R ()
backticks
        _ -> R () -> R ()
forall a. a -> a
id
  Layout
layout <- R Layout
getLayout
  let ub :: R () -> R ()
ub = case Layout
layout of
        SingleLine -> R () -> R ()
useBraces
        MultiLine -> case Placement
placement of
          Hanging -> R () -> R ()
useBraces
          Normal -> R () -> R ()
dontUseBraces
      gotDollar :: Bool
gotDollar = case HsExpr GhcPs -> Maybe RdrName
getOpName (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
op) of
        Just rname :: RdrName
rname -> String -> OccName
mkVarOcc "$" OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc RdrName
rname
        _ -> Bool
False
      lhs :: R ()
lhs =
        [SrcSpan] -> R () -> R ()
switchLayout [OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> SrcSpan
forall a b. OpTree (Located a) b -> SrcSpan
opTreeLoc OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
x] (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
          Bool
-> BracketStyle -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> R ()
p_exprOpTree (Bool -> Bool
not Bool
gotDollar) BracketStyle
s OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
x
  let p_op :: R ()
p_op = LHsExpr GhcPs -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsExpr GhcPs
op (R () -> R ()
opWrapper (R () -> R ()) -> (HsExpr GhcPs -> R ()) -> HsExpr GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> R ()
p_hsExpr)
      p_y :: R ()
p_y = [SrcSpan] -> R () -> R ()
switchLayout [OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> SrcSpan
forall a b. OpTree (Located a) b -> SrcSpan
opTreeLoc OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
y] (Bool
-> BracketStyle -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> R ()
p_exprOpTree Bool
True BracketStyle
N OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
y)
      isSection :: Bool
isSection = case (OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> SrcSpan
forall a b. OpTree (Located a) b -> SrcSpan
opTreeLoc OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
x, LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
op) of
        (RealSrcSpan treeSpan :: RealSrcSpan
treeSpan, RealSrcSpan opSpan :: RealSrcSpan
opSpan) ->
          RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
treeSpan Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
opSpan
        _ -> Bool
False
  Bool
useRecordDot' <- R Bool
useRecordDot
  let isRecordDot' :: Bool
isRecordDot' = HsExpr GhcPs -> SrcSpan -> Bool
isRecordDot (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
op) (OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> SrcSpan
forall a b. OpTree (Located a) b -> SrcSpan
opTreeLoc OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
y)
  if Bool
useRecordDot' Bool -> Bool -> Bool
&& Bool
isRecordDot'
    then do
      R ()
lhs
      Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isSection R ()
space
      R ()
p_op
      R ()
p_y
    else
      if Bool
isDollarSpecial
        Bool -> Bool -> Bool
&& Bool
gotDollar
        Bool -> Bool -> Bool
&& Placement
placement
        Placement -> Placement -> Bool
forall a. Eq a => a -> a -> Bool
== Placement
Normal
        Bool -> Bool -> Bool
&& SrcSpan -> Bool
isOneLineSpan (OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> SrcSpan
forall a b. OpTree (Located a) b -> SrcSpan
opTreeLoc OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
x)
        then do
          R () -> R ()
useBraces R ()
lhs
          R ()
space
          R ()
p_op
          R ()
breakpoint
          R () -> R ()
inci R ()
p_y
        else do
          R () -> R ()
ub R ()
lhs
          Placement -> R () -> R ()
placeHanging Placement
placement (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
            R ()
p_op
            R ()
space
            R ()
p_y

-- | Return 'True' if given expression is a record-dot operator expression.
isRecordDot ::
  -- | Operator expression
  HsExpr GhcPs ->
  -- | Span of the expression on the right-hand side of the operator
  SrcSpan ->
  Bool
isRecordDot :: HsExpr GhcPs -> SrcSpan -> Bool
isRecordDot op :: HsExpr GhcPs
op (RealSrcSpan ySpan :: RealSrcSpan
ySpan) = case HsExpr GhcPs
op of
  HsVar NoExt (L (RealSrcSpan opSpan :: RealSrcSpan
opSpan) opName :: IdP GhcPs
opName) ->
    RdrName -> Bool
isDot IdP GhcPs
RdrName
opName Bool -> Bool -> Bool
&& (RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
opSpan Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
ySpan)
  _ -> Bool
False
isRecordDot _ _ = Bool
False

-- | Check whether a given 'RdrName' is the dot operator.
isDot :: RdrName -> Bool
isDot :: RdrName -> Bool
isDot name :: RdrName
name = RdrName -> OccName
rdrNameOcc RdrName
name OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> OccName
mkVarOcc "."

-- | Get annotations for the enclosing element.
getEnclosingAnns :: R [AnnKeywordId]
getEnclosingAnns :: R [AnnKeywordId]
getEnclosingAnns = do
  Maybe RealSrcSpan
e <- (RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan)
getEnclosingSpan (Bool -> RealSrcSpan -> Bool
forall a b. a -> b -> a
const Bool
True)
  case Maybe RealSrcSpan
e of
    Nothing -> [AnnKeywordId] -> R [AnnKeywordId]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just e' :: RealSrcSpan
e' -> SrcSpan -> R [AnnKeywordId]
getAnns (RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
e')