{-# 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_hsDocName,
p_sourceText,
)
where
import Control.Monad
import Data.Text qualified as T
import GHC.Data.FastString
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 (SourceType (..))
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 (Text -> R ()) -> Text -> R ()
forall a b. (a -> b) -> a -> b
$ case SourceType
sourceType of
SourceType
ModuleSource -> Text
"module"
SourceType
SignatureSource -> Text
"signature"
R ()
space
ModuleName -> R ()
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 LocatedN RdrName
LIdP GhcPs
x
IEPattern XIEPattern GhcPs
_ LIdP GhcPs
x -> do
Text -> R ()
txt Text
"pattern"
R ()
space
LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
LIdP GhcPs
x
IEType XIEType GhcPs
_ LIdP GhcPs
x -> do
Text -> R ()
txt Text
"type"
R ()
space
LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
LIdP GhcPs
x
p_rdrName :: LocatedN RdrName -> R ()
p_rdrName :: LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
l = LocatedN RdrName -> (RdrName -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedN RdrName
l ((RdrName -> R ()) -> R ()) -> (RdrName -> R ()) -> R ()
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 :: NameAnn
anns :: forall ann. EpAnn ann -> ann
anns} -> case NameAnn
anns of
NameAnnQuote {SrcSpanAnnN
nann_quoted :: SrcSpanAnnN
nann_quoted :: NameAnn -> SrcSpanAnnN
nann_quoted} -> R () -> R ()
forall {b}. R b -> R b
tickPrefix (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAnn NameAnn -> R () -> R ()
wrapper (SrcSpanAnnN -> EpAnn NameAnn
forall a. SrcSpanAnn' a -> a
ann SrcSpanAnnN
nann_quoted)
NameAnn {nann_adornment :: NameAnn -> NameAdornment
nann_adornment = NameAdornment
NameParens} ->
BracketStyle -> R () -> R ()
parens BracketStyle
N (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
forall {b}. R b -> R b
handleUnboxedSumsAndHashInteraction
NameAnn {nann_adornment :: NameAnn -> NameAdornment
nann_adornment = NameAdornment
NameBackquotes} -> R () -> R ()
backticks
NameAnnRArrow {nann_mopen :: NameAnn -> Maybe EpaLocation
nann_mopen = Just EpaLocation
_} -> BracketStyle -> R () -> R ()
parens BracketStyle
N
NameAnnOnly {nann_adornment :: NameAnn -> NameAdornment
nann_adornment = NameAdornment
NameParensHash} -> R () -> R () -> R ()
forall a b. a -> b -> a
const (R () -> R () -> R ()) -> R () -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt Text
"(# #)"
NameAnn
_ -> R () -> R ()
forall a. a -> a
id
EpAnn NameAnn
EpAnnNotUsed -> R () -> R ()
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 R () -> R a -> R a
forall a b. R a -> R b -> R b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> R a
y R a -> R () -> R a
forall a b. R a -> R b -> R a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* R ()
space
| Bool
otherwise = R a -> R a
forall a. a -> a
id
EpAnn NameAnn -> R () -> R ()
wrapper (SrcSpanAnnN -> EpAnn NameAnn
forall a. SrcSpanAnn' a -> a
ann (SrcSpanAnnN -> EpAnn NameAnn)
-> (LocatedN RdrName -> SrcSpanAnnN)
-> LocatedN RdrName
-> EpAnn NameAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
getLoc (LocatedN RdrName -> EpAnn NameAnn)
-> LocatedN RdrName -> EpAnn NameAnn
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
l) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ case RdrName
x of
Unqual OccName
occName ->
OccName -> R ()
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 ->
OccName -> R ()
forall a. Outputable a => a -> R ()
atom OccName
occName
Exact Name
name ->
Name -> R ()
forall a. Outputable a => a -> R ()
atom Name
name
where
tickPrefix :: R b -> R b
tickPrefix R b
y = Text -> R ()
txt Text
"'" R () -> R b -> R b
forall a b. R a -> R b -> R b
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
ModuleName -> R ()
forall a. Outputable a => a -> R ()
atom ModuleName
mname
Text -> R ()
txt Text
"."
OccName -> R ()
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 [R ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [R ()]
ps
then R () -> R ()
forall a. a -> a
id
else BracketStyle -> R () -> R ()
parens BracketStyle
N
R () -> R ()
parens' (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
R ()
p0
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
$ do
R ()
name
R ()
space
R ()
p1
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([R ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [R ()]
ps) (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> R () -> R ()
inciIf Bool
indentArgs (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
R ()
breakpoint
R () -> R ()
sitcc (R () -> (R () -> R ()) -> [R ()] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint R () -> R ()
sitcc [R ()]
ps)
(Bool
_, [R ()]
ps) -> do
R ()
name
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([R ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [R ()]
ps) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
R ()
breakpoint
Bool -> R () -> R ()
inciIf Bool
indentArgs (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> R ()
sitcc (R () -> (R () -> R ()) -> [R ()] -> R ()
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 (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 <- Bool -> (SpanMark -> Bool) -> Maybe SpanMark -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False SpanMark -> Bool
isCommentSpan (Maybe SpanMark -> Bool) -> R (Maybe SpanMark) -> R Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R (Maybe SpanMark)
getSpanMark
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
goesAfterComment R ()
newline
let docStringLines :: [Text]
docStringLines = HsDocString -> [Text]
splitDocString (HsDocString -> [Text]) -> HsDocString -> [Text]
forall a b. (a -> b) -> a -> b
$ HsDoc GhcPs -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString HsDoc GhcPs
str
[(Text, Bool)] -> ((Text, Bool) -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Text] -> [Bool] -> [(Text, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
docStringLines (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False)) (((Text, Bool) -> R ()) -> R ()) -> ((Text, Bool) -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \(Text
x, Bool
isFirst) -> do
if Bool
isFirst
then case HaddockStyle
hstyle of
HaddockStyle
Pipe -> Text -> R ()
txt Text
"-- |"
HaddockStyle
Caret -> Text -> R ()
txt Text
"-- ^"
Asterisk Int
n -> Text -> R ()
txt (Text
"-- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
n Text
"*")
Named String
name -> String -> R ()
p_hsDocName String
name
else R ()
newline R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"--"
R ()
space
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
x) (Text -> R ()
txt Text
x)
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsNewline R ()
newline
case SrcSpan
l of
UnhelpfulSpan UnhelpfulSpanReason
_ ->
R (Maybe RealSrcSpan)
getEnclosingSpan R (Maybe RealSrcSpan) -> (Maybe RealSrcSpan -> R ()) -> R ()
forall a b. R a -> (a -> R b) -> R b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (RealSrcSpan -> R ()) -> Maybe RealSrcSpan -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanMark -> R ()
setSpanMark (SpanMark -> R ())
-> (RealSrcSpan -> SpanMark) -> RealSrcSpan -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockStyle -> RealSrcSpan -> SpanMark
HaddockSpan HaddockStyle
hstyle)
RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_ -> SpanMark -> R ()
setSpanMark (HaddockStyle -> RealSrcSpan -> SpanMark
HaddockSpan HaddockStyle
hstyle RealSrcSpan
spn)
p_hsDocName :: String -> R ()
p_hsDocName :: String -> R ()
p_hsDocName String
name = Text -> R ()
txt (Text
"-- $" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
name)
p_sourceText :: SourceText -> R ()
p_sourceText :: SourceText -> R ()
p_sourceText = \case
SourceText
NoSourceText -> () -> R ()
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SourceText FastString
s -> forall a. Outputable a => a -> R ()
atom @FastString FastString
s