{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Combinators
(
R,
runR,
getAnns,
getEnclosingSpan,
txt,
atom,
space,
newline,
inci,
inciIf,
located,
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,
)
where
import Control.Monad
import Data.List (intersperse)
import Data.Text (Text)
import Ormolu.Printer.Comments
import Ormolu.Printer.Internal
import SrcLoc
inciIf ::
Bool ->
R () ->
R ()
inciIf :: Bool -> R () -> R ()
inciIf b :: Bool
b m :: R ()
m = if Bool
b then R () -> R ()
inci R ()
m else R ()
m
located ::
Located a ->
(a -> R ()) ->
R ()
located :: Located a -> (a -> R ()) -> R ()
located (L (UnhelpfulSpan _) a :: a
a) f :: a -> R ()
f = a -> R ()
f a
a
located (L (RealSrcSpan l :: RealSrcSpan
l) a :: a
a) f :: a -> R ()
f = 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 -> SrcSpan
RealSrcSpan RealSrcSpan
l] (a -> R ()
f a
a)
RealSrcSpan -> R ()
spitFollowingComments RealSrcSpan
l
located' ::
(a -> R ()) ->
Located a ->
R ()
located' :: (a -> R ()) -> Located a -> R ()
located' = (Located a -> (a -> R ()) -> R ())
-> (a -> R ()) -> Located a -> R ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Located a -> (a -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located
switchLayout ::
[SrcSpan] ->
R () ->
R ()
switchLayout :: [SrcSpan] -> R () -> R ()
switchLayout spans' :: [SrcSpan]
spans' = Layout -> R () -> R ()
enterLayout ([SrcSpan] -> Layout
spansLayout [SrcSpan]
spans')
spansLayout :: [SrcSpan] -> Layout
spansLayout :: [SrcSpan] -> Layout
spansLayout = \case
[] -> Layout
SingleLine
(x :: SrcSpan
x : xs :: [SrcSpan]
xs) ->
if SrcSpan -> Bool
isOneLineSpan ((SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan
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 (m :: * -> *) a. Monad m => a -> m a
return ()) R ()
newline
sep ::
R () ->
(a -> R ()) ->
[a] ->
R ()
sep :: R () -> (a -> R ()) -> [a] -> R ()
sep s :: R ()
s f :: a -> R ()
f xs :: [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 :: (a -> R ()) -> [a] -> R ()
sepSemi f :: a -> R ()
f xs :: [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 "{}"
xs' :: [a]
xs' ->
if Bool
ub
then do
Text -> R ()
txt "{"
R ()
space
R () -> (a -> R ()) -> [a] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt ";" R () -> R () -> R ()
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 "}"
else R () -> (a -> R ()) -> [a] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt ";" R () -> R () -> R ()
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
/= :: BracketStyle -> BracketStyle -> Bool
$c/= :: BracketStyle -> BracketStyle -> Bool
== :: BracketStyle -> BracketStyle -> Bool
$c== :: 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
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 m :: R ()
m = do
Text -> R ()
txt "`"
R ()
m
Text -> R ()
txt "`"
banana :: R () -> R ()
banana :: R () -> R ()
banana = Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
True "(|" "|)" BracketStyle
N
braces :: BracketStyle -> R () -> R ()
braces :: BracketStyle -> R () -> R ()
braces = Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
False "{" "}"
brackets :: BracketStyle -> R () -> R ()
brackets :: BracketStyle -> R () -> R ()
brackets = Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
False "[" "]"
parens :: BracketStyle -> R () -> R ()
parens :: BracketStyle -> R () -> R ()
parens = Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
False "(" ")"
parensHash :: BracketStyle -> R () -> R ()
parensHash :: BracketStyle -> R () -> R ()
parensHash = Bool -> Text -> Text -> BracketStyle -> R () -> R ()
brackets_ Bool
True "(#" "#)"
pragmaBraces :: R () -> R ()
pragmaBraces :: R () -> R ()
pragmaBraces m :: R ()
m = R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
Text -> R ()
txt "{-#"
R ()
space
R ()
m
R ()
breakpoint
R () -> R ()
inci (Text -> R ()
txt "#-}")
pragma ::
Text ->
R () ->
R ()
pragma :: Text -> R () -> R ()
pragma pragmaText :: Text
pragmaText body :: 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_ needBreaks :: Bool
needBreaks open :: Text
open close :: Text
close style :: BracketStyle
style m :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R () -> R ()
inci R ()
m
else R ()
space R () -> R () -> R ()
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 ","
commaDel :: R ()
commaDel :: R ()
commaDel = R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint
equals :: R ()
equals :: R ()
equals = Text -> R ()
interferingTxt "="