{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Calligraphy.Util.Printer where

import Control.Monad.RWS
import Control.Monad.State
import Data.Foldable
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as TB

newtype Printer a = Printer {Printer a -> RWS Int () Builder a
unPrinter :: RWS Int () Builder a}
  deriving newtype (a -> Printer b -> Printer a
(a -> b) -> Printer a -> Printer b
(forall a b. (a -> b) -> Printer a -> Printer b)
-> (forall a b. a -> Printer b -> Printer a) -> Functor Printer
forall a b. a -> Printer b -> Printer a
forall a b. (a -> b) -> Printer a -> Printer b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Printer b -> Printer a
$c<$ :: forall a b. a -> Printer b -> Printer a
fmap :: (a -> b) -> Printer a -> Printer b
$cfmap :: forall a b. (a -> b) -> Printer a -> Printer b
Functor, Functor Printer
a -> Printer a
Functor Printer
-> (forall a. a -> Printer a)
-> (forall a b. Printer (a -> b) -> Printer a -> Printer b)
-> (forall a b c.
    (a -> b -> c) -> Printer a -> Printer b -> Printer c)
-> (forall a b. Printer a -> Printer b -> Printer b)
-> (forall a b. Printer a -> Printer b -> Printer a)
-> Applicative Printer
Printer a -> Printer b -> Printer b
Printer a -> Printer b -> Printer a
Printer (a -> b) -> Printer a -> Printer b
(a -> b -> c) -> Printer a -> Printer b -> Printer c
forall a. a -> Printer a
forall a b. Printer a -> Printer b -> Printer a
forall a b. Printer a -> Printer b -> Printer b
forall a b. Printer (a -> b) -> Printer a -> Printer b
forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Printer a -> Printer b -> Printer a
$c<* :: forall a b. Printer a -> Printer b -> Printer a
*> :: Printer a -> Printer b -> Printer b
$c*> :: forall a b. Printer a -> Printer b -> Printer b
liftA2 :: (a -> b -> c) -> Printer a -> Printer b -> Printer c
$cliftA2 :: forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
<*> :: Printer (a -> b) -> Printer a -> Printer b
$c<*> :: forall a b. Printer (a -> b) -> Printer a -> Printer b
pure :: a -> Printer a
$cpure :: forall a. a -> Printer a
$cp1Applicative :: Functor Printer
Applicative, Applicative Printer
a -> Printer a
Applicative Printer
-> (forall a b. Printer a -> (a -> Printer b) -> Printer b)
-> (forall a b. Printer a -> Printer b -> Printer b)
-> (forall a. a -> Printer a)
-> Monad Printer
Printer a -> (a -> Printer b) -> Printer b
Printer a -> Printer b -> Printer b
forall a. a -> Printer a
forall a b. Printer a -> Printer b -> Printer b
forall a b. Printer a -> (a -> Printer b) -> Printer b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Printer a
$creturn :: forall a. a -> Printer a
>> :: Printer a -> Printer b -> Printer b
$c>> :: forall a b. Printer a -> Printer b -> Printer b
>>= :: Printer a -> (a -> Printer b) -> Printer b
$c>>= :: forall a b. Printer a -> (a -> Printer b) -> Printer b
$cp1Monad :: Applicative Printer
Monad)
  deriving (b -> Printer a -> Printer a
NonEmpty (Printer a) -> Printer a
Printer a -> Printer a -> Printer a
(Printer a -> Printer a -> Printer a)
-> (NonEmpty (Printer a) -> Printer a)
-> (forall b. Integral b => b -> Printer a -> Printer a)
-> Semigroup (Printer a)
forall b. Integral b => b -> Printer a -> Printer a
forall a. Semigroup a => NonEmpty (Printer a) -> Printer a
forall a. Semigroup a => Printer a -> Printer a -> Printer a
forall a b.
(Semigroup a, Integral b) =>
b -> Printer a -> Printer a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Printer a -> Printer a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> Printer a -> Printer a
sconcat :: NonEmpty (Printer a) -> Printer a
$csconcat :: forall a. Semigroup a => NonEmpty (Printer a) -> Printer a
<> :: Printer a -> Printer a -> Printer a
$c<> :: forall a. Semigroup a => Printer a -> Printer a -> Printer a
Semigroup, Semigroup (Printer a)
Printer a
Semigroup (Printer a)
-> Printer a
-> (Printer a -> Printer a -> Printer a)
-> ([Printer a] -> Printer a)
-> Monoid (Printer a)
[Printer a] -> Printer a
Printer a -> Printer a -> Printer a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (Printer a)
forall a. Monoid a => Printer a
forall a. Monoid a => [Printer a] -> Printer a
forall a. Monoid a => Printer a -> Printer a -> Printer a
mconcat :: [Printer a] -> Printer a
$cmconcat :: forall a. Monoid a => [Printer a] -> Printer a
mappend :: Printer a -> Printer a -> Printer a
$cmappend :: forall a. Monoid a => Printer a -> Printer a -> Printer a
mempty :: Printer a
$cmempty :: forall a. Monoid a => Printer a
$cp1Monoid :: forall a. Monoid a => Semigroup (Printer a)
Monoid) via (Ap Printer a)

type Prints a = a -> Printer ()

runPrinter :: Printer () -> Text
runPrinter :: Printer () -> Text
runPrinter (Printer RWS Int () Builder ()
p) = Text -> Text
TL.toStrict (Text -> Text) -> ((Builder, ()) -> Text) -> (Builder, ()) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TB.toLazyText (Builder -> Text)
-> ((Builder, ()) -> Builder) -> (Builder, ()) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder, ()) -> Builder
forall a b. (a, b) -> a
fst ((Builder, ()) -> Text) -> (Builder, ()) -> Text
forall a b. (a -> b) -> a -> b
$ RWS Int () Builder () -> Int -> Builder -> (Builder, ())
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS RWS Int () Builder ()
p Int
0 Builder
forall a. Monoid a => a
mempty

