-- |
--
-- Module:      Language.Egison.Pretty.Pattern.Print
-- Description: Printer monad
-- Stability:   experimental
--
-- This module defines a pretty printing monad 'Print'.

module Language.Egison.Pretty.Pattern.Print
  ( Print
  , askMode
  , askContext
  , operatorOf
  , withContext
  , runPrint
  )
where

import qualified Data.Map                      as Map
                                                ( Map
                                                , empty
                                                , lookup
                                                , insert
                                                )
import           Control.Monad.Except           ( MonadError(..) )
import           Control.Monad.Reader           ( ReaderT
                                                , MonadReader(..)
                                                , runReaderT
                                                )

import           Language.Egison.Pretty.Pattern.Error
                                                ( Error(UnknownInfixOperator) )
import           Language.Egison.Pretty.Pattern.Context
                                                ( Context(World) )
import           Language.Egison.Pretty.Pattern.PrintMode
                                                ( PrintMode(..)
                                                , PrintFixity(..)
                                                , Fixity(..)
                                                )
import           Language.Egison.Pretty.Pattern.Operator
                                                ( Operator(..) )


type OperatorTable n = Map.Map n Operator

data Env n v e
  = Env { forall n v e. Env n v e -> PrintMode n v e
mode :: PrintMode n v e
        , forall n v e. Env n v e -> OperatorTable n
table :: OperatorTable n
        , forall n v e. Env n v e -> Context
context :: Context
        }

buildOperatorTable :: Ord n => [PrintFixity n] -> OperatorTable n
buildOperatorTable :: forall n. Ord n => [PrintFixity n] -> OperatorTable n
buildOperatorTable = (PrintFixity n -> OperatorTable n -> OperatorTable n)
-> OperatorTable n -> [PrintFixity n] -> OperatorTable n
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PrintFixity n -> OperatorTable n -> OperatorTable n
forall {n}.
Ord n =>
PrintFixity n -> Map n Operator -> Map n Operator
go OperatorTable n
forall k a. Map k a
Map.empty
 where
  go :: PrintFixity n -> Map n Operator -> Map n Operator
go fixity :: PrintFixity n
fixity@PrintFixity { fixity :: forall n. PrintFixity n -> Fixity n
fixity = Fixity { n
symbol :: n
symbol :: forall n. Fixity n -> n
symbol } } =
    n -> Operator -> Map n Operator -> Map n Operator
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert n
symbol (PrintFixity n -> Operator
forall {n}. PrintFixity n -> Operator
toOperator PrintFixity n
fixity)
  toOperator :: PrintFixity n -> Operator
toOperator PrintFixity { fixity :: forall n. PrintFixity n -> Fixity n
fixity = Fixity { Precedence
precedence :: Precedence
precedence :: forall n. Fixity n -> Precedence
precedence, Associativity
associativity :: Associativity
associativity :: forall n. Fixity n -> Associativity
associativity }, Text
printed :: Text
printed :: forall n. PrintFixity n -> Text
printed }
    = InfixOp { Precedence
precedence :: Precedence
precedence :: Precedence
precedence, Associativity
associativity :: Associativity
associativity :: Associativity
associativity, symbol :: Text
symbol = Text
printed }

initialEnv :: Ord n => PrintMode n v e -> Env n v e
initialEnv :: forall n v e. Ord n => PrintMode n v e -> Env n v e
initialEnv mode :: PrintMode n v e
mode@PrintMode { [PrintFixity n]
fixities :: [PrintFixity n]
fixities :: forall n v e. PrintMode n v e -> [PrintFixity n]
fixities } =
  Env { PrintMode n v e
mode :: PrintMode n v e
mode :: PrintMode n v e
mode, table :: OperatorTable n
table = [PrintFixity n] -> OperatorTable n
forall n. Ord n => [PrintFixity n] -> OperatorTable n
buildOperatorTable [PrintFixity n]
fixities, context :: Context
context = Context
World }

