Evaluator.hs

-- | A general purpose evaluator; useful for evaluating 
-- languages/structures that need to:
--     * Access an environment
--     * Log messages or signal errors
--     * Generate free variables
--
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Evaluator where

import Control.Applicative 
import Control.Arrow (first)
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Map as M
import Data.Char

-- * Evaluator
--
--
-- The evaluator monad is used to sequence 
-- computations that can fail: 
--   Maybe a
--
-- Each computation has access to an environment
--   Reader env (Maybe a)
-- which can be used for variable substitutions 
--
-- It also maintains an integer state which can 
-- be used to generate new free variables.
--   ReaderT env (State Int) (Maybe a)
--
-- Lastly, it has access to a msg Writer, which 
-- is useful for logging messages. 
--   ReaderT env (StateT Int (Writer msg)) (Maybe a)
--
newtype Eval env msg a = Eval {
  runEval :: ReaderT env (StateT Int (Writer msg)) (Maybe a)} 

--
-- Unpacking an Eval looks like this:
--
--     ReaderT e (StateT Int (Writer m)) (Maybe a)
--   ~
--     e -> StateT Int (Writer m) (Maybe a)
--   ~
--     e -> Int -> Writer m ((Maybe a), Int)
--   ~
--     e -> Int -> (((Maybe a), Int), m)
--
-- So
--    
--    Eval env msg a  ~~  env -> Int -> (((Maybe a), Int) msg)
--


liftRT :: Monad m => a -> ReaderT env m (Maybe a)
liftRT = return . Just

instance Monoid msg => Functor (Eval env msg) where
  fmap f e = e >>= return . f

instance Monoid msg => Applicative (Eval env msg) where 
  pure = Eval . liftRT
  f <*> e = f >>= \f' -> e >>= return . f'

instance Monoid msg => Alternative (Eval env msg) where 
  empty = Eval (return Nothing)
  (Eval e1) <|> (Eval e2) = Eval (e1 >>= maybe e2 liftRT)

instance Monoid msg => Monad (Eval env msg) where 
  return = pure
  (Eval e) >>= f = Eval (e >>= maybe (return Nothing) (runEval . f))

instance Monoid msg => MonadReader env (Eval env msg) where 
  ask = Eval (ask >>= liftRT)
  local f (Eval e) = Eval (local f e)

instance Monoid msg => MonadWriter msg (Eval env msg) where
  tell w = Eval (tell w >>= liftRT)
  pass e = e >>= Eval . (pass . return >=> liftRT)
  listen (Eval e) = Eval (listen e >>= \(a,w) -> return $ fmap (\i -> (i, w)) a)

instance Monoid msg => MonadState Int (Eval env msg) where
  get = Eval (get >>= liftRT)
  put i = Eval (put i >>= liftRT)



-- ** Helper functions
--
annotate :: Eval env [msg] res -> msg -> Eval env [msg] res
annotate eval msg = tell [msg] >> eval 

(<?>) :: Eval env [msg] res -> msg -> Eval env [msg] res
(<?>) = annotate

fails :: Monoid msg => Eval env msg res
fails = empty

failsWith :: msg -> Eval env [msg] res
failsWith = annotate fails

succeeds :: Monoid msg => res -> Eval env msg res
succeeds = return 

succeedsWith :: Monoid msg => msg -> res -> Eval env [msg] res
succeedsWith msg res = annotate (succeeds res) msg

evalEval :: Monoid msg => Eval env msg res -> env -> (Maybe res, msg)
evalEval (Eval e) env = runWriter (evalStateT (runReaderT e env) 0)


-- ** Environments
--
type E k v = M.Map k v
type Env a = E String a

envLookup :: String -> Eval (Env b) [String] b
envLookup = envLookupWith M.lookup

envLookupWith :: (String -> env -> Maybe b) -> String -> Eval env [String] b
envLookupWith f k = asks (f k) >>=
  maybe (failsWith $ "Variable `" ++ k ++ "' not found") succeeds


-- ** Generating free variables
--
newFreeVar :: Monoid msg => Eval env msg String
newFreeVar = modify (+1) >> gets toVar

toVar :: Int -> String
toVar n | n < 20 = ['?', chr (n + ord 'e')]
        | otherwise = ['?', chr (mod n 20 + ord 'e')] ++ show (n `div` 20)