-----------------------------------------------------------------------------
-- |
-- 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.
--
-----------------------------------------------------------------------------

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

module Disco.Pretty.DSL where

import           Control.Applicative hiding (empty)
import           Data.String         (IsString (..))
import           Prelude             hiding ((<>))

import           Polysemy
import           Polysemy.Reader

import           Text.PrettyPrint    (Doc)
import qualified Text.PrettyPrint    as PP

import           Disco.Pretty.Prec

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

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

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

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

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

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

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

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

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

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

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

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

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

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

hang :: Applicative f => f Doc -> Int -> f Doc -> f Doc
hang :: f Doc -> Int -> f Doc -> f Doc
hang f Doc
d1 Int
n f Doc
d2 = Doc -> Int -> Doc -> Doc
PP.hang (Doc -> Int -> Doc -> Doc) -> f Doc -> f (Int -> Doc -> Doc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Doc
d1 f (Int -> Doc -> Doc) -> f Int -> f (Doc -> Doc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> f Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n f (Doc -> Doc) -> f Doc -> f Doc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f Doc
d2

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

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

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

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

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

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

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

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

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

renderDoc' :: Doc -> String
renderDoc' :: Doc -> String
renderDoc' = Doc -> String
PP.render