{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
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 (occNameString)
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
data MatchGroupStyle
= Function (Located RdrName)
| PatternBind
| Case
| Lambda
| LambdaCase
data GroupStyle
= EqualSign
| RightArrow
data Placement
=
Normal
|
Hanging
deriving (Eq, Show)
p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
p_valDecl = \case
FunBind NoExtField funId funMatches _ _ -> p_funBind funId funMatches
PatBind NoExtField pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
VarBind {} -> notImplemented "VarBinds"
AbsBinds {} -> notImplemented "AbsBinds"
PatSynBind NoExtField psb -> p_patSynBind psb
XHsBindsLR x -> noExtCon x
p_funBind ::
Located RdrName ->
MatchGroup GhcPs (LHsExpr GhcPs) ->
R ()
p_funBind name = p_matchGroup (Function name)
p_matchGroup ::
MatchGroupStyle ->
MatchGroup GhcPs (LHsExpr GhcPs) ->
R ()
p_matchGroup = p_matchGroup' exprPlacement p_hsExpr
p_matchGroup' ::
Data body =>
(body -> Placement) ->
(body -> R ()) ->
MatchGroupStyle ->
MatchGroup GhcPs (Located body) ->
R ()
p_matchGroup' placer render style MG {..} = do
let ob = case style of
Case -> id
LambdaCase -> id
_ -> dontUseBraces
ub <- bool dontUseBraces useBraces <$> canUseBraces
ob $ sepSemi (located' (ub . p_Match)) (unLoc mg_alts)
where
p_Match m@Match {..} =
p_match'
placer
render
(adjustMatchGroupStyle m style)
(isInfixMatch m)
(matchStrictness m)
m_pats
m_grhss
p_Match (XMatch x) = noExtCon x
p_matchGroup' _ _ _ (XMatchGroup x) = noExtCon x
adjustMatchGroupStyle ::
Match GhcPs body ->
MatchGroupStyle ->
MatchGroupStyle
adjustMatchGroupStyle m = \case
Function _ -> (Function . mc_fun . m_ctxt) m
style -> style
matchStrictness :: Match id body -> SrcStrictness
matchStrictness match =
case m_ctxt match of
FunRhs {mc_strictness = s} -> s
_ -> NoSrcStrict
p_match ::
MatchGroupStyle ->
Bool ->
SrcStrictness ->
[LPat GhcPs] ->
GRHSs GhcPs (LHsExpr GhcPs) ->
R ()
p_match = p_match' exprPlacement p_hsExpr
p_match' ::
Data body =>
(body -> Placement) ->
(body -> R ()) ->
MatchGroupStyle ->
Bool ->
SrcStrictness ->
[LPat GhcPs] ->
GRHSs GhcPs (Located body) ->
R ()
p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
case strictness of
NoSrcStrict -> return ()
SrcStrict -> txt "!"
SrcLazy -> txt "~"
indentBody <- case NE.nonEmpty m_pats of
Nothing ->
False <$ case style of
Function name -> p_rdrName name
_ -> return ()
Just ne_pats -> do
let combinedSpans = case style of
Function name -> combineSrcSpans (getLoc name) patSpans
_ -> patSpans
patSpans = combineSrcSpans' (getLoc <$> ne_pats)
indentBody = not (isOneLineSpan combinedSpans)
switchLayout [combinedSpans] $ do
let stdCase = sep breakpoint (located' p_pat) m_pats
case style of
Function name ->
p_infixDefHelper
isInfix
indentBody
(p_rdrName name)
(located' p_pat <$> m_pats)
PatternBind -> stdCase
Case -> stdCase
Lambda -> do
let needsSpace = case unLoc (NE.head ne_pats) of
LazyPat _ _ -> True
BangPat _ _ -> True
SplicePat _ _ -> True
_ -> False
txt "\\"
when needsSpace space
sitcc stdCase
LambdaCase -> stdCase
return indentBody
let
endOfPats = case NE.nonEmpty m_pats of
Nothing -> case style of
Function name -> Just (getLoc name)
_ -> Nothing
Just pats -> (Just . getLoc . NE.last) pats
isCase = \case
Case -> True
LambdaCase -> True
_ -> False
hasGuards = withGuards grhssGRHSs
grhssSpan =
combineSrcSpans' $
getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
patGrhssSpan =
maybe
grhssSpan
(combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd)
endOfPats
placement =
case endOfPats of
Nothing -> blockPlacement placer grhssGRHSs
Just spn ->
if onTheSameLine spn grhssSpan
then blockPlacement placer grhssGRHSs
else Normal
p_body = do
let groupStyle =
if isCase style && hasGuards
then RightArrow
else EqualSign
sep newline (located' (p_grhs' placer render groupStyle)) grhssGRHSs
p_where = do
let whereIsEmpty = GHC.isEmptyLocalBindsPR (unLoc grhssLocalBinds)
unless (GHC.eqEmptyLocalBinds (unLoc grhssLocalBinds)) $ do
breakpoint
txt "where"
unless whereIsEmpty breakpoint
inci $ located grhssLocalBinds p_hsLocalBinds
inciIf indentBody $ do
unless (length grhssGRHSs > 1) $
case style of
Function _ | hasGuards -> return ()
Function _ -> space >> inci equals
PatternBind -> space >> inci equals
s | isCase s && hasGuards -> return ()
_ -> space >> txt "->"
switchLayout [patGrhssSpan] $
placeHanging placement p_body
inci p_where
p_match' _ _ _ _ _ _ (XGRHSs x) = noExtCon x
p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
p_grhs = p_grhs' exprPlacement p_hsExpr
p_grhs' ::
Data body =>
(body -> Placement) ->
(body -> R ()) ->
GroupStyle ->
GRHS GhcPs (Located body) ->
R ()
p_grhs' placer render style (GRHS NoExtField guards body) =
case guards of
[] -> p_body
xs -> do
txt "|"
space
sitcc (sep commaDel (sitcc . located' p_stmt) xs)
space
inci $ case style of
EqualSign -> equals
RightArrow -> txt "->"
placeHanging placement p_body
where
placement =
case endOfGuards of
Nothing -> placer (unLoc body)
Just spn ->
if onTheSameLine spn (getLoc body)
then placer (unLoc body)
else Normal
endOfGuards =
case NE.nonEmpty guards of
Nothing -> Nothing
Just gs -> (Just . getLoc . NE.last) gs
p_body = located body render
p_grhs' _ _ _ (XGRHS x) = noExtCon x
p_hsCmd :: HsCmd GhcPs -> R ()
p_hsCmd = \case
HsCmdArrApp NoExtField body input arrType _ -> do
located body p_hsExpr
breakpoint
inci $ do
case arrType of
HsFirstOrderApp -> txt "-<"
HsHigherOrderApp -> txt "-<<"
placeHanging (exprPlacement (unLoc input)) $
located input p_hsExpr
HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ do
located form p_hsExpr
unless (null cmds) $ do
breakpoint
inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
HsCmdArrForm NoExtField form Infix _ [left, right] -> do
located left p_hsCmdTop
space
located form p_hsExpr
placeHanging (cmdTopPlacement (unLoc right)) $
located right p_hsCmdTop
HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm"
HsCmdApp {} ->
notImplemented "HsCmdApp"
HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
HsCmdPar NoExtField c -> parens N (located c p_hsCmd)
HsCmdCase NoExtField e mgroup ->
p_case cmdPlacement p_hsCmd e mgroup
HsCmdIf NoExtField _ if' then' else' ->
p_if cmdPlacement p_hsCmd if' then' else'
HsCmdLet NoExtField localBinds c ->
p_let p_hsCmd localBinds c
HsCmdDo NoExtField es -> do
txt "do"
newline
inci . located es $
sitcc . sep newline (sitcc . withSpacing (p_stmt' cmdPlacement p_hsCmd))
HsCmdWrap {} -> notImplemented "HsCmdWrap"
XCmd x -> noExtCon x
p_hsCmdTop :: HsCmdTop GhcPs -> R ()
p_hsCmdTop = \case
HsCmdTop NoExtField cmd -> located cmd p_hsCmd
XCmdTop x -> noExtCon x
withSpacing ::
(a -> R ()) ->
Located a ->
R ()
withSpacing f l = located l $ \x -> do
case getLoc l of
UnhelpfulSpan _ -> f x
RealSrcSpan currentSpn -> do
getSpanMark >>= \case
Just (StatementSpan lastSpn) ->
if srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1
then newline
else return ()
_ -> return ()
f x
getSpanMark >>= \case
Just (HaddockSpan _ _) -> return ()
Just (CommentSpan _) -> return ()
_ -> setSpanMark (StatementSpan currentSpn)
p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
p_stmt = p_stmt' exprPlacement p_hsExpr
p_stmt' ::
Data body =>
(body -> Placement) ->
(body -> R ()) ->
Stmt GhcPs (Located body) ->
R ()
p_stmt' placer render = \case
LastStmt NoExtField body _ _ -> located body render
BindStmt NoExtField p f _ _ -> do
located p p_pat
space
txt "<-"
let loc = getLoc p
placement =
case f of
L l' x ->
if isOneLineSpan
(mkSrcSpan (srcSpanEnd loc) (srcSpanStart l'))
then placer x
else Normal
switchLayout [loc, getLoc f] $
placeHanging placement (located f render)
ApplicativeStmt {} -> notImplemented "ApplicativeStmt"
BodyStmt NoExtField body _ _ -> located body render
LetStmt NoExtField binds -> do
txt "let"
space
sitcc $ located binds p_hsLocalBinds
ParStmt {} ->
notImplemented "ParStmt"
TransStmt {..} ->
case (trS_form, trS_by) of
(ThenForm, Nothing) -> do
txt "then"
breakpoint
inci $ located trS_using p_hsExpr
(ThenForm, Just e) -> do
txt "then"
breakpoint
inci $ located trS_using p_hsExpr
breakpoint
txt "by"
breakpoint
inci $ located e p_hsExpr
(GroupForm, Nothing) -> do
txt "then group using"
breakpoint
inci $ located trS_using p_hsExpr
(GroupForm, Just e) -> do
txt "then group by"
breakpoint
inci $ located e p_hsExpr
breakpoint
txt "using"
breakpoint
inci $ located trS_using p_hsExpr
RecStmt {..} -> do
txt "rec"
space
sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts
XStmtLR c -> noExtCon c
gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
gatherStmt (L _ (ParStmt NoExtField block _ _)) =
foldr ((<>) . gatherStmtBlock) [] block
gatherStmt (L s stmt@TransStmt {..}) =
foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])
gatherStmt stmt = [[stmt]]
gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
gatherStmtBlock (ParStmtBlock _ stmts _ _) =
foldr (liftAppend . gatherStmt) [] stmts
gatherStmtBlock (XParStmtBlock x) = noExtCon x
p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
p_hsLocalBinds = \case
HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
br <- layoutToBraces <$> getLayout
let items =
let injectLeft (L l x) = L l (Left x)
injectRight (L l x) = L l (Right x)
in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs)
positionToBracing = \case
SinglePos -> id
FirstPos -> br
MiddlePos -> br
LastPos -> id
p_item' (p, item) =
positionToBracing p $
withSpacing (either p_valDecl p_sigDecl) item
binds = sortOn (srcSpanStart . getLoc) items
sitcc $ sepSemi p_item' (attachRelativePos binds)
HsValBinds NoExtField _ -> notImplemented "HsValBinds"
HsIPBinds NoExtField (IPBinds NoExtField xs) ->
let p_ipBind (IPBind NoExtField (Left name) expr) = do
atom name
space
equals
breakpoint
useBraces $ inci $ located expr p_hsExpr
p_ipBind (IPBind NoExtField (Right _) _) =
notImplemented "IPBind _ (Right _) _"
p_ipBind (XIPBind x) = noExtCon x
in sepSemi (located' p_ipBind) xs
HsIPBinds NoExtField _ -> notImplemented "HsIpBinds"
EmptyLocalBinds NoExtField -> return ()
XHsLocalBindsLR x -> noExtCon x
p_hsRecField ::
HsRecField' RdrName (LHsExpr GhcPs) ->
R ()
p_hsRecField HsRecField {..} = do
p_rdrName hsRecFieldLbl
unless hsRecPun $ do
space
equals
let placement =
if onTheSameLine (getLoc hsRecFieldLbl) (getLoc hsRecFieldArg)
then exprPlacement (unLoc hsRecFieldArg)
else Normal
placeHanging placement (located hsRecFieldArg p_hsExpr)
p_hsExpr :: HsExpr GhcPs -> R ()
p_hsExpr = p_hsExpr' N
p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' s = \case
HsVar NoExtField name -> p_rdrName name
HsUnboundVar NoExtField v -> atom (unboundVarOcc v)
HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut"
HsRecFld NoExtField x ->
case x of
Unambiguous NoExtField name -> p_rdrName name
Ambiguous NoExtField name -> p_rdrName name
XAmbiguousFieldOcc xx -> noExtCon xx
HsOverLabel NoExtField _ v -> do
txt "#"
atom v
HsIPVar NoExtField (HsIPName name) -> do
txt "?"
atom name
HsOverLit NoExtField v -> atom (ol_val v)
HsLit NoExtField lit ->
case lit of
HsString (SourceText stxt) _ -> p_stringLit stxt
HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
r -> atom r
HsLam NoExtField mgroup ->
p_matchGroup Lambda mgroup
HsLamCase NoExtField mgroup -> do
txt "\\case"
breakpoint
inci (p_matchGroup LambdaCase mgroup)
HsApp NoExtField f x -> do
let
gatherArgs f' knownArgs =
case f' of
L _ (HsApp _ l r) -> gatherArgs l (r <| knownArgs)
_ -> (f', knownArgs)
(func, args) = gatherArgs f (x :| [])
(initp, lastp) = (NE.init args, NE.last args)
initSpan =
combineSrcSpans' $
getLoc f :| [(srcLocSpan . srcSpanStart . getLoc) lastp]
placement =
if isOneLineSpan initSpan
then exprPlacement (unLoc lastp)
else Normal
case placement of
Normal -> do
let
doIndent =
case func of
L _ (HsPar NoExtField _) -> True
L _ (HsAppType NoExtField _ _) -> True
L _ (HsMultiIf NoExtField _) -> True
L spn _ -> isOneLineSpan spn
ub <-
getLayout <&> \case
SingleLine -> useBraces
MultiLine -> id
ub $ do
located func (p_hsExpr' s)
breakpoint
inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp
inciIf doIndent $ do
unless (null initp) breakpoint
located lastp p_hsExpr
Hanging -> do
useBraces . switchLayout [initSpan] $ do
located func (p_hsExpr' s)
breakpoint
sep breakpoint (located' p_hsExpr) initp
placeHanging placement $
located lastp p_hsExpr
HsAppType NoExtField e a -> do
located e p_hsExpr
breakpoint
inci $ do
txt "@"
case unLoc (hswc_body a) of
HsSpliceTy {} -> space
_ -> return ()
located (hswc_body a) p_hsType
OpApp NoExtField x op y -> do
let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
p_exprOpTree s (reassociateOpTree getOpName opTree)
NegApp NoExtField e _ -> do
txt "-"
space
located e p_hsExpr
HsPar NoExtField e ->
parens s (located e (dontUseBraces . p_hsExpr))
SectionL NoExtField x op -> do
located x p_hsExpr
breakpoint
inci (located op p_hsExpr)
SectionR NoExtField op x -> do
located op p_hsExpr
useRecordDot' <- useRecordDot
let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
unless (useRecordDot' && isRecordDot') breakpoint
inci (located x p_hsExpr)
ExplicitTuple NoExtField args boxity ->
let isSection = any (isMissing . unLoc) args
isMissing = \case
Missing NoExtField -> True
_ -> False
p_arg = \case
Present NoExtField x -> located x p_hsExpr
Missing NoExtField -> pure ()
XTupArg x -> noExtCon x
p_larg = sitcc . located' p_arg
parens' =
case boxity of
Boxed -> parens
Unboxed -> parensHash
in if isSection
then
switchLayout [] . parens' s $
sep comma p_larg args
else
switchLayout (getLoc <$> args) . parens' s $
sep commaDel p_larg args
ExplicitSum NoExtField tag arity e ->
p_unboxedSum N tag arity (located e p_hsExpr)
HsCase NoExtField e mgroup ->
p_case exprPlacement p_hsExpr e mgroup
HsIf NoExtField _ if' then' else' ->
p_if exprPlacement p_hsExpr if' then' else'
HsMultiIf NoExtField guards -> do
txt "if"
breakpoint
inci . inci $ sep newline (located' (p_grhs RightArrow)) guards
HsLet NoExtField localBinds e ->
p_let p_hsExpr localBinds e
HsDo NoExtField ctx es -> do
let doBody header = do
txt header
breakpoint
ub <- layoutToBraces <$> getLayout
inci $
sepSemi
(ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
(unLoc es)
compBody = brackets N . located es $ \xs -> do
let p_parBody =
sep
(breakpoint >> txt "|" >> space)
p_seqBody
p_seqBody =
sitcc
. sep
commaDel
(located' (sitcc . p_stmt))
stmts = init xs
yield = last xs
lists = foldr (liftAppend . gatherStmt) [] stmts
located yield p_stmt
breakpoint
txt "|"
space
p_parBody lists
case ctx of
DoExpr -> doBody "do"
MDoExpr -> doBody "mdo"
ListComp -> compBody
MonadComp -> notImplemented "MonadComp"
ArrowExpr -> notImplemented "ArrowExpr"
GhciStmtCtxt -> notImplemented "GhciStmtCtxt"
PatGuard _ -> notImplemented "PatGuard"
ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
TransStmtCtxt _ -> notImplemented "TransStmtCtxt"
ExplicitList _ _ xs ->
brackets s $
sep commaDel (sitcc . located' p_hsExpr) xs
RecordCon {..} -> do
located rcon_con_name atom
breakpoint
let HsRecFields {..} = rcon_flds
updName f =
(f :: HsRecField GhcPs (LHsExpr GhcPs))
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
FieldOcc _ n -> n
XFieldOcc x -> noExtCon x
}
fields = located' (p_hsRecField . updName) <$> rec_flds
dotdot =
case rec_dotdot of
Just {} -> [txt ".."]
Nothing -> []
inci . braces N $
sep commaDel sitcc (fields <> dotdot)
RecordUpd {..} -> do
located rupd_expr p_hsExpr
useRecordDot' <- useRecordDot
let mrs sp = case getLoc sp of
RealSrcSpan r -> Just r
_ -> Nothing
let isPluginForm =
((1 +) . srcSpanEndCol <$> mrs rupd_expr)
== (srcSpanStartCol <$> mrs (head rupd_flds))
unless (useRecordDot' && isPluginForm) breakpoint
let updName f =
(f :: HsRecUpdField GhcPs)
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
Ambiguous _ n -> n
Unambiguous _ n -> n
XAmbiguousFieldOcc x -> noExtCon x
}
inci . braces N $
sep
commaDel
(sitcc . located' (p_hsRecField . updName))
rupd_flds
ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
located x p_hsExpr
space
txt "::"
breakpoint
inci $ located hsib_body p_hsType
ExprWithTySig NoExtField _ HsWC {hswc_body = XHsImplicitBndrs x} -> noExtCon x
ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x
ArithSeq NoExtField _ x ->
case x of
From from -> brackets s $ do
located from p_hsExpr
breakpoint
txt ".."
FromThen from next -> brackets s $ do
sep commaDel (located' p_hsExpr) [from, next]
breakpoint
txt ".."
FromTo from to -> brackets s $ do
located from p_hsExpr
breakpoint
txt ".."
space
located to p_hsExpr
FromThenTo from next to -> brackets s $ do
sep commaDel (located' p_hsExpr) [from, next]
breakpoint
txt ".."
space
located to p_hsExpr
HsSCC NoExtField _ name x -> do
txt "{-# SCC "
atom name
txt " #-}"
breakpoint
located x p_hsExpr
HsCoreAnn NoExtField _ value x -> do
txt "{-# CORE "
atom value
txt " #-}"
breakpoint
located x p_hsExpr
HsBracket NoExtField x -> p_hsBracket x
HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
HsSpliceE NoExtField splice -> p_hsSplice splice
HsProc NoExtField p e -> do
txt "proc"
located p $ \x -> do
breakpoint
inci (p_pat x)
breakpoint
txt "->"
placeHanging (cmdTopPlacement (unLoc e)) $
located e p_hsCmdTop
HsStatic _ e -> do
txt "static"
breakpoint
inci (located e p_hsExpr)
HsTick {} -> notImplemented "HsTick"
HsBinTick {} -> notImplemented "HsBinTick"
HsTickPragma {} -> notImplemented "HsTickPragma"
HsWrap {} -> notImplemented "HsWrap"
XExpr x -> noExtCon x
p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
p_patSynBind PSB {..} = do
let rhs = do
space
case psb_dir of
Unidirectional -> do
txt "<-"
breakpoint
located psb_def p_pat
ImplicitBidirectional -> do
equals
breakpoint
located psb_def p_pat
ExplicitBidirectional mgroup -> do
txt "<-"
breakpoint
located psb_def p_pat
newline
txt "where"
newline
inci (p_matchGroup (Function psb_id) mgroup)
txt "pattern"
case psb_args of
PrefixCon xs -> do
space
p_rdrName psb_id
inci $ do
switchLayout (getLoc <$> xs) $ do
unless (null xs) breakpoint
sitcc (sep breakpoint p_rdrName xs)
rhs
RecCon xs -> do
space
p_rdrName psb_id
inci $ do
switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do
unless (null xs) breakpoint
braces N $
sep commaDel (p_rdrName . recordPatSynPatVar) xs
rhs
InfixCon l r -> do
switchLayout [getLoc l, getLoc r] $ do
space
p_rdrName l
breakpoint
inci $ do
p_rdrName psb_id
space
p_rdrName r
inci rhs
p_patSynBind (XPatSynBind x) = noExtCon x
p_case ::
Data body =>
(body -> Placement) ->
(body -> R ()) ->
LHsExpr GhcPs ->
MatchGroup GhcPs (Located body) ->
R ()
p_case placer render e mgroup = do
txt "case"
space
located e p_hsExpr
space
txt "of"
breakpoint
inci (p_matchGroup' placer render Case mgroup)
p_if ::
Data body =>
(body -> Placement) ->
(body -> R ()) ->
LHsExpr GhcPs ->
Located body ->
Located body ->
R ()
p_if placer render if' then' else' = do
txt "if"
space
located if' p_hsExpr
breakpoint
inci $ do
txt "then"
space
located then' $ \x ->
placeHanging (placer x) (render x)
breakpoint
txt "else"
space
located else' $ \x ->
placeHanging (placer x) (render x)
p_let ::
Data body =>
(body -> R ()) ->
Located (HsLocalBindsLR GhcPs GhcPs) ->
Located body ->
R ()
p_let render localBinds e = sitcc $ do
txt "let"
space
dontUseBraces $ sitcc (located localBinds p_hsLocalBinds)
vlayout space (newline >> txt " ")
txt "in"
space
sitcc (located e render)
p_pat :: Pat GhcPs -> R ()
p_pat = \case
WildPat NoExtField -> txt "_"
VarPat NoExtField name -> p_rdrName name
LazyPat NoExtField pat -> do
txt "~"
located pat p_pat
AsPat NoExtField name pat -> do
p_rdrName name
txt "@"
located pat p_pat
ParPat NoExtField pat ->
located pat (parens S . p_pat)
BangPat NoExtField pat -> do
txt "!"
located pat p_pat
ListPat NoExtField pats ->
brackets S $ sep commaDel (located' p_pat) pats
TuplePat NoExtField pats boxing -> do
let parens' =
case boxing of
Boxed -> parens S
Unboxed -> parensHash S
parens' $ sep commaDel (sitcc . located' p_pat) pats
SumPat NoExtField pat tag arity ->
p_unboxedSum S tag arity (located pat p_pat)
ConPatIn pat details ->
case details of
PrefixCon xs -> sitcc $ do
p_rdrName pat
unless (null xs) $ do
breakpoint
inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs
RecCon (HsRecFields fields dotdot) -> do
p_rdrName pat
breakpoint
let f = \case
Nothing -> txt ".."
Just x -> located x p_pat_hsRecField
inci . braces N . sep commaDel f $
case dotdot of
Nothing -> Just <$> fields
Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]
InfixCon l r -> do
switchLayout [getLoc l, getLoc r] $ do
located l p_pat
breakpoint
inci $ do
p_rdrName pat
space
located r p_pat
ConPatOut {} -> notImplemented "ConPatOut"
ViewPat NoExtField expr pat -> sitcc $ do
located expr p_hsExpr
space
txt "->"
breakpoint
inci (located pat p_pat)
SplicePat NoExtField splice -> p_hsSplice splice
LitPat NoExtField p -> atom p
NPat NoExtField v _ _ -> located v (atom . ol_val)
NPlusKPat NoExtField n k _ _ _ -> sitcc $ do
p_rdrName n
breakpoint
inci $ do
txt "+"
space
located k (atom . ol_val)
SigPat NoExtField pat hswc -> do
located pat p_pat
p_typeAscription hswc
CoPat {} -> notImplemented "CoPat"
XPat x -> noExtCon x
p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
p_pat_hsRecField HsRecField {..} = do
located hsRecFieldLbl $ \x ->
p_rdrName (rdrNameFieldOcc x)
unless hsRecPun $ do
space
equals
breakpoint
inci (located hsRecFieldArg p_pat)
p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()
p_unboxedSum s tag arity m = do
let before = tag - 1
after = arity - before - 1
args = replicate before Nothing <> [Just m] <> replicate after Nothing
f x =
case x :: Maybe (R ()) of
Nothing ->
space
Just m' -> do
space
m'
space
parensHash s $ sep (txt "|") f args
p_hsSplice :: HsSplice GhcPs -> R ()
p_hsSplice = \case
HsTypedSplice NoExtField deco _ expr -> p_hsSpliceTH True expr deco
HsUntypedSplice NoExtField deco _ expr -> p_hsSpliceTH False expr deco
HsQuasiQuote NoExtField _ quoterName srcSpan str -> do
txt "["
p_rdrName (L srcSpan quoterName)
txt "|"
atom str
txt "|]"
HsSpliced {} -> notImplemented "HsSpliced"
HsSplicedT {} -> notImplemented "HsSplicedT"
XSplice x -> noExtCon x
p_hsSpliceTH ::
Bool ->
LHsExpr GhcPs ->
SpliceDecoration ->
R ()
p_hsSpliceTH isTyped expr = \case
HasParens -> do
txt decoSymbol
parens N (located expr (sitcc . p_hsExpr))
HasDollar -> do
txt decoSymbol
located expr (sitcc . p_hsExpr)
NoParens ->
located expr (sitcc . p_hsExpr)
where
decoSymbol = if isTyped then "$$" else "$"
p_hsBracket :: HsBracket GhcPs -> R ()
p_hsBracket = \case
ExpBr NoExtField expr -> do
anns <- getEnclosingAnns
let name = case anns of
AnnOpenEQ : _ -> ""
_ -> "e"
quote name (located expr p_hsExpr)
PatBr NoExtField pat -> located pat (quote "p" . p_pat)
DecBrL NoExtField decls -> quote "d" (p_hsDecls Free decls)
DecBrG NoExtField _ -> notImplemented "DecBrG"
TypBr NoExtField ty -> quote "t" (located ty p_hsType)
VarBr NoExtField isSingleQuote name -> do
txt (bool "''" "'" isSingleQuote)
let isOperator =
all
(\i -> isPunctuation i || isSymbol i)
(showOutputable (rdrNameOcc name))
&& not (doesNotNeedExtraParens name)
wrapper = if isOperator then parens N else id
wrapper $ p_rdrName (noLoc name)
TExpBr NoExtField expr -> do
txt "[||"
breakpoint'
located expr p_hsExpr
breakpoint'
txt "||]"
XBracket x -> noExtCon x
where
quote :: Text -> R () -> R ()
quote name body = do
txt "["
txt name
txt "|"
breakpoint'
inci $ do
dontUseBraces body
breakpoint'
txt "|]"
p_stringLit :: String -> R ()
p_stringLit src =
let s = splitGaps src
singleLine =
txt $ Text.pack (mconcat s)
multiLine =
sitcc $ sep breakpoint (txt . Text.pack) (backslashes s)
in vlayout singleLine multiLine
where
splitGaps :: String -> [String]
splitGaps "" = []
splitGaps s =
let
p (Just '\\', _, _) = True
p (_, '\\', Just c) | ghcSpace c = False
p _ = True
in case span p (zipPrevNext s) of
(l, r) ->
let
r' = drop 1 . dropWhile ghcSpace . drop 1 $ map orig r
in map orig l : splitGaps r'
ghcSpace :: Char -> Bool
ghcSpace c = c <= '\x7f' && is_space c
backslashes :: [String] -> [String]
backslashes (x : y : xs) = (x ++ "\\") : backslashes (('\\' : y) : xs)
backslashes xs = xs
zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
zipPrevNext xs =
let z =
zip
(zip (Nothing : map Just xs) xs)
(map Just (tail xs) ++ repeat Nothing)
in map (\((p, x), n) -> (p, x, n)) z
orig (_, x, _) = x
layoutToBraces :: Layout -> R () -> R ()
layoutToBraces = \case
SingleLine -> useBraces
MultiLine -> id
liftAppend :: Semigroup a => [a] -> [a] -> [a]
liftAppend [] [] = []
liftAppend [] (y : ys) = y : ys
liftAppend (x : xs) [] = x : xs
liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys
getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
getGRHSSpan (GRHS NoExtField guards body) =
combineSrcSpans' $ getLoc body :| map getLoc guards
getGRHSSpan (XGRHS x) = noExtCon x
placeHanging :: Placement -> R () -> R ()
placeHanging placement m =
case placement of
Hanging -> do
space
m
Normal -> do
breakpoint
inci m
blockPlacement ::
(body -> Placement) ->
[LGRHS GhcPs (Located body)] ->
Placement
blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x
blockPlacement _ _ = Normal
cmdPlacement :: HsCmd GhcPs -> Placement
cmdPlacement = \case
HsCmdLam NoExtField _ -> Hanging
HsCmdCase NoExtField _ _ -> Hanging
HsCmdDo NoExtField _ -> Hanging
_ -> Normal
cmdTopPlacement :: HsCmdTop GhcPs -> Placement
cmdTopPlacement = \case
HsCmdTop NoExtField (L _ x) -> cmdPlacement x
XCmdTop x -> noExtCon x
exprPlacement :: HsExpr GhcPs -> Placement
exprPlacement = \case
HsLam NoExtField mg -> case mg of
MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _
| isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
Hanging
_ -> Normal
HsLamCase NoExtField _ -> Hanging
HsCase NoExtField _ _ -> Hanging
HsDo NoExtField DoExpr _ -> Hanging
HsDo NoExtField MDoExpr _ -> Hanging
OpApp NoExtField _ op y ->
case (fmap getOpNameStr . getOpName . unLoc) op of
Just "$" -> exprPlacement (unLoc y)
_ -> Normal
HsApp NoExtField _ y -> exprPlacement (unLoc y)
HsProc NoExtField p _ ->
if isOneLineSpan (getLoc p)
then Hanging
else Normal
_ -> Normal
withGuards :: [LGRHS GhcPs (Located body)] -> Bool
withGuards = any (checkOne . unLoc)
where
checkOne :: GRHS GhcPs (Located body) -> Bool
checkOne (GRHS NoExtField [] _) = False
checkOne _ = True
exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
exprOpTree n = OpNode n
getOpName :: HsExpr GhcPs -> Maybe RdrName
getOpName = \case
HsVar NoExtField (L _ a) -> Just a
_ -> Nothing
getOpNameStr :: RdrName -> String
getOpNameStr = occNameString . rdrNameOcc
p_exprOpTree ::
BracketStyle ->
OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
R ()
p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)
p_exprOpTree s (OpBranch x op y) = do
let placement =
if isOneLineSpan
(mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y)))
then case y of
OpNode (L _ n) -> exprPlacement n
_ -> Normal
else Normal
opWrapper = case unLoc op of
HsUnboundVar NoExtField _ -> backticks
_ -> id
layout <- getLayout
let ub = case layout of
SingleLine -> useBraces
MultiLine -> case placement of
Hanging -> useBraces
Normal -> dontUseBraces
opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
gotDollar = opNameStr == Just "$"
gotColon = opNameStr == Just ":"
gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
lhs =
switchLayout [opTreeLoc x] $
p_exprOpTree s x
p_op = located op (opWrapper . p_hsExpr)
p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)
isSection = case (opTreeLoc x, getLoc op) of
(RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
_ -> False
isDoBlock = \case
OpNode (L _ HsDo {}) -> True
_ -> False
useRecordDot' <- useRecordDot
if
| gotColon -> do
lhs
space
p_op
case placement of
Hanging -> do
space
p_y
Normal -> do
breakpoint
inciIf (isDoBlock y) p_y
| gotDollar
&& isOneLineSpan (opTreeLoc x)
&& placement == Normal -> do
useBraces lhs
space
p_op
breakpoint
inci p_y
| useRecordDot' && gotRecordDot -> do
lhs
when isSection space
p_op
p_y
| otherwise -> do
ub lhs
placeHanging placement $ do
p_op
space
p_y
isRecordDot ::
HsExpr GhcPs ->
SrcSpan ->
Bool
isRecordDot op (RealSrcSpan ySpan) = case op of
HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
(getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
_ -> False
isRecordDot _ _ = False
getEnclosingAnns :: R [AnnKeywordId]
getEnclosingAnns = do
e <- getEnclosingSpan (const True)
case e of
Nothing -> return []
Just e' -> getAnns (RealSrcSpan e')