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

-- |
-- Module      :  Disco.Pretty.DSL
-- Copyright   :  disco team and contributors
-- Maintainer  :  byorgey@gmail.com
--
-- 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 = 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 = forall ann. [Doc ann] -> Doc ann
PP.vcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t 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 = forall ann. [Doc ann] -> Doc ann
PP.hcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t 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 = forall ann. [Doc ann] -> Doc ann
PP.hsep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (m :: * -> *) ann. Applicative m => String -> m (Doc ann)
text String
"⟅" forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> f (Doc ann)
p forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall ann. Int -> Doc ann -> Doc ann
PP.nest Int
n 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 = forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
n 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 forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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)
(<+>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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)
(<>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 = forall ann. Doc ann -> Doc ann -> Doc ann
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Doc ann)
d1 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 = 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 = forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
PP.punctuate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Doc ann)
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t 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' <- forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> [f (Doc ann)] -> f [f (Doc ann)]
punctuate f (Doc ann)
p [f (Doc ann)]
ds
  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 = forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ann. Doc ann -> String
renderDoc' forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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' = forall ann. SimpleDocStream ann -> String
renderString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty LayoutOptions
PP.defaultLayoutOptions