newtype Print n v e a = Print { forall n v e a.
Print n v e a -> ReaderT (Env n v e) (Either (Error n)) a
unParse :: ReaderT (Env n v e) (Either (Error n)) a }
  deriving newtype ((forall a b. (a -> b) -> Print n v e a -> Print n v e b)
-> (forall a b. a -> Print n v e b -> Print n v e a)
-> Functor (Print n v e)
forall a b. a -> Print n v e b -> Print n v e a
forall a b. (a -> b) -> Print n v e a -> Print n v e b
forall n v e a b. a -> Print n v e b -> Print n v e a
forall n v e a b. (a -> b) -> Print n v e a -> Print n v e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall n v e a b. (a -> b) -> Print n v e a -> Print n v e b
fmap :: forall a b. (a -> b) -> Print n v e a -> Print n v e b
$c<$ :: forall n v e a b. a -> Print n v e b -> Print n v e a
<$ :: forall a b. a -> Print n v e b -> Print n v e a
Functor, Functor (Print n v e)
Functor (Print n v e) =>
(forall a. a -> Print n v e a)
-> (forall a b.
    Print n v e (a -> b) -> Print n v e a -> Print n v e b)
-> (forall a b c.
    (a -> b -> c) -> Print n v e a -> Print n v e b -> Print n v e c)
-> (forall a b. Print n v e a -> Print n v e b -> Print n v e b)
-> (forall a b. Print n v e a -> Print n v e b -> Print n v e a)
-> Applicative (Print n v e)
forall a. a -> Print n v e a
forall a b. Print n v e a -> Print n v e b -> Print n v e a
forall a b. Print n v e a -> Print n v e b -> Print n v e b
forall a b. Print n v e (a -> b) -> Print n v e a -> Print n v e b
forall n v e. Functor (Print n v e)
forall a b c.
(a -> b -> c) -> Print n v e a -> Print n v e b -> Print n v e c
forall n v e a. a -> Print n v e a
forall n v e a b. Print n v e a -> Print n v e b -> Print n v e a
forall n v e a b. Print n v e a -> Print n v e b -> Print n v e b
forall n v e a b.
Print n v e (a -> b) -> Print n v e a -> Print n v e b
forall n v e a b c.
(a -> b -> c) -> Print n v e a -> Print n v e b -> Print n v e 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
$cpure :: forall n v e a. a -> Print n v e a
pure :: forall a. a -> Print n v e a
$c<*> :: forall n v e a b.
Print n v e (a -> b) -> Print n v e a -> Print n v e b
<*> :: forall a b. Print n v e (a -> b) -> Print n v e a -> Print n v e b
$cliftA2 :: forall n v e a b c.
(a -> b -> c) -> Print n v e a -> Print n v e b -> Print n v e c
liftA2 :: forall a b c.
(a -> b -> c) -> Print n v e a -> Print n v e b -> Print n v e c
$c*> :: forall n v e a b. Print n v e a -> Print n v e b -> Print n v e b
*> :: forall a b. Print n v e a -> Print n v e b -> Print n v e b
$c<* :: forall n v e a b. Print n v e a -> Print n v e b -> Print n v e a
<* :: forall a b. Print n v e a -> Print n v e b -> Print n v e a
Applicative, Applicative (Print n v e)
Applicative (Print n v e) =>
(forall a b.
 Print n v e a -> (a -> Print n v e b) -> Print n v e b)
-> (forall a b. Print n v e a -> Print n v e b -> Print n v e b)
-> (forall a. a -> Print n v e a)
-> Monad (Print n v e)
forall a. a -> Print n v e a
forall a b. Print n v e a -> Print n v e b -> Print n v e b
forall a b. Print n v e a -> (a -> Print n v e b) -> Print n v e b
forall n v e. Applicative (Print n v e)
forall n v e a. a -> Print n v e a
forall n v e a b. Print n v e a -> Print n v e b -> Print n v e b
forall n v e a b.
Print n v e a -> (a -> Print n v e b) -> Print n v e 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
$c>>= :: forall n v e a b.
Print n v e a -> (a -> Print n v e b) -> Print n v e b
>>= :: forall a b. Print n v e a -> (a -> Print n v e b) -> Print n v e b
$c>> :: forall n v e a b. Print n v e a -> Print n v e b -> Print n v e b
>> :: forall a b. Print n v e a -> Print n v e b -> Print n v e b
$creturn :: forall n v e a. a -> Print n v e a
return :: forall a. a -> Print n v e a
Monad)
  deriving newtype (MonadReader (Env n v e))
  deriving newtype (MonadError (Error n))

