{-
 - husk scheme
 - Macro
 - @author Justin Ethier
 -
 - Purpose:
 -
 - This file contains code for hygienic macros.
 -
 - During transformation, the following components are considered:
 -  - Pattern (part of a rule that matches input)
 -  - Transform (what the macro "expands" into)
 -  - Input (the actual code in the user's program)
 -
 - At a high level, macro transformation is broken down into the following steps:
 -
 -  1) Search for a rule that matches the input.
 -     During this process, any variables in the input are loaded into a temporary environment
 -  2) If a rule matches,
 -  3) Transform by walking the transform, inserting variables as needed
 -
 -
 - Remaining Work:
 -
 - * Vectors are currently not supported
 -
 - * Dotted lists are not 100% correctly implemented. In particular, the transformation should
 -   take into account whether the input was presented as a list or a pair, and replicate that
 -    in the output.
 -
 - -}
module Scheme.Macro 
    (
      macroEval
    ) where
import Scheme.Types
import Scheme.Variables
import Control.Monad
import Control.Monad.Error
import Debug.Trace -- Only req'd to support trace, can be disabled at any time...

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

-- Search for macro's in the AST, and transform any that are found.
-- There is also a special case (define-syntax) that loads new rules.
macroEval :: Env -> LispVal -> IOThrowsError LispVal
macroEval env (List [Atom "define-syntax", Atom keyword, syntaxRules@(List (Atom "syntax-rules" : (List identifiers : rules)))]) = do
  -- TODO: there really ought to be some error checking of the syntax rules, since they could be malformed...
  --       As it stands now, there is no checking until the code attempts to perform a macro transformation.
  defineNamespacedVar env macroNamespace keyword syntaxRules
  return $ Nil "" -- Sentinal value
macroEval env lisp@(List (x@(List _) : xs)) = do
  first <- macroEval env x
  rest <- mapM (macroEval env) xs
  return $ List $ first : rest
-- TODO: equivalent matches/transforms for vectors
--       what about dotted lists?
macroEval env lisp@(List (Atom x : xs)) = do
  isDefined <- liftIO $ isNamespacedBound env macroNamespace x
  if isDefined
     then do
       syntaxRules@(List (Atom "syntax-rules" : (List identifiers : rules))) <- getNamespacedVar env macroNamespace x 
       -- Transform the input and then call macroEval again, since a macro may be contained within...
       macroEval env =<< macroTransform env (List identifiers) rules lisp
     else do
       rest <- mapM (macroEval env) xs
       return $ List $ (Atom x) : rest
macroEval _ lisp@(_) = return 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 -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal
macroTransform env identifiers rules@(rule@(List r) : rs) input = do
  localEnv <- liftIO $ nullEnv -- Local environment used just for this invocation
  result <- matchRule env identifiers localEnv rule input
  case result of 
    Nil _ -> macroTransform env identifiers rs input
    otherwise -> return result
-- Ran out of rules to match...
macroTransform _ _ _ input = throwError $ BadSpecialForm "Input does not match a macro pattern" input

-- Determine if the next element in a list matches 0-to-n times due to an ellipsis
macroElementMatchesMany :: LispVal -> Bool
macroElementMatchesMany (List (p:ps)) = do
  if not (null ps)
     then case (head ps) of
                Atom "..." -> True
                otherwise -> False
     else False
macroElementMatchesMany _ = False

-- Given input, determine if that input matches any rules
-- @return Transformed code, or Nil if no rules match
matchRule :: Env -> LispVal -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
--matchRule env identifiers localEnv (List [p@(List patternVar), template@(List _)]) (List inputVar) = do
matchRule env identifiers localEnv (List [pattern, template]) (List inputVar) = do
   let is = tail inputVar
   let p = case pattern of
              DottedList ds d -> case ds of
                                  (Atom l : ls) -> List [Atom l, DottedList ls d]
                                  otherwise -> pattern
              otherwise -> pattern
   case p of 
      List (Atom _ : ps) -> do
        match <- loadLocal localEnv identifiers (List ps) (List is) False False
        case match of
           Bool False -> return $ Nil ""
           otherwise  -> transformRule localEnv 0 (List []) template (List [])
      otherwise -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" p

