{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Combinators
(
R,
runR,
getEnclosingSpan,
isExtensionEnabled,
txt,
atom,
space,
newline,
declNewline,
inci,
inciBy,
inciIf,
inciByFrac,
inciHalf,
askSourceType,
askFixityOverrides,
askFixityMap,
located,
located',
switchLayout,
Layout (..),
vlayout,
getLayout,
breakpoint,
breakpoint',
getPrinterOpt,
sep,
sepSemi,
canUseBraces,
useBraces,
dontUseBraces,
BracketStyle (..),
sitcc,
backticks,
banana,
braces,
brackets,
parens,
parensHash,
pragmaBraces,
pragma,
comma,
commaDel,
commaDelImportExport,
equals,
token'Larrowtail,
token'Rarrowtail,
token'darrow,
token'dcolon,
token'larrow,
token'larrowtail,
token'rarrow,
token'rarrowtail,
token'star,
token'forall,
token'oparenbar,
token'cparenbar,
token'openExpQuote,
token'closeQuote,
token'lolly,
SpanMark (..),
spanMarkSpan,
HaddockStyle (..),
setSpanMark,
getSpanMark,
Placement (..),
placeHanging,
)
where
import Control.Monad
import Data.List (intersperse)
import Data.Text (Text)
import qualified GHC.Data.Strict as Strict
import GHC.LanguageExtensions.Type
import GHC.Types.SrcLoc
import Ormolu.Config
import Ormolu.Config.Types
import Ormolu.Printer.Comments
import Ormolu.Printer.Internal
import Ormolu.Utils (HasSrcSpan (..))
inciIf ::
Bool ->
R () ->
R ()
inciIf :: Bool -> R () -> R ()
inciIf Bool
b R ()
m = if Bool
b then R () -> R ()
inci R ()
m else R ()
m
located ::
HasSrcSpan l =>
GenLocated l a ->
(a -> R ()) ->
R ()
located :: forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located (L l
l' a
a) a -> R ()
f = case forall l. HasSrcSpan l => l -> SrcSpan
loc' l
l' of
UnhelpfulSpan UnhelpfulSpanReason
_ -> a -> R ()
f a
a
RealSrcSpan RealSrcSpan
l Maybe BufSpan
_ -> do
RealSrcSpan -> R ()
spitPrecedingComments RealSrcSpan
l
RealSrcSpan -> R () -> R ()
withEnclosingSpan RealSrcSpan
l forall a b. (a -> b) -> a -> b
$
[SrcSpan] -> R () -> R ()
switchLayout [RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
l forall a. Maybe a
Strict.Nothing] (a -> R ()
f a
a)
RealSrcSpan -> R ()
spitFollowingComments RealSrcSpan
l
located' ::
HasSrcSpan l =>
(a -> R ()) ->
GenLocated l a ->
R ()
located' :: forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located
switchLayout ::
[SrcSpan] ->
R () ->
R ()
switchLayout :: [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
spans' = Layout -> R () -> R ()
enterLayout ([SrcSpan] -> Layout
spansLayout [SrcSpan]
spans')
spansLayout :: [SrcSpan] -> Layout
spansLayout :: [SrcSpan] -> Layout
spansLayout = \case
[] -> Layout
SingleLine
(SrcSpan
x : [SrcSpan]
xs) ->
if SrcSpan -> Bool
isOneLineSpan (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
x [SrcSpan]
xs)
then Layout
SingleLine
else Layout
MultiLine
breakpoint :: R ()
breakpoint :: R ()
breakpoint = forall a. R a -> R a -> R a
vlayout R ()
space R ()
newline
breakpoint' :: R ()
breakpoint' :: R ()
breakpoint' = forall a. R a -> R a -> R a
vlayout (forall (m :: * -> *) a. Monad m => a -> m a
return ()) R ()
newline
sep ::
R () ->
(a -> R ()) ->
[a] ->
R ()
sep :: forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
s a -> R ()
f [a]
xs = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (forall a. a -> [a] -> [a]
intersperse R ()
s (a -> R ()
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs))
sepSemi ::
(a -> R ()) ->
[a] ->
R ()
sepSemi :: forall a. (a -> R ()) -> [a] -> R ()
sepSemi a -> R ()
f [a]
xs = forall a. R a -> R a -> R a
vlayout R ()
singleLine R ()
multiLine
where
singleLine :: R ()
singleLine = do
Bool
ub <- R Bool
canUseBraces
case [a]
xs of
[] -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ub forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt Text
"{}"
[a]
xs' ->
if Bool
ub
then do
Text -> R ()
txt Text
"{"
R ()
space
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt Text
";" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space) (R () -> R ()
dontUseBraces forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> R ()
f) [a]
xs'
R ()
space
Text -> R ()
txt Text
"}"
else forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt Text
";" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space) a -> R ()
f [a]
xs'
multiLine :: R ()
multiLine =
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
newline (R () -> R ()
dontUseBraces forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> R ()
f) [a]
xs
data BracketStyle
=
N
|
S
deriving (BracketStyle -> BracketStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BracketStyle -> BracketStyle -> Bool
$c/= :: BracketStyle -> BracketStyle -> Bool
== :: BracketStyle -> BracketStyle -> Bool
$c== :: BracketStyle -> BracketStyle -> Bool
Eq, Int -> BracketStyle -> ShowS
[BracketStyle] -> ShowS
BracketStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BracketStyle] -> ShowS
$cshowList :: [BracketStyle] -> ShowS
show :: BracketStyle -> String
$cshow :: BracketStyle -> String
showsPrec :: Int -> BracketStyle -> ShowS
$cshowsPrec :: Int -> BracketStyle -> ShowS
Show)
backticks :: R () -> R ()
backticks :: R () -> R ()
backticks R ()
m = do
Text -> R ()
txt Text
"`"
R ()
m
Text -> R ()
txt Text
"`"
banana :: BracketStyle -> R () -> R ()
banana :: BracketStyle -> R () -> R ()
banana = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
True R ()
token'oparenbar R ()
token'cparenbar
braces :: BracketStyle -> R () -> R ()
braces :: BracketStyle -> R () -> R ()
braces = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
False (Text -> R ()
txt Text
"{") (Text -> R ()
txt Text
"}")
brackets :: BracketStyle -> R () -> R ()
brackets :: BracketStyle -> R () -> R ()
brackets = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
False (Text -> R ()
txt Text
"[") (Text -> R ()
txt Text
"]")
parens :: BracketStyle -> R () -> R ()
parens :: BracketStyle -> R () -> R ()
parens = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
False (Text -> R ()
txt Text
"(") (Text -> R ()
txt Text
")")
parensHash :: BracketStyle -> R () -> R ()
parensHash :: BracketStyle -> R () -> R ()
parensHash = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
True (Text -> R ()
txt Text
"(#") (Text -> R ()
txt Text
"#)")
pragmaBraces :: R () -> R ()
pragmaBraces :: R () -> R ()
pragmaBraces R ()
m = R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$ do
Text -> R ()
txt Text
"{-#"
R ()
space
R ()
m
R ()
breakpoint
R () -> R ()
inci (Text -> R ()
txt Text
"#-}")
pragma ::
Text ->
R () ->
R ()
pragma :: Text -> R () -> R ()
pragma Text
pragmaText R ()
body = R () -> R ()
pragmaBraces forall a b. (a -> b) -> a -> b
$ do
Text -> R ()
txt Text
pragmaText
R ()
breakpoint
R ()
body
brackets_ ::
Bool ->
R () ->
R () ->
BracketStyle ->
R () ->
R ()
brackets_ :: Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
needBreaks R ()
open R ()
close BracketStyle
style R ()
m = R () -> R ()
sitcc (forall a. R a -> R a -> R a
vlayout R ()
singleLine R ()
multiLine)
where
singleLine :: R ()
singleLine = do
R ()
open
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBreaks R ()
space
R ()
m
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBreaks R ()
space
R ()
close
multiLine :: R ()
multiLine = do
R ()
open
CommaStyle
commaStyle <- forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f CommaStyle
poCommaStyle
case CommaStyle
commaStyle of
CommaStyle
Leading ->
if Bool
needBreaks
then R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ R ()
newline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
m
else Bool -> R () -> R ()
inciIf (BracketStyle
style forall a. Eq a => a -> a -> Bool
== BracketStyle
S) forall a b. (a -> b) -> a -> b
$ R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
m
CommaStyle
Trailing ->
if Bool
needBreaks
then R ()
newline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R () -> R ()
inci R ()
m
else R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R () -> R ()
sitcc R ()
m
R ()
newline
Bool -> R () -> R ()
inciIf (BracketStyle
style forall a. Eq a => a -> a -> Bool
== BracketStyle
S) R ()
close
comma :: R ()
comma :: R ()
comma = Text -> R ()
txt Text
","
commaDel :: R ()
commaDel :: R ()
commaDel = forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f CommaStyle
poCommaStyle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CommaStyle -> R ()
commaDel'
commaDelImportExport :: R ()
commaDelImportExport :: R ()
commaDelImportExport =
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f ImportExportStyle
poImportExportStyle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ImportExportStyle
ImportExportLeading -> CommaStyle -> R ()
commaDel' CommaStyle
Leading
ImportExportStyle
ImportExportTrailing -> CommaStyle -> R ()
commaDel' CommaStyle
Trailing
ImportExportStyle
ImportExportDiffFriendly -> CommaStyle -> R ()
commaDel' CommaStyle
Trailing
commaDel' :: CommaStyle -> R ()
commaDel' :: CommaStyle -> R ()
commaDel' = \case
CommaStyle
Leading -> R ()
breakpoint' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
comma forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
CommaStyle
Trailing -> R ()
comma forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint
equals :: R ()
equals :: R ()
equals = Text -> R ()
interferingTxt Text
"="
token'Larrowtail :: R ()
token'Larrowtail :: R ()
token'Larrowtail = Text
"⤛" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"-<<"
token'Rarrowtail :: R ()
token'Rarrowtail :: R ()
token'Rarrowtail = Text
"⤜" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
">>-"
token'darrow :: R ()
token'darrow :: R ()
token'darrow = Text
"⇒" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"=>"
token'dcolon :: R ()
token'dcolon :: R ()
token'dcolon = Text
"∷" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"::"
token'larrow :: R ()
token'larrow :: R ()
token'larrow = Text
"←" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"<-"
token'larrowtail :: R ()
token'larrowtail :: R ()
token'larrowtail = Text
"⤙" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"-<"
token'rarrow :: R ()
token'rarrow :: R ()
token'rarrow = Text
"→" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"->"
token'rarrowtail :: R ()
token'rarrowtail :: R ()
token'rarrowtail = Text
"⤚" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
">-"
token'star :: R ()
token'star :: R ()
token'star = Text
"★" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"*"
token'forall :: R ()
token'forall :: R ()
token'forall = Text
"∀" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"forall"
token'oparenbar :: R ()
token'oparenbar :: R ()
token'oparenbar = Text
"⦇" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"(|"
token'cparenbar :: R ()
token'cparenbar :: R ()
token'cparenbar = Text
"⦈" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"|)"
token'openExpQuote :: R ()
token'openExpQuote :: R ()
token'openExpQuote = Text
"⟦" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"[|"
token'closeQuote :: R ()
token'closeQuote :: R ()
token'closeQuote = Text
"⟧" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"|]"
token'lolly :: R ()
token'lolly :: R ()
token'lolly = Text
"⊸" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"%1 ->"
whenUnicodeOtherwise :: Text -> Text -> R ()
Text
unicodeText whenUnicodeOtherwise :: Text -> Text -> R ()
`whenUnicodeOtherwise` Text
asciiText = do
Unicode
unicodePrinterOption <- forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Unicode
poUnicode
Bool
unicodeExtensionIsEnabled <- Extension -> R Bool
isExtensionEnabled Extension
UnicodeSyntax
Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ case Unicode
unicodePrinterOption of
Unicode
UnicodeDetect -> if Bool
unicodeExtensionIsEnabled then Text
unicodeText else Text
asciiText
Unicode
UnicodeAlways -> Text
unicodeText
Unicode
UnicodeNever -> Text
asciiText
data Placement
=
Normal
|
Hanging
deriving (Placement -> Placement -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Placement -> Placement -> Bool
$c/= :: Placement -> Placement -> Bool
== :: Placement -> Placement -> Bool
$c== :: Placement -> Placement -> Bool
Eq, Int -> Placement -> ShowS
[Placement] -> ShowS
Placement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Placement] -> ShowS
$cshowList :: [Placement] -> ShowS
show :: Placement -> String
$cshow :: Placement -> String
showsPrec :: Int -> Placement -> ShowS
$cshowsPrec :: Int -> Placement -> ShowS
Show)
placeHanging :: Placement -> R () -> R ()
placeHanging :: Placement -> R () -> R ()
placeHanging Placement
placement R ()
m =
case Placement
placement of
Placement
Hanging -> do
R ()
space
R ()
m
Placement
Normal -> do
R ()
breakpoint
R () -> R ()
inci R ()
m