{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Meat.Common
( FamilyStyle (..),
p_hsmodName,
p_ieWrappedName,
p_rdrName,
p_qualName,
p_infixDefHelper,
p_hsDocString,
p_hsDocName,
p_sourceText,
)
where
import Control.Monad
import qualified Data.Text as T
import GHC.Hs.Doc
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_hsDocString ::
HaddockStyle ->
Bool ->
LHsDocString ->
R ()
p_hsDocString :: HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
hstyle Bool
needsNewline (L SrcSpan
l HsDocString
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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip (HsDocString -> [Text]
splitDocString HsDocString
str) (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)