DSL.hs

{-# 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 = 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 ds = PP.vcat <$> sequenceA ds

hcat :: Applicative f => [f (Doc ann)] -> f (Doc ann)
hcat ds = PP.hcat <$> sequenceA ds

hsep :: Applicative f => [f (Doc ann)] -> f (Doc ann)
hsep ds = PP.hsep <$> sequenceA ds

parens :: Functor f => f (Doc ann) -> f (Doc ann)
parens = fmap PP.parens

brackets :: Functor f => f (Doc ann) -> f (Doc ann)
brackets = fmap PP.brackets

braces :: Functor f => f (Doc ann) -> f (Doc ann)
braces = fmap PP.braces

bag :: Applicative f => f (Doc ann) -> f (Doc ann)
bag p = text "⟅" <> p <> text "⟆"

quotes :: Functor f => f (Doc ann) -> f (Doc ann)
quotes = fmap PP.squotes

doubleQuotes :: Functor f => f (Doc ann) -> f (Doc ann)
doubleQuotes = fmap PP.dquotes

text :: Applicative m => String -> m (Doc ann)
text = pure . fromString

integer :: Applicative m => Integer -> m (Doc ann)
integer = pure . PP.pretty

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

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

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

empty :: Applicative m => m (Doc ann)
empty = pure PP.emptyDoc

(<+>) :: Applicative f => f (Doc ann) -> f (Doc ann) -> f (Doc ann)
(<+>) = liftA2 (PP.<+>)

(<>) :: Applicative f => f (Doc ann) -> f (Doc ann) -> f (Doc ann)
(<>) = liftA2 (PP.<>)

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

punctuate :: Applicative f => f (Doc ann) -> [f (Doc ann)] -> f [f (Doc ann)]
punctuate p ds = map pure <$> (PP.punctuate <$> p <*> sequenceA ds)

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

bulletList :: Applicative f => f (Doc ann) -> [f (Doc ann)] -> f (Doc ann)
bulletList bullet = vcat . map (hang bullet 2)

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

renderDoc :: Sem (Reader PA ': r) (Doc ann) -> Sem r String
renderDoc = fmap renderDoc' . runReader initPA

renderDoc' :: Doc ann -> String
renderDoc' = renderString . PP.layoutPretty PP.defaultLayoutOptions