askMode :: Print n v e (PrintMode n v e)
askMode :: forall n v e. Print n v e (PrintMode n v e)
askMode = do
  Env { PrintMode n v e
mode :: forall n v e. Env n v e -> PrintMode n v e
mode :: PrintMode n v e
mode } <- Print n v e (Env n v e)
forall r (m :: * -> *). MonadReader r m => m r
ask
  PrintMode n v e -> Print n v e (PrintMode n v e)
forall a. a -> Print n v e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrintMode n v e
mode

askContext :: Print n v e Context
askContext :: forall n v e. Print n v e Context
askContext = do
  Env { Context
context :: forall n v e. Env n v e -> Context
context :: Context
context } <- Print n v e (Env n v e)
forall r (m :: * -> *). MonadReader r m => m r
ask
  Context -> Print n v e Context
forall a. a -> Print n v e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context
context

withContext :: Context -> Print n v e a -> Print n v e a
withContext :: forall n v e a. Context -> Print n v e a -> Print n v e a
withContext = (Env n v e -> Env n v e) -> Print n v e a -> Print n v e a
forall a.
(Env n v e -> Env n v e) -> Print n v e a -> Print n v e a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Env n v e -> Env n v e) -> Print n v e a -> Print n v e a)
-> (Context -> Env n v e -> Env n v e)
-> Context
-> Print n v e a
-> Print n v e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Env n v e -> Env n v e
forall {n} {v} {e}. Context -> Env n v e -> Env n v e
updateContext
  where updateContext :: Context -> Env n v e -> Env n v e
updateContext Context
context Env n v e
env = Env n v e
env { context }

runPrint
  :: (Ord n, MonadError (Error n) m) => Print n v e a -> PrintMode n v e -> m a
runPrint :: forall n (m :: * -> *) v e a.
(Ord n, MonadError (Error n) m) =>
Print n v e a -> PrintMode n v e -> m a
runPrint Print n v e a
p PrintMode n v e
mode = case ReaderT (Env n v e) (Either (Error n)) a
-> Env n v e -> Either (Error n) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Print n v e a -> ReaderT (Env n v e) (Either (Error n)) a
forall n v e a.
Print n v e a -> ReaderT (Env n v e) (Either (Error n)) a
unParse Print n v e a
p) (PrintMode n v e -> Env n v e
forall n v e. Ord n => PrintMode n v e -> Env n v e
initialEnv PrintMode n v e
mode) of
  Left  Error n
err -> Error n -> m a
forall a. Error n -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error n
err
  Right a
x   -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

operatorOf :: Ord n => n -> Print n v e Operator
operatorOf :: forall n v e. Ord n => n -> Print n v e Operator
operatorOf n
n = do
  Env { OperatorTable n
table :: forall n v e. Env n v e -> OperatorTable n
table :: OperatorTable n
table } <- Print n v e (Env n v e)
forall r (m :: * -> *). MonadReader r m => m r
ask
  case n -> OperatorTable n -> Maybe Operator
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
n OperatorTable n
table of
    Just Operator
op -> Operator -> Print n v e Operator
forall a. a -> Print n v e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Operator
op
    Maybe Operator
Nothing -> Error n -> Print n v e Operator
forall a. Error n -> Print n v e a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error n -> Print n v e Operator)
-> Error n -> Print n v e Operator
forall a b. (a -> b) -> a -> b
$ n -> Error n
forall n. n -> Error n
UnknownInfixOperator n
n