{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Combinators
(
R,
runR,
getEnclosingSpan,
getEnclosingSpanWhere,
isExtensionEnabled,
txt,
atom,
space,
newline,
inci,
inciIf,
askSourceType,
askModuleFixityMap,
located,
encloseLocated,
located',
switchLayout,
Layout (..),
vlayout,
getLayout,
breakpoint,
breakpoint',
sep,
sepSemi,
canUseBraces,
useBraces,
dontUseBraces,
BracketStyle (..),
sitcc,
backticks,
banana,
braces,
brackets,
parens,
parensHash,
pragmaBraces,
pragma,
comma,
commaDel,
equals,
SpanMark (..),
spanMarkSpan,
HaddockStyle (..),
setSpanMark,
getSpanMark,
Placement (..),
placeHanging,
)
where
import Control.Monad
import Data.List (intersperse)
import Data.Text (Text)
import GHC.Data.Strict qualified as Strict
import GHC.Types.SrcLoc
import Ormolu.Printer.Comments
import Ormolu.Printer.Internal
import Ormolu.Utils (HasSrcSpan (..), getLoc')
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 l -> SrcSpan
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 (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
[SrcSpan] -> R () -> R ()
switchLayout [RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
l Maybe BufSpan
forall a. Maybe a
Strict.Nothing] (a -> R ()
f a
a)
RealSrcSpan -> R ()
spitFollowingComments RealSrcSpan
l
encloseLocated ::
(HasSrcSpan l) =>
GenLocated l [a] ->
([a] -> R ()) ->
R ()
encloseLocated :: forall l a.
HasSrcSpan l =>
GenLocated l [a] -> ([a] -> R ()) -> R ()
encloseLocated GenLocated l [a]
la [a] -> R ()
f = GenLocated l [a] -> ([a] -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated l [a]
la (([a] -> R ()) -> R ()) -> ([a] -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \[a]
a -> do
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
a) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan () -> (() -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located (SrcSpan -> () -> GenLocated SrcSpan ()
forall l e. l -> e -> GenLocated l e
L SrcSpan
startSpan ()) () -> R ()
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[a] -> R ()
f [a]
a
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
a) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan () -> (() -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located (SrcSpan -> () -> GenLocated SrcSpan ()
forall l e. l -> e -> GenLocated l e
L SrcSpan
endSpan ()) () -> R ()
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
where
l :: SrcSpan
l = GenLocated l [a] -> SrcSpan
forall l a. HasSrcSpan l => GenLocated l a -> SrcSpan
getLoc' GenLocated l [a]
la
(SrcLoc
startLoc, SrcLoc
endLoc) = (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
l, SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
l)
(SrcSpan
startSpan, SrcSpan
endSpan) = (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
startLoc SrcLoc
startLoc, SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
endLoc SrcLoc
endLoc)
located' ::
(HasSrcSpan l) =>
(a -> R ()) ->
GenLocated l a ->
R ()
located' :: forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' = (GenLocated l a -> (a -> R ()) -> R ())
-> (a -> R ()) -> GenLocated l a -> R ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip GenLocated l a -> (a -> R ()) -> R ()
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 ((SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan
forall a b. (a -> b -> b) -> b -> [a] -> b
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 = R () -> R () -> R ()
forall a. R a -> R a -> R a
vlayout R ()
space R ()
newline
breakpoint' :: R ()
breakpoint' :: R ()
breakpoint' = R () -> R () -> R ()
forall a. R a -> R a -> R a
vlayout (() -> R ()
forall a. a -> R a
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 = [R ()] -> R ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (R () -> [R ()] -> [R ()]
forall a. a -> [a] -> [a]
intersperse R ()
s (a -> R ()
f (a -> R ()) -> [a] -> [R ()]
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 = R () -> R () -> R ()
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
[] -> Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ub (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt Text
"{}"
[a]
xs' ->
if Bool
ub
then do
Text -> R ()
txt Text
"{"
R ()
space
R () -> (a -> R ()) -> [a] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt Text
";" R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space) (R () -> R ()
dontUseBraces (R () -> R ()) -> (a -> R ()) -> a -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> R ()
f) [a]
xs'
R ()
space
Text -> R ()
txt Text
"}"
else R () -> (a -> R ()) -> [a] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt Text
";" R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space) a -> R ()
f [a]
xs'
multiLine :: R ()
multiLine =
R () -> (a -> R ()) -> [a] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
newline (R () -> R ()
dontUseBraces (R () -> R ()) -> (a -> R ()) -> a -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> R ()
f) [a]
xs
data BracketStyle
=
N
|
S
deriving (BracketStyle -> BracketStyle -> Bool
(BracketStyle -> BracketStyle -> Bool)
-> (BracketStyle -> BracketStyle -> Bool) -> Eq BracketStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BracketStyle -> BracketStyle -> Bool
== :: BracketStyle -> BracketStyle -> Bool
$c/= :: BracketStyle -> BracketStyle -> Bool
/= :: BracketStyle -> BracketStyle -> Bool
Eq, Int -> BracketStyle -> ShowS
[BracketStyle] -> ShowS
BracketStyle -> String
(Int -> BracketStyle -> ShowS)
-> (BracketStyle -> String)
-> ([BracketStyle] -> ShowS)
-> Show BracketStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BracketStyle -> ShowS
showsPrec :: Int -> BracketStyle -> ShowS
$cshow :: BracketStyle -> String
show :: BracketStyle -> String
$cshowList :: [BracketStyle] -> ShowS
showList :: [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 -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
True Text
"(|" Text
"|)"
braces :: BracketStyle -> R () -> R ()
braces :: BracketStyle -> R () -> R ()
braces = Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
False Text
"{" Text
"}"
brackets :: BracketStyle -> R () -> R ()
brackets :: BracketStyle -> R () -> R ()
brackets = Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
False Text
"[" Text
"]"
parens :: BracketStyle -> R () -> R ()
parens :: BracketStyle -> R () -> R ()
parens = Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
False Text
"(" Text
")"
parensHash :: BracketStyle -> R () -> R ()
parensHash :: BracketStyle -> R () -> R ()
parensHash = Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
True Text
"(#" Text
"#)"
pragmaBraces :: R () -> R ()
pragmaBraces :: R () -> R ()
pragmaBraces R ()
m = R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
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 (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
Text -> R ()
txt Text
pragmaText
R ()
breakpoint
R ()
body
brackets_ ::
Bool ->
Text ->
Text ->
BracketStyle ->
R () ->
R ()
brackets_ :: Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
needBreaks Text
open Text
close BracketStyle
style R ()
m = R () -> R ()
sitcc (R () -> R () -> R ()
forall a. R a -> R a -> R a
vlayout R ()
singleLine R ()
multiLine)
where
singleLine :: R ()
singleLine = do
Text -> R ()
txt Text
open
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBreaks R ()
space
R ()
m
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBreaks R ()
space
Text -> R ()
txt Text
close
multiLine :: R ()
multiLine = do
Text -> R ()
txt Text
open
if Bool
needBreaks
then 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
>> R () -> R ()
inci R ()
m
else R ()
space R () -> R () -> R ()
forall a b. R a -> R b -> R b
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 BracketStyle -> BracketStyle -> Bool
forall a. Eq a => a -> a -> Bool
== BracketStyle
S) (Text -> R ()
txt Text
close)
comma :: R ()
comma :: R ()
comma = Text -> R ()
txt Text
","
commaDel :: R ()
commaDel :: R ()
commaDel = R ()
comma R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint
equals :: R ()
equals :: R ()
equals = Text -> R ()
interferingTxt Text
"="
data Placement
=
Normal
|
Hanging
deriving (Placement -> Placement -> Bool
(Placement -> Placement -> Bool)
-> (Placement -> Placement -> Bool) -> Eq Placement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Placement -> Placement -> Bool
== :: Placement -> Placement -> Bool
$c/= :: Placement -> Placement -> Bool
/= :: Placement -> Placement -> Bool
Eq, Int -> Placement -> ShowS
[Placement] -> ShowS
Placement -> String
(Int -> Placement -> ShowS)
-> (Placement -> String)
-> ([Placement] -> ShowS)
-> Show Placement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Placement -> ShowS
showsPrec :: Int -> Placement -> ShowS
$cshow :: Placement -> String
show :: Placement -> String
$cshowList :: [Placement] -> ShowS
showList :: [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