matchRule _ identifiers _ rule input = do
  throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ List [Atom "rule: ", rule, Atom "input: ", input]

--
-- loadLocal - Determine if pattern matches input, loading input into pattern variables as we go,
--             in preparation for macro transformation.
loadLocal :: Env -> LispVal -> LispVal -> LispVal -> Bool -> Bool -> IOThrowsError LispVal
loadLocal localEnv identifiers pattern input hasEllipsis outerHasEllipsis = do -- TODO: kind of a hack to have both ellipsis vars. Is only outer req'd?
  case (pattern, input) of

       -- Future: vector

       ((DottedList ps p), (DottedList is i)) -> do
         result <- loadLocal localEnv  identifiers (List ps) (List is) False outerHasEllipsis
         case result of
            Bool True -> loadLocal localEnv identifiers p i False outerHasEllipsis
            otherwise -> return $ Bool False

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

         let hasEllipsis = macroElementMatchesMany pattern

         -- TODO: error if ... detected when there is an outer ... ????
         --       no, this should (eventually) be allowed. See scheme-faq-macros

         status <- checkLocal localEnv identifiers (hasEllipsis || outerHasEllipsis) p i 
         case status of
              -- No match
              Bool False -> if hasEllipsis
                                -- No match, must be finished with ...
                                -- Move past it, but keep the same input.
                                then do
                                        loadLocal localEnv identifiers (List $ tail ps) (List (i:is)) False outerHasEllipsis
                                else return $ Bool False
              -- There was a match
              otherwise -> if hasEllipsis
                              then loadLocal localEnv identifiers pattern (List is) True outerHasEllipsis
                              else loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis

       -- Base case - All data processed
       (List [], List []) -> return $ Bool True

       -- Ran out of input to process
       (List (p:ps), List []) -> do
                                 -- Ensure any patterns that are not present in the input still
                                 -- have their variables initialized so they are ready during trans.
                                 initializePatternVars localEnv "list" identifiers pattern
                                 let hasEllipsis = macroElementMatchesMany pattern
                                 if hasEllipsis && ((length ps) == 1) 
                                           then return $ Bool True
                                           else return $ Bool False

       -- Pattern ran out, but there is still input. No match.
       (List [], _) -> return $ Bool False

       -- Check input against pattern (both should be single var)
       (_, _) -> checkLocal localEnv identifiers (hasEllipsis || outerHasEllipsis) pattern input 

-- Check pattern against input to determine if there is a match
--
--  @param localEnv - Local variables for the macro, used during transform
--  @param hasEllipsis - Determine whether we are in a zero-or-many match.
--                       Used for loading local vars and NOT for purposes of matching.
--  @param pattern - Pattern to match
--  @param input - Input to be matched
checkLocal :: Env -> LispVal -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal
checkLocal localEnv identifiers hasEllipsis (Bool pattern) (Bool input) = return $ Bool $ pattern == input
checkLocal localEnv identifiers hasEllipsis (Number pattern) (Number input) = return $ Bool $ pattern == input
checkLocal localEnv identifiers hasEllipsis (Float pattern) (Float input) = return $ Bool $ pattern == input
checkLocal localEnv identifiers hasEllipsis (String pattern) (String input) = return $ Bool $ pattern == input
checkLocal localEnv identifiers hasEllipsis (Char pattern) (Char input) = return $ Bool $ pattern == input
checkLocal localEnv identifiers hasEllipsis (Atom pattern) input = do
  if hasEllipsis
     -- Var is part of a 0-to-many match, store up in a list...
     then do isDefined <- liftIO $ isBound localEnv pattern
             -- If pattern is a literal identifier, then just pass it along as-is
             found <- findAtom (Atom pattern) identifiers
             let val = case found of
                         (Bool True) -> Atom pattern
                         otherwise -> input
             -- Set variable in the local environment
             if isDefined
                then do v <- getVar localEnv pattern
                        case v of
                          (List vs) -> setVar localEnv pattern (List $ vs ++ [val])
                else defineVar localEnv pattern (List [val])
     -- Simple var, load up into macro env
     else defineVar localEnv pattern input
  return $ Bool True

