-- |
--
-- 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 { Env n v e -> PrintMode n v e
mode :: PrintMode n v e
        , Env n v e -> OperatorTable n
table :: OperatorTable n
        , Env n v e -> Context
context :: Context
        }

buildOperatorTable :: Ord n => [PrintFixity n] -> OperatorTable n
buildOperatorTable :: [PrintFixity n] -> OperatorTable n
buildOperatorTable = (PrintFixity n -> OperatorTable n -> OperatorTable n)
-> OperatorTable n -> [PrintFixity n] -> OperatorTable n
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 { $sel:fixity:PrintFixity :: forall n. PrintFixity n -> Fixity n
fixity = Fixity { n
$sel:symbol:Fixity :: forall n. Fixity n -> n
symbol :: 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 { $sel:fixity:PrintFixity :: forall n. PrintFixity n -> Fixity n
fixity = Fixity { Precedence
$sel:precedence:Fixity :: forall n. Fixity n -> Precedence
precedence :: Precedence
precedence, Associativity
$sel:associativity:Fixity :: forall n. Fixity n -> Associativity
associativity :: Associativity
associativity }, Text
$sel:printed:PrintFixity :: forall n. PrintFixity n -> Text
printed :: Text
printed }
    = InfixOp :: Associativity -> Precedence -> Text -> Operator
InfixOp { Precedence
$sel:precedence:InfixOp :: Precedence
precedence :: Precedence
precedence, Associativity
$sel:associativity:InfixOp :: Associativity
associativity :: Associativity
associativity, $sel:symbol:InfixOp :: Text
symbol = Text
printed }

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

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

askMode :: Print n v e (PrintMode n v e)
askMode :: Print n v e (PrintMode n v e)
askMode = do
  Env { PrintMode n v e
mode :: PrintMode n v e
$sel:mode:Env :: forall n v e. Env n v e -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure PrintMode n v e
mode

askContext :: Print n v e Context
askContext :: Print n v e Context
askContext = do
  Env { Context
context :: Context
$sel:context:Env :: forall n v e. Env n v e -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure Context
context

withContext :: Context -> Print n v e a -> Print n v e a
withContext :: 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 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
context :: Context
$sel:context:Env :: Context
context }

runPrint
  :: (Ord n, MonadError (Error n) m) => Print n v e a -> PrintMode n v e -> m a
runPrint :: 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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error n
err
  Right a
x   -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

operatorOf :: Ord n => n -> Print n v e Operator
operatorOf :: n -> Print n v e Operator
operatorOf n
n = do
  Env { OperatorTable n
table :: OperatorTable n
$sel:table:Env :: forall n v e. Env n v e -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure Operator
op
    Maybe Operator
Nothing -> Error n -> Print n v e Operator
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