{-# 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.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.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 (..))
import RdrName (rdrNameOcc)
import SrcLoc (combineSrcSpans, isOneLineSpan)
data MatchGroupStyle
= Function (Located RdrName)
| PatternBind
| Case
| Lambda
| LambdaCase
data GroupStyle
= EqualSign
| RightArrow
data Placement
=
Normal
|
Hanging
deriving (Eq)
p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
p_valDecl = \case
FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches
PatBind NoExt pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
VarBind {} -> notImplemented "VarBinds"
AbsBinds {} -> notImplemented "AbsBinds"
PatSynBind NoExt psb -> p_patSynBind psb
XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
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 _ = notImplemented "XMatch"
p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
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 m_grhss = do
case strictness of
NoSrcStrict -> return ()
SrcStrict -> txt "!"
SrcLazy -> txt "~"
inci' <- case NE.nonEmpty m_pats of
Nothing -> id <$ case style of
Function name -> p_rdrName name
_ -> return ()
Just ne_pats -> do
let combinedSpans =
combineSrcSpans' $
getLoc <$> ne_pats
inci' =
if isOneLineSpan combinedSpans
then id
else inci
switchLayout [combinedSpans] $ do
let stdCase = sep breakpoint (located' p_pat) m_pats
case style of
Function name ->
p_infixDefHelper
isInfix
inci'
(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 inci'
let
endOfPats = case NE.nonEmpty m_pats of
Nothing -> case style of
Function name -> (Just . srcSpanEnd . getLoc) name
_ -> Nothing
Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats
isCase = \case
Case -> True
LambdaCase -> True
_ -> False
let GRHSs {..} = m_grhss
hasGuards = withGuards grhssGRHSs
unless (length grhssGRHSs > 1) $ do
case style of
Function _ | hasGuards -> return ()
Function _ -> space >> txt "="
PatternBind -> space >> txt "="
s | isCase s && hasGuards -> return ()
_ -> space >> txt "->"
let grhssSpan =
combineSrcSpans' $
getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
patGrhssSpan =
maybe
grhssSpan
(combineSrcSpans grhssSpan . srcLocSpan)
endOfPats
placement =
case endOfPats of
Nothing -> blockPlacement placer grhssGRHSs
Just spn ->
if isOneLineSpan
(mkSrcSpan spn (srcSpanStart 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
inci' $ do
switchLayout [patGrhssSpan] $
placeHanging placement p_body
inci p_where
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 NoExt guards body) =
case guards of
[] -> p_body
xs -> do
txt "|"
space
sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs)
space
txt $ case style of
EqualSign -> "="
RightArrow -> "->"
placeHanging placement p_body
where
placement =
case endOfGuards of
Nothing -> placer (unLoc body)
Just spn ->
if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body)))
then placer (unLoc body)
else Normal
endOfGuards =
case NE.nonEmpty guards of
Nothing -> Nothing
Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
p_body = located body render
p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"
p_hsCmd :: HsCmd GhcPs -> R ()
p_hsCmd = \case
HsCmdArrApp NoExt body input arrType _ -> do
located body p_hsExpr
space
case arrType of
HsFirstOrderApp -> txt "-<"
HsHigherOrderApp -> txt "-<<"
placeHanging (exprPlacement (unLoc input)) $
located input p_hsExpr
HsCmdArrForm NoExt form Prefix _ cmds -> banana $ sitcc $ do
located form p_hsExpr
unless (null cmds) $ do
breakpoint
inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
HsCmdArrForm NoExt form Infix _ [left, right] -> do
located left p_hsCmdTop
space
located form p_hsExpr
placeHanging (cmdTopPlacement (unLoc right)) $
located right p_hsCmdTop
HsCmdArrForm NoExt _ Infix _ _ -> notImplemented "HsCmdArrForm"
HsCmdApp {} ->
notImplemented "HsCmdApp"
HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
HsCmdPar NoExt c -> parens N (located c p_hsCmd)
HsCmdCase NoExt e mgroup ->
p_case cmdPlacement p_hsCmd e mgroup
HsCmdIf NoExt _ if' then' else' ->
p_if cmdPlacement p_hsCmd if' then' else'
HsCmdLet NoExt localBinds c ->
p_let p_hsCmd localBinds c
HsCmdDo NoExt es -> do
txt "do"
newline
inci . located es $
sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
HsCmdWrap {} -> notImplemented "HsCmdWrap"
XCmd {} -> notImplemented "XCmd"
p_hsCmdTop :: HsCmdTop GhcPs -> R ()
p_hsCmdTop = \case
HsCmdTop NoExt cmd -> located cmd p_hsCmd
XCmdTop {} -> notImplemented "XHsCmdTop"
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 NoExt body _ _ -> located body render
BindStmt NoExt l f _ _ -> do
located l p_pat
space
txt "<-"
let placement =
case f of
L l' x ->
if isOneLineSpan
(mkSrcSpan (srcSpanEnd (getLoc l)) (srcSpanStart l'))
then placer x
else Normal
switchLayout [getLoc l, getLoc f] $
placeHanging placement (located f render)
ApplicativeStmt {} -> notImplemented "ApplicativeStmt"
BodyStmt NoExt body _ _ -> located body render
LetStmt NoExt binds -> do
txt "let"
space
sitcc $ located binds p_hsLocalBinds
ParStmt {} ->
notImplemented "ParStmt"
TransStmt {..} -> do
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 (located' (p_stmt' placer render)) recS_stmts
XStmtLR {} -> notImplemented "XStmtLR"
gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
gatherStmt (L _ (ParStmt NoExt 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 {} = notImplemented "XParStmtBlock"
p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
p_hsLocalBinds = \case
HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do
let ssStart =
either
(srcSpanStart . getLoc)
(srcSpanStart . getLoc)
items =
(Left <$> bagToList bag) ++ (Right <$> lsigs)
p_item (Left x) = located x p_valDecl
p_item (Right x) = located x p_sigDecl
markInit :: [a] -> [(Bool, a)]
markInit [] = []
markInit (x : []) = [(False, x)]
markInit (x : xs) = (True, x) : markInit xs
br <- layoutToBraces <$> getLayout
sitcc $
sepSemi
(\(m, i) -> (if m then br else id) $ p_item i)
(markInit $ sortOn ssStart items)
HsValBinds NoExt _ -> notImplemented "HsValBinds"
HsIPBinds NoExt (IPBinds NoExt xs) ->
let p_ipBind (IPBind NoExt (Left name) expr) = do
atom name
space
txt "="
breakpoint
useBraces $ inci $ located expr p_hsExpr
p_ipBind _ = notImplemented "XHsIPBinds"
in sepSemi (located' p_ipBind) xs
HsIPBinds NoExt _ -> notImplemented "HsIpBinds"
EmptyLocalBinds NoExt -> return ()
XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"
p_hsRecField ::
HsRecField' RdrName (LHsExpr GhcPs) ->
R ()
p_hsRecField = \HsRecField {..} -> do
p_rdrName hsRecFieldLbl
unless hsRecPun $ do
space
txt "="
let placement = exprPlacement (unLoc hsRecFieldArg)
placeHanging placement $ located hsRecFieldArg p_hsExpr
p_hsTupArg :: HsTupArg GhcPs -> R ()
p_hsTupArg = \case
Present NoExt x -> located x p_hsExpr
Missing NoExt -> pure ()
XTupArg {} -> notImplemented "XTupArg"
p_hsExpr :: HsExpr GhcPs -> R ()
p_hsExpr = p_hsExpr' N
p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' s = \case
HsVar NoExt name -> p_rdrName name
HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"
HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"
HsRecFld NoExt x ->
case x of
Unambiguous NoExt name -> p_rdrName name
Ambiguous NoExt name -> p_rdrName name
XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"
HsOverLabel NoExt _ v -> do
txt "#"
atom v
HsIPVar NoExt (HsIPName name) -> do
txt "?"
atom name
HsOverLit NoExt v -> atom (ol_val v)
HsLit NoExt lit ->
case lit of
HsString (SourceText stxt) _ -> p_stringLit stxt
HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
r -> atom r
HsLam NoExt mgroup ->
p_matchGroup Lambda mgroup
HsLamCase NoExt mgroup -> do
txt "\\case"
breakpoint
inci (p_matchGroup LambdaCase mgroup)
HsApp NoExt 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 :| map getLoc initp
placement =
if isOneLineSpan initSpan
then exprPlacement (unLoc lastp)
else Normal
case placement of
Normal -> do
useBraces $ do
located func (p_hsExpr' s)
breakpoint
inci $ sep breakpoint (located' p_hsExpr) initp
inci $ 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 a e -> do
located e p_hsExpr
breakpoint
inci $ do
txt "@"
located (hswc_body a) p_hsType
OpApp NoExt x op y -> do
let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
p_exprOpTree True s (reassociateOpTree getOpName opTree)
NegApp NoExt e _ -> do
txt "-"
space
located e p_hsExpr
HsPar NoExt e ->
parens s (located e (dontUseBraces . p_hsExpr))
SectionL NoExt x op -> do
located x p_hsExpr
breakpoint
inci (located op p_hsExpr)
SectionR NoExt op x -> do
located op p_hsExpr
breakpoint
inci (located x p_hsExpr)
ExplicitTuple NoExt args boxity -> do
let isSection = any (isMissing . unLoc) args
isMissing = \case
Missing NoExt -> True
_ -> False
let parens' =
case boxity of
Boxed -> parens
Unboxed -> parensHash
if isSection
then
switchLayout [] . parens' s $
sep comma (located' p_hsTupArg) args
else
switchLayout (getLoc <$> args) . parens' s . sitcc $
sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
ExplicitSum NoExt tag arity e ->
p_unboxedSum N tag arity (located e p_hsExpr)
HsCase NoExt e mgroup ->
p_case exprPlacement p_hsExpr e mgroup
HsIf NoExt _ if' then' else' ->
p_if exprPlacement p_hsExpr if' then' else'
HsMultiIf NoExt guards -> do
txt "if"
breakpoint
inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
HsLet NoExt localBinds e ->
p_let p_hsExpr localBinds e
HsDo NoExt ctx es -> do
let doBody header = do
txt header
breakpoint
ub <- layoutToBraces <$> getLayout
inci $
sepSemi
(located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
(unLoc es)
compBody = brackets N $ located es $ \xs -> do
let p_parBody =
sep
(breakpoint >> txt "| ")
p_seqBody
p_seqBody =
sitcc
. sep
(comma >> breakpoint)
(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 . sitcc $
sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs
RecordCon {..} -> do
located rcon_con_name atom
breakpoint
let HsRecFields {..} = rcon_flds
updName f =
f
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
FieldOcc _ n -> n
XFieldOcc _ -> notImplemented "XFieldOcc"
}
fields = located' (p_hsRecField . updName) <$> rec_flds
dotdot =
case rec_dotdot of
Just {} -> [txt ".."]
Nothing -> []
inci . braces N . sitcc $
sep (comma >> breakpoint) sitcc (fields <> dotdot)
RecordUpd {..} -> do
located rupd_expr p_hsExpr
breakpoint
let updName f =
f
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
Ambiguous _ n -> n
Unambiguous _ n -> n
XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
}
inci . braces N . sitcc $
sep
(comma >> breakpoint)
(sitcc . located' (p_hsRecField . updName))
rupd_flds
ExprWithTySig affix x -> sitcc $ do
located x p_hsExpr
space
txt "::"
breakpoint
inci $ do
let HsWC {..} = affix
HsIB {..} = hswc_body
located hsib_body p_hsType
ArithSeq NoExt _ x -> do
case x of
From from -> brackets s . sitcc $ do
located from p_hsExpr
breakpoint
txt ".."
FromThen from next -> brackets s . sitcc $ do
sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
breakpoint
txt ".."
FromTo from to -> brackets s . sitcc $ do
located from p_hsExpr
breakpoint
txt ".."
space
located to p_hsExpr
FromThenTo from next to -> brackets s . sitcc $ do
sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
breakpoint
txt ".."
space
located to p_hsExpr
HsSCC NoExt _ name x -> do
txt "{-# SCC "
atom name
txt " #-}"
breakpoint
located x p_hsExpr
HsCoreAnn NoExt _ value x -> do
txt "{-# CORE "
atom value
txt " #-}"
breakpoint
located x p_hsExpr
HsBracket NoExt x -> p_hsBracket x
HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
HsSpliceE NoExt splice -> p_hsSplice splice
HsProc NoExt 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)
HsArrApp NoExt body input arrType cond ->
p_hsCmd (HsCmdArrApp NoExt body input arrType cond)
HsArrForm NoExt form mfixity cmds ->
p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds)
HsTick {} -> notImplemented "HsTick"
HsBinTick {} -> notImplemented "HsBinTick"
HsTickPragma {} -> notImplemented "HsTickPragma"
EWildPat NoExt -> txt "_"
EAsPat NoExt n p -> do
p_rdrName n
txt "@"
located p p_hsExpr
EViewPat NoExt p e -> do
located p p_hsExpr
space
txt "->"
breakpoint
inci (located e p_hsExpr)
ELazyPat NoExt p -> do
txt "~"
located p p_hsExpr
HsWrap {} -> notImplemented "HsWrap"
XExpr {} -> notImplemented "XExpr"
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
txt "="
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 . sitcc $
sep (comma >> breakpoint) (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 NoExt) = notImplemented "XPatSynBind"
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"
located then' $ \x ->
placeHanging (placer x) (render x)
breakpoint
txt "else"
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 NoExt -> txt "_"
VarPat NoExt name -> p_rdrName name
LazyPat NoExt pat -> do
txt "~"
located pat p_pat
AsPat NoExt name pat -> do
p_rdrName name
txt "@"
located pat p_pat
ParPat NoExt pat ->
located pat (parens S . p_pat)
BangPat NoExt pat -> do
txt "!"
located pat p_pat
ListPat NoExt pats -> do
brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats
TuplePat NoExt pats boxing -> do
let f =
case boxing of
Boxed -> parens S
Unboxed -> parensHash S
f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats
SumPat NoExt 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 . sitcc . sep (comma >> breakpoint) f $
case dotdot of
Nothing -> Just <$> fields
Just n -> (Just <$> take n fields) ++ [Nothing]
InfixCon x y -> do
located x p_pat
space
p_rdrName pat
breakpoint
inci (located y p_pat)
ConPatOut {} -> notImplemented "ConPatOut"
ViewPat NoExt expr pat -> sitcc $ do
located expr p_hsExpr
space
txt "->"
breakpoint
inci (located pat p_pat)
SplicePat NoExt splice -> p_hsSplice splice
LitPat NoExt p -> atom p
NPat NoExt v _ _ -> located v (atom . ol_val)
NPlusKPat NoExt n k _ _ _ -> sitcc $ do
p_rdrName n
breakpoint
inci $ do
txt "+"
space
located k (atom . ol_val)
SigPat hswc pat -> do
located pat p_pat
p_typeAscription hswc
CoPat {} -> notImplemented "CoPat"
XPat NoExt -> notImplemented "XPat"
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
txt "="
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, i) = do
let isFirst = i == 0
isLast = i == arity - 1
case x :: Maybe (R ()) of
Nothing ->
unless (isFirst || isLast) space
Just m' -> do
unless isFirst space
m'
unless isLast space
parensHash s $ sep (txt "|") f (zip args [0 ..])
p_hsSplice :: HsSplice GhcPs -> R ()
p_hsSplice = \case
HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco
HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco
HsQuasiQuote NoExt _ quoterName srcSpan str -> do
txt "["
p_rdrName (L srcSpan quoterName)
txt "|"
atom str
txt "|]"
HsSpliced {} -> notImplemented "HsSpliced"
XSplice {} -> notImplemented "XSplice"
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 NoExt expr -> do
anns <- getEnclosingAnns
let name = case anns of
AnnOpenEQ : _ -> ""
_ -> "e"
quote name (located expr p_hsExpr)
PatBr NoExt pat -> quote "p" (located pat p_pat)
DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)
DecBrG NoExt _ -> notImplemented "DecBrG"
TypBr NoExt ty -> quote "t" (located ty p_hsType)
VarBr NoExt 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 NoExt expr -> do
txt "[||"
breakpoint'
located expr p_hsExpr
breakpoint'
txt "||]"
XBracket {} -> notImplemented "XBracket"
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 NoExt guards body) =
combineSrcSpans' $ getLoc body :| map getLoc guards
getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
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 NoExt _ (L _ x)))] = placer x
blockPlacement _ _ = Normal
cmdPlacement :: HsCmd GhcPs -> Placement
cmdPlacement = \case
HsCmdLam NoExt _ -> Hanging
HsCmdCase NoExt _ _ -> Hanging
HsCmdDo NoExt _ -> Hanging
_ -> Normal
cmdTopPlacement :: HsCmdTop GhcPs -> Placement
cmdTopPlacement = \case
HsCmdTop NoExt (L _ x) -> cmdPlacement x
XCmdTop {} -> notImplemented "XCmdTop"
exprPlacement :: HsExpr GhcPs -> Placement
exprPlacement = \case
HsLam NoExt mg -> case mg of
MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _
| isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
Hanging
_ -> Normal
HsLamCase NoExt _ -> Hanging
HsCase NoExt _ _ -> Hanging
HsDo NoExt DoExpr _ -> Hanging
HsDo NoExt MDoExpr _ -> Hanging
RecordCon NoExt _ _ -> Hanging
OpApp NoExt _ _ y -> exprPlacement (unLoc y)
HsApp NoExt _ y -> exprPlacement (unLoc y)
HsProc NoExt (L s _) _ ->
if isOneLineSpan s
then Hanging
else Normal
_ -> Normal
withGuards :: [LGRHS GhcPs (Located body)] -> Bool
withGuards = any (checkOne . unLoc)
where
checkOne :: GRHS GhcPs (Located body) -> Bool
checkOne (GRHS NoExt [] _) = False
checkOne _ = True
exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
exprOpTree (L _ (OpApp NoExt x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
exprOpTree n = OpNode n
getOpName :: HsExpr GhcPs -> Maybe RdrName
getOpName = \case
HsVar NoExt (L _ a) -> Just a
_ -> Nothing
p_exprOpTree ::
Bool ->
BracketStyle ->
OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
R ()
p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
p_exprOpTree isDollarSpecial 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
EWildPat NoExt -> backticks
_ -> id
layout <- getLayout
let ub = case layout of
SingleLine -> useBraces
MultiLine -> case placement of
Hanging -> useBraces
Normal -> dontUseBraces
gotDollar = case getOpName (unLoc op) of
Just rname -> mkVarOcc "$" == (rdrNameOcc rname)
_ -> False
switchLayout [opTreeLoc x]
$ ub
$ p_exprOpTree (not gotDollar) s x
let p_op = located op (opWrapper . p_hsExpr)
p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
if isDollarSpecial && gotDollar && placement == Normal && isOneLineSpan (opTreeLoc x)
then do
space
p_op
breakpoint
inci p_y
else placeHanging placement $ do
p_op
space
p_y
getEnclosingAnns :: R [AnnKeywordId]
getEnclosingAnns = do
e <- getEnclosingSpan (const True)
case e of
Nothing -> return []
Just e' -> getAnns (RealSrcSpan e')