class Monad m => MonadPrint m where
  line :: Builder -> m ()
  indent :: m a -> m a

instance MonadPrint Printer where
  {-# INLINE indent #-}
  indent :: Printer a -> Printer a
indent (Printer RWS Int () Builder a
p) = RWS Int () Builder a -> Printer a
forall a. RWS Int () Builder a -> Printer a
Printer (RWS Int () Builder a -> Printer a)
-> RWS Int () Builder a -> Printer a
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> RWS Int () Builder a -> RWS Int () Builder a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) RWS Int () Builder a
p

  {-# INLINE line #-}
  line :: Builder -> Printer ()
line Builder
t = RWS Int () Builder () -> Printer ()
forall a. RWS Int () Builder a -> Printer a
Printer (RWS Int () Builder () -> Printer ())
-> RWS Int () Builder () -> Printer ()
forall a b. (a -> b) -> a -> b
$ do
    Int
n <- RWST Int () Builder Identity Int
forall r (m :: * -> *). MonadReader r m => m r
ask
    (Builder -> Builder) -> RWS Int () Builder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Builder -> Builder) -> RWS Int () Builder ())
-> (Builder -> Builder) -> RWS Int () Builder ()
forall a b. (a -> b) -> a -> b
$
      (Builder -> Builder -> Builder) -> Builder -> Builder -> Builder
forall a b c. (a -> b -> c) -> b -> a -> c
flip Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Builder -> Builder -> Builder) -> Builder -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
n (Char -> Builder
TB.singleton Char
' ')) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
'\n'

instance MonadPrint m => MonadPrint (StateT s m) where
  line :: Builder -> StateT s m ()
line = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (Builder -> m ()) -> Builder -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> m ()
forall (m :: * -> *). MonadPrint m => Builder -> m ()
line
  indent :: StateT s m a -> StateT s m a
indent (StateT s -> m (a, s)
m) = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ m (a, s) -> m (a, s)
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (m (a, s) -> m (a, s)) -> (s -> m (a, s)) -> s -> m (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m (a, s)
m

{-# INLINE brack #-}
brack :: MonadPrint m => String -> String -> m a -> m a
brack :: String -> String -> m a -> m a
brack String
pre String
post m a
inner = String -> m ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
pre m () -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a -> m a
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent m a
inner m a -> m () -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> m ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
post

{-# INLINE strLn #-}
strLn :: MonadPrint m => String -> m ()
strLn :: String -> m ()
strLn = Builder -> m ()
forall (m :: * -> *). MonadPrint m => Builder -> m ()
line (Builder -> m ()) -> (String -> Builder) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
TB.fromString

{-# INLINE textLn #-}
textLn :: MonadPrint m => Text -> m ()
textLn :: Text -> m ()
textLn = Builder -> m ()
forall (m :: * -> *). MonadPrint m => Builder -> m ()
line (Builder -> m ()) -> (Text -> Builder) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
TB.fromText

{-# INLINE showLn #-}
showLn :: (MonadPrint m, Show a) => a -> m ()
showLn :: a -> m ()
showLn = String -> m ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show