{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Ormolu.Printer.Meat.Common
( FamilyStyle (..),
p_hsmodName,
p_ieWrappedName,
p_rdrName,
p_qualName,
p_infixDefHelper,
p_hsDoc,
p_hsDoc',
p_sourceText,
)
where
import Control.Monad
import Data.Foldable (traverse_)
import Data.Text qualified as T
import GHC.Hs.Doc
import GHC.Hs.Extension (GhcPs)
import GHC.Hs.ImpExp
import GHC.LanguageExtensions.Type (Extension (..))
import GHC.Parser.Annotation
import GHC.Types.Name.Occurrence (OccName (..), occNameString)
import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import Language.Haskell.Syntax.Module.Name
import Ormolu.Config
import Ormolu.Printer.Combinators
import Ormolu.Utils
data FamilyStyle
=
Associated
|
Free
p_hsmodName :: ModuleName -> R ()
p_hsmodName :: ModuleName -> R ()
p_hsmodName ModuleName
mname = do
SourceType
sourceType <- R SourceType
askSourceType
Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ case SourceType
sourceType of
SourceType
ModuleSource -> Text
"module"
SourceType
SignatureSource -> Text
"signature"
R ()
space
forall a. Outputable a => a -> R ()
atom ModuleName
mname
p_ieWrappedName :: IEWrappedName GhcPs -> R ()
p_ieWrappedName :: IEWrappedName GhcPs -> R ()
p_ieWrappedName = \case
IEName XIEName GhcPs
_ LIdP GhcPs
x -> LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
x
IEPattern XIEPattern GhcPs
_ LIdP GhcPs
x -> do
Text -> R ()
txt Text
"pattern"
R ()
space
LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
x
IEType XIEType GhcPs
_ LIdP GhcPs
x -> do
Text -> R ()
txt Text
"type"
R ()
space
LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
x
p_rdrName :: LocatedN RdrName -> R ()
p_rdrName :: LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
l = forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedN RdrName
l forall a b. (a -> b) -> a -> b
$ \RdrName
x -> do
Bool
unboxedSums <- Extension -> R Bool
isExtensionEnabled Extension
UnboxedSums
let wrapper :: EpAnn NameAnn -> R () -> R ()
wrapper = \case
EpAnn {NameAnn
anns :: forall ann. EpAnn ann -> ann
anns :: NameAnn
anns} -> case NameAnn
anns of
NameAnnQuote {SrcSpanAnnN
nann_quoted :: NameAnn -> SrcSpanAnnN
nann_quoted :: SrcSpanAnnN
nann_quoted} -> forall {b}. R b -> R b
tickPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAnn NameAnn -> R () -> R ()
wrapper (forall a. SrcSpanAnn' a -> a
ann SrcSpanAnnN
nann_quoted)
NameAnn {nann_adornment :: NameAnn -> NameAdornment
nann_adornment = NameAdornment
NameParens} ->
BracketStyle -> R () -> R ()
parens BracketStyle
N forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. R b -> R b
handleUnboxedSumsAndHashInteraction
NameAnn {nann_adornment :: NameAnn -> NameAdornment
nann_adornment = NameAdornment
NameBackquotes} -> R () -> R ()
backticks
NameAnnOnly {nann_adornment :: NameAnn -> NameAdornment
nann_adornment = NameAdornment
NameParensHash} -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt Text
"(# #)"
NameAnn
_ -> forall a. a -> a
id
EpAnn NameAnn
EpAnnNotUsed -> forall a. a -> a
id
handleUnboxedSumsAndHashInteraction :: R a -> R a
handleUnboxedSumsAndHashInteraction
| Bool
unboxedSums,
Unqual (OccName -> String
occNameString -> Char
'#' : String
_) <- RdrName
x =
\R a
y -> R ()
space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> R a
y forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* R ()
space
| Bool
otherwise = forall a. a -> a
id
EpAnn NameAnn -> R () -> R ()
wrapper (forall a. SrcSpanAnn' a -> a
ann forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
l) forall a b. (a -> b) -> a -> b
$ case RdrName
x of
Unqual OccName
occName ->
forall a. Outputable a => a -> R ()
atom OccName
occName
Qual ModuleName
mname OccName
occName ->
ModuleName -> OccName -> R ()
p_qualName ModuleName
mname OccName
occName
Orig Module
_ OccName
occName ->
forall a. Outputable a => a -> R ()
atom OccName
occName
Exact Name
name ->
forall a. Outputable a => a -> R ()
atom Name
name
where
tickPrefix :: R b -> R b
tickPrefix R b
y = Text -> R ()
txt Text
"'" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> R b
y
p_qualName :: ModuleName -> OccName -> R ()
p_qualName :: ModuleName -> OccName -> R ()
p_qualName ModuleName
mname OccName
occName = do
forall a. Outputable a => a -> R ()
atom ModuleName
mname
Text -> R ()
txt Text
"."
forall a. Outputable a => a -> R ()
atom OccName
occName
p_infixDefHelper ::
Bool ->
Bool ->
R () ->
[R ()] ->
R ()
p_infixDefHelper :: Bool -> Bool -> R () -> [R ()] -> R ()
p_infixDefHelper Bool
isInfix Bool
indentArgs R ()
name [R ()]
args =
case (Bool
isInfix, [R ()]
args) of
(Bool
True, R ()
p0 : R ()
p1 : [R ()]
ps) -> do
let parens' :: R () -> R ()
parens' =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [R ()]
ps
then forall a. a -> a
id
else BracketStyle -> R () -> R ()
parens BracketStyle
N forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc
R () -> R ()
parens' forall a b. (a -> b) -> a -> b
$ do
R ()
p0
R ()
breakpoint
R () -> R ()
inci forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$ do
R ()
name
R ()
space
R ()
p1
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [R ()]
ps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> R () -> R ()
inciIf Bool
indentArgs forall a b. (a -> b) -> a -> b
$ do
R ()
breakpoint
R () -> R ()
sitcc (forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint R () -> R ()
sitcc [R ()]
ps)
(Bool
_, [R ()]
ps) -> do
R ()
name
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [R ()]
ps) forall a b. (a -> b) -> a -> b
$ do
R ()
breakpoint
Bool -> R () -> R ()
inciIf Bool
indentArgs forall a b. (a -> b) -> a -> b
$ R () -> R ()
sitcc (forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint R () -> R ()
sitcc [R ()]
args)
p_hsDoc ::
HaddockStyle ->
Bool ->
LHsDoc GhcPs ->
R ()
p_hsDoc :: HaddockStyle -> Bool -> LHsDoc GhcPs -> R ()
p_hsDoc HaddockStyle
hstyle Bool
needsNewline LHsDoc GhcPs
lstr = do
HaddockPrintStyle
poHStyle <- forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle
poHaddockStyle
HaddockPrintStyle -> HaddockStyle -> Bool -> LHsDoc GhcPs -> R ()
p_hsDoc' HaddockPrintStyle
poHStyle HaddockStyle
hstyle Bool
needsNewline LHsDoc GhcPs
lstr
p_hsDoc' ::
HaddockPrintStyle ->
HaddockStyle ->
Bool ->
LHsDoc GhcPs ->
R ()
p_hsDoc' :: HaddockPrintStyle -> HaddockStyle -> Bool -> LHsDoc GhcPs -> R ()
p_hsDoc' HaddockPrintStyle
poHStyle HaddockStyle
hstyle Bool
needsNewline (L SrcSpan
l HsDoc GhcPs
str) = do
let isCommentSpan :: SpanMark -> Bool
isCommentSpan = \case
HaddockSpan HaddockStyle
_ RealSrcSpan
_ -> Bool
True
CommentSpan RealSrcSpan
_ -> Bool
True
SpanMark
_ -> Bool
False
Bool
goesAfterComment <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False SpanMark -> Bool
isCommentSpan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R (Maybe SpanMark)
getSpanMark
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
goesAfterComment R ()
newline
let shouldEscapeCommentBraces :: Bool
shouldEscapeCommentBraces =
case HaddockPrintStyle
poHStyle of
HaddockPrintStyle
HaddockSingleLine -> Bool
False
HaddockPrintStyle
HaddockMultiLine -> Bool
True
HaddockPrintStyle
HaddockMultiLineCompact -> Bool
True
let docStringLines :: [Text]
docStringLines = Bool -> HsDocString -> [Text]
splitDocString Bool
shouldEscapeCommentBraces forall a b. (a -> b) -> a -> b
$ forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString HsDoc GhcPs
str
Maybe RealSrcSpan
mSrcSpan <- SrcSpan -> R (Maybe RealSrcSpan)
getSrcSpan SrcSpan
l
let useSingleLineComments :: Bool
useSingleLineComments =
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
[ HaddockPrintStyle
poHStyle forall a. Eq a => a -> a -> Bool
== HaddockPrintStyle
HaddockSingleLine,
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
docStringLines forall a. Ord a => a -> a -> Bool
<= Int
1,
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> Int
srcSpanStartCol) Maybe RealSrcSpan
mSrcSpan
]
let body :: R () -> R ()
body R ()
sep' =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
docStringLines (Bool
True forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat Bool
False)) forall a b. (a -> b) -> a -> b
$ \(Text
x, Bool
isFirst) -> do
if Bool
isFirst
then do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not Bool
useSingleLineComments Bool -> Bool -> Bool
&& Text -> Bool
T.null Text
x) R ()
space
else do
R ()
sep'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
x) (Text -> R ()
txt Text
x)
if Bool
useSingleLineComments
then do
Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ Text
"-- " forall a. Semigroup a => a -> a -> a
<> Text
haddockDelim
R () -> R ()
body forall a b. (a -> b) -> a -> b
$ R ()
newline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"--" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
else do
Text -> R ()
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
[ Text
"{-",
case (HaddockStyle
hstyle, HaddockPrintStyle
poHStyle) of
(HaddockStyle
Pipe, HaddockPrintStyle
HaddockMultiLineCompact) -> Text
""
(HaddockStyle, HaddockPrintStyle)
_ -> Text
" ",
Text
haddockDelim
]
R () -> R ()
body forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt Text
"\n"
R ()
newline
Text -> R ()
txt Text
"-}"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsNewline R ()
newline
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SpanMark -> R ()
setSpanMark forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockStyle -> RealSrcSpan -> SpanMark
HaddockSpan HaddockStyle
hstyle) Maybe RealSrcSpan
mSrcSpan
where
haddockDelim :: Text
haddockDelim =
case HaddockStyle
hstyle of
HaddockStyle
Pipe -> Text
"|"
HaddockStyle
Caret -> Text
"^"
Asterisk Int
n -> Int -> Text -> Text
T.replicate Int
n Text
"*"
Named String
name -> Text
"$" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
name
getSrcSpan :: SrcSpan -> R (Maybe RealSrcSpan)
getSrcSpan = \case
UnhelpfulSpan UnhelpfulSpanReason
_ -> R (Maybe RealSrcSpan)
getEnclosingSpan
RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just RealSrcSpan
spn
p_sourceText :: SourceText -> R ()
p_sourceText :: SourceText -> R ()
p_sourceText = \case
SourceText
NoSourceText -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SourceText String
s -> Text -> R ()
txt (String -> Text
T.pack String
s)