{- |
Module      : Language.Scheme.Macro.ExplicitRenaming
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

Maintainer  : github.com/justinethier
Stability   : experimental
Portability : portable

This module contains code for explicit renaming (ER) macros, and is
used by the Macro module to provide support for ER macros, both when 
called directly or when ER macros are found during macro expansion. 
This ensures both the er-macro-transformer and syntax-rules systems 
are compatible with each other.

Explicit renaming macros are based on the low-level facility from
Will Clinger's paper "Hygienic Macros Through Explicit Renaming",
which was developed to complement the high level specification
language (syntax-rules) from "Macros that Work".

-}

module Language.Scheme.Macro.ExplicitRenaming
    (
      explicitRenamingTransform
    ) where
import Language.Scheme.Types
import Language.Scheme.Variables
import Language.Scheme.Primitives (_gensym)
import Control.Monad.Except
-- import Debug.Trace

-- |Handle an explicit renaming macro
explicitRenamingTransform :: 
       Env -- ^Environment where macro was used
    -> Env -- ^Temporary environment to store renamed variables
    -> Env -- ^Environment containing any variables renamed by syntax-rules
    -> LispVal -- ^Form to transform
    -> LispVal -- ^Macro transformer
    -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Eval func
    -> IOThrowsError LispVal
explicitRenamingTransform :: Env
-> Env
-> Env
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
explicitRenamingTransform Env
useEnv Env
renameEnv Env
srRenameEnv LispVal
lisp 
                          transformer :: LispVal
transformer@(Func [String]
_ Maybe String
_ [LispVal]
_ Env
defEnv) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  let continuation :: LispVal
continuation = Env -> LispVal
makeNullContinuation Env
useEnv
  LispVal
result <- LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply 
    LispVal
continuation
    LispVal
transformer
    [LispVal
lisp, 
     ([LispVal] -> IOThrowsError LispVal) -> LispVal
IOFunc (([LispVal] -> IOThrowsError LispVal) -> LispVal)
-> ([LispVal] -> IOThrowsError LispVal) -> LispVal
forall a b. (a -> b) -> a -> b
$ Env -> Env -> Env -> Env -> [LispVal] -> IOThrowsError LispVal
exRename Env
useEnv Env
renameEnv Env
srRenameEnv Env
defEnv, 
     ([LispVal] -> IOThrowsError LispVal) -> LispVal
IOFunc (([LispVal] -> IOThrowsError LispVal) -> LispVal)
-> ([LispVal] -> IOThrowsError LispVal) -> LispVal
forall a b. (a -> b) -> a -> b
$ Env -> Env -> Env -> [LispVal] -> IOThrowsError LispVal
exCompare Env
useEnv Env
renameEnv Env
defEnv] 
  LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
result
explicitRenamingTransform Env
_ Env
_ Env
_ LispVal
_ LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = 
  LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"explicitRenamingTransform"

-- |The explicit renaming /rename/ function
--
-- From clinger's paper "Hygienic Macros Through Explicit Renaming":
--
-- The expression returned by the transformation procedure
-- will be expanded in the syntactic environment obtained
-- from the syntactic environment of the macro application
-- by binding any fresh identifiers in the syntactic
-- environment in which the macro was defined. This means
-- that a renamed identifier will denote the same thing as
-- the original identifier unless the transformation
-- procedure that renamed the identifier placed an
-- occurrence of it in a binding position.
--
-- The renaming procedure acts as a mathematical function
-- in the sense that the idenfiers obtained from any two
-- calls with the same argument will be the same in
-- the sense of eqv?. It is an error if the renaming
-- procedure is called after the transformation
-- procedure has returned.
exRename :: Env -> Env -> Env -> Env -> [LispVal] -> IOThrowsError LispVal
exRename :: Env -> Env -> Env -> Env -> [LispVal] -> IOThrowsError LispVal
exRename Env
useEnv Env
_ Env
srRenameEnv Env
defEnv [Atom String
a] = do
  Bool
isSynRulesRenamed <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
srRenameEnv String
a

  if Bool
isSynRulesRenamed -- already renamed by syntax-rules, so just return it
   then Env -> String -> IOThrowsError LispVal
getVar Env
srRenameEnv String
a
   else do
    Bool
isDef <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
defEnv String
a
    if Bool
isDef
     then do

       -- NOTE: useEnv/'r' is used to store renamed variables due
       --       to issues with separate invocations of er macros
       --       renaming the same variable differently within the
       --       same context. This caused the module meta language
       --       to not work properly...
       Maybe LispVal
r <- Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
useEnv Char
'r' String
a
       case Maybe LispVal
r of
         Just LispVal
renamed -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
renamed
         Maybe LispVal
Nothing -> do
            LispVal
value <- Env -> String -> IOThrowsError LispVal
getVar Env
defEnv String
a
            Atom String
renamed <- String -> IOThrowsError LispVal
_gensym String
a -- Unique name
            LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
useEnv String
renamed LispVal
value -- divert value to Use Env
            LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
useEnv Char
'r' String
a (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
renamed -- Record renamed sym

            -- Keep track of diverted values for use by the compiler
            List [LispVal]
diverted <- Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
useEnv Char
' ' String
"diverted"
            LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
setNamespacedVar Env
useEnv Char
' ' String
"diverted" (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
                [LispVal] -> LispVal
List ([LispVal]
diverted [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List [String -> LispVal
Atom String
renamed, String -> LispVal
Atom String
a]])

            LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
renamed
     else
       LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
a
exRename Env
_ Env
_ Env
_ Env
_ [LispVal]
form = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ String
"Unable to rename: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
form

-- |The explicit renaming /compare/ function
exCompare :: Env        -- ^ Environment of use
          -> Env        -- ^ Environment with renames
          -> Env        -- ^ Environment of definition
          -> [LispVal]  -- ^ Values to compare
          -> IOThrowsError LispVal
exCompare :: Env -> Env -> Env -> [LispVal] -> IOThrowsError LispVal
exCompare Env
_ Env
_ Env
_ [LispVal
a, LispVal
b] = do
  LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ LispVal -> LispVal -> Bool
eqVal LispVal
a LispVal
b
exCompare Env
_ Env
_ Env
_ [LispVal]
form = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
   String -> LispError
Default (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ String
"Unable to compare: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
form