{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Meat.Common
( FamilyStyle (..),
p_hsmodName,
p_ieWrappedName,
p_rdrName,
doesNotNeedExtraParens,
p_qualName,
p_infixDefHelper,
p_hsDocString,
p_sourceText,
)
where
import Control.Monad
import Data.List (intersperse, isPrefixOf)
import qualified Data.Text as T
import GHC.Hs.Doc
import GHC.Hs.ImpExp
import GHC.Parser.Annotation
import GHC.Types.Basic
import GHC.Types.Name (nameStableString)
import GHC.Types.Name.Occurrence (OccName (..))
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Unit.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
Text -> R ()
txt Text
"module"
R ()
space
ModuleName -> R ()
forall a. Outputable a => a -> R ()
atom ModuleName
mname
p_ieWrappedName :: IEWrappedName RdrName -> R ()
p_ieWrappedName :: IEWrappedName RdrName -> R ()
p_ieWrappedName = \case
IEName Located RdrName
x -> Located RdrName -> R ()
p_rdrName Located RdrName
x
IEPattern Located RdrName
x -> do
Text -> R ()
txt Text
"pattern"
R ()
space
Located RdrName -> R ()
p_rdrName Located RdrName
x
IEType Located RdrName
x -> do
Text -> R ()
txt Text
"type"
R ()
space
Located RdrName -> R ()
p_rdrName Located RdrName
x
p_rdrName :: Located RdrName -> R ()
p_rdrName :: Located RdrName -> R ()
p_rdrName l :: Located RdrName
l@(L SrcSpan
spn RdrName
_) = Located RdrName -> (RdrName -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located RdrName
l ((RdrName -> R ()) -> R ()) -> (RdrName -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \RdrName
x -> do
[AnnKeywordId]
ids <- SrcSpan -> R [AnnKeywordId]
getAnns SrcSpan
spn
let backticksWrapper :: R () -> R ()
backticksWrapper =
if AnnKeywordId
AnnBackquote AnnKeywordId -> [AnnKeywordId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnnKeywordId]
ids
then R () -> R ()
backticks
else R () -> R ()
forall a. a -> a
id
parensWrapper :: R () -> R ()
parensWrapper =
if AnnKeywordId
AnnOpenP AnnKeywordId -> [AnnKeywordId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnnKeywordId]
ids
then BracketStyle -> R () -> R ()
parens BracketStyle
N
else R () -> R ()
forall a. a -> a
id
singleQuoteWrapper :: R b -> R b
singleQuoteWrapper =
if AnnKeywordId
AnnSimpleQuote AnnKeywordId -> [AnnKeywordId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnnKeywordId]
ids
then \R b
y -> do
Text -> R ()
txt Text
"'"
R b
y
else R b -> R b
forall a. a -> a
id
m :: R ()
m =
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
m' :: R ()
m' = R () -> R ()
backticksWrapper (R () -> R ()
forall b. R b -> R b
singleQuoteWrapper R ()
m)
if RdrName -> Bool
doesNotNeedExtraParens RdrName
x
then R ()
m'
else R () -> R ()
parensWrapper R ()
m'
doesNotNeedExtraParens :: RdrName -> Bool
= \case
Exact Name
name ->
let s :: String
s = Name -> String
nameStableString Name
name
in
(String
"$ghc-prim$GHC.Tuple$" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s)
Bool -> Bool -> Bool
|| (String
"$ghc-prim$GHC.Types$[]" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s)
RdrName
_ -> Bool
False
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 (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 ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc
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 (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 (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_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 <- 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 txt' :: Text -> R ()
txt' Text
x = Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
x) (Text -> R ()
txt Text
x)
docLines :: [Text]
docLines = HsDocString -> [Text]
splitDocString HsDocString
str
body :: R () -> R ()
body R ()
s = do
Text -> R ()
txt (Text -> R ()) -> Text -> R ()
forall a b. (a -> b) -> a -> b
$ case HaddockStyle
hstyle of
HaddockStyle
Pipe -> Text
" |"
HaddockStyle
Caret -> Text
" ^"
Asterisk Int
n -> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
n Text
"*"
Named String
name -> Text
" $" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
name
[R ()] -> R ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([R ()] -> R ()) -> [R ()] -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> [R ()] -> [R ()]
forall a. a -> [a] -> [a]
intersperse (R ()
newline R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
s) ([R ()] -> [R ()]) -> [R ()] -> [R ()]
forall a b. (a -> b) -> a -> b
$ (Text -> R ()) -> [Text] -> [R ()]
forall a b. (a -> b) -> [a] -> [b]
map Text -> R ()
txt' [Text]
docLines
Bool
single <-
(forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle)
-> R HaddockPrintStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle
poHaddockStyle R HaddockPrintStyle -> (HaddockPrintStyle -> R Bool) -> R Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
HaddockPrintStyle
HaddockSingleLine -> Bool -> R Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
HaddockPrintStyle
HaddockMultiLine -> Bool -> (RealSrcSpan -> Bool) -> Maybe RealSrcSpan -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> (RealSrcSpan -> Int) -> RealSrcSpan -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> Int
srcSpanStartCol) (Maybe RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan) -> R Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> R (Maybe RealSrcSpan)
getSrcSpan SrcSpan
l
if Bool
single
then do
Text -> R ()
txt Text
"--"
R () -> R ()
body (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt Text
"--"
else
if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
docLines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
then do
Text -> R ()
txt Text
"--"
R () -> R ()
body (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ () -> R ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else do
Text -> R ()
txt Text
"{-"
R () -> R ()
body (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ () -> R ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
R ()
newline
Text -> R ()
txt Text
"-}"
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsNewline R ()
newline
SrcSpan -> R (Maybe RealSrcSpan)
getSrcSpan SrcSpan
l R (Maybe RealSrcSpan) -> (Maybe RealSrcSpan -> R ()) -> R ()
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)
where
getSrcSpan :: SrcSpan -> R (Maybe RealSrcSpan)
getSrcSpan = \case
UnhelpfulSpan UnhelpfulSpanReason
_ -> (RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan)
getEnclosingSpan (Bool -> RealSrcSpan -> Bool
forall a b. a -> b -> a
const Bool
True)
RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_ -> Maybe RealSrcSpan -> R (Maybe RealSrcSpan)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RealSrcSpan -> R (Maybe RealSrcSpan))
-> Maybe RealSrcSpan -> R (Maybe RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
spn
p_sourceText :: SourceText -> R ()
p_sourceText :: SourceText -> R ()
p_sourceText = \case
SourceText
NoSourceText -> () -> R ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SourceText String
s -> R ()
space R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt (String -> Text
T.pack String
s)