-- TODO: vector support. And what the heck are these next two TODO's doing here? :)
-- TODO, load into localEnv in some (all?) cases?: eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
-- TODO: eqv [(Vector arg1), (Vector arg2)] = eqv [List $ (elems arg1), List $ (elems arg2)] 
--
checkLocal localEnv identifiers hasEllipsis pattern@(DottedList ps p) input@(DottedList is i) = 
  loadLocal localEnv identifiers pattern input False hasEllipsis
--  throwError $ BadSpecialForm "Test" input
checkLocal localEnv identifiers hasEllipsis pattern@(DottedList ps p) input@(List (i : is)) = do
  if (length ps) == (length is)
          -- Lists are same length, implying elements in both should be the same.
          -- Cast pair to a List for further processing
     then loadLocal localEnv identifiers (List $ ps ++ [p]) input False hasEllipsis
          -- Idea here is that if we have a dotted list, the last component does not have to be provided
          -- in the input. So in that case just fill in an empty list for the missing component.
     else loadLocal localEnv identifiers pattern (DottedList (i : is) (List [])) False hasEllipsis
checkLocal localEnv identifiers hasEllipsis pattern@(List _) input@(List _) = 
  loadLocal localEnv identifiers pattern input False hasEllipsis

checkLocal localEnv identifiers hasEllipsis _ _ = return $ Bool False

-- 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
transformRule :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal

-- Recursively transform a list
--
-- Parameters:
--
--  localEnv - Local variable environment
--  ellipsisIndex - Zero-or-more match variables are stored as a list. 
--                  This is the index into the current value to read from list
--  result - Resultant value, must be a parameter as it mutates with each function call, so we pass it using CPS
--  transform - The macro transformation, we read it out one atom at a time, and rewrite it into result
--  ellipsisList - Temporarily holds value of the "outer" result while we process the 
--                  zero-or-more match. Once that is complete we swap this value back into it's rightful place
--
transformRule localEnv ellipsisIndex (List result) transform@(List(List l : ts)) (List ellipsisList) = do
  if macroElementMatchesMany transform
     then do 
             curT <- transformRule localEnv (ellipsisIndex + 1) (List []) (List l) (List result)
             case curT of
               Nil _ -> if ellipsisIndex == 0
                                -- First time through and no match ("zero" case). Use tail to move past the "..."
                           then transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])  
                                -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."
                           else transformRule localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List [])
               -- Dotted list transform returned during processing...
               List [Nil _, List elst] -> if ellipsisIndex == 0
                                -- First time through and no match ("zero" case). Use tail to move past the "..."
                           then transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])  
                                -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."
                          else transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])
               List t -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ [curT]) transform (List ellipsisList)
     else do
             lst <- transformRule localEnv ellipsisIndex (List []) (List l) (List ellipsisList)
             case lst of
                  List [Nil _, l] -> return lst
                  List _ -> transformRule localEnv ellipsisIndex (List $ result ++ [lst]) (List ts) (List ellipsisList)
                  Nil _ -> return lst
                  otherwise -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisIndex]

  where lastElementIsNil l = case (last l) of
                               Nil _ -> True
                               otherwise -> False
        getListAtTail l = case (last l) of
                               List lst -> lst


-- TODO: vector transform (and taking vectors into account in other cases as well???)


