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

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

This module contains code for hygienic macros.

Hygienic macros are implemented using the algorithm from the paper
Macros That Work by William Clinger and Jonathan Rees. During 
transformation, the following components are considered:

 - Pattern (part of a rule that matches input)

 - Transform (what the macro expands into)

 - Literal Identifiers (from the macro definition)

 - Input (the actual code in the user's program)

 - Environments of macro definition and macro use

At a high level, macro transformation is broken down into the following steps:

 (0) Walk the input code looking for a macro definition or macro call.
 
 (1) If a macro call is found, search for a rule that matches the input.
     During this process any pattern variables in the input are loaded 
     into a temporary environment

 (2) If a rule matches, transcribe the rule's template by walking the 
     template, inserting pattern variables and renaming free identifiers 
     as needed.

 (3) Walk the expanded code, checking for each of the cases from Macros That Work. If a 
     case is found (such as a macro call or procedure abstraction) then the appropriate 
     handler will be called to deal with it.
-}

module Language.Scheme.Macro
    (
      expand
    , macroEval
    , loadMacros  
    , getDivertedVars 
    ) where
import Language.Scheme.Types
import Language.Scheme.Variables
import Language.Scheme.Macro.ExplicitRenaming
import qualified Language.Scheme.Macro.Matches as Matches
import Language.Scheme.Primitives (_gensym)
import Control.Monad.Except
import Data.Array
-- import Debug.Trace -- Only req'd to support trace, can be disabled at any time...

{-
 Implementation notes:

 Nice FAQ regarding macro's, points out some of the limitations of current implementation
 http://community.schemewiki.org/?scheme-faq-macros

 -}

--
-- Notes regarding other side of hygiene.
--
-- !!!
-- Turns out this was unnecessary because it is sufficient to simply save the environment of
-- definition directly. Even though this causes problems with define, it seems that is how
-- other Schemes work, so it will stay that way for now. This note is being kept for the 
-- moment although it should probably go away... in any case only take it as brainstorming
-- notes and nothing further:
-- !!!
--
-- In order to handle the 'other side', the env at macro definition needs to be saved. It
-- will be used again when a macro is expanded. The pattern matcher will compare any named
-- identifiers it finds against both environments to ensure identifiers were not redefined.
--
-- Also, during rewrite identifiers are supposed to be read out of envDef. They are then 
-- diverted into envUse at the end of the macro transcription (in other words, once an
-- instance of rewrite is finished).
--
-- So... how do we preserve envDef? One idea is to create a deep copy of the env during
-- macro definition, but this could be error prone and expensive. Another idea is to
-- call extendEnv to create a new environment on top of envDef. This new environment
-- would then need to be passed along to eval (and presumably its current/next continuations).
--
-- This should work because any env changes would only affect the new environment and not
-- the parent one. The disadvantage is that macroEval is called in several places in Core.
-- It's calls will need to be modified to use a new function that will pass along the
-- extended env if necessary. I am a bit concerned about subtle errors occurring if any
-- continuations in the chain are not updated and still have the old environment in them.
-- It may be tricky to get this right. But otherwise the change *should* be straightforward.


-- |Get a list of variables that the macro hygiene 
--  subsystem diverted back into the calling environment.
--
--  This is a specialized function that is only
--  mean to be used by the husk compiler.
getDivertedVars :: Env -> IOThrowsError [LispVal]
getDivertedVars :: Env -> IOThrowsError [LispVal]
getDivertedVars Env
env = do
  List [LispVal]
tmp <- Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
env Char
' ' String
"diverted"
  [LispVal] -> IOThrowsError [LispVal]
forall (m :: * -> *) a. Monad m => a -> m a
return [LispVal]
tmp

clearDivertedVars :: Env -> IOThrowsError LispVal
clearDivertedVars :: Env -> IOThrowsError LispVal
clearDivertedVars Env
env = Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
env Char
' ' String
"diverted" (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List []

-- |Examines the input AST to see if it is a macro call. 
--  If a macro call is found, the code is expanded.
--  Otherwise the input is returned unchanged.
macroEval :: Env        -- ^Current environment for the AST
          -> LispVal    -- ^AST to search
          -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Eval func

          -> IOThrowsError LispVal -- ^Transformed AST containing an
                                   -- expanded macro if found

{- Inspect code for macros
 -
 - Only a list form is required because a pattern may only consist
 - of a list here. From the spec:
 -
 - "The <pattern> in a <syntax rule> is a list <pattern> that 
 -  begins with the keyword for the macro." 
 -
 -}
macroEval :: Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
macroEval Env
env lisp :: LispVal
lisp@(List (Atom String
_ : [LispVal]
_)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  -- Keep track of diverted variables
  LispVal
_ <- Env -> IOThrowsError LispVal
clearDivertedVars Env
env
  Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
_macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
_macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

-- |Do the actual work for the 'macroEval' wrapper func
_macroEval :: Env
           -> LispVal
           -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
           -> ExceptT LispError IO LispVal
_macroEval :: Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
_macroEval Env
env lisp :: LispVal
lisp@(List (Atom String
x : [LispVal]
_)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  -- Note: If there is a procedure of the same name it will be shadowed by the macro.
  Maybe LispVal
var <- Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
env Char
macroNamespace String
x
  -- DEBUG: var <- (trace ("expand: " ++ x) getNamespacedVar') env macroNamespace x
  case Maybe LispVal
var of
    -- Explicit Renaming
    Just (SyntaxExplicitRenaming transformer :: LispVal
transformer@(Func {})) -> do
      Env
renameEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
nullEnv -- Local environment used just for this
      LispVal
expanded <- Env
-> Env
-> Env
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
explicitRenamingTransform Env
env Env
renameEnv Env
renameEnv 
                                          LispVal
lisp LispVal
transformer LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
      Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
_macroEval Env
env LispVal
expanded LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

    -- Syntax Rules
    Just (Syntax (Just Env
defEnv) Maybe Env
_ Bool
definedInMacro String
ellipsis [LispVal]
identifiers [LispVal]
rules) -> do
      Env
renameEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
nullEnv -- Local environment used just for this
                                    -- invocation to hold renamed variables
      Env
cleanupEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
nullEnv -- Local environment used just for 
                                     -- this invocation to hold new symbols
                                     -- introduced by renaming. We can use
                                     -- this to clean up any left after 
                                     -- transformation

      -- Transform the input and then call macroEval again, 
      -- since a macro may be contained within...
      LispVal
expanded <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> [LispVal]
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> String
-> IOThrowsError LispVal
macroTransform [Env
defEnv] Env
env Env
env Env
renameEnv Env
cleanupEnv 
                                 Bool
definedInMacro 
                                ([LispVal] -> LispVal
List [LispVal]
identifiers) [LispVal]
rules LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
                                String
ellipsis
      Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
_macroEval Env
env LispVal
expanded LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
      -- Useful debug to see all exp's:
      -- macroEval env (trace ("exp = " ++ show expanded) expanded)
    Just 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
"_macroEval"
    Maybe LispVal
Nothing -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
lisp

-- No macro to process, just return code as it is...
_macroEval Env
_ LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
lisp

{-
 - Given input and syntax-rules, determine if any rule is a match and transform it.
 -
 - FUTURE: validate that the pattern's template and pattern are consistent 
 - (IE: no vars in transform that do not appear in matching pattern - csi "stmt1" case)
 -
 - Parameters:
 -  env - Higher level LISP environment
 -  identifiers - Literal identifiers - IE, atoms that should not be transformed
 -  rules - pattern/transform pairs to compare to input
 -  input - Code from the scheme application 
 -}
macroTransform :: 
     [Env]
  -> Env 
  -> Env 
  -> Env 
  -> Env 
  -> Bool 
  -> LispVal 
  -> [LispVal] 
  -> LispVal 
  -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Apply func
  -> String -- ^ Ellipsis symbol
  -> IOThrowsError LispVal
macroTransform :: [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> [LispVal]
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> String
-> IOThrowsError LispVal
macroTransform [Env]
defEnv Env
env Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers (rule :: LispVal
rule@(List [LispVal]
_) : [LispVal]
rs) LispVal
input LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply String
esym = do
  Env
localEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
nullEnv -- Local environment used just for this invocation
                               -- to hold pattern variables
  LispVal
result <- [Env]
-> Env
-> Env
-> Bool
-> LispVal
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> String
-> IOThrowsError LispVal
matchRule [Env]
defEnv Env
env Env
divertEnv Bool
dim LispVal
identifiers Env
localEnv Env
renameEnv Env
cleanupEnv LispVal
rule LispVal
input String
esym
  case LispVal
result of
    -- No match, check the next rule
    Nil String
_ -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> [LispVal]
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> String
-> IOThrowsError LispVal
macroTransform [Env]
defEnv Env
env Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers [LispVal]
rs LispVal
input LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply String
esym
    LispVal
_ -> do
        -- Walk the resulting code, performing the Clinger algorithm's 4 components
        [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
env Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
False ([LispVal] -> LispVal
List []) LispVal
result LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

-- Ran out of rules to match...
macroTransform [Env]
_ Env
_ Env
_ Env
_ Env
_ Bool
_ LispVal
_ [LispVal]
_ LispVal
input LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ String
_ = 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 -> LispVal -> LispError
BadSpecialForm String
"Input does not match a macro pattern" LispVal
input

-- Determine if the next element in a list matches 0-to-n times due to an ellipsis
macroElementMatchesMany :: LispVal -> String -> Bool
macroElementMatchesMany :: LispVal -> String -> Bool
macroElementMatchesMany (List (LispVal
_ : [LispVal]
ps)) String
ellipsisSym = do
  Bool -> Bool
not ([LispVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LispVal]
ps) Bool -> Bool -> Bool
&& (([LispVal] -> LispVal
forall a. [a] -> a
head [LispVal]
ps) LispVal -> LispVal -> Bool
forall a. Eq a => a -> a -> Bool
== (String -> LispVal
Atom String
ellipsisSym))
macroElementMatchesMany LispVal
_ String
_ = Bool
False

{- Given input, determine if that input matches any rules
@return Transformed code, or Nil if no rules match -}
matchRule :: [Env] -> Env -> Env -> Bool -> LispVal -> Env -> Env -> Env -> LispVal -> LispVal -> String -> IOThrowsError LispVal
matchRule :: [Env]
-> Env
-> Env
-> Bool
-> LispVal
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> String
-> IOThrowsError LispVal
matchRule [Env]
defEnv Env
outerEnv Env
divertEnv Bool
dim LispVal
identifiers Env
localEnv Env
renameEnv Env
cleanupEnv (List [LispVal
pattern, LispVal
template]) (List [LispVal]
inputVar) String
esym = do
   let is :: [LispVal]
is = [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
inputVar
   let p :: (LispVal, Bool)
p = case LispVal
pattern of
              DottedList [LispVal]
ds LispVal
d -> case [LispVal]
ds of
                                  -- Fix for Issue #44 - detect when pattern's match should 
                                  -- be modified from a pair to an ellipsis
                                  (Atom String
l : [LispVal]
ls) -> ([LispVal] -> LispVal
List [String -> LispVal
Atom String
l, [LispVal] -> LispVal -> LispVal
DottedList [LispVal]
ls LispVal
d], Bool
True)
                                  [LispVal]
_ -> (LispVal
pattern, Bool
False)
              LispVal
_ -> (LispVal
pattern, Bool
False)
   case (LispVal, Bool)
p of
      ((List (Atom String
_ : [LispVal]
ps)), Bool
flag) -> do
        LispVal
match <- [LispVal] -> [LispVal] -> Bool -> IOThrowsError LispVal
checkPattern [LispVal]
ps [LispVal]
is Bool
flag 
        case LispVal
match of
           Bool Bool
False -> 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
Nil String
""
           LispVal
_ -> do
                [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
0 [] ([LispVal] -> LispVal
List []) LispVal
template
      (LispVal, Bool)
_ -> 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 -> LispVal -> LispError
BadSpecialForm String
"Malformed rule in syntax-rules" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ String -> LispVal
String (String -> LispVal) -> String -> LispVal
forall a b. (a -> b) -> a -> b
$ (LispVal, Bool) -> String
forall a. Show a => a -> String
show (LispVal, Bool)
p

 where
   -- A pair at the outmost level must be transformed to use the ellipsis, 
   -- or else its nary match will not work properly during pattern matching. 
   checkPattern :: [LispVal] -> [LispVal] -> Bool -> IOThrowsError LispVal
checkPattern ps :: [LispVal]
ps@(DottedList [LispVal]
ds LispVal
d : [LispVal]
_) [LispVal]
is Bool
True = do
     case [LispVal]
is of
       (DottedList [LispVal]
_ LispVal
_ : [LispVal]
_) -> do 
         [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers 
                                  ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
ds [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
d, String -> LispVal
Atom String
esym])
                                  ([LispVal] -> LispVal
List [LispVal]
is)
                                   Int
0 []
                                  ([(Bool, Bool)] -> (Bool, Bool) -> Int -> [(Bool, Bool)]
flagDottedLists [] (Bool
False, Bool
False) (Int -> [(Bool, Bool)]) -> Int -> [(Bool, Bool)]
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([LispVal] -> Int) -> [LispVal] -> Int
forall a b. (a -> b) -> a -> b
$ (LispVal -> Bool) -> [LispVal] -> [LispVal]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> LispVal -> Bool
filterEsym String
esym) [LispVal]
ds)) -- Mark any ellipsis we are passing over
                                  String
esym
       (List [LispVal]
_ : [LispVal]
_) -> do 
         [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers 
                                  ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
ds [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
d, String -> LispVal
Atom String
esym])
                                  ([LispVal] -> LispVal
List [LispVal]
is)
                                   Int
0 []
                                  ([(Bool, Bool)] -> (Bool, Bool) -> Int -> [(Bool, Bool)]
flagDottedLists [] (Bool
True, Bool
False) (Int -> [(Bool, Bool)]) -> Int -> [(Bool, Bool)]
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([LispVal] -> Int) -> [LispVal] -> Int
forall a b. (a -> b) -> a -> b
$ (LispVal -> Bool) -> [LispVal] -> [LispVal]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> LispVal -> Bool
filterEsym String
esym) [LispVal]
ds)) -- Mark any ellipsis we are passing over
                                  String
esym
       [LispVal]
_ -> [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers ([LispVal] -> LispVal
List [LispVal]
ps) ([LispVal] -> LispVal
List [LispVal]
is) Int
0 [] [] String
esym

   -- No pair, immediately begin matching
   checkPattern [LispVal]
ps [LispVal]
is Bool
_ = [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers ([LispVal] -> LispVal
List [LispVal]
ps) ([LispVal] -> LispVal
List [LispVal]
is) Int
0 [] [] String
esym

matchRule [Env]
_ Env
_ Env
_ Bool
_ LispVal
_ Env
_ Env
_ Env
_ LispVal
rule LispVal
input String
_ = do
  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 -> LispVal -> LispError
BadSpecialForm String
"Malformed rule in syntax-rules" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"rule: ", LispVal
rule, String -> LispVal
Atom String
"input: ", LispVal
input]

{- loadLocal - Determine if pattern matches input, loading input into pattern variables as we go,
in preparation for macro transformation. -}
loadLocal :: [Env] -> Env -> Env -> Env -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> String -> IOThrowsError LispVal
loadLocal :: [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers LispVal
pattern LispVal
input Int
ellipsisLevel [Int]
ellipsisIndex [(Bool, Bool)]
listFlags String
esym = do
  --case (trace ("loadLocal [" ++ (show pattern) ++ "] [" ++ (show input) ++ "] flags = " ++ (show listFlags) ++ " ...lvl = " ++ (show ellipsisLevel) ++ " ...indx = " ++ (show ellipsisIndex)) (pattern, input)) of
  case (LispVal
pattern, LispVal
input) of

       ((DottedList [LispVal]
ps LispVal
p), (DottedList [LispVal]
isRaw LispVal
iRaw)) -> do
         
         -- Split input into two sections: 
         --   is - required inputs that must be present
         --   i  - variable length inputs to each compare against p 
         let isSplit :: ([LispVal], [LispVal])
isSplit = Int -> [LispVal] -> ([LispVal], [LispVal])
forall a. Int -> [a] -> ([a], [a])
splitAt ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
ps) [LispVal]
isRaw
         let is :: [LispVal]
is = ([LispVal], [LispVal]) -> [LispVal]
forall a b. (a, b) -> a
fst ([LispVal], [LispVal])
isSplit
         let i :: [LispVal]
i = (([LispVal], [LispVal]) -> [LispVal]
forall a b. (a, b) -> b
snd ([LispVal], [LispVal])
isSplit) [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
iRaw]

         LispVal
result <- [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers ([LispVal] -> LispVal
List [LispVal]
ps) ([LispVal] -> LispVal
List [LispVal]
is) Int
ellipsisLevel [Int]
ellipsisIndex [(Bool, Bool)]
listFlags String
esym
         case LispVal
result of
            Bool Bool
True -> --  By matching on an elipsis we force the code 
                         --  to match p against all elements in i. 
                         [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers 
                                  ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal
p, String -> LispVal
Atom String
esym]) 
                                  ([LispVal] -> LispVal
List [LispVal]
i)
                                   Int
ellipsisLevel -- Incremented in the list/list match below
                                   [Int]
ellipsisIndex
                                   ([(Bool, Bool)] -> (Bool, Bool) -> Int -> [(Bool, Bool)]
flagDottedLists [(Bool, Bool)]
listFlags (Bool
True, Bool
True) (Int -> [(Bool, Bool)]) -> Int -> [(Bool, Bool)]
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ellipsisIndex) -- Do not think we need to flag ... that are passed over, since this is a direct comparison of both cdr's
                                   String
esym
            LispVal
_ -> 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
False

       (List (LispVal
p : [LispVal]
ps), List (LispVal
i : [LispVal]
is)) -> do -- check first input against first pattern, recurse...

         let nextHasEllipsis :: Bool
nextHasEllipsis = LispVal -> String -> Bool
macroElementMatchesMany LispVal
pattern String
esym
         let level :: Int
level = if Bool
nextHasEllipsis then Int
ellipsisLevel Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                                        else Int
ellipsisLevel
         let idx :: [Int]
idx = if Bool
nextHasEllipsis 
                      then if ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ellipsisIndex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
level)
                              -- This is not the first match, increment existing index
                              then do
                                let l :: ([Int], [Int])
l = Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Int]
ellipsisIndex
                                (([Int], [Int]) -> [Int]
forall a b. (a, b) -> a
fst ([Int], [Int])
l) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [([Int] -> Int
forall a. [a] -> a
head (([Int], [Int]) -> [Int]
forall a b. (a, b) -> b
snd ([Int], [Int])
l)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1]
                              -- First input element that matches pattern; start at 0
                              else [Int]
ellipsisIndex [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
0]
                      else [Int]
ellipsisIndex

         -- At this point we know if the input is part of an ellipsis, so set the level accordingly 
         LispVal
status <- [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> Int
-> [Int]
-> LispVal
-> LispVal
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
checkLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers Int
level [Int]
idx LispVal
p LispVal
i [(Bool, Bool)]
listFlags String
esym
         case LispVal
status of
              -- No match
              Bool Bool
False -> if Bool
nextHasEllipsis
                                {- No match, must be finished with ...
                                Move past it, but keep the same input. -}
                                then do
                                        case [LispVal]
ps of
                                          [Atom String
_] -> 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
True -- An otherwise empty list, so just let the caller know match is done
                                          [LispVal]
_ -> [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ps) ([LispVal] -> LispVal
List (LispVal
i LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
is)) Int
ellipsisLevel [Int]
ellipsisIndex [(Bool, Bool)]
listFlags String
esym
                                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
$ Bool -> LispVal
Bool Bool
False
              -- There was a match
              LispVal
_ -> if Bool
nextHasEllipsis
                      then 
                           [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers LispVal
pattern ([LispVal] -> LispVal
List [LispVal]
is)
                            Int
ellipsisLevel -- Do not increment level, just wait until the next go-round when it will be incremented above
                            [Int]
idx -- Must keep index since it is incremented each time
                            [(Bool, Bool)]
listFlags
                            String
esym
                      else [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers ([LispVal] -> LispVal
List [LispVal]
ps) ([LispVal] -> LispVal
List [LispVal]
is) Int
ellipsisLevel [Int]
ellipsisIndex [(Bool, Bool)]
listFlags String
esym

       -- Base case - All data processed
       (List [], List []) -> 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
True

       -- Ran out of input to process
       (List (LispVal
_ : [LispVal]
_), List []) -> do
         if (LispVal -> String -> Bool
macroElementMatchesMany LispVal
pattern String
esym)
            then do
              -- Ensure any patterns that are not present in the input still
              -- have their variables initialized so they are ready during transformation
              -- Note:
              -- Appending to eIndex to compensate for fact we are outside the list containing the nary match 
              let flags :: (Bool, Bool)
flags = [Int] -> [(Bool, Bool)] -> (Bool, Bool)
getListFlags ([Int]
ellipsisIndex [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
0]) [(Bool, Bool)]
listFlags
              [Env]
-> Env
-> Env
-> LispVal
-> LispVal
-> Bool
-> String
-> IOThrowsError LispVal
flagUnmatchedVars [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers LispVal
pattern ((Bool, Bool) -> Bool
forall a b. (a, b) -> a
fst (Bool, Bool)
flags) String
esym
            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
$ Bool -> LispVal
Bool Bool
False

       -- Pattern ran out, but there is still input. No match.
       (List [], LispVal
_) -> 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
False

       -- Check input against pattern (both should be single var)
       (LispVal
_, LispVal
_) -> [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> Int
-> [Int]
-> LispVal
-> LispVal
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
checkLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers Int
ellipsisLevel [Int]
ellipsisIndex LispVal
pattern LispVal
input [(Bool, Bool)]
listFlags String
esym

--
-- |Utility function to flag pattern variables as 'no match' that exist in the 
--  pattern after input has run out. Note that this can only happen if the 
--  remaining pattern is part of a zero-or-more match.
--
-- Extended for Issue #42 -
-- Flag whether an unmatched pattern variable was part of an improper list in the pattern
-- This information is necessary for use during transformation, where the output may
-- change depending upon the form of the input.
--
flagUnmatchedVars :: [Env] -> Env -> Env -> LispVal -> LispVal -> Bool -> String -> IOThrowsError LispVal 

flagUnmatchedVars :: [Env]
-> Env
-> Env
-> LispVal
-> LispVal
-> Bool
-> String
-> IOThrowsError LispVal
flagUnmatchedVars [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers (DottedList [LispVal]
ps LispVal
p) Bool
partOfImproperPattern String
esym = do
  [Env]
-> Env
-> Env
-> LispVal
-> LispVal
-> Bool
-> String
-> IOThrowsError LispVal
flagUnmatchedVars [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
ps [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
p]) Bool
partOfImproperPattern String
esym

flagUnmatchedVars [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers (Vector Array Int LispVal
p) Bool
partOfImproperPattern String
esym = do
  [Env]
-> Env
-> Env
-> LispVal
-> LispVal
-> Bool
-> String
-> IOThrowsError LispVal
flagUnmatchedVars [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
p) Bool
partOfImproperPattern String
esym

flagUnmatchedVars [Env]
_ Env
_ Env
_ LispVal
_ (List []) Bool
_ String
_ = 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
True 

flagUnmatchedVars [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers (List (LispVal
p : [LispVal]
ps)) Bool
partOfImproperPattern String
esym = do
  LispVal
_ <- [Env]
-> Env
-> Env
-> LispVal
-> LispVal
-> Bool
-> String
-> IOThrowsError LispVal
flagUnmatchedVars [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers LispVal
p Bool
partOfImproperPattern String
esym
  [Env]
-> Env
-> Env
-> LispVal
-> LispVal
-> Bool
-> String
-> IOThrowsError LispVal
flagUnmatchedVars [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers ([LispVal] -> LispVal
List [LispVal]
ps) Bool
partOfImproperPattern String
esym

flagUnmatchedVars [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers (Atom String
p) Bool
partOfImproperPattern String
esym =
  if String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
esym
     then 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
True
     else [Env]
-> Env -> Env -> LispVal -> String -> Bool -> IOThrowsError LispVal
flagUnmatchedAtom [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers String
p Bool
partOfImproperPattern

flagUnmatchedVars [Env]
_ Env
_ Env
_ LispVal
_ LispVal
_ Bool
_ String
_ = 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
True 

-- |Flag an atom that did not have any matching input
--
--  Note that an atom may not be flagged in certain cases, for example if
--  the var is lexically defined in the outer environment. This logic
--  matches that in the pattern matching code.
flagUnmatchedAtom :: [Env] -> Env -> Env -> LispVal -> String -> Bool -> IOThrowsError LispVal 
flagUnmatchedAtom :: [Env]
-> Env -> Env -> LispVal -> String -> Bool -> IOThrowsError LispVal
flagUnmatchedAtom [Env]
defEnv Env
outerEnv Env
localEnv LispVal
identifiers String
p Bool
improperListFlag = do
  Bool
isDefined <- 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
isBound Env
localEnv String
p
  LispVal
isIdent <- LispVal -> LispVal -> IOThrowsError LispVal
findAtom (String -> LispVal
Atom String
p) LispVal
identifiers
  if Bool
isDefined
     -- Var already defined, skip it...
     then IOThrowsError LispVal
continueFlagging
     else case LispVal
isIdent of
             Bool Bool
True -> do
                           Bool
matches <- Env -> Env -> String -> ExceptT LispError IO Bool
identifierMatches ([Env] -> Env
forall a. [a] -> a
head [Env]
defEnv) Env
outerEnv String
p
                           if Bool -> Bool
not Bool
matches 
                             then 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
True
                             else do LispVal
_ <- Env -> String -> Bool -> IOThrowsError LispVal
flagUnmatchedVar Env
localEnv String
p Bool
improperListFlag
                                     IOThrowsError LispVal
continueFlagging
             LispVal
_ -> do LispVal
_ <- Env -> String -> Bool -> IOThrowsError LispVal
flagUnmatchedVar Env
localEnv String
p Bool
improperListFlag 
                     IOThrowsError LispVal
continueFlagging
 where continueFlagging :: IOThrowsError LispVal
continueFlagging = 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
True 

-- |Flag a pattern variable that did not have any matching input
flagUnmatchedVar :: Env -> String -> Bool -> IOThrowsError LispVal
flagUnmatchedVar :: Env -> String -> Bool -> IOThrowsError LispVal
flagUnmatchedVar Env
localEnv String
var Bool
improperListFlag = do
  LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
localEnv String
var (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Nil String
"" -- Empty nil will signify the empty match
  Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
localEnv 
                      Char
'_' -- "unmatched nary pattern variable" 
                      String
var (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
$ Bool
improperListFlag

{- 
 - Utility function to insert a True flag to the proper trailing position of the DottedList indicator list
 - to indicate a dotted (improper) list in the pattern (fst) or input (snd)
 - -}
flagDottedLists :: [(Bool, Bool)] -> (Bool, Bool) -> Int -> [(Bool, Bool)]
flagDottedLists :: [(Bool, Bool)] -> (Bool, Bool) -> Int -> [(Bool, Bool)]
flagDottedLists [(Bool, Bool)]
listFlags (Bool, Bool)
status Int
lengthOfEllipsisIndex
 | [(Bool, Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Bool)]
listFlags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lengthOfEllipsisIndex = [(Bool, Bool)]
listFlags [(Bool, Bool)] -> [(Bool, Bool)] -> [(Bool, Bool)]
forall a. [a] -> [a] -> [a]
++ [(Bool, Bool)
status]
   -- Pad the original list with False flags, and append our status flags at the end
 | Bool
otherwise = [(Bool, Bool)]
listFlags [(Bool, Bool)] -> [(Bool, Bool)] -> [(Bool, Bool)]
forall a. [a] -> [a] -> [a]
++ (Int -> (Bool, Bool) -> [(Bool, Bool)]
forall a. Int -> a -> [a]
replicate (Int
lengthOfEllipsisIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
- ([(Bool, Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Bool)]
listFlags)) (Bool
False, Bool
False)) [(Bool, Bool)] -> [(Bool, Bool)] -> [(Bool, Bool)]
forall a. [a] -> [a] -> [a]
++ [(Bool, Bool)
status]

-- Get pair of list flags that are at depth of ellipIndex, or False if flags do not exist (means improper not flagged)
getListFlags :: [Int] -> [(Bool, Bool)] -> (Bool, Bool)
getListFlags :: [Int] -> [(Bool, Bool)] -> (Bool, Bool)
getListFlags [Int]
elIndices [(Bool, Bool)]
flags 
  | Bool -> Bool
not ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
elIndices) Bool -> Bool -> Bool
&& [(Bool, Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Bool)]
flags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
elIndices = [(Bool, Bool)]
flags [(Bool, Bool)] -> Int -> (Bool, Bool)
forall a. [a] -> Int -> a
!! (([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
elIndices) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  | Bool
otherwise = (Bool
False, Bool
False)

-- ^ Check pattern against input to determine if there is a match
checkLocal :: [Env]          -- ^ Environment where the macro was defined
           -> Env            -- ^ Outer environment where this macro was called
           -> Env            -- ^ Outer env that the macro may divert values back to
           -> Env            -- ^ Local environment used to store temporary variables for macro processing
           -> Env            -- ^ Local environment used to store vars that have been renamed by the macro subsystem 
           -> LispVal        -- ^ List of identifiers specified in the syntax-rules
           -> Int            -- ^ Current nary (ellipsis) level
           -> [Int]          -- ^ Ellipsis Index, keeps track of the current nary (ellipsis) depth at each level 
           -> LispVal        -- ^ Pattern to match
           -> LispVal        -- ^ Input to be matched
           -> [(Bool, Bool)] -- ^ Flags to determine whether input pattern/variables are proper lists
           -> String         -- ^ Symbol used to specify ellipsis (IE, 0 or many match)
           -> IOThrowsError LispVal
checkLocal :: [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> Int
-> [Int]
-> LispVal
-> LispVal
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
checkLocal [Env]
_ Env
_ Env
_ Env
_ Env
_ LispVal
_ Int
_ [Int]
_ (Bool Bool
pattern) (Bool Bool
input) [(Bool, Bool)]
_ String
_ = 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
$ Bool
pattern Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
input
checkLocal [Env]
_ Env
_ Env
_ Env
_ Env
_ LispVal
_ Int
_ [Int]
_ (Number Integer
pattern) (Number Integer
input) [(Bool, Bool)]
_ String
_ = 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
$ Integer
pattern Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
input
checkLocal [Env]
_ Env
_ Env
_ Env
_ Env
_ LispVal
_ Int
_ [Int]
_ (Float Double
pattern) (Float Double
input) [(Bool, Bool)]
_ String
_ = 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
$ Double
pattern Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
input
checkLocal [Env]
_ Env
_ Env
_ Env
_ Env
_ LispVal
_ Int
_ [Int]
_ (String String
pattern) (String String
input) [(Bool, Bool)]
_ String
_ = 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
$ String
pattern String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
input
checkLocal [Env]
_ Env
_ Env
_ Env
_ Env
_ LispVal
_ Int
_ [Int]
_ (Char Char
pattern) (Char Char
input) [(Bool, Bool)]
_ String
_ = 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
$ Char
pattern Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
input
checkLocal [Env]
defEnv Env
outerEnv Env
_ Env
localEnv Env
renameEnv LispVal
identifiers Int
ellipsisLevel [Int]
ellipsisIndex (Atom String
pattern) LispVal
input [(Bool, Bool)]
listFlags String
_ = do
  -- This code mostly just loads up pattern variables, but it also needs to be
  -- careful to take into account literal identifiers. From spec:
  --
  -- Identifiers that appear in <literals> are interpreted as literal identifiers 
  -- to be matched against corresponding subforms of the input. A subform in the input 
  -- matches a literal identifier if and only if it is an identifier and either both 
  -- its occurrence in the macro expression and its occurrence in the macro definition 
  -- have the same lexical binding, or the two identifiers are equal and both have no 
  -- lexical binding.
  Bool
isRenamed <- 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
renameEnv String
pattern
  Bool
doesIdentMatch <- Env -> Env -> String -> ExceptT LispError IO Bool
identifierMatches ([Env] -> Env
forall a. [a] -> a
head [Env]
defEnv) Env
outerEnv String
pattern
  Int
match <- Bool -> Bool -> IOThrowsError Int
haveMatch Bool
isRenamed Bool
doesIdentMatch

  if Int
match Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 
     then 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
False
     else if Int
ellipsisLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
             -- Var is part of a 0-to-many match, store up in a list...
             then do Bool
isDefined <- 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
isBound Env
localEnv String
pattern
                     if Int
match Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -- Literal identifier
                        then Bool -> Int -> [Int] -> String -> LispVal -> IOThrowsError LispVal
forall p.
Bool -> p -> [Int] -> String -> LispVal -> IOThrowsError LispVal
addPatternVar Bool
isDefined Int
ellipsisLevel [Int]
ellipsisIndex String
pattern (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
pattern
                        else Bool -> Int -> [Int] -> String -> LispVal -> IOThrowsError LispVal
forall p.
Bool -> p -> [Int] -> String -> LispVal -> IOThrowsError LispVal
addPatternVar Bool
isDefined Int
ellipsisLevel [Int]
ellipsisIndex String
pattern LispVal
input
             -- Simple var, try to load up into macro env
             else do
                  LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
localEnv String
pattern LispVal
input
                  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
True
    where
      haveMatch :: Bool -> Bool -> IOThrowsError Int
      haveMatch :: Bool -> Bool -> IOThrowsError Int
haveMatch Bool
isRenamed Bool
doesIdentMatch = do
         LispVal
isIdent <- LispVal -> LispVal -> IOThrowsError LispVal
findAtom (String -> LispVal
Atom String
pattern) LispVal
identifiers
         case LispVal
isIdent of
            -- Literal identifier in pattern, do we have a match?
            Bool Bool
True -> do
                case LispVal
input of
                    Atom String
inpt -> do
                        String
p' <- Env -> String -> IOThrowsError String
getOrigName Env
renameEnv String
pattern
                        String
i' <- Env -> String -> IOThrowsError String
getOrigName Env
renameEnv String
inpt
                        Bool
pl <- Env -> Env -> String -> ExceptT LispError IO Bool
isLexicallyDefined Env
outerEnv Env
renameEnv String
pattern
                        Bool
il <- Env -> Env -> String -> ExceptT LispError IO Bool
isLexicallyDefined Env
outerEnv Env
renameEnv String
inpt
                        if (((String
p' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
i' Bool -> Bool -> Bool
&& Bool
doesIdentMatch) Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
isRenamed)) Bool -> Bool -> Bool
|| 
                            -- Equal and neither have a lexical binding, per spec
                            (String
p' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
i' Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
pl) Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
il)))
                           then Int -> IOThrowsError Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
                           else Int -> IOThrowsError Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
                    -- Pattern/Input cannot match because input is not an atom
                    LispVal
_ -> Int -> IOThrowsError Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

            -- No literal identifier, just load up the var
            LispVal
_ -> Int -> IOThrowsError Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
2

      -- Store pattern variable in a nested list
      -- FUTURE: ellipsisLevel should probably be used here for validation.
      -- 
      -- some notes:
      --  (above): need to flag the ellipsisLevel of this variable.
      --  also, it is an error if, for an existing var, ellipsisLevel input does not match the var's stored level
      --
      addPatternVar :: Bool -> p -> [Int] -> String -> LispVal -> IOThrowsError LispVal
addPatternVar Bool
isDefined p
ellipLevel [Int]
ellipIndex String
pat LispVal
val
        | Bool
isDefined = do LispVal
v <- Env -> String -> IOThrowsError LispVal
getVar Env
localEnv String
pat
--                         case (trace ("addPV pat = " ++ show pat ++ " v = " ++ show v) v) of
                         case LispVal
v of
                            Nil String
_ -> do
                              -- What's going on here is that the pattern var was found
                              -- before but not set as a pattern variable because it
                              -- was flagged as an unmatched var because input ran out
                              -- before it was found. So we need to define it at this step.
                              --
                              -- This feels like a special case that should be handled
                              -- in a more generic way. Anyhow, it seems to work fine for
                              -- the moment, but we may need to revisit this down the road.
                              LispVal
_ <- p -> [Int] -> String -> LispVal -> IOThrowsError LispVal
forall p. p -> [Int] -> String -> LispVal -> IOThrowsError LispVal
initializePatternVar p
ellipLevel [Int]
ellipIndex String
pat LispVal
val
                              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
False
                            LispVal
_ -> do LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
setVar Env
localEnv String
pat (LispVal -> [Int] -> LispVal -> LispVal
Matches.setData LispVal
v [Int]
ellipIndex LispVal
val)
                                    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
True
        | Bool
otherwise = do
            LispVal
_ <- p -> [Int] -> String -> LispVal -> IOThrowsError LispVal
forall p. p -> [Int] -> String -> LispVal -> IOThrowsError LispVal
initializePatternVar p
ellipLevel [Int]
ellipIndex String
pat LispVal
val
            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
True

      -- Define a pattern variable that is seen for the first time
      initializePatternVar :: p -> [Int] -> String -> LispVal -> IOThrowsError LispVal
initializePatternVar p
_ [Int]
ellipIndex String
pat LispVal
val = do
        let flags :: (Bool, Bool)
flags = [Int] -> [(Bool, Bool)] -> (Bool, Bool)
getListFlags [Int]
ellipIndex [(Bool, Bool)]
listFlags 
        LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
localEnv String
pat (LispVal -> [Int] -> LispVal -> LispVal
Matches.setData ([LispVal] -> LispVal
List []) [Int]
ellipIndex LispVal
val)
        LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
localEnv Char
'p' {-"improper pattern"-} String
pat (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
$ (Bool, Bool) -> Bool
forall a b. (a, b) -> a
fst (Bool, Bool)
flags
        Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
localEnv Char
'i' {-"improper input"-} String
pat (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
$ (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Bool, Bool)
flags

checkLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers Int
ellipsisLevel [Int]
ellipsisIndex (Vector Array Int LispVal
p) (Vector Array Int LispVal
i) [(Bool, Bool)]
flags String
esym =
  -- For vectors, just use list match for now, since vector input matching just requires a
  -- subset of that behavior. Should be OK since parser would catch problems with trying
  -- to add pair syntax to a vector declaration. -}
  [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
p) ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
i) Int
ellipsisLevel [Int]
ellipsisIndex [(Bool, Bool)]
flags String
esym

checkLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers Int
ellipsisLevel [Int]
ellipsisIndex pattern :: LispVal
pattern@(DottedList [LispVal]
_ LispVal
_) input :: LispVal
input@(DottedList [LispVal]
_ LispVal
_) [(Bool, Bool)]
flags String
esym =
  [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers LispVal
pattern LispVal
input Int
ellipsisLevel [Int]
ellipsisIndex [(Bool, Bool)]
flags String
esym

checkLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers Int
ellipsisLevel [Int]
ellipsisIndex (DottedList [LispVal]
ps LispVal
p) input :: LispVal
input@(List (LispVal
_ : [LispVal]
_)) [(Bool, Bool)]
flags String
esym = do
  [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers 
                                  ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
ps [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
p, String -> LispVal
Atom String
esym])
                                  LispVal
input
                                   Int
ellipsisLevel -- Incremented in the list/list match below
                                   [Int]
ellipsisIndex
                                   ([(Bool, Bool)] -> (Bool, Bool) -> Int -> [(Bool, Bool)]
flagDottedLists [(Bool, Bool)]
flags (Bool
True, Bool
False) (Int -> [(Bool, Bool)]) -> Int -> [(Bool, Bool)]
forall a b. (a -> b) -> a -> b
$ ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ellipsisIndex) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([LispVal] -> Int) -> [LispVal] -> Int
forall a b. (a -> b) -> a -> b
$ (LispVal -> Bool) -> [LispVal] -> [LispVal]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> LispVal -> Bool
filterEsym String
esym) [LispVal]
ps)) -- Mark any ellipsis in the list that we are passing over
                                   String
esym
checkLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers Int
ellipsisLevel [Int]
ellipsisIndex pattern :: LispVal
pattern@(List [LispVal]
_) input :: LispVal
input@(List [LispVal]
_) [(Bool, Bool)]
flags String
esym =
  [Env]
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> LispVal
-> LispVal
-> Int
-> [Int]
-> [(Bool, Bool)]
-> String
-> IOThrowsError LispVal
loadLocal [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv LispVal
identifiers LispVal
pattern LispVal
input Int
ellipsisLevel [Int]
ellipsisIndex [(Bool, Bool)]
flags String
esym

checkLocal [Env]
_ Env
_ Env
_ Env
_ Env
_ LispVal
_ Int
_ [Int]
_ LispVal
_ LispVal
_ [(Bool, Bool)]
_ String
_ = 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
False

-- |Helper for filter, remove all lispvals that are not the ellipsis marker
filterEsym :: String -> LispVal -> Bool
filterEsym :: String -> LispVal -> Bool
filterEsym String
esym (Atom String
a) = String
esym String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
a
filterEsym String
_ LispVal
_ = Bool
False

-- |Determine if an identifier in a pattern matches an identifier of the same
--  name in the input.
--
-- Note that identifiers are lexically scoped: bindings that intervene
-- between the definition and use of a macro may cause match failure
--
-- TODO: what if var is a macro or a special form?
--
-- TODO: what about vars that are introduced during macro expansion, that are not
-- yet defined in an Env? This may be a future TBD
--
identifierMatches :: Env -> Env -> String -> IOThrowsError Bool
identifierMatches :: Env -> Env -> String -> ExceptT LispError IO Bool
identifierMatches Env
defEnv Env
useEnv String
ident = do
  Bool
atDef <- 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
ident
  Bool
atUse <- 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
useEnv String
ident
  Bool -> Bool -> ExceptT LispError IO Bool
matchIdent Bool
atDef Bool
atUse

 where
  matchIdent :: Bool -> Bool -> ExceptT LispError IO Bool
matchIdent Bool
False Bool
False = Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- Never defined, so match
  matchIdent Bool
True Bool
True = do -- Defined in both places, check for equality
    LispVal
d <- Env -> String -> IOThrowsError LispVal
getVar Env
defEnv String
ident
    LispVal
u <- Env -> String -> IOThrowsError LispVal
getVar Env
useEnv String
ident
    Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ExceptT LispError IO Bool)
-> Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ LispVal -> LispVal -> Bool
eqVal LispVal
d LispVal
u 
  matchIdent Bool
_ Bool
_ = Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- Not defined in one place, reject it 

-- |This function walks the given block of code using the macro expansion algorithm,
--  recursively expanding macro calls as they are encountered.
expand :: 
     Env       -- ^Environment of the code being expanded
  -> Bool      -- ^True if the macro was defined within another macro
  -> LispVal   -- ^Code to expand
  -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Apply func
  -> IOThrowsError LispVal -- ^Expanded code
expand :: Env
-> Bool
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
expand Env
env Bool
dim LispVal
code LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  Env
renameEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
nullEnv
  Env
cleanupEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
nullEnv
  -- Keep track of diverted variables
  LispVal
_ <- Env -> IOThrowsError LispVal
clearDivertedVars Env
env
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env
env] Env
env Env
env Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
False ([LispVal] -> LispVal
List []) LispVal
code LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

-- |Walk expanded code per Clinger's algorithm from Macros That Work
walkExpanded :: [Env]
  -> Env 
  -> Env 
  -> Env 
  -> Env 
  -> Bool 
  -> Bool 
  -> Bool 
  -> LispVal 
  -> LispVal 
  -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Apply func
  -> IOThrowsError LispVal
walkExpanded :: [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ Bool
isQuoted (List [LispVal]
result) (List (List [LispVal]
l : [LispVal]
ls)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  LispVal
lst <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
isQuoted ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal]
l) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
isQuoted ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
lst]) ([LispVal] -> LispVal
List [LispVal]
ls) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ Bool
isQuoted (List [LispVal]
result) (List ((Vector Array Int LispVal
v) : [LispVal]
vs)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  List [LispVal]
lst <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
isQuoted ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
isQuoted ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
asVector [LispVal]
lst]) ([LispVal] -> LispVal
List [LispVal]
vs) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ Bool
isQuoted (List [LispVal]
result) (List ((DottedList [LispVal]
ds LispVal
d) : [LispVal]
ts)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  List [LispVal]
ls <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
isQuoted ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal]
ds) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
  LispVal
l <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
isQuoted ([LispVal] -> LispVal
List []) LispVal
d LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
isQuoted ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal -> LispVal
DottedList [LispVal]
ls LispVal
l]) ([LispVal] -> LispVal
List [LispVal]
ts) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
startOfList Bool
inputIsQuoted (List [LispVal]
result) (List (Atom String
aa : [LispVal]
ts)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
 Atom String
a <- Env -> LispVal -> IOThrowsError LispVal
expandAtom Env
renameEnv (String -> LispVal
Atom String
aa)
 Maybe LispVal
maybeMacro <- [Env] -> Env -> String -> IOThrowsError (Maybe LispVal)
findBoundMacro [Env]
defEnv Env
useEnv String
a
 -- If a macro is quoted, keep track of it and do not invoke rules below for
 -- procedure abstraction or macro calls 
 let isQuoted :: Bool
isQuoted = Bool
inputIsQuoted Bool -> Bool -> Bool
|| (String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"quote")

 case Maybe LispVal
maybeMacro of
   Just LispVal
_ -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> String
-> [LispVal]
-> Bool
-> Maybe LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv 
                              Bool
dim Bool
startOfList Bool
inputIsQuoted ([LispVal] -> LispVal
List [LispVal]
result) 
                              String
a [LispVal]
ts Bool
isQuoted Maybe LispVal
maybeMacro LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
   Maybe LispVal
_ -> do
    -- Determine if we should recursively rename an atom
    -- This code is a bit of a hack/mess at the moment
    if  (String
a String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` 
           [ String
aa -- Prevent an infinite loop
           -- Preserve keywords encountered in the macro 
           -- as each of these is really a special form, and renaming them
           -- would not work because there is nothing to divert back...
           , String
"if"
           , String
"let-syntax" 
           , String
"letrec-syntax" 
           , String
"define-syntax" 
           , String
"define"  
           , String
"set!"
           , String
"lambda"
           , String
"quote"
           , String
"expand"
           , String
"string-set!"
           , String
"set-car!"
           , String
"set-cdr!"
           , String
"vector-set!"
           , String
"hash-table-set!"
           , String
"hash-table-delete!"])
       then [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> String
-> [LispVal]
-> Bool
-> Maybe LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv 
                             Bool
dim Bool
startOfList Bool
inputIsQuoted ([LispVal] -> LispVal
List [LispVal]
result) String
a [LispVal]
ts Bool
isQuoted Maybe LispVal
maybeMacro LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
       else [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv 
                         Bool
dim Bool
startOfList Bool
inputIsQuoted ([LispVal] -> LispVal
List [LispVal]
result) ([LispVal] -> LispVal
List (String -> LispVal
Atom String
a LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ts)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

-- Transform anything else as itself...
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ Bool
isQuoted (List [LispVal]
result) (List (LispVal
t : [LispVal]
ts)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
isQuoted ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
t]) ([LispVal] -> LispVal
List [LispVal]
ts) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

-- Base case - empty transform
walkExpanded [Env]
_ Env
_ Env
_ Env
_ Env
_ Bool
_ Bool
_ Bool
_ result :: LispVal
result@(List [LispVal]
_) (List []) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
result

-- Single atom, rename (if necessary) and return
walkExpanded [Env]
_ Env
_ Env
_ Env
renameEnv Env
_ Bool
_ Bool
_ Bool
_ LispVal
_ (Atom String
a) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = Env -> LispVal -> IOThrowsError LispVal
expandAtom Env
renameEnv (String -> LispVal
Atom String
a)

-- If transforming into a scalar, just return the transform directly...
-- Not sure if this is strictly desirable, but does not break any tests so we'll go with it for now.
walkExpanded [Env]
_ Env
_ Env
_ Env
_ Env
_ Bool
_ Bool
_ Bool
_ LispVal
_ LispVal
transform LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
transform

walkExpandedAtom :: [Env]
  -> Env 
  -> Env 
  -> Env 
  -> Env 
  -> Bool 
  -> Bool 
  -> Bool 
  -> LispVal 
  -> String 
  -> [LispVal] 
  -> Bool -- is Quoted
  -> Maybe LispVal -- is defined as macro
  -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Apply func
  -> IOThrowsError LispVal

{- 
Some high-level design notes on how this could be made to work:

Note from http://www.cs.indiana.edu/~dyb/pubs/LaSC-5-4-pp295-326.pdf

Also, internal define-syntax forms may appear wherever internal define forms are
permitted, in which case the definitions behave as if introduced by letrec-syntax

so we could transform a letrec-syntax form into another using define-syntax.
let-syntax could be handled in the same way, although we would need to walk
the macro to ensure that none of the introduced macros reference each other.


 if (startOfList) && a == "let-syntax" && not isQuoted -- TODO: letrec-syntax, and a better way to organize all this
  then case ts of
    List bindings : body -> do
        bodyEnv <- liftIO $ extendEnv -- TODO: not sure about this... how will this work?
        _ <- loadMacros env bodyEnv bindings
        -- TODO: expand the macro body
    -- TODO: error
  else 
-}

walkExpandedAtom :: [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> String
-> [LispVal]
-> Bool
-> Maybe LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
inputIsQuoted (List [LispVal]
_)
    String
"let-syntax" 
    (List [LispVal]
_bindings : [LispVal]
_body)
    Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
        Env
bodyEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
useEnv []
        Env
bodyRenameEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
renameEnv []
        LispVal
_ <- Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
loadMacros Env
useEnv Env
bodyEnv (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
bodyRenameEnv) Bool
True [LispVal]
_bindings
        LispVal
expanded <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
bodyEnv Env
divertEnv Env
bodyRenameEnv Env
cleanupEnv Bool
dim Bool
True Bool
inputIsQuoted ([LispVal] -> LispVal
List [String -> LispVal
Atom String
"lambda", [LispVal] -> LispVal
List []]) ([LispVal] -> LispVal
List [LispVal]
_body) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
        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
$ [LispVal] -> LispVal
List [LispVal
expanded]

walkExpandedAtom [Env]
_ Env
_ Env
_ Env
_ Env
_ Bool
_ Bool
True Bool
_ LispVal
_ String
"let-syntax" [LispVal]
ts Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = do
  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 -> LispVal -> LispError
BadSpecialForm String
"Malformed let-syntax expression" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List (String -> LispVal
Atom String
"let-syntax" LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ts)

walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
inputIsQuoted (List [LispVal]
_)
    String
"letrec-syntax" 
    (List [LispVal]
_bindings : [LispVal]
_body)
    Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
        Env
bodyEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
useEnv []
        Env
bodyRenameEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
renameEnv []
        LispVal
_ <- Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
loadMacros Env
bodyEnv Env
bodyEnv (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
bodyRenameEnv) Bool
True [LispVal]
_bindings
        LispVal
expanded <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
bodyEnv Env
divertEnv Env
bodyRenameEnv Env
cleanupEnv Bool
dim Bool
True Bool
inputIsQuoted ([LispVal] -> LispVal
List [String -> LispVal
Atom String
"lambda", [LispVal] -> LispVal
List []]) ([LispVal] -> LispVal
List [LispVal]
_body) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
        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
$ [LispVal] -> LispVal
List [LispVal
expanded]

walkExpandedAtom [Env]
_ Env
_ Env
_ Env
_ Env
_ Bool
_ Bool
True Bool
_ LispVal
_ String
"letrec-syntax" [LispVal]
ts Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = do
  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 -> LispVal -> LispError
BadSpecialForm String
"Malformed letrec-syntax expression" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List (String -> LispVal
Atom String
"letrec-syntax" LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ts)

walkExpandedAtom [Env]
_ Env
useEnv Env
_ Env
renameEnv Env
_ Bool
_ Bool
True Bool
_ (List [LispVal]
_)
    String
"define-syntax" 
    ([Atom String
keyword, (List (Atom String
"syntax-rules" : Atom String
ellipsis : (List [LispVal]
identifiers : [LispVal]
rules)))])
    Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = do
        -- Do we need to rename the keyword, or at least take that into account?
        Env
renameEnvClosure <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> IO Env
copyEnv Env
renameEnv
        LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
useEnv Char
macroNamespace String
keyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Env
-> Maybe Env -> Bool -> String -> [LispVal] -> [LispVal] -> LispVal
Syntax (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
useEnv) (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
renameEnvClosure) Bool
True String
ellipsis [LispVal]
identifiers [LispVal]
rules
        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
Nil String
"" -- Sentinal value
walkExpandedAtom [Env]
_ Env
useEnv Env
_ Env
renameEnv Env
_ Bool
_ Bool
True Bool
_ (List [LispVal]
_)
    String
"define-syntax" 
    ([Atom String
keyword, (List (Atom String
"syntax-rules" : (List [LispVal]
identifiers : [LispVal]
rules)))])
    Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = do
        -- Do we need to rename the keyword, or at least take that into account?
        Env
renameEnvClosure <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> IO Env
copyEnv Env
renameEnv
        LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
useEnv Char
macroNamespace String
keyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Env
-> Maybe Env -> Bool -> String -> [LispVal] -> [LispVal] -> LispVal
Syntax (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
useEnv) (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
renameEnvClosure) Bool
True String
"..." [LispVal]
identifiers [LispVal]
rules
        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
Nil String
"" -- Sentinal value
walkExpandedAtom [Env]
_ Env
useEnv Env
_ Env
_ Env
_ Bool
_ Bool
True Bool
_ (List [LispVal]
_)
    String
"define-syntax" 
    ([Atom String
keyword, 
       (List [Atom String
"er-macro-transformer",  
             (List (Atom String
"lambda" : List [LispVal]
fparams : [LispVal]
fbody))])])
    Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = do
        LispVal
f <- Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *).
Monad m =>
Env -> [LispVal] -> [LispVal] -> m LispVal
makeNormalFunc Env
useEnv [LispVal]
fparams [LispVal]
fbody 
        LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
useEnv Char
macroNamespace String
keyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal -> LispVal
SyntaxExplicitRenaming LispVal
f
        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
Nil String
"" -- Sentinal value
walkExpandedAtom [Env]
_ Env
_ Env
_ Env
_ Env
_ Bool
_ Bool
True Bool
_ LispVal
_ String
"define-syntax" [LispVal]
ts Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = do
  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 -> LispVal -> LispError
BadSpecialForm String
"Malformed define-syntax expression" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List (String -> LispVal
Atom String
"define-syntax" LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ts)


{-
 Notes regarding define and set:

 if define or set is found, need to add an entry to renameEnv (?) so as to get 
 the transLiteral code to work. otherwise there is no way for that code to know 
 that a (define) called within a macro is inserting a new binding.
 do not actually need to do anything to the (define) form, just mark somehow
 that it is inserting a binding for the var
-}

walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
_ (List [LispVal]
_)
    String
"define" 
    [Atom String
var, LispVal
val]
    Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
{- It seems like this should be necessary, but it causes problems so it is
   disabled for now...
      isAlreadyRenamed <- liftIO $ isRecBound renameEnv var
      case (isAlreadyRenamed) of
        _ -> do --False -> do -}
          LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
renameEnv String
var (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
var
          IOThrowsError LispVal
walk
--        _ -> walk
 where walk :: IOThrowsError LispVal
walk = [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
False ([LispVal] -> LispVal
List [String -> LispVal
Atom String
"define", String -> LispVal
Atom String
var]) ([LispVal] -> LispVal
List [LispVal
val]) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
_ (List [LispVal]
result) a :: String
a@String
"define" [LispVal]
ts Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
    -- define is malformed, just transform as normal atom...
    [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
False ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [String -> LispVal
Atom String
a]) ([LispVal] -> LispVal
List [LispVal]
ts) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
_ (List [LispVal]
_)
    String
"set!" 
    [Atom String
var, LispVal
val]
    Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
      Bool
isLexicalDef <- 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
useEnv String
var
      Bool
isAlreadyRenamed <- 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
renameEnv String
var
      case (Bool
isLexicalDef, Bool
isAlreadyRenamed) of
        -- Only create a new record for this variable if it has not yet been
        -- seen within this macro. Otherwise the existing algorithms will handle
        -- everything just fine...
        (Bool
True, Bool
False) -> do
           LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
renameEnv String
var (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
var
           IOThrowsError LispVal
walk
        (Bool, Bool)
_ -> IOThrowsError LispVal
walk
  where
    walk :: IOThrowsError LispVal
walk = [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
False ([LispVal] -> LispVal
List [String -> LispVal
Atom String
"set!"]) ([LispVal] -> LispVal
List [String -> LispVal
Atom String
var, LispVal
val]) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
_ (List [LispVal]
result) a :: String
a@String
"set!" [LispVal]
ts Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
    -- define is malformed, just transform as normal atom...
    [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
False ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [String -> LispVal
Atom String
a]) ([LispVal] -> LispVal
List [LispVal]
ts) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
_ (List [LispVal]
_)
    String
"lambda" 
    (List [LispVal]
vars : [LispVal]
fbody)
    Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
-- Placed here, the lambda primitive trumps a macro of the same name... (desired behavior?)
    -- Create a new Env for this, so args of the same name do not overwrite those in the current Env
--    env <- liftIO $ extendEnv (trace ("found procedure abstraction, vars = " ++ show vars ++ "body = " ++ show fbody) renameEnv) []
    Env
env <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
renameEnv []
    LispVal
renamedVars <- Env -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
markBoundIdentifiers Env
env Env
cleanupEnv [LispVal]
vars []
    [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
env Env
cleanupEnv Bool
dim Bool
True Bool
False ([LispVal] -> LispVal
List [String -> LispVal
Atom String
"lambda", LispVal
renamedVars]) ([LispVal] -> LispVal
List [LispVal]
fbody) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
_ (List [LispVal]
result) a :: String
a@String
"lambda" [LispVal]
ts Bool
False Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
    -- lambda is malformed, just transform as normal atom...
    [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False Bool
False ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [String -> LispVal
Atom String
a]) ([LispVal] -> LispVal
List [LispVal]
ts) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

walkExpandedAtom [Env]
defEnvs Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True Bool
_ (List [LispVal]
result)
    String
a
    [LispVal]
ts 
    Bool
False (Just LispVal
syn) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
    case LispVal
syn of
--
-- Note:
--
-- Why do we assume that defEnv is the same as the one defined for the macro? Should read
-- this out of the Syntax object, right?
--
-- A) I think this is because for a macro with a renameClosure, it may only be defined
--    within another macro. So defEnv is not modified by this macro definition, and
--    there is no need to insert it.
--
      Syntax Maybe Env
_ (Just Env
renameClosure) Bool
definedInMacro String
ellipsis [LispVal]
identifiers [LispVal]
rules -> do 
         -- Before expanding the macro, make a pass across the macro body to mark
         -- any instances of renamed variables. 
         -- 
         -- It seems this does not need to be done in the two cases below. 
         -- Presumably this is because in those cases there is no rename 
         -- environment inserted by the macro call, so no information is lost.
         --
         -- I am still concerned that this may highlight a flaw in the husk
         -- implementation, and that this solution may not be complete.
         --
         List [LispVal]
lexpanded <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnvs Env
useEnv Env
divertEnv Env
renameEnv Env
renameEnv Bool
True Bool
False ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal]
ts) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
         [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> [LispVal]
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> String
-> IOThrowsError LispVal
macroTransform [Env]
defEnvs Env
useEnv Env
divertEnv Env
renameClosure Env
cleanupEnv Bool
definedInMacro ([LispVal] -> LispVal
List [LispVal]
identifiers) [LispVal]
rules ([LispVal] -> LispVal
List (String -> LispVal
Atom String
a LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
lexpanded)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply String
ellipsis
      Syntax (Just Env
_defEnv) Maybe Env
_ Bool
definedInMacro String
ellipsis [LispVal]
identifiers [LispVal]
rules -> do 

        -- Experimenting with this workaround for 162. The problem is that it
        -- substantially increases the time to run the test suite (only a couple
        -- seconds but 50% longer). So for various reasons this is not a
        -- preferred change. May want to look into ramifications of just using defEnv.
        --
        -- Hack to use defEnv from original macro, to preserve definitions in
        -- that scope, instead of just using _defEnv. Not sure yet if this the
        -- correct solution or if there a hygiene problem this hides.
--        newEnv <- liftIO $ nullEnv
--        _ <- liftIO $ importEnv newEnv defEnv -- Start with outer macro's def
--        _ <- liftIO $ importEnv newEnv _defEnv -- But prefer this macro
--
--        macroTransform newEnv useEnv divertEnv renameEnv cleanupEnv 
--        macroTransform _defEnv useEnv divertEnv renameEnv cleanupEnv 

-- Use defEnv from original macro, so any definitions are in scope for expansion
        let defEnvs' :: [Env]
defEnvs' = if (Env -> [Env] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Env
_defEnv [Env]
defEnvs)
                          then [Env]
defEnvs
                          else [Env]
defEnvs [Env] -> [Env] -> [Env]
forall a. [a] -> [a] -> [a]
++ [Env
_defEnv]
        [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> [LispVal]
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> String
-> IOThrowsError LispVal
macroTransform [Env]
defEnvs' Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv 
                       Bool
definedInMacro ([LispVal] -> LispVal
List [LispVal]
identifiers) [LispVal]
rules 
                       ([LispVal] -> LispVal
List (String -> LispVal
Atom String
a LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ts)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply String
ellipsis
      Syntax Maybe Env
Nothing Maybe Env
_ Bool
definedInMacro String
ellipsis [LispVal]
identifiers [LispVal]
rules -> do 
        -- A child renameEnv is not created because for a macro call there is no way an
        -- renamed identifier inserted by the macro could override one in the outer env.
        --
        -- This is because the macro renames non-matched identifiers and stores mappings
        -- from the {rename ==> original}. Each new name is unique by definition, so
        -- no conflicts are possible.
        [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> [LispVal]
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> String
-> IOThrowsError LispVal
macroTransform [Env]
defEnvs Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
definedInMacro ([LispVal] -> LispVal
List [LispVal]
identifiers) [LispVal]
rules ([LispVal] -> LispVal
List (String -> LispVal
Atom String
a LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ts)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply String
ellipsis
      SyntaxExplicitRenaming LispVal
transformer -> do
        Env
erRenameEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
nullEnv -- Local environment used just for this
                                        -- Different than the syntax-rules rename env (??)
        LispVal
expanded <- Env
-> Env
-> Env
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
explicitRenamingTransform 
                      Env
useEnv Env
erRenameEnv Env
renameEnv ([LispVal] -> LispVal
List (String -> LispVal
Atom String
a LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ts)) LispVal
transformer LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
        [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnvs Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv 
          Bool
dim Bool
False Bool
False ([LispVal] -> LispVal
List [LispVal]
result) LispVal
expanded LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

      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
Default String
"Unexpected error processing a macro in walkExpandedAtom"

walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ Bool
_ (List [LispVal]
result)
    String
a
    [LispVal]
ts
    Bool
True Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
    -- Cleanup all symbols in the quoted code
    List [LispVal]
cleaned <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded 
                      [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv 
                      Bool
dim Bool
True
                      ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal]
ts)
                      LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
    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
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ (String -> LispVal
Atom String
a LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
cleaned)

walkExpandedAtom [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ Bool
_ (List [LispVal]
result)
    String
a [LispVal]
ts Bool
isQuoted Maybe LispVal
_ LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
    [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
walkExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv 
                 Bool
dim Bool
False Bool
isQuoted 
                ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [String -> LispVal
Atom String
a]) ([LispVal] -> LispVal
List [LispVal]
ts)
                 LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

walkExpandedAtom [Env]
_ Env
_ Env
_ Env
_ Env
_ Bool
_ Bool
_ Bool
_ LispVal
_ String
_ [LispVal]
_ Bool
_ Maybe 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
Default String
"Unexpected error in walkExpandedAtom"

-- |Accept a list of bound identifiers from a lambda expression, and rename them
--  Returns a list of the renamed identifiers as well as marking those identifiers
--  in the given environment, so they can be renamed during expansion.
markBoundIdentifiers :: Env -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
markBoundIdentifiers :: Env -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
markBoundIdentifiers Env
env Env
cleanupEnv (Atom String
v : [LispVal]
vs) [LispVal]
renamedVars = do
  Atom String
renamed <- String -> IOThrowsError LispVal
_gensym String
v
  LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
env String
v (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
renamed
  LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
cleanupEnv String
renamed (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
v
  Env -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
markBoundIdentifiers Env
env Env
cleanupEnv [LispVal]
vs ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
renamedVars [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [String -> LispVal
Atom String
renamed]
markBoundIdentifiers Env
env Env
cleanupEnv (LispVal
_: [LispVal]
vs) [LispVal]
renamedVars = Env -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
markBoundIdentifiers Env
env Env
cleanupEnv [LispVal]
vs [LispVal]
renamedVars
markBoundIdentifiers Env
_ Env
_ [] [LispVal]
renamedVars = 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
$ [LispVal] -> LispVal
List [LispVal]
renamedVars

-- |Expand an atom, optionally recursively
_expandAtom :: Bool -> Env -> LispVal -> IOThrowsError LispVal
_expandAtom :: Bool -> Env -> LispVal -> IOThrowsError LispVal
_expandAtom Bool
isRec Env
renameEnv (Atom String
a) = do
  Maybe LispVal
isDefined <- Env -> String -> IOThrowsError (Maybe LispVal)
getVar' Env
renameEnv String
a
  case Maybe LispVal
isDefined of
    Just LispVal
expanded -> do
       if Bool
isRec then Bool -> Env -> LispVal -> IOThrowsError LispVal
_expandAtom Bool
isRec Env
renameEnv LispVal
expanded
                else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
expanded
    Maybe LispVal
Nothing -> 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 
_expandAtom Bool
_ Env
_ LispVal
a = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
a

-- |Recursively expand an atom that may have been renamed multiple times
recExpandAtom :: Env -> LispVal -> IOThrowsError LispVal
recExpandAtom :: Env -> LispVal -> IOThrowsError LispVal
recExpandAtom = Bool -> Env -> LispVal -> IOThrowsError LispVal
_expandAtom Bool
True

-- |Expand an atom
expandAtom :: Env -> LispVal -> IOThrowsError LispVal
expandAtom :: Env -> LispVal -> IOThrowsError LispVal
expandAtom = Bool -> Env -> LispVal -> IOThrowsError LispVal
_expandAtom Bool
False

-- |Clean up any remaining renamed variables in the expanded code
--  Only needed in special circumstances to deal with quoting.
--
-- Notes:
--
--  Keep in mind this will never work when using the renameEnv from walk, because that env binds
--  (old name => new name) in order to clean up any new names prior to eval, there would
--  need to be another environment with the reverse mappings.
--
--  ALSO, due to parent Env logic going on, these bindings need to be in some sort of
--  /master/ env that transcends those env's and maps all gensyms back to their original symbols
--
cleanExpanded :: 
     [Env]
  -> Env 
  -> Env 
  -> Env 
  -> Env 
  -> Bool 
  -> Bool 
  -> LispVal 
  -> LispVal 
  -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Apply func
  -> IOThrowsError LispVal

cleanExpanded :: [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ (List [LispVal]
result) (List (List [LispVal]
l : [LispVal]
ls)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  LispVal
lst <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal]
l) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
lst]) ([LispVal] -> LispVal
List [LispVal]
ls) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ (List [LispVal]
result) (List ((Vector Array Int LispVal
v) : [LispVal]
vs)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  List [LispVal]
lst <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
asVector [LispVal]
lst]) ([LispVal] -> LispVal
List [LispVal]
vs) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ (List [LispVal]
result) (List ((DottedList [LispVal]
ds LispVal
d) : [LispVal]
ts)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  List [LispVal]
ls <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal]
ds) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
  LispVal
l <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
True ([LispVal] -> LispVal
List []) LispVal
d LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal -> LispVal
DottedList [LispVal]
ls LispVal
l]) ([LispVal] -> LispVal
List [LispVal]
ts) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ (List [LispVal]
result) (List (Atom String
a : [LispVal]
ts)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  LispVal
expanded <- Env -> LispVal -> IOThrowsError LispVal
recExpandAtom Env
cleanupEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
a
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
expanded]) ([LispVal] -> LispVal
List [LispVal]
ts) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

-- Transform anything else as itself...
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
_ (List [LispVal]
result) (List (LispVal
t : [LispVal]
ts)) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply = do
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> LispVal
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
cleanExpanded [Env]
defEnv Env
useEnv Env
divertEnv Env
renameEnv Env
cleanupEnv Bool
dim Bool
False ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
t]) ([LispVal] -> LispVal
List [LispVal]
ts) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply

-- Base case - empty transform
cleanExpanded [Env]
_ Env
_ Env
_ Env
_ Env
_ Bool
_ Bool
_ result :: LispVal
result@(List [LispVal]
_) (List []) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = do
  LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
result

-- If transforming into a scalar, just return the transform directly...
-- Not sure if this is strictly desirable, but does not break any tests so we'll go with it for now.
cleanExpanded [Env]
_ Env
_ Env
_ Env
_ Env
_ Bool
_ Bool
_ LispVal
_ LispVal
transform LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
transform


{- |Transform input by walking the tranform structure and creating a new structure
    with the same form, replacing identifiers in the tranform with those bound in localEnv 

 This is essentially the rewrite step from MTW, and does all that is req'd, including:
 - renaming of free variables
 - collecting an env of variables that are renamed
 - diverting bindings back into the Env of use (outer env)
-}
transformRule :: [Env]      -- ^ Environment the macro was defined in
              -> Env        -- ^ Outer, enclosing environment
              -> Env        -- ^ Outer environment that the macro may divert values back to
              -> Env        -- ^ Environment local to the macro containing pattern variables
              -> Env        -- ^ Environment local to the macro containing renamed variables
              -> Env        -- ^ Environment local to the macro used to cleanup any left-over renamed vars 
              -> Bool
              -> LispVal    -- ^ Literal identifiers
              -> String     -- ^ ellipsisSymbol - Symbol used to identify an ellipsis
              -> Int        -- ^ ellipsisLevel - Nesting level of the zero-to-many match, or 0 if none
              -> [Int]      -- ^ ellipsisIndex - The index at each ellipsisLevel. This is used to read data stored in
                            --                   pattern variables.
              -> LispVal    -- ^ Resultant (transformed) value. 
                            -- ^ Must be a parameter as it mutates with each transform call
              -> LispVal    -- ^ The macro transformation, read out one atom at a time and rewritten to result
              -> IOThrowsError LispVal

-- Recursively transform a list
transformRule :: [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex (List [LispVal]
result) transform :: LispVal
transform@(List (List [LispVal]
l : [LispVal]
ts)) = do
  let nextHasEllipsis :: Bool
nextHasEllipsis = LispVal -> String -> Bool
macroElementMatchesMany LispVal
transform String
esym
  let level :: Int
level = Bool -> Int -> Int
calcEllipsisLevel Bool
nextHasEllipsis Int
ellipsisLevel
  let idx :: [Int]
idx = Bool -> Int -> [Int] -> [Int]
calcEllipsisIndex Bool
nextHasEllipsis Int
level [Int]
ellipsisIndex
  if Bool
nextHasEllipsis
     then do
             LispVal
curT <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
level [Int]
idx ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal]
l)
             case LispVal
curT of
               Nil String
_ -> -- No match ("zero" case). Use tail to move past the "..."
                        [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> [LispVal]
-> [LispVal]
-> IOThrowsError LispVal
continueTransform [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers 
                                          String
esym
                                          Int
ellipsisLevel 
                                          ([Int] -> [Int]
forall a. [a] -> [a]
init [Int]
ellipsisIndex) -- Issue #56 - done w/ellip so no need for last idx
                                          [LispVal]
result ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ts
               List [LispVal]
_ -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers 
                           String
esym
                           Int
ellipsisLevel -- Do not increment level, just wait until the next go-round when it will be incremented above
                           [Int]
idx -- Must keep index since it is incremented each time
                           ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
curT]) LispVal
transform
               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
Default String
"Unexpected error"
     else do
             LispVal
lst <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal]
l)
             case LispVal
lst of
                  List [LispVal]
_ -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
lst]) ([LispVal] -> LispVal
List [LispVal]
ts)
                  Nil String
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
lst
                  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 -> LispVal -> LispError
BadSpecialForm String
"Macro transform error" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal
lst, ([LispVal] -> LispVal
List [LispVal]
l), Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
ellipsisLevel]

-- Recursively transform a vector by processing it as a list
-- FUTURE: can this code be consolidated with the list code?
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex (List [LispVal]
result) transform :: LispVal
transform@(List ((Vector Array Int LispVal
v) : [LispVal]
ts)) = do
  let nextHasEllipsis :: Bool
nextHasEllipsis = LispVal -> String -> Bool
macroElementMatchesMany LispVal
transform String
esym
  let level :: Int
level = Bool -> Int -> Int
calcEllipsisLevel Bool
nextHasEllipsis Int
ellipsisLevel
  let idx :: [Int]
idx = Bool -> Int -> [Int] -> [Int]
calcEllipsisIndex Bool
nextHasEllipsis Int
level [Int]
ellipsisIndex
  if Bool
nextHasEllipsis
     then do
             -- Idea here is that we need to handle case where you have (vector ...) - EG: (#(var step) ...)
             LispVal
curT <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
level [Int]
idx ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v)
--             case (trace ("curT = " ++ show curT) curT) of
             case LispVal
curT of
               Nil String
_ -> -- No match ("zero" case). Use tail to move past the "..."
                        [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> [LispVal]
-> [LispVal]
-> IOThrowsError LispVal
continueTransform [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel ([Int] -> [Int]
forall a. [a] -> [a]
init [Int]
ellipsisIndex) [LispVal]
result ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ts
               List [LispVal]
t -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers 
                           String
esym
                           Int
ellipsisLevel -- Do not increment level, just wait until the next go-round when it will be incremented above
                           [Int]
idx -- Must keep index since it is incremented each time
                           ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
asVector [LispVal]
t]) LispVal
transform
               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
Default String
"Unexpected error in transformRule"
     else do LispVal
lst <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v)
             case LispVal
lst of
                  List [LispVal]
l -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
asVector [LispVal]
l]) ([LispVal] -> LispVal
List [LispVal]
ts)
                  Nil String
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
lst
                  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 -> LispVal -> LispError
BadSpecialForm String
"transformRule: Macro transform error" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal
lst, ([LispVal] -> LispVal
List [Array Int LispVal -> LispVal
Vector Array Int LispVal
v]), Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
ellipsisLevel]

-- Recursively transform an improper list
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex (List [LispVal]
result) transform :: LispVal
transform@(List (dl :: LispVal
dl@(DottedList [LispVal]
_ LispVal
_) : [LispVal]
ts)) = do
  let nextHasEllipsis :: Bool
nextHasEllipsis = LispVal -> String -> Bool
macroElementMatchesMany LispVal
transform String
esym
  let level :: Int
level = Bool -> Int -> Int
calcEllipsisLevel Bool
nextHasEllipsis Int
ellipsisLevel
  let idx :: [Int]
idx = Bool -> Int -> [Int] -> [Int]
calcEllipsisIndex Bool
nextHasEllipsis Int
level [Int]
ellipsisIndex
  if Bool
nextHasEllipsis
--  if (trace ("trans Pair: " ++ show transform ++ " lvl = " ++ show ellipsisLevel ++ " idx = " ++ show ellipsisIndex) nextHasEllipsis)
     then do
             -- Idea here is that we need to handle case where you have (pair ...) - EG: ((var . step) ...)
             LispVal
curT <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformDottedList [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
level [Int]
idx ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal
dl])
             case LispVal
curT of
               Nil String
_ -> -- No match ("zero" case). Use tail to move past the "..."
                        [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> [LispVal]
-> [LispVal]
-> IOThrowsError LispVal
continueTransform [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel ([Int] -> [Int]
forall a. [a] -> [a]
init [Int]
ellipsisIndex) [LispVal]
result ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ts 
               List [LispVal]
t -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers 
                          String
esym
                          Int
ellipsisLevel -- Do not increment level, just wait until next iteration where incremented above
                          [Int]
idx -- Keep incrementing each time
                         ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
t) LispVal
transform
               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
Default String
"Unexpected error in transformRule"
     else do LispVal
lst <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformDottedList [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal
dl])
             case LispVal
lst of
                  List [LispVal]
l -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
l) ([LispVal] -> LispVal
List [LispVal]
ts)
                  Nil String
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
lst
                  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 -> LispVal -> LispError
BadSpecialForm String
"transformRule: Macro transform error" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal
lst, ([LispVal] -> LispVal
List [LispVal
dl]), Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
ellipsisLevel]

-- |Transform an atom
--
-- This is a complicated transformation because we need to take into account
-- literal identifiers, pattern variables, ellipses in the current list, and 
-- nested ellipses.
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex (List [LispVal]
result) transform :: LispVal
transform@(List (Atom String
a : [LispVal]
ts)) = do
  Bool Bool
isIdent <- LispVal -> LispVal -> IOThrowsError LispVal
findAtom (String -> LispVal
Atom String
a) LispVal
identifiers -- Literal Identifier
  Bool
isDefined <- 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
isBound Env
localEnv String
a -- Pattern Variable

  if Bool
isIdent
     then IOThrowsError LispVal
literalHere
     else do
        if Bool
hasEllipsis
          then Bool -> IOThrowsError LispVal
ellipsisHere Bool
isDefined
          else Bool -> IOThrowsError LispVal
noEllipsis Bool
isDefined

  where
    literalHere :: IOThrowsError LispVal
literalHere = do
      LispVal
expanded <- [Env]
-> Env -> Env -> Env -> Bool -> String -> IOThrowsError LispVal
transformLiteralIdentifier [Env]
defEnv Env
outerEnv Env
divertEnv Env
renameEnv Bool
dim String
a
      if Bool
hasEllipsis 
         then do
              -- Skip over ellipsis if present
              -- 
              -- TODO:
              -- We should throw an error here, but the problem is that we need to differentiate
              -- between the case where an ellipsis is inserted as a shorthand for a pair (in which
              -- case this is allowed) or when an ellipsis is present in the actual macro (which
              -- should be an error).
              --
              [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
expanded]) ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ts)
         --   TODO: if error (per above logic) then -
         --   throwError $ Default "Unexpected ellipsis encountered after literal identifier in macro template" 
         else do
              [LispVal] -> IOThrowsError LispVal
continueTransformWith ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
expanded]

    -- A function to use input flags to append a '() to a list if necessary
    -- Only makes sense to do this if the *transform* is a dotted list
    appendNil :: LispVal -> LispVal -> LispVal -> LispVal
appendNil LispVal
d (Bool Bool
isImproperPattern) (Bool Bool
isImproperInput) =
      case LispVal
d of
         List [LispVal]
lst -> if Bool
isImproperPattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isImproperInput
                        then [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
lst [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List []]
                        else [LispVal] -> LispVal
List [LispVal]
lst
         LispVal
_ -> LispVal
d
    appendNil LispVal
d LispVal
_ LispVal
_ = LispVal
d -- Should never be reached...

    loadNamespacedBool :: Char -> IOThrowsError LispVal
loadNamespacedBool Char
namespc = do
        Maybe LispVal
val <- Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
localEnv Char
namespc String
a
        case Maybe LispVal
val of
            Just LispVal
b -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
b
            Maybe LispVal
Nothing -> 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
False

    hasEllipsis :: Bool
hasEllipsis = LispVal -> String -> Bool
macroElementMatchesMany LispVal
transform String
esym
    ellipsisHere :: Bool -> IOThrowsError LispVal
ellipsisHere Bool
isDefined = do
        if Bool
isDefined
             then do 
                    LispVal
isImproperPattern <- Char -> IOThrowsError LispVal
loadNamespacedBool Char
'p' -- "improper pattern"
                    LispVal
isImproperInput <- Char -> IOThrowsError LispVal
loadNamespacedBool Char
'i' -- "improper input"
                    -- Load variable and ensure it is a list
                    LispVal
var <- Env -> String -> IOThrowsError LispVal
getVar Env
localEnv String
a
                    case LispVal
var of
                      -- add all elements of the list into result
                      List [LispVal]
_ -> do case (LispVal -> LispVal -> LispVal -> LispVal
appendNil (LispVal -> [Int] -> LispVal
Matches.getData LispVal
var [Int]
ellipsisIndex) LispVal
isImproperPattern LispVal
isImproperInput) of
                                     List [LispVal]
aa -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
aa) ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ts)
                                     LispVal
_ -> -- No matches for var
                                          [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> [LispVal]
-> [LispVal]
-> IOThrowsError LispVal
continueTransform [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex [LispVal]
result ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ts

                      Nil String
"" -> -- No matches, keep going
                                [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> [LispVal]
-> [LispVal]
-> IOThrowsError LispVal
continueTransform [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex [LispVal]
result ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ts
                      LispVal
v -> [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
v]) ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ts)
             else -- Matched 0 times, skip it
                  [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List [LispVal]
result) ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
ts)

    noEllipsis :: Bool -> IOThrowsError LispVal
noEllipsis Bool
isDefined = do
      LispVal
isImproperPattern <- Char -> IOThrowsError LispVal
loadNamespacedBool Char
'p' -- "improper pattern"
      LispVal
isImproperInput <- Char -> IOThrowsError LispVal
loadNamespacedBool Char
'i' -- "improper input"
      LispVal
t <- if Bool
isDefined
              then do
                   LispVal
var <- Env -> String -> IOThrowsError LispVal
getVar Env
localEnv String
a
                   case LispVal
var of
                     Nil String
"" -> do 
                        -- Fix for issue #42: A 0 match case for var (input ran out in pattern), flag to calling code
                        --
                        -- What's happening here is that the pattern was flagged because it was not matched in
                        -- the pattern. We pick it up and in turn pass a special flag to the outer code (as t)
                        -- so that it can finally be processed correctly.
                        LispVal
wasPair <- Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
localEnv 
                                                    Char
'_' --  "unmatched nary pattern variable" 
                                                    String
a
                        case LispVal
wasPair of
                            Bool Bool
True -> 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
Nil String
"var (pair) not defined in pattern"
                            LispVal
_ -> 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
Nil String
"var not defined in pattern"
-- TODO: I think the outerEnv should be accessed by the walker, and not within rewrite as is done below...
                     Nil String
input -> Env -> String -> IOThrowsError LispVal
getVar Env
outerEnv String
input
                     List [LispVal]
_ -> do
                          if Int
ellipsisLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                                  then -- Take all elements, instead of one-at-a-time
                                       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
$ LispVal -> LispVal -> LispVal -> LispVal
appendNil (LispVal -> [Int] -> LispVal
Matches.getData LispVal
var [Int]
ellipsisIndex) 
                                                           LispVal
isImproperPattern 
                                                           LispVal
isImproperInput 
                                  else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
var -- no ellipsis, just return elements directly, so all can be appended
                     LispVal
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
var
              else do
                  -- Rename each encountered symbol, but the trick is that we want to give
                  -- the same symbol the same new name if it is found more than once, so...
                  -- we need to keep track of the var in two environments to map both ways 
                  -- between the original name and the new name.

                  Maybe LispVal
alreadyRenamed <- Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
localEnv Char
'r' {-"renamed"-} String
a
                  case Maybe LispVal
alreadyRenamed of
                    Just LispVal
renamed -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
renamed
                    Maybe LispVal
Nothing -> do
                       Atom String
renamed <- String -> IOThrowsError LispVal
_gensym String
a
                       LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
localEnv  Char
'r' {-"renamed"-} String
a (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
renamed
                       LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
renameEnv Char
'r' {-"renamed"-} String
a (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
renamed
                       -- Keep track of vars that are renamed; maintain reverse mapping
                       LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
cleanupEnv String
renamed (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
a -- Global record for final cleanup of macro
                       LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
renameEnv String
renamed (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
a -- Keep for Clinger
--                       return $ Atom (trace ("macro call renamed " ++ a ++ " to " ++ renamed) renamed)
                       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
      case LispVal
t of
         Nil String
"var not defined in pattern" -> 
            if Int
ellipsisLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
               then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
t
               else [LispVal] -> IOThrowsError LispVal
continueTransformWith [LispVal]
result -- nary match in the pattern but used as list in transform; keep going
         Nil String
"var (pair) not defined in pattern" -> 
            if Int
ellipsisLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
               then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
t
                    -- nary match in pattern as part of an improper list but used as list here; append the empty list
               else [LispVal] -> IOThrowsError LispVal
continueTransformWith ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List []]
         Nil String
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
t
         List [LispVal]
l -> do
            -- What's going on here is that if the pattern was a dotted list but the transform is not, we
            -- need to /lift/ the input up out of a list.
            if (LispVal -> LispVal -> Bool
eqVal LispVal
isImproperPattern (LispVal -> Bool) -> LispVal -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True) Bool -> Bool -> Bool
&& (LispVal -> LispVal -> Bool
eqVal LispVal
isImproperInput (LispVal -> Bool) -> LispVal -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True)
              then [LispVal] -> IOThrowsError LispVal
continueTransformWith ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ ([LispVal] -> [LispVal]
buildImproperList [LispVal]
l)
              else [LispVal] -> IOThrowsError LispVal
continueTransformWith ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
t]
         LispVal
_ -> [LispVal] -> IOThrowsError LispVal
continueTransformWith ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
t]

    -- Transformed code should be an improper list, but may need to /promote/ it to a proper list
    buildImproperList :: [LispVal] -> [LispVal]
buildImproperList [LispVal]
lst 
      | [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
lst Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = [[LispVal] -> LispVal -> LispVal
DottedList ([LispVal] -> [LispVal]
forall a. [a] -> [a]
init [LispVal]
lst) ([LispVal] -> LispVal
forall a. [a] -> a
last [LispVal]
lst)]
      | Bool
otherwise      = [LispVal]
lst

    -- Continue calling into transformRule
    continueTransformWith :: [LispVal] -> IOThrowsError LispVal
continueTransformWith [LispVal]
results = 
      [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv 
                    Env
localEnv
                    Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers 
                    String
esym
                    Int
ellipsisLevel 
                    [Int]
ellipsisIndex 
                   ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
results)
                   ([LispVal] -> LispVal
List [LispVal]
ts)

-- Transform anything else as itself...
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex (List [LispVal]
result) (List (LispVal
t : [LispVal]
ts)) = do
  [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
t]) ([LispVal] -> LispVal
List [LispVal]
ts) 

-- Base case - empty transform
transformRule [Env]
_ Env
_ Env
_ Env
_ Env
_ Env
_ Bool
_ LispVal
_ String
_ Int
_ [Int]
_ result :: LispVal
result@(List [LispVal]
_) (List []) = do
  LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
result

-- Transform a single var
--
-- The nice thing about this case is that the only way we can get here is if the
-- transform is an atom - if it is a list then there is no way this case can be reached.
-- So... we do not need to worry about pattern variables here. No need to port that code
-- from the above case.
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
_ Bool
dim LispVal
identifiers String
_ Int
_ [Int]
_ LispVal
_ (Atom String
transform) = do
  Bool Bool
isIdent <- LispVal -> LispVal -> IOThrowsError LispVal
findAtom (String -> LispVal
Atom String
transform) LispVal
identifiers
  Bool
isPattVar <- 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
localEnv String
transform
  if Bool
isPattVar Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isIdent
     then Env -> String -> IOThrowsError LispVal
getVar Env
localEnv String
transform
     else [Env]
-> Env -> Env -> Env -> Bool -> String -> IOThrowsError LispVal
transformLiteralIdentifier [Env]
defEnv Env
outerEnv Env
divertEnv Env
renameEnv Bool
dim String
transform

-- If transforming into a scalar, just return the transform directly...
-- Not sure if this is strictly desirable, but does not break any tests so we'll go with it for now.
transformRule [Env]
_ Env
_ Env
_ Env
_ Env
_ Env
_ Bool
_ LispVal
_ String
_ Int
_ [Int]
_ LispVal
_ LispVal
transform = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
transform

-- |A helper function for transforming an atom that has been marked as as literal identifier
transformLiteralIdentifier :: [Env] -> Env -> Env -> Env -> Bool -> String -> IOThrowsError LispVal
transformLiteralIdentifier :: [Env]
-> Env -> Env -> Env -> Bool -> String -> IOThrowsError LispVal
transformLiteralIdentifier [Env]
defEnv Env
outerEnv Env
divertEnv Env
renameEnv Bool
definedInMacro String
transform = do
  Bool
isInDef <- 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] -> Env
forall a. [a] -> a
head [Env]
defEnv) String
transform
  Bool
isRenamed <- 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
renameEnv String
transform
  if (Bool
isInDef Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
definedInMacro) Bool -> Bool -> Bool
|| (Bool
isInDef Bool -> Bool -> Bool
&& Bool
definedInMacro Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isRenamed)
     then do
          {- Variable exists in the environment the macro was defined in,
             so divert that value back into the environment of use. The value
             is diverted back with a different name so as not to be shadowed by
             a variable of the same name in env of use.           -}
         LispVal
value <- Env -> String -> IOThrowsError LispVal
getVar ([Env] -> Env
forall a. [a] -> a
head [Env]
defEnv) String
transform
         Atom String
renamed <- String -> IOThrowsError LispVal
_gensym String
transform
         LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
divertEnv String
renamed LispVal
value 

         -- Keep track of diverted values for use by the compiler
         List [LispVal]
diverted <- Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
outerEnv Char
' ' String
"diverted"
         LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
setNamespacedVar Env
outerEnv 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
transform]])

         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 do
         -- else if not defined in defEnv then just pass the var back as-is
         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
transform
         {-
           TODO:         
           above @else@ is not entirely correct, a special form would not be defined but still
           has a meaning and could be shadowed in useEnv. need some way of being able to
           divert a special form back into useEnv...
         
           Or, consider the following example. csi throws an error because if is not defined.
           If we make the modifications to store intermediate vars somewhere that are introduced
           via lambda, set!, and define then we may be able to throw an error if the var is not
           defined, instead of trying to store the special form to a variable somehow.
           
           ;(define if 3)
           (define-syntax test-template
            (syntax-rules (if)
               ((_)
                   if)))
           (write (let ((if 1)) (test-template)) )
           (write (let ((if 2)) (test-template)) )
         -}

-- | A helper function for transforming an improper list
transformDottedList :: [Env] -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> String -> Int -> [Int] -> LispVal -> LispVal -> IOThrowsError LispVal
transformDottedList :: [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformDottedList [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex (List [LispVal]
result) (List (DottedList [LispVal]
ds LispVal
d : [LispVal]
ts)) = do
          LispVal
lsto <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List []) ([LispVal] -> LispVal
List [LispVal]
ds)
          case LispVal
lsto of
            List [LispVal]
lst -> do
              -- Similar logic to the parser is applied here, where
              -- results are transformed into either a list or pair depending upon whether
              -- they form a proper list
              --
              -- d is an n-ary match, per Issue #34
              LispVal
r <- [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers 
                                 String
esym
                                 Int
ellipsisLevel -- OK not to increment here, this is accounted for later on
                                 [Int]
ellipsisIndex -- Same as above 
                                 ([LispVal] -> LispVal
List []) 
                                 ([LispVal] -> LispVal
List [LispVal
d, String -> LispVal
Atom String
esym])
              case LispVal
r of
                   -- Trailing symbol in the pattern may be neglected in the transform, so skip it...
                   List [] ->
                       [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List [LispVal]
lst]) ([LispVal] -> LispVal
List [LispVal]
ts)
                   Nil String
_ ->  -- Same as above, no match for d, so skip it 
                       [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
result [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List [LispVal]
lst]) ([LispVal] -> LispVal
List [LispVal]
ts)
                   List [LispVal]
rst -> do
                       [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex 
                                    ([LispVal] -> [LispVal] -> [LispVal] -> LispVal
buildTransformedCode [LispVal]
result [LispVal]
lst [LispVal]
rst) ([LispVal] -> LispVal
List [LispVal]
ts)
                   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 -> LispVal -> LispError
BadSpecialForm String
"Macro transform error processing pair" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal -> LispVal
DottedList [LispVal]
ds LispVal
d
            Nil String
_ -> 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
Nil String
""
            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 -> LispVal -> LispError
BadSpecialForm String
"Macro transform error processing pair" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal -> LispVal
DottedList [LispVal]
ds LispVal
d
 where 
   -- Transform code as either a proper or improper list depending upon the data
   -- These are rather crude methods of /cons/-ing everything together... are all cases accounted for?
   buildTransformedCode :: [LispVal] -> [LispVal] -> [LispVal] -> LispVal
buildTransformedCode [LispVal]
results [LispVal]
ps [LispVal]
p = do 
     case [LispVal]
p of
        [List []] -> [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
results [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List [LispVal]
ps]         -- Proper list has null list at the end
--        [List l@(Atom "unquote" : _ )] -> List $ results ++ [DottedList ps $ List l] -- Special case from parser. 
        [List [LispVal]
ls] -> [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
results [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
ps [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
ls] -- Again, convert to proper list because a proper list is at end
        [LispVal
l] -> [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
results [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal -> LispVal
DottedList [LispVal]
ps LispVal
l]
        [LispVal]
ls -> do
            -- Same concepts as above, but here we check the last entry of a list of elements
            -- FUTURE: should be able to use a common function to encapsulate logic above and below
            case [LispVal] -> LispVal
forall a. [a] -> a
last [LispVal]
ls of
              List [] -> [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
results [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
ps [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal] -> [LispVal]
forall a. [a] -> [a]
init [LispVal]
ls]
              List [LispVal]
lls -> [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
results [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
ps [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ ([LispVal] -> [LispVal]
forall a. [a] -> [a]
init [LispVal]
ls) [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
lls]
              LispVal
t -> [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
results [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal -> LispVal
DottedList ([LispVal]
ps [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal] -> [LispVal]
forall a. [a] -> [a]
init [LispVal]
ls) LispVal
t]


transformDottedList [Env]
_ Env
_ Env
_ Env
_ Env
_ Env
_ Bool
_ LispVal
_ String
_ Int
_ [Int]
_ LispVal
_ 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
Default String
"Unexpected error in transformDottedList"

-- |Continue transforming after a preceding match has ended 
continueTransform :: [Env] -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> String -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
continueTransform :: [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> [LispVal]
-> [LispVal]
-> IOThrowsError LispVal
continueTransform [Env]
defEnv Env
outerEnv Env
divertEnv Env
localEnv Env
renameEnv Env
cleanupEnv Bool
dim LispVal
identifiers String
esym Int
ellipsisLevel [Int]
ellipsisIndex [LispVal]
result [LispVal]
remaining = do
    if Bool -> Bool
not ([LispVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LispVal]
remaining)
       then [Env]
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> String
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule [Env]
defEnv Env
outerEnv Env
divertEnv 
                          Env
localEnv 
                          Env
renameEnv
                          Env
cleanupEnv Bool
dim LispVal
identifiers
                          String
esym
                          Int
ellipsisLevel 
                          [Int]
ellipsisIndex 
                         ([LispVal] -> LispVal
List [LispVal]
result) 
                         ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
remaining)
       else if Bool -> Bool
not ([LispVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LispVal]
result)
               then 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
$ [LispVal] -> LispVal
List [LispVal]
result
               else if Int
ellipsisLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 
                       then 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
Nil String
""  -- Nothing remains, no match
                       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
$ [LispVal] -> LispVal
List [] -- Nothing remains, return empty list

-- |Find an atom in a list; non-recursive (IE, a sub-list will not be inspected)
findAtom :: LispVal -> LispVal -> IOThrowsError LispVal
findAtom :: LispVal -> LispVal -> IOThrowsError LispVal
findAtom (Atom String
target) (List (Atom String
a : [LispVal]
as)) = do
  if String
target String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
a
     then 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
True
     else LispVal -> LispVal -> IOThrowsError LispVal
findAtom (String -> LispVal
Atom String
target) ([LispVal] -> LispVal
List [LispVal]
as)
findAtom LispVal
_ (List (LispVal
badtype : [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 -> LispVal -> LispError
TypeMismatch String
"symbol" LispVal
badtype
findAtom LispVal
_ LispVal
_ = 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
False

-- |Increment ellipsis level based on whether a new ellipsis is present
calcEllipsisLevel :: Bool -> Int -> Int
calcEllipsisLevel :: Bool -> Int -> Int
calcEllipsisLevel  Bool
nextHasEllipsis Int
ellipsisLevel =
    if Bool
nextHasEllipsis then Int
ellipsisLevel Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                       else Int
ellipsisLevel

-- |Increment ellipsis index information based on given parameters
calcEllipsisIndex :: Bool -> Int -> [Int] -> [Int]
calcEllipsisIndex :: Bool -> Int -> [Int] -> [Int]
calcEllipsisIndex Bool
nextHasEllipsis Int
ellipsisLevel [Int]
ellipsisIndex =
    if Bool
nextHasEllipsis 
       then if ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ellipsisIndex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ellipsisLevel)
               -- This is not the first match, increment existing index
               then do
                 let l :: ([Int], [Int])
l = Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
ellipsisLevel Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Int]
ellipsisIndex
                 (([Int], [Int]) -> [Int]
forall a b. (a, b) -> a
fst ([Int], [Int])
l) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [([Int] -> Int
forall a. [a] -> a
head (([Int], [Int]) -> [Int]
forall a b. (a, b) -> b
snd ([Int], [Int])
l)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1]
               -- First input element that matches pattern; start at 0
               else [Int]
ellipsisIndex [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
0]
       else [Int]
ellipsisIndex

-- |Convert a list of lisp values to a vector
asVector :: [LispVal] -> LispVal
asVector :: [LispVal] -> LispVal
asVector [LispVal]
lst = (Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
lst Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [LispVal]
lst)

-- |Helper function to load macros from a let*-syntax expression
loadMacros :: Env       -- ^ Parent environment containing the let*-syntax expression
           -> Env       -- ^ Environment of the let*-syntax body
           -> Maybe Env -- ^ Environment of renamed variables, if applicable
           -> Bool      -- ^ True if the macro was defined inside another macro
           -> [LispVal] -- ^ List containing syntax-rule definitions
           -> IOThrowsError LispVal -- ^ A dummy value, unless an error is thrown

-- Standard processing for a syntax-rules transformer
loadMacros :: Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
loadMacros Env
e Env
be Maybe Env
Nothing Bool
dim 
    (List 
        [Atom String
keyword, 
         (List (Atom String
"syntax-rules" : 
                Atom String
ellipsis :
                (List [LispVal]
identifiers : [LispVal]
rules)))] : 
        [LispVal]
bs) = do
  LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
be Char
macroNamespace String
keyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
        Maybe Env
-> Maybe Env -> Bool -> String -> [LispVal] -> [LispVal] -> LispVal
Syntax (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
e) Maybe Env
forall a. Maybe a
Nothing Bool
dim String
ellipsis [LispVal]
identifiers [LispVal]
rules
  Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
loadMacros Env
e Env
be Maybe Env
forall a. Maybe a
Nothing Bool
dim [LispVal]
bs

-- Standard processing for a syntax-rules transformer
loadMacros Env
e Env
be Maybe Env
Nothing Bool
dim 
    (List 
        [Atom String
keyword, 
         (List (Atom String
"syntax-rules" : 
                (List [LispVal]
identifiers : [LispVal]
rules)))] : 
        [LispVal]
bs) = do
  LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
be Char
macroNamespace String
keyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
        Maybe Env
-> Maybe Env -> Bool -> String -> [LispVal] -> [LispVal] -> LispVal
Syntax (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
e) Maybe Env
forall a. Maybe a
Nothing Bool
dim String
"..." [LispVal]
identifiers [LispVal]
rules
  Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
loadMacros Env
e Env
be Maybe Env
forall a. Maybe a
Nothing Bool
dim [LispVal]
bs

-- Standard processing for an explicit renaming transformer
loadMacros Env
e Env
be Maybe Env
Nothing Bool
dim 
    (List  
       [Atom String
keyword, (List [Atom String
"er-macro-transformer",  
             (List (Atom String
"lambda" : List [LispVal]
fparams : [LispVal]
fbody))])]
       : [LispVal]
bs) = do
  LispVal
f <- Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *).
Monad m =>
Env -> [LispVal] -> [LispVal] -> m LispVal
makeNormalFunc Env
e [LispVal]
fparams [LispVal]
fbody 
  LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
be Char
macroNamespace String
keyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal -> LispVal
SyntaxExplicitRenaming LispVal
f
  Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
loadMacros Env
e Env
be Maybe Env
forall a. Maybe a
Nothing Bool
dim [LispVal]
bs

-- This pattern is reached when there is a rename env, which
-- means that we were already expanding a syntax-rules macro
-- when loadMacros was called again.
loadMacros Env
e Env
be (Just Env
re) Bool
dim 
    args :: [LispVal]
args@(List [Atom String
keyword, 
                (List (Atom String
syntaxrules : [LispVal]
spec))] : 
               [LispVal]
bs) = do
  Atom String
exKeyword <- Env -> LispVal -> IOThrowsError LispVal
expandAtom Env
re (String -> LispVal
Atom String
keyword)
  LispVal
exSynRules <- Env -> LispVal -> IOThrowsError LispVal
expandAtom Env
re (String -> LispVal
Atom String
syntaxrules)

-- TODO: need to process identifiers and rules - are they just expanded, or cleaned up?

  case (LispVal
exSynRules, [LispVal]
spec) of
    (Atom String
"syntax-rules", 
     (Atom String
ellipsis :
      (List [LispVal]
identifiers : [LispVal]
rules))) -> do
        LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
be Char
macroNamespace String
exKeyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
             Maybe Env
-> Maybe Env -> Bool -> String -> [LispVal] -> [LispVal] -> LispVal
Syntax (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
e) (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
re) Bool
dim String
ellipsis [LispVal]
identifiers [LispVal]
rules
        Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
loadMacros Env
e Env
be (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
re) Bool
dim [LispVal]
bs
    (Atom String
"syntax-rules", 
      (List [LispVal]
identifiers : [LispVal]
rules)) -> do
--        -- Temporary hack to expand the rules
--        List exRules <- cleanExpanded e e e re re dim False False (List []) (List rules)

        -- TODO: error checking
        LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
be Char
macroNamespace String
exKeyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
--             Syntax (Just e) (Just re) dim identifiers (trace ("exRules = " ++ show exRules) exRules) --rules
--             Syntax (Just e) (Just re) dim identifiers exRules --rules
             Maybe Env
-> Maybe Env -> Bool -> String -> [LispVal] -> [LispVal] -> LispVal
Syntax (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
e) (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
re) Bool
dim String
"..." [LispVal]
identifiers [LispVal]
rules
        Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
loadMacros Env
e Env
be (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
re) Bool
dim [LispVal]
bs
    --
    -- TODO: should check for lambda instead of _
    --
    (Atom String
"er-macro-transformer",
      [List (Atom String
_ : List [LispVal]
fparams : [LispVal]
fbody)]) -> do

        -- TODO: this is not good enough, er macros will
        --       need access to the rename env
        LispVal
f <- Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *).
Monad m =>
Env -> [LispVal] -> [LispVal] -> m LispVal
makeNormalFunc Env
e [LispVal]
fparams [LispVal]
fbody 
        LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
be Char
macroNamespace String
exKeyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal -> LispVal
SyntaxExplicitRenaming LispVal
f
        Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
loadMacros Env
e Env
be (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
re) Bool
dim [LispVal]
bs
    (LispVal, [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 -> LispVal -> LispError
BadSpecialForm String
"Unable to evaluate form w/re" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args

loadMacros Env
_ Env
_ Maybe Env
_ Bool
_ [] = 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
Nil String
""
loadMacros Env
_ Env
_ Maybe Env
_ Bool
_ [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 -> LispVal -> LispError
BadSpecialForm String
"Unable to evaluate form" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
form 

-- |Retrieve original (non-renamed) identifier
getOrigName :: Env -> String -> IOThrowsError String
getOrigName :: Env -> String -> IOThrowsError String
getOrigName Env
renameEnv String
a = do
  Maybe LispVal
v <- Env -> String -> IOThrowsError (Maybe LispVal)
getVar' Env
renameEnv String
a
  case Maybe LispVal
v of 
    Just (Atom String
a') ->
      if String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
a'
        then String -> IOThrowsError String
forall (m :: * -> *) a. Monad m => a -> m a
return String
a'
        else Env -> String -> IOThrowsError String
getOrigName Env
renameEnv String
a'
    Maybe LispVal
_ -> String -> IOThrowsError String
forall (m :: * -> *) a. Monad m => a -> m a
return String
a

-- |Determine if the given identifier is lexically defined
isLexicallyDefined :: Env -> Env -> String -> IOThrowsError Bool
isLexicallyDefined :: Env -> Env -> String -> ExceptT LispError IO Bool
isLexicallyDefined Env
outerEnv Env
renameEnv String
a = do
  Bool
o <- 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
isBound Env
outerEnv String
a
  Bool
r <- 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
isBound Env
renameEnv String
a
  Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ExceptT LispError IO Bool)
-> Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
o Bool -> Bool -> Bool
|| Bool
r

findBoundMacro :: [Env] -> Env -> String -> IOThrowsError (Maybe LispVal)
findBoundMacro :: [Env] -> Env -> String -> IOThrowsError (Maybe LispVal)
findBoundMacro [Env]
defEnv Env
useEnv String
a = do
  Maybe LispVal
synUse <- Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
useEnv Char
macroNamespace String
a
  case Maybe LispVal
synUse of
    Just LispVal
syn -> Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LispVal -> IOThrowsError (Maybe LispVal))
-> Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall a b. (a -> b) -> a -> b
$ LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
syn
    Maybe LispVal
_ -> [Env] -> IOThrowsError (Maybe LispVal)
check [Env]
defEnv
 where
  check :: [Env] -> IOThrowsError (Maybe LispVal)
check (Env
e : [Env]
es) = do
    Maybe LispVal
r <- Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
e Char
macroNamespace String
a
    case Maybe LispVal
r of
      Just LispVal
_ -> Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LispVal
r
      Maybe LispVal
_ -> [Env] -> IOThrowsError (Maybe LispVal)
check [Env]
es
  check [] = Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LispVal
forall a. Maybe a
Nothing