{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module      :  Disco.Pretty.DSL
-- Copyright   :  disco team and contributors
-- Maintainer  :  [email protected]
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Adapter DSL on top of Text.PrettyPrint for Applicative pretty-printing.
module Disco.Pretty.DSL where

import Control.Applicative hiding (empty)
import Data.String (IsString (..))
import Disco.Pretty.Prec
import Polysemy
import Polysemy.Reader
import Prettyprinter (Doc)
import qualified Prettyprinter as PP
import Prettyprinter.Internal (Doc (Empty)) -- XXX comment me
import Prettyprinter.Render.String (renderString)
import Prelude hiding ((<>))

instance IsString (Sem r (Doc ann)) where
  fromString :: String -> Sem r (Doc ann)
fromString = String -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => String -> m (Doc ann)
text

------------------------------------------------------------
-- Adapter DSL
--
-- Each combinator here mirrors one from Text.PrettyPrint, but
-- operates over a generic functor/monad.

vcat :: Applicative f => [f (Doc ann)] -> f (Doc ann)
vcat :: forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat [f (Doc ann)]
ds = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat ([Doc ann] -> Doc ann) -> f [Doc ann] -> f (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [f (Doc ann)] -> f [Doc ann]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA [f (Doc ann)]
ds

hcat :: Applicative f => [f (Doc ann)] -> f (Doc ann)
hcat :: forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
hcat [f (Doc ann)]
ds = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.hcat ([Doc ann] -> Doc ann) -> f [Doc ann] -> f (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [f (Doc ann)] -> f [Doc ann]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA [f (Doc ann)]
ds

hsep :: Applicative f => [f (Doc ann)] -> f (Doc ann)
hsep :: forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
hsep [f (Doc ann)]
ds = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.hsep ([Doc ann] -> Doc ann) -> f [Doc ann] -> f (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [f (Doc ann)] -> f [Doc ann]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA [f (Doc ann)]
ds

parens :: Functor f => f (Doc ann) -> f (Doc ann)
parens :: forall (f :: * -> *) ann. Functor f => f (Doc ann) -> f (Doc ann)
parens = (Doc ann -> Doc ann) -> f (Doc ann) -> f (Doc ann)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.parens

brackets :: Functor f => f (Doc ann) -> f (Doc ann)
brackets :: forall (f :: * -> *) ann. Functor f => f (Doc ann) -> f (Doc ann)
brackets = (Doc ann -> Doc ann) -> f (Doc ann) -> f (Doc ann)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.brackets

braces :: Functor f => f (Doc ann) -> f (Doc ann)
braces :: forall (f :: * -> *) ann. Functor f => f (Doc ann) -> f (Doc ann)
braces = (Doc ann -> Doc ann) -> f (Doc ann) -> f (Doc ann)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.braces

bag :: Applicative f => f (Doc ann) -> f (Doc ann)
bag :: forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann)
bag f (Doc ann)
p = String -> f (Doc ann)
forall (m :: * -> *) ann. Applicative m => String -> m (Doc ann)
text String
"⟅" f (Doc ann) -> f (Doc ann) -> f (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> f (Doc ann)
p f (Doc ann) -> f (Doc ann) -> f (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> String -> f (Doc ann)
forall (m :: * -> *) ann. Applicative m => String -> m (Doc ann)
text String
"⟆"

quotes :: Functor f => f (Doc ann) -> f (Doc ann)
quotes :: forall (f :: * -> *) ann. Functor f => f (Doc ann) -> f (Doc ann)
quotes = (Doc ann -> Doc ann) -> f (Doc ann) -> f (Doc ann)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.squotes

doubleQuotes :: Functor f => f (Doc ann) -> f (Doc ann)
doubleQuotes :: forall (f :: * -> *) ann. Functor f => f (Doc ann) -> f (Doc ann)
doubleQuotes = (Doc ann -> Doc ann) -> f (Doc ann) -> f (Doc ann)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.dquotes

text :: Applicative m => String -> m (Doc ann)
text :: forall (m :: * -> *) ann. Applicative m => String -> m (Doc ann)
text = Doc ann -> m (Doc ann)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> m (Doc ann))
-> (String -> Doc ann) -> String -> m (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc ann
forall a. IsString a => String -> a
fromString

integer :: Applicative m => Integer -> m (Doc ann)
integer :: forall (m :: * -> *) ann. Applicative m => Integer -> m (Doc ann)
integer = Doc ann -> m (Doc ann)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> m (Doc ann))
-> (Integer -> Doc ann) -> Integer -> m (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Doc ann
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty

nest :: Functor f => Int -> f (Doc ann) -> f (Doc ann)
nest :: forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
nest Int
n f (Doc ann)
d = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.nest Int
n (Doc ann -> Doc ann) -> f (Doc ann) -> f (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Doc ann)
d

indent :: Functor f => Int -> f (Doc ann) -> f (Doc ann)
indent :: forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
indent Int
n f (Doc ann)
d = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
n (Doc ann -> Doc ann) -> f (Doc ann) -> f (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Doc ann)
d

hang :: Applicative f => f (Doc ann) -> Int -> f (Doc ann) -> f (Doc ann)
hang :: forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> Int -> f (Doc ann) -> f (Doc ann)
hang f (Doc ann)
d1 Int
n f (Doc ann)
d2 = f (Doc ann)
d1 f (Doc ann) -> f (Doc ann) -> f (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Int -> f (Doc ann) -> f (Doc ann)
forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
nest Int
n f (Doc ann)
d2

empty :: Applicative m => m (Doc ann)
empty :: forall (m :: * -> *) ann. Applicative m => m (Doc ann)
empty = Doc ann -> m (Doc ann)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
forall ann. Doc ann
PP.emptyDoc

(<+>) :: Applicative f => f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> :: forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
(<+>) = (Doc ann -> Doc ann -> Doc ann)
-> f (Doc ann) -> f (Doc ann) -> f (Doc ann)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
(PP.<+>)

(<>) :: Applicative f => f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> :: forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
(<>) = (Doc ann -> Doc ann -> Doc ann)
-> f (Doc ann) -> f (Doc ann) -> f (Doc ann)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
(PP.<>)

($+$) :: Applicative f => f (Doc ann) -> f (Doc ann) -> f (Doc ann)
f (Doc ann)
d1 $+$ :: forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
$+$ f (Doc ann)
d2 = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
f (Doc ann -> Doc ann -> Doc ann)
-> f (Doc ann) -> f (Doc ann -> Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Doc ann)
d1 f (Doc ann -> Doc ann) -> f (Doc ann) -> f (Doc ann)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (Doc ann)
d2
 where
  f :: Doc ann -> Doc ann -> Doc ann
f Doc ann
x1 Doc ann
Empty = Doc ann
x1
  f Doc ann
x1 Doc ann
x2 = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat [Doc ann
x1, Doc ann
x2]

punctuate :: Applicative f => f (Doc ann) -> [f (Doc ann)] -> f [f (Doc ann)]
punctuate :: forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> [f (Doc ann)] -> f [f (Doc ann)]
punctuate f (Doc ann)
p [f (Doc ann)]
ds = (Doc ann -> f (Doc ann)) -> [Doc ann] -> [f (Doc ann)]
forall a b. (a -> b) -> [a] -> [b]
map Doc ann -> f (Doc ann)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Doc ann] -> [f (Doc ann)]) -> f [Doc ann] -> f [f (Doc ann)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
PP.punctuate (Doc ann -> [Doc ann] -> [Doc ann])
-> f (Doc ann) -> f ([Doc ann] -> [Doc ann])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Doc ann)
p f ([Doc ann] -> [Doc ann]) -> f [Doc ann] -> f [Doc ann]
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [f (Doc ann)] -> f [Doc ann]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA [f (Doc ann)]
ds)

intercalate :: Monad f => f (Doc ann) -> [f (Doc ann)] -> f (Doc ann)
intercalate :: forall (f :: * -> *) ann.
Monad f =>
f (Doc ann) -> [f (Doc ann)] -> f (Doc ann)
intercalate f (Doc ann)
p [f (Doc ann)]
ds = do
  [f (Doc ann)]
ds' <- f (Doc ann) -> [f (Doc ann)] -> f [f (Doc ann)]
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> [f (Doc ann)] -> f [f (Doc ann)]
punctuate f (Doc ann)
p [f (Doc ann)]
ds
  [f (Doc ann)] -> f (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
hsep [f (Doc ann)]
ds'

bulletList :: Applicative f => f (Doc ann) -> [f (Doc ann)] -> f (Doc ann)
bulletList :: forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> [f (Doc ann)] -> f (Doc ann)
bulletList f (Doc ann)
bullet = [f (Doc ann)] -> f (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat ([f (Doc ann)] -> f (Doc ann))
-> ([f (Doc ann)] -> [f (Doc ann)]) -> [f (Doc ann)] -> f (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (Doc ann) -> f (Doc ann)) -> [f (Doc ann)] -> [f (Doc ann)]
forall a b. (a -> b) -> [a] -> [b]
map (f (Doc ann) -> Int -> f (Doc ann) -> f (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> Int -> f (Doc ann) -> f (Doc ann)
hang f (Doc ann)
bullet Int
2)

------------------------------------------------------------
-- Running a pretty-printer

renderDoc :: Sem (Reader PA ': r) (Doc ann) -> Sem r String
renderDoc :: forall (r :: EffectRow) ann.
Sem (Reader PA : r) (Doc ann) -> Sem r String
renderDoc = (Doc ann -> String) -> Sem r (Doc ann) -> Sem r String
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc ann -> String
forall ann. Doc ann -> String
renderDoc' (Sem r (Doc ann) -> Sem r String)
-> (Sem (Reader PA : r) (Doc ann) -> Sem r (Doc ann))
-> Sem (Reader PA : r) (Doc ann)
-> Sem r String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PA -> Sem (Reader PA : r) (Doc ann) -> Sem r (Doc ann)
forall i (r :: EffectRow) a. i -> Sem (Reader i : r) a -> Sem r a
runReader PA
initPA

renderDoc' :: Doc ann -> String
renderDoc' :: forall ann. Doc ann -> String
renderDoc' = SimpleDocStream ann -> String
forall ann. SimpleDocStream ann -> String
renderString (SimpleDocStream ann -> String)
-> (Doc ann -> SimpleDocStream ann) -> Doc ann -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty LayoutOptions
PP.defaultLayoutOptions