transformRule localEnv ellipsisIndex (List result) transform@(List (dl@(DottedList ds d) : ts)) (List ellipsisList) = do
  if macroElementMatchesMany transform
     then do 
     -- Idea here is that we need to handle case where you have (pair ...) - EG: ((var . step) ...)
             curT <- transformDottedList localEnv (ellipsisIndex + 1) (List []) (List [dl]) (List result)
             case curT of
               Nil _ -> if ellipsisIndex == 0
                                -- First time through and no match ("zero" case). Use tail to move past the "..."
                           then transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])  
                                -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."
                           else transformRule localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List [])
               -- This case is here because we need to process individual components of the pair to determine
               -- whether we are done with the match. It is similar to above but not exact...
               List [Nil _, List elst] -> if ellipsisIndex == 0
                                -- First time through and no match ("zero" case). Use tail to move past the "..."
                           then transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])  
                                -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."
                           else transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])
               List t -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ t) transform (List ellipsisList)
     else do lst <- transformDottedList localEnv ellipsisIndex (List []) (List [dl]) (List ellipsisList)
             case lst of
                  List [Nil _, List l] -> return lst 
                  List l -> transformRule localEnv ellipsisIndex (List $ result ++ l) (List ts) (List ellipsisList)
                  Nil n -> return lst
                  otherwise -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [dl]), Number $ toInteger ellipsisIndex]

  where transformDottedList :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
        transformDottedList localEnv ellipsisIndex (List result) transform@(List (DottedList ds d : ts)) (List ellipsisList) = do
          lsto <- transformRule localEnv ellipsisIndex (List []) (List ds) (List ellipsisList)
          case lsto of
            List lst -> do 
                           r <- transformRule localEnv ellipsisIndex (List []) (List [d]) (List ellipsisList)
                           case r of
                                -- Trailing symbol in the pattern may be neglected in the transform, so skip it...
                                List [List []] -> transformRule localEnv ellipsisIndex (List $ result ++ [List lst]) (List ts) (List ellipsisList)
                                -- TODO: the transform needs to be as follows:
                                --  - transform into a list if original input was a list - code is below but commented-out
                                --  - transform into a dotted list if original input was a dotted list
                                --
                                -- Could implement this by calling a new function on input (ds?) that goes through it and
                                -- looks up each atom that it finds, looking for its src. The src (or Nil?) would then be returned
                                -- and used here to determine what type of transform is used.
                                --
--                                List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) 
--                                List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList) 
                                List [rst] -> do
                                                 src <- lookupPatternVarSrc localEnv $ List ds
                                                 case src of
                                                    String "pair" -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList) 
                                                    otherwise -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) 
                                otherwise -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d 
            Nil _ -> return $ List [Nil "", List ellipsisList]
            otherwise -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d

-- Transform an atom by attempting to look it up as a var...
transformRule localEnv ellipsisIndex (List result) transform@(List (Atom a : ts)) unused = do
  let hasEllipsis = macroElementMatchesMany transform
  isDefined <- liftIO $ isBound localEnv a
  if hasEllipsis
     then if isDefined
             then do
                  -- get var
                  var <- getVar localEnv a
                  -- ensure it is a list
                  case var of 
                    -- add all elements of the list into result
                    List v -> transformRule localEnv ellipsisIndex (List $ result ++ v) (List $ tail ts) unused
                    v@(_) -> transformRule localEnv ellipsisIndex (List $ result ++ [v]) (List $ tail ts) unused
             else -- Matched 0 times, skip it
                  transformRule localEnv ellipsisIndex (List result) (List $ tail ts) unused
     else do t <- if isDefined
                     then do var <- getVar localEnv a
                             if ellipsisIndex > 0 
                                then do case var of
                                          List v -> if (length v) > (ellipsisIndex - 1)
                                                       then return $ v !! (ellipsisIndex - 1)
                                                       else return $ Nil ""
                                else return var
                     else return $ Atom a
             case t of
               Nil _ -> return t
               otherwise -> transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) unused

-- Transform anything else as itself...
transformRule localEnv ellipsisIndex (List result) transform@(List (t : ts)) (List ellipsisList) = do
  transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) (List ellipsisList)

-- Base case - empty transform
transformRule localEnv ellipsisIndex result@(List _) transform@(List []) unused = do
  return result

transformRule localEnv ellipsisIndex result transform unused = do
  throwError $ BadSpecialForm "An error occurred during macro transform" $ List [(Number $ toInteger ellipsisIndex), result, transform, unused]

-- Find an atom in a list; non-recursive (IE, a sub-list will not be inspected)
findAtom :: LispVal -> LispVal -> IOThrowsError LispVal
findAtom (Atom target) (List (Atom a:as)) = do
  if target == a
     then return $ Bool True
     else findAtom (Atom target) (List as)
findAtom target (List (badtype : _)) = throwError $ TypeMismatch "symbol" badtype -- TODO: test this, non-atoms should throw err
findAtom target _ = return $ Bool False
 
-- Initialize any pattern variables as an empty list.
-- That way a zero-match case can be identified later during transformation.
--
-- Input:
--  localEnv - Local environment that contains variables
--  src - Input source, required because a pair in the pattern may be matched by either a list or a pair,
--        and the transform needs to know this...
--  identifiers - Literal identifiers that are transformed as themselves
--  pattern - Pattern portion of the syntax rule
initializePatternVars :: Env -> String -> LispVal -> LispVal -> IOThrowsError LispVal
initializePatternVars localEnv src identifiers pattern@(List _) = do
    case pattern of
        List (p:ps) -> do initializePatternVars localEnv src identifiers p
                          initializePatternVars localEnv src identifiers $ List ps
        List [] -> return $ Bool True

initializePatternVars localEnv src identifiers pattern@(DottedList ps p) = do
    initializePatternVars localEnv src identifiers $ List ps
    initializePatternVars localEnv src identifiers p

-- TODO: vector

initializePatternVars localEnv src identifiers (Atom pattern) =  
       -- FUTURE:
       -- there is code to attempt to flag "src" here, but it is not
       -- wire up correctly. In fact, the whole design here probably
       -- needs to be rethinked.
    do defineNamespacedVar localEnv "src" pattern $ String src
       isDefined <- liftIO $ isBound localEnv pattern
       found <- findAtom (Atom pattern) identifiers
       case found of
            (Bool False) -> if not isDefined -- Set variable in the local environment
                               then do
                                        defineVar localEnv pattern (List [])
                               else do
                                        return $ Bool True
             -- Ignore identifiers since they are just passed along as-is
            otherwise -> return $ Bool True

initializePatternVars localEnv src identifiers pattern =  
    return $ Bool True 

-- Find the first pattern var that reports being from a src, or False if none
lookupPatternVarSrc :: Env -> LispVal -> IOThrowsError LispVal
lookupPatternVarSrc localEnv pattern@(List _) = do
    case pattern of
        List (p:ps) -> do result <- lookupPatternVarSrc localEnv p
                          case result of
                            Bool False -> lookupPatternVarSrc localEnv $ List ps
                            otherwise -> return result
        List [] -> return $ Bool False

lookupPatternVarSrc localEnv pattern@(DottedList ps p) = do
    result <- lookupPatternVarSrc localEnv $ List ps
    case result of
        Bool False -> lookupPatternVarSrc localEnv p
        otherwise -> return result

-- TODO: vector

lookupPatternVarSrc localEnv (Atom pattern) =  
    do isDefined <- liftIO $ isNamespacedBound localEnv "src" pattern
       if isDefined then getNamespacedVar localEnv "src" pattern
                    else return $ Bool False

lookupPatternVarSrc localEnv pattern =  
    return $ Bool False