{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
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 qualified Data.Text as T
import GHC.Hs.Doc
import GHC.Hs.Extension (GhcPs)
import GHC.Hs.ImpExp
import GHC.Parser.Annotation
import GHC.Types.Name.Occurrence (OccName (..))
import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Unit.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 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 RdrName -> R ()
p_ieWrappedName :: IEWrappedName RdrName -> R ()
p_ieWrappedName = \case
IEName LocatedN RdrName
x -> LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
x
IEPattern EpaLocation
_ LocatedN RdrName
x -> do
Text -> R ()
txt Text
"pattern"
R ()
space
LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
x
IEType EpaLocation
_ LocatedN RdrName
x -> do
Text -> R ()
txt Text
"type"
R ()
space
LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
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
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
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
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
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 (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 docStringLines :: [Text]
docStringLines = HsDocString -> [Text]
splitDocString forall a b. (a -> b) -> a -> b
$ forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString HsDoc GhcPs
str
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 case HaddockStyle
hstyle of
HaddockStyle
Pipe -> Text -> R ()
txt Text
"-- |"
HaddockStyle
Caret -> Text -> R ()
txt Text
"-- ^"
Asterisk Int
n -> Text -> R ()
txt (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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"--"
R ()
space
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
x) (Text -> R ()
txt Text
x)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsNewline R ()
newline
case SrcSpan
l of
UnhelpfulSpan UnhelpfulSpanReason
_ ->
(RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan)
getEnclosingSpan (forall a b. a -> b -> a
const Bool
True) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanMark -> R ()
setSpanMark 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
"-- $" 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SourceText String
s -> R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt (String -> Text
T.pack String
s)