{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Combinators
(
R,
runR,
getAnns,
getEnclosingSpan,
txt,
atom,
space,
newline,
inci,
located,
located',
locatedPat,
switchLayout,
Layout (..),
vlayout,
getLayout,
breakpoint,
breakpoint',
sep,
sepSemi,
canUseBraces,
useBraces,
dontUseBraces,
BracketStyle (..),
sitcc,
backticks,
banana,
braces,
brackets,
parens,
parensHash,
pragmaBraces,
pragma,
comma,
HaddockStyle (..),
setLastCommentSpan,
getLastCommentSpan,
)
where
import Control.Monad
import Data.Data (Data)
import Data.List (intersperse)
import Data.Text (Text)
import GHC (Pat (XPat), XXPat)
import Ormolu.Printer.Comments
import Ormolu.Printer.Internal
import Ormolu.Utils (isModule)
import SrcLoc
located ::
Data a =>
Located a ->
(a -> R ()) ->
R ()
located :: Located a -> (a -> R ()) -> R ()
located loc :: Located a
loc f :: a -> R ()
f = do
let withRealLocated :: GenLocated SrcSpan e -> (GenLocated RealSrcSpan e -> m ()) -> m ()
withRealLocated (L l :: SrcSpan
l a :: e
a) g :: GenLocated RealSrcSpan e -> m ()
g =
case SrcSpan
l of
UnhelpfulSpan _ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RealSrcSpan l' :: RealSrcSpan
l' -> GenLocated RealSrcSpan e -> m ()
g (RealSrcSpan -> e -> GenLocated RealSrcSpan e
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
l' e
a)
Located a -> (GenLocated RealSrcSpan a -> R ()) -> R ()
forall (m :: * -> *) e.
Monad m =>
GenLocated SrcSpan e -> (GenLocated RealSrcSpan e -> m ()) -> m ()
withRealLocated Located a
loc GenLocated RealSrcSpan a -> R ()
forall a. Data a => RealLocated a -> R ()
spitPrecedingComments
let setEnclosingSpan :: R () -> R ()
setEnclosingSpan =
case Located a -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located a
loc of
UnhelpfulSpan _ -> R () -> R ()
forall a. a -> a
id
RealSrcSpan orf :: RealSrcSpan
orf ->
if a -> Bool
forall a. Data a => a -> Bool
isModule (Located a -> SrcSpanLess (Located a)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located a
loc)
then R () -> R ()
forall a. a -> a
id
else RealSrcSpan -> R () -> R ()
withEnclosingSpan RealSrcSpan
orf
R () -> R ()
setEnclosingSpan (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ [SrcSpan] -> R () -> R ()
switchLayout [Located a -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located a
loc] (a -> R ()
f (Located a -> SrcSpanLess (Located a)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located a
loc))
Located a -> (GenLocated RealSrcSpan a -> R ()) -> R ()
forall (m :: * -> *) e.
Monad m =>
GenLocated SrcSpan e -> (GenLocated RealSrcSpan e -> m ()) -> m ()
withRealLocated Located a
loc GenLocated RealSrcSpan a -> R ()
forall a. Data a => RealLocated a -> R ()
spitFollowingComments
located' ::
Data a =>
(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. Data a => Located a -> (a -> R ()) -> R ()
located
locatedPat ::
(Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>
Pat pass ->
(Pat pass -> R ()) ->
R ()
locatedPat :: Pat pass -> (Pat pass -> R ()) -> R ()
locatedPat p :: Pat pass
p f :: Pat pass -> R ()
f = case Pat pass
p of
XPat pat :: XXPat pass
pat -> Located (Pat pass) -> (Pat pass -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located XXPat pass
Located (Pat pass)
pat Pat pass -> R ()
f
_ -> [Char] -> R ()
forall a. HasCallStack => [Char] -> a
error "locatedPat: Pat does not contain a location"
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 () -> (a -> R ()) -> [a] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt "; ") (R () -> R ()
dontUseBraces (R () -> R ()) -> (a -> R ()) -> a -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> R ()
f) [a]
xs'
Text -> R ()
txt " }"
else R () -> (a -> R ()) -> [a] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt "; ") 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
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
case BracketStyle
style of
N -> Text -> R ()
txt Text
close
S -> R () -> R ()
inci (Text -> R ()
txt Text
close)
comma :: R ()
comma :: R ()
comma = Text -> R ()
txt ","