module Language.Scheme.Macro
(
macroEval
, loadMacros
, expand
) where
import Language.Scheme.Types
import Language.Scheme.Variables
import qualified Language.Scheme.Macro.Matches as Matches
import Language.Scheme.Primitives (_gensym)
import Control.Monad.Error
import Data.Array
macroEval :: Env -> LispVal -> IOThrowsError LispVal
macroEval env lisp@(List (Atom x : _)) = do
isDefined <- liftIO $ isNamespacedRecBound env macroNamespace x
if isDefined
then do
Syntax (Just defEnv) _ definedInMacro identifiers rules <- getNamespacedVar env macroNamespace x
renameEnv <- liftIO $ nullEnv
cleanupEnv <- liftIO $ nullEnv
expanded <- macroTransform defEnv env env renameEnv cleanupEnv
definedInMacro
(List identifiers) rules lisp
macroEval env expanded
else return lisp
macroEval _ lisp@(_) = return lisp
macroTransform :: Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal
macroTransform defEnv env divertEnv renameEnv cleanupEnv dim identifiers (rule@(List _) : rs) input = do
localEnv <- liftIO $ nullEnv
result <- matchRule defEnv env divertEnv dim identifiers localEnv renameEnv cleanupEnv rule input
case (result) of
Nil _ -> macroTransform defEnv env divertEnv renameEnv cleanupEnv dim identifiers rs input
_ -> do
walkExpanded defEnv env divertEnv renameEnv cleanupEnv dim True False (List []) (result)
macroTransform _ _ _ _ _ _ _ _ input = throwError $ BadSpecialForm "Input does not match a macro pattern" input
macroElementMatchesMany :: LispVal -> Bool
macroElementMatchesMany (List (_ : ps)) = do
if not (null ps)
then case (head ps) of
Atom "..." -> True
_ -> False
else False
macroElementMatchesMany _ = False
matchRule :: Env -> Env -> Env -> Bool -> LispVal -> Env -> Env -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
matchRule defEnv outerEnv divertEnv dim identifiers localEnv renameEnv cleanupEnv (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], True)
_ -> (pattern, False)
_ -> (pattern, False)
case p of
((List (Atom _ : ps)), flag) -> do
match <- checkPattern ps is flag
case match of
Bool False -> return $ Nil ""
_ -> do
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers 0 [] (List []) template
_ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ String $ show p
where
checkPattern ps@(DottedList ds d : _) is True = do
case is of
(DottedList _ _ : _) -> do
loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers
(List $ ds ++ [d, Atom "..."])
(List is)
0 []
(flagDottedLists [] (False, False) 0)
(List _ : _) -> do
loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers
(List $ ds ++ [d, Atom "..."])
(List is)
0 []
(flagDottedLists [] (True, False) 0)
_ -> loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] []
checkPattern ps is _ = loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] []
matchRule _ _ _ _ _ _ _ _ rule input = do
throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ List [Atom "rule: ", rule, Atom "input: ", input]
loadLocal :: Env -> Env -> Env -> Env -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> IOThrowsError LispVal
loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex listFlags = do
case (pattern, input) of
((DottedList ps p), (DottedList isRaw iRaw)) -> do
let isSplit = splitAt (length ps) isRaw
let is = fst isSplit
let i = (snd isSplit) ++ [iRaw]
result <- loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags
case result of
Bool True ->
loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers
(List $ [p, Atom "..."])
(List i)
ellipsisLevel
ellipsisIndex
(flagDottedLists listFlags (True, True) $ length ellipsisIndex)
_ -> return $ Bool False
(List (p : ps), List (i : is)) -> do
let nextHasEllipsis = macroElementMatchesMany pattern
let level = if nextHasEllipsis then ellipsisLevel + 1
else ellipsisLevel
let idx = if nextHasEllipsis
then if (length ellipsisIndex == level)
then do
let l = splitAt (level 1) ellipsisIndex
(fst l) ++ [(head (snd l)) + 1]
else ellipsisIndex ++ [0]
else ellipsisIndex
status <- checkLocal defEnv outerEnv divertEnv (localEnv) renameEnv identifiers level idx p i listFlags
case (status) of
Bool False -> if nextHasEllipsis
then do
case ps of
[Atom "..."] -> return $ Bool True
_ -> loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ tail ps) (List (i : is)) ellipsisLevel ellipsisIndex listFlags
else return $ Bool False
_ -> if nextHasEllipsis
then
loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern (List is)
ellipsisLevel
idx
listFlags
else loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags
(List [], List []) -> return $ Bool True
(List (_ : _), List []) -> do
if (macroElementMatchesMany pattern)
then do
let flags = getListFlags (ellipsisIndex ++ [0]) listFlags
flagUnmatchedVars defEnv outerEnv localEnv identifiers pattern $ fst flags
else return $ Bool False
(List [], _) -> return $ Bool False
(_, _) -> checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern input listFlags
flagUnmatchedVars :: Env -> Env -> Env -> LispVal -> LispVal -> Bool -> IOThrowsError LispVal
flagUnmatchedVars defEnv outerEnv localEnv identifiers (DottedList ps p) partOfImproperPattern = do
flagUnmatchedVars defEnv outerEnv localEnv identifiers (List $ ps ++ [p]) partOfImproperPattern
flagUnmatchedVars defEnv outerEnv localEnv identifiers (Vector p) partOfImproperPattern = do
flagUnmatchedVars defEnv outerEnv localEnv identifiers (List $ elems p) partOfImproperPattern
flagUnmatchedVars _ _ _ _ (List []) _ = return $ Bool True
flagUnmatchedVars defEnv outerEnv localEnv identifiers (List (p : ps)) partOfImproperPattern = do
_ <- flagUnmatchedVars defEnv outerEnv localEnv identifiers p partOfImproperPattern
flagUnmatchedVars defEnv outerEnv localEnv identifiers (List ps) partOfImproperPattern
flagUnmatchedVars _ _ _ _ (Atom "...") _ = return $ Bool True
flagUnmatchedVars defEnv outerEnv localEnv identifiers (Atom p) partOfImproperPattern =
flagUnmatchedAtom defEnv outerEnv localEnv identifiers p partOfImproperPattern
flagUnmatchedVars _ _ _ _ _ _ = return $ Bool True
flagUnmatchedAtom :: Env -> Env -> Env -> LispVal -> String -> Bool -> IOThrowsError LispVal
flagUnmatchedAtom defEnv outerEnv localEnv identifiers p improperListFlag = do
isDefined <- liftIO $ isBound localEnv p
isIdent <- findAtom (Atom p) identifiers
if isDefined
then continueFlagging
else case isIdent of
Bool True -> do
matches <- identifierMatches defEnv outerEnv p
if not matches
then return $ Bool True
else do _ <- flagUnmatchedVar localEnv p improperListFlag
continueFlagging
_ -> do _ <- flagUnmatchedVar localEnv p improperListFlag
continueFlagging
where continueFlagging = return $ Bool True
flagUnmatchedVar :: Env -> String -> Bool -> IOThrowsError LispVal
flagUnmatchedVar localEnv var improperListFlag = do
_ <- defineVar localEnv var $ Nil ""
defineNamespacedVar localEnv "unmatched nary pattern variable" var $ Bool $ improperListFlag
flagDottedLists :: [(Bool, Bool)] -> (Bool, Bool) -> Int -> [(Bool, Bool)]
flagDottedLists listFlags status lengthOfEllipsisIndex
| length listFlags == lengthOfEllipsisIndex = listFlags ++ [status]
| otherwise = listFlags ++ (replicate ((lengthOfEllipsisIndex) (length listFlags)) (False, False)) ++ [status]
getListFlags :: [Int] -> [(Bool, Bool)] -> (Bool, Bool)
getListFlags elIndices flags
| length elIndices > 0 && length flags >= length elIndices = flags !! ((length elIndices) 1)
| otherwise = (False, False)
checkLocal :: Env
-> Env
-> Env
-> Env
-> Env
-> LispVal
-> Int
-> [Int]
-> LispVal
-> LispVal
-> [(Bool, Bool)]
-> IOThrowsError LispVal
checkLocal _ _ _ _ _ _ _ _ (Bool pattern) (Bool input) _ = return $ Bool $ pattern == input
checkLocal _ _ _ _ _ _ _ _ (Number pattern) (Number input) _ = return $ Bool $ pattern == input
checkLocal _ _ _ _ _ _ _ _ (Float pattern) (Float input) _ = return $ Bool $ pattern == input
checkLocal _ _ _ _ _ _ _ _ (String pattern) (String input) _ = return $ Bool $ pattern == input
checkLocal _ _ _ _ _ _ _ _ (Char pattern) (Char input) _ = return $ Bool $ pattern == input
checkLocal defEnv outerEnv _ localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Atom pattern) input listFlags = do
isRenamed <- liftIO $ isRecBound renameEnv (pattern)
doesIdentMatch <- identifierMatches defEnv outerEnv pattern
if (ellipsisLevel) > 0
then do isDefined <- liftIO $ isBound localEnv pattern
isIdent <- findAtom (Atom pattern) identifiers
case isIdent of
Bool True -> do
case input of
Atom inpt -> do
if (pattern == inpt)
then if (doesIdentMatch) && (not isRenamed)
then do
addPatternVar isDefined ellipsisLevel ellipsisIndex pattern $ Atom pattern
else return $ Bool False
else return $ Bool False
_ -> return $ Bool False
_ -> addPatternVar isDefined ellipsisLevel ellipsisIndex pattern input
else do
isIdent <- findAtom (Atom pattern) identifiers
case (isIdent) of
Bool True -> do
case input of
Atom inpt -> do
if (pattern == inpt && (doesIdentMatch)) && (not isRenamed)
then do _ <- defineVar localEnv pattern input
return $ Bool True
else return $ (Bool False)
_ -> return $ (Bool False)
_ -> do _ <- defineVar localEnv pattern input
return $ Bool True
where
addPatternVar isDefined ellipLevel ellipIndex pat val
| isDefined = do v <- getVar localEnv pat
case (v) of
Nil _ -> do
_ <- initializePatternVar ellipLevel ellipIndex pat val
return $ Bool False
_ -> do _ <- setVar localEnv pat (Matches.setData v ellipIndex val)
return $ Bool True
| otherwise = do
_ <- initializePatternVar ellipLevel ellipIndex pat val
return $ Bool True
initializePatternVar _ ellipIndex pat val = do
let flags = getListFlags ellipIndex listFlags
_ <- defineVar localEnv pat (Matches.setData (List []) ellipIndex val)
_ <- defineNamespacedVar localEnv "improper pattern" pat $ Bool $ fst flags
defineNamespacedVar localEnv "improper input" pat $ Bool $ snd flags
checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Vector p) (Vector i) flags =
loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ elems p) (List $ elems i) ellipsisLevel ellipsisIndex flags
checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern@(DottedList _ _) input@(DottedList _ _) flags =
loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex flags
checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (DottedList ps p) input@(List (_ : _)) flags = do
loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers
(List $ ps ++ [p, Atom "..."])
input
ellipsisLevel
ellipsisIndex
(flagDottedLists flags (True, False) $ length ellipsisIndex)
checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern@(List _) input@(List _) flags =
loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex flags
checkLocal _ _ _ _ _ _ _ _ _ _ _ = return $ Bool False
identifierMatches :: Env -> Env -> String -> IOThrowsError Bool
identifierMatches defEnv useEnv ident = do
atDef <- liftIO $ isRecBound defEnv ident
atUse <- liftIO $ isRecBound useEnv ident
matchIdent atDef atUse
where
matchIdent False False = return True
matchIdent True True = do
d <- getVar defEnv ident
u <- getVar useEnv ident
return $ eqVal d u
matchIdent _ _ = return False
expand :: Env -> Bool -> LispVal -> IOThrowsError LispVal
expand env dim code = do
renameEnv <- liftIO $ nullEnv
cleanupEnv <- liftIO $ nullEnv
walkExpanded env env env renameEnv cleanupEnv dim True False (List []) code
walkExpanded :: Env -> Env -> Env -> Env -> Env -> Bool -> Bool -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List (List l : ls)) = do
lst <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQuoted (List []) (List l)
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List $ result ++ [lst]) (List ls)
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List ((Vector v) : vs)) = do
List lst <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List []) (List $ elems v)
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List $ result ++ [asVector lst]) (List vs)
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List ((DottedList ds d) : ts)) = do
List ls <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List []) (List ds)
l <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List []) d
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List $ result ++ [DottedList ls l]) (List ts)
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim startOfList inputIsQuoted (List result) (List (Atom aa : ts)) = do
Atom a <- expandAtom renameEnv (Atom aa)
let isQuoted = inputIsQuoted || (a == "quote") || (a == "quasiquote")
isDefinedAsMacro <- liftIO $ isNamespacedRecBound useEnv macroNamespace a
if isDefinedAsMacro
|| a == aa
|| a == "if"
|| a == "begin"
|| a == "let-syntax"
|| a == "letrec-syntax"
|| a == "define-syntax"
|| a == "define"
|| a == "set!"
|| a == "lambda"
then walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv
dim startOfList inputIsQuoted (List result) a ts isQuoted isDefinedAsMacro
else walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv
dim startOfList inputIsQuoted (List result) (List (Atom a : ts))
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List (t : ts)) = do
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List $ result ++ [t]) (List ts)
walkExpanded _ _ _ _ _ _ _ _ result@(List _) (List []) = return result
walkExpanded _ _ _ renameEnv _ _ _ _ _ (Atom a) = expandAtom renameEnv (Atom a)
walkExpanded _ _ _ _ _ _ _ _ _ transform = return transform
walkExpandedAtom :: Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> Bool
-> Bool
-> LispVal
-> String
-> [LispVal]
-> Bool
-> Bool
-> IOThrowsError LispVal
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List _)
"let-syntax"
(List _bindings : _body)
False _ = do
bodyEnv <- liftIO $ extendEnv useEnv []
bodyRenameEnv <- liftIO $ extendEnv renameEnv []
_ <- loadMacros useEnv bodyEnv (Just bodyRenameEnv) True _bindings
expanded <- walkExpanded defEnv bodyEnv divertEnv bodyRenameEnv cleanupEnv dim True inputIsQuoted (List [Atom "lambda", List []]) (List _body)
return $ List [expanded]
walkExpandedAtom _ _ _ _ _ _ True _ _ "let-syntax" ts False _ = do
throwError $ BadSpecialForm "Malformed let-syntax expression" $ List (Atom "let-syntax" : ts)
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List _)
"letrec-syntax"
(List _bindings : _body)
False _ = do
bodyEnv <- liftIO $ extendEnv useEnv []
bodyRenameEnv <- liftIO $ extendEnv renameEnv []
_ <- loadMacros bodyEnv bodyEnv (Just bodyRenameEnv) True _bindings
expanded <- walkExpanded defEnv bodyEnv divertEnv bodyRenameEnv cleanupEnv dim True inputIsQuoted (List [Atom "lambda", List []]) (List _body)
return $ List [expanded]
walkExpandedAtom _ _ _ _ _ _ True _ _ "letrec-syntax" ts False _ = do
throwError $ BadSpecialForm "Malformed letrec-syntax expression" $ List (Atom "letrec-syntax" : ts)
walkExpandedAtom _ useEnv _ renameEnv _ _ True _ (List _)
"define-syntax"
([Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))])
False _ = do
renameEnvClosure <- liftIO $ copyEnv renameEnv
_ <- defineNamespacedVar useEnv macroNamespace keyword $ Syntax (Just useEnv) (Just renameEnvClosure) True identifiers rules
return $ Nil ""
walkExpandedAtom _ _ _ _ _ _ True _ _ "define-syntax" ts False _ = do
throwError $ BadSpecialForm "Malformed define-syntax expression" $ List (Atom "define-syntax" : ts)
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List _)
"define"
[Atom var, val]
False _ = do
_ <- defineVar renameEnv var $ Atom var
walk
where walk = walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List [Atom "define", Atom var]) (List [val])
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a@"define" ts False _ = do
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts)
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List _)
"set!"
[Atom var, val]
False _ = do
isLexicalDef <- liftIO $ isRecBound useEnv var
isAlreadyRenamed <- liftIO $ isRecBound renameEnv var
case (isLexicalDef, isAlreadyRenamed) of
(True, False) -> do
_ <- defineVar renameEnv var $ Atom var
walk
_ -> walk
where
walk = walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List [Atom "set!"]) (List [Atom var, val])
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a@"set!" ts False _ = do
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts)
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List _)
"lambda"
(List vars : fbody)
False _ = do
env <- liftIO $ extendEnv renameEnv []
renamedVars <- markBoundIdentifiers env cleanupEnv vars []
walkExpanded defEnv useEnv divertEnv env cleanupEnv dim True False (List [Atom "lambda", (renamedVars)]) (List fbody)
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a@"lambda" ts False _ = do
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts)
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv _ True _ (List _)
a
ts
False True = do
syn <- getNamespacedVar useEnv macroNamespace a
case syn of
Syntax _ (Just renameClosure) definedInMacro identifiers rules -> do
List lexpanded <- cleanExpanded defEnv useEnv divertEnv renameEnv renameEnv True False False (List []) (List ts)
macroTransform defEnv useEnv divertEnv renameClosure cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : lexpanded))
Syntax (Just _defEnv) _ definedInMacro identifiers rules -> do
macroTransform _defEnv useEnv divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts))
Syntax Nothing _ definedInMacro identifiers rules -> do
macroTransform defEnv useEnv divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts))
_ -> throwError $ Default "Unexpected error processing a macro in walkExpandedAtom"
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim _ _ (List result)
a
ts
True _ = do
let isQuasiQuoted = (a == "quasiquote")
List cleaned <- cleanExpanded
defEnv useEnv divertEnv renameEnv cleanupEnv
dim True isQuasiQuoted
(List []) (List ts)
return $ List $ result ++ (Atom a : cleaned)
walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim _ _ (List result)
a ts isQuoted _ = do
walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv
dim False isQuoted
(List $ result ++ [Atom a]) (List ts)
walkExpandedAtom _ _ _ _ _ _ _ _ _ _ _ _ _ = throwError $ Default "Unexpected error in walkExpandedAtom"
markBoundIdentifiers :: Env -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
markBoundIdentifiers env cleanupEnv (Atom v : vs) renamedVars = do
Atom renamed <- _gensym v
_ <- defineVar env v $ Atom renamed
_ <- defineVar cleanupEnv renamed $ Atom v
markBoundIdentifiers env cleanupEnv vs $ renamedVars ++ [Atom renamed]
markBoundIdentifiers env cleanupEnv (_: vs) renamedVars = markBoundIdentifiers env cleanupEnv vs renamedVars
markBoundIdentifiers _ _ [] renamedVars = return $ List renamedVars
expandAtom :: Env -> LispVal -> IOThrowsError LispVal
expandAtom renameEnv (Atom a) = do
isDefined <- liftIO $ isRecBound renameEnv a
if isDefined
then do
expanded <- getVar renameEnv a
return expanded
else return $ Atom a
expandAtom _ a = return a
cleanExpanded :: Env -> Env -> Env -> Env -> Env -> Bool -> Bool -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQQ (List result) (List (List l : ls)) = do
lst <- cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQQ (List []) (List l)
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQQ (List $ result ++ [lst]) (List ls)
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQQ (List result) (List ((Vector v) : vs)) = do
List lst <- cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQQ (List []) (List $ elems v)
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQQ (List $ result ++ [asVector lst]) (List vs)
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQQ (List result) (List ((DottedList ds d) : ts)) = do
List ls <- cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQQ (List []) (List ds)
l <- cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQQ (List []) d
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQQ (List $ result ++ [DottedList ls l]) (List ts)
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim startOfList isQQ (List result) (List (Atom a : ts)) = do
expanded <- tmpexpandAtom cleanupEnv $ Atom a
case (startOfList, isQQ, expanded) of
(True, True, Atom "unquote") -> do
r <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True False (List $ result ++ [Atom "unquote"]) (List ts)
return r
_ ->
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQQ (List $ result ++ [expanded]) (List ts)
where
tmpexpandAtom :: Env -> LispVal -> IOThrowsError LispVal
tmpexpandAtom _renameEnv (Atom _a) = do
isDefined <- liftIO $ isRecBound _renameEnv _a
if isDefined
then do
expanded <- getVar _renameEnv _a
tmpexpandAtom _renameEnv expanded
else return $ Atom _a
tmpexpandAtom _ _a = return _a
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQQ (List result) (List (t : ts)) = do
cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQQ (List $ result ++ [t]) (List ts)
cleanExpanded _ _ _ _ _ _ _ _ result@(List _) (List []) = do
return result
cleanExpanded _ _ _ _ _ _ _ _ _ transform = return transform
transformRule :: Env
-> Env
-> Env
-> Env
-> Env
-> Env
-> Bool
-> LispVal
-> Int
-> [Int]
-> LispVal
-> LispVal
-> IOThrowsError LispVal
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (List l : ts)) = do
let nextHasEllipsis = macroElementMatchesMany transform
let level = calcEllipsisLevel nextHasEllipsis ellipsisLevel
let idx = calcEllipsisIndex nextHasEllipsis level ellipsisIndex
if (nextHasEllipsis)
then do
curT <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers level idx (List []) (List l)
case (curT) of
Nil _ ->
continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers
ellipsisLevel
(init ellipsisIndex)
result $ tail ts
List _ -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers
ellipsisLevel
idx
(List $ result ++ [curT]) transform
_ -> throwError $ Default "Unexpected error"
else do
lst <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List l)
case lst of
List _ -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [lst]) (List ts)
Nil _ -> return lst
_ -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisLevel]
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) transform@(List ((Vector v) : ts)) = do
let nextHasEllipsis = macroElementMatchesMany transform
let level = calcEllipsisLevel nextHasEllipsis ellipsisLevel
let idx = calcEllipsisIndex nextHasEllipsis level ellipsisIndex
if nextHasEllipsis
then do
curT <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers level idx (List []) (List $ elems v)
case curT of
Nil _ ->
continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel (init ellipsisIndex) result $ tail ts
List t -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers
ellipsisLevel
idx
(List $ result ++ [asVector t]) transform
_ -> throwError $ Default "Unexpected error in transformRule"
else do lst <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List $ elems v)
case lst of
List l -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [asVector l]) (List ts)
Nil _ -> return lst
_ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [lst, (List [Vector v]), Number $ toInteger ellipsisLevel]
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) = do
let nextHasEllipsis = macroElementMatchesMany transform
let level = calcEllipsisLevel nextHasEllipsis ellipsisLevel
let idx = calcEllipsisIndex nextHasEllipsis level ellipsisIndex
if nextHasEllipsis
then do
curT <- transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers level idx (List []) (List [dl])
case curT of
Nil _ ->
continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel (init ellipsisIndex) result $ tail ts
List t -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers
ellipsisLevel
idx
(List $ result ++ t) transform
_ -> throwError $ Default "Unexpected error in transformRule"
else do lst <- transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List [dl])
case lst of
List l -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ l) (List ts)
Nil _ -> return lst
_ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [lst, (List [dl]), Number $ toInteger ellipsisLevel]
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (Atom a : ts)) = do
Bool isIdent <- findAtom (Atom a) identifiers
isDefined <- liftIO $ isBound localEnv a
if isIdent
then literalHere
else do
if hasEllipsis
then ellipsisHere isDefined
else noEllipsis isDefined
where
literalHere = do
expanded <- transformLiteralIdentifier defEnv outerEnv divertEnv renameEnv dim a
if hasEllipsis
then do
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [expanded]) (List $ tail ts)
else do
continueTransformWith $ result ++ [expanded]
appendNil d (Bool isImproperPattern) (Bool isImproperInput) =
case d of
List lst -> if isImproperPattern && not isImproperInput
then List $ lst ++ [List []]
else List lst
_ -> d
appendNil d _ _ = d
loadNamespacedBool namespc = do
isDef <- liftIO $ isNamespacedBound localEnv namespc a
if isDef
then getNamespacedVar localEnv namespc a
else return $ Bool False
hasEllipsis = macroElementMatchesMany transform
ellipsisHere isDefined = do
if isDefined
then do
isImproperPattern <- loadNamespacedBool "improper pattern"
isImproperInput <- loadNamespacedBool "improper input"
var <- getVar localEnv a
case var of
List _ -> do case (appendNil (Matches.getData var ellipsisIndex) isImproperPattern isImproperInput) of
List aa -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ aa) (List $ tail ts)
_ ->
continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex result $ tail ts
Nil "" ->
continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex result $ tail ts
v@(_) -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [v]) (List $ tail ts)
else
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) (List $ tail ts)
noEllipsis isDefined = do
isImproperPattern <- loadNamespacedBool "improper pattern"
isImproperInput <- loadNamespacedBool "improper input"
t <- if (isDefined)
then do
var <- getVar localEnv a
case (var) of
Nil "" -> do
wasPair <- getNamespacedVar localEnv "unmatched nary pattern variable" a
case wasPair of
Bool True -> return $ Nil "var (pair) not defined in pattern"
_ -> return $ Nil "var not defined in pattern"
Nil input -> do v <- getVar outerEnv input
return v
List v -> do
if ellipsisLevel > 0
then
return $ appendNil (Matches.getData var ellipsisIndex)
isImproperPattern
isImproperInput
else if length v > 0
then return var
else return $ Nil ""
_ -> if ellipsisLevel > 0
then
throwError $ Default "Unexpected error processing data in transformRule"
else return var
else do
isAlreadyRenamed <- liftIO $ isNamespacedBound localEnv "renamed" a
if isAlreadyRenamed
then do
renamed <- getNamespacedVar localEnv "renamed" a
return renamed
else do
Atom renamed <- _gensym a
_ <- defineNamespacedVar localEnv "renamed" a $ Atom renamed
_ <- defineNamespacedVar renameEnv "renamed" a $ Atom renamed
_ <- defineVar cleanupEnv renamed $ Atom a
_ <- defineVar (renameEnv) renamed $ Atom a
return $ Atom renamed
case t of
Nil "var not defined in pattern" ->
if ellipsisLevel > 0
then return t
else continueTransformWith result
Nil "var (pair) not defined in pattern" ->
if ellipsisLevel > 0
then return t
else continueTransformWith $ result ++ [List []]
Nil _ -> return t
List l -> do
if (eqVal isImproperPattern $ Bool True) && (eqVal isImproperInput $ Bool True)
then continueTransformWith $ result ++ (buildImproperList l)
else continueTransformWith $ result ++ [t]
_ -> continueTransformWith $ result ++ [t]
buildImproperList lst
| length lst > 1 = [DottedList (init lst) (last lst)]
| otherwise = lst
continueTransformWith results =
transformRule defEnv outerEnv divertEnv
localEnv
renameEnv cleanupEnv dim identifiers
ellipsisLevel
ellipsisIndex
(List $ results)
(List ts)
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) (List (t : ts)) = do
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [t]) (List ts)
transformRule _ _ _ _ _ _ _ _ _ _ result@(List _) (List []) = do
return result
transformRule defEnv outerEnv divertEnv localEnv renameEnv _ dim identifiers _ _ _ (Atom transform) = do
Bool isIdent <- findAtom (Atom transform) identifiers
isPattVar <- liftIO $ isRecBound localEnv transform
if isPattVar && not isIdent
then getVar localEnv transform
else transformLiteralIdentifier defEnv outerEnv divertEnv renameEnv dim transform
transformRule _ _ _ _ _ _ _ _ _ _ _ transform = return transform
transformLiteralIdentifier :: Env -> Env -> Env -> Env -> Bool -> String -> IOThrowsError LispVal
transformLiteralIdentifier defEnv _ divertEnv renameEnv definedInMacro transform = do
isInDef <- liftIO $ isRecBound defEnv transform
isRenamed <- liftIO $ isRecBound renameEnv transform
if (isInDef && not definedInMacro) || (isInDef && definedInMacro && not isRenamed)
then do
value <- getVar defEnv transform
Atom renamed <- _gensym transform
_ <- defineVar divertEnv renamed value
return $ Atom renamed
else do
return $ Atom transform
transformDottedList :: Env -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> Int -> [Int] -> LispVal -> LispVal -> IOThrowsError LispVal
transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) (List (DottedList ds d : ts)) = do
lsto <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List ds)
case lsto of
List lst -> do
r <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers
ellipsisLevel
ellipsisIndex
(List [])
(List [d, Atom "..."])
case r of
List [] ->
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts)
Nil _ ->
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts)
List rst -> do
transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex
(buildTransformedCode result lst rst) (List ts)
_ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d
Nil _ -> return $ Nil ""
_ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d
where
buildTransformedCode results ps p = do
case p of
[List []] -> List $ results ++ [List ps]
[List l@(Atom "unquote" : _ )] -> List $ results ++ [DottedList ps $ List l]
[List ls] -> List $ results ++ [List $ ps ++ ls]
[l] -> List $ results ++ [DottedList ps l]
ls -> do
case last ls of
List [] -> List $ results ++ [List $ ps ++ init ls]
List lls -> List $ results ++ [List $ ps ++ (init ls) ++ lls]
t -> List $ results ++ [DottedList (ps ++ init ls) t]
transformDottedList _ _ _ _ _ _ _ _ _ _ _ _ = throwError $ Default "Unexpected error in transformDottedList"
continueTransform :: Env -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex result remaining = do
if not (null remaining)
then transformRule defEnv outerEnv divertEnv
localEnv
renameEnv
cleanupEnv dim identifiers
ellipsisLevel
ellipsisIndex
(List result)
(List $ remaining)
else if length result > 0
then return $ List result
else if ellipsisLevel > 0
then return $ Nil ""
else return $ List []
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 _ (List (badtype : _)) = throwError $ TypeMismatch "symbol" badtype
findAtom _ _ = return $ Bool False
calcEllipsisLevel :: Bool -> Int -> Int
calcEllipsisLevel nextHasEllipsis ellipsisLevel =
if nextHasEllipsis then ellipsisLevel + 1
else ellipsisLevel
calcEllipsisIndex :: Bool -> Int -> [Int] -> [Int]
calcEllipsisIndex nextHasEllipsis ellipsisLevel ellipsisIndex =
if nextHasEllipsis
then if (length ellipsisIndex == ellipsisLevel)
then do
let l = splitAt (ellipsisLevel 1) ellipsisIndex
(fst l) ++ [(head (snd l)) + 1]
else ellipsisIndex ++ [0]
else ellipsisIndex
asVector :: [LispVal] -> LispVal
asVector lst = (Vector $ (listArray (0, length lst 1)) lst)
loadMacros :: Env
-> Env
-> Maybe Env
-> Bool
-> [LispVal]
-> IOThrowsError LispVal
loadMacros e be Nothing dim (List [Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))] : bs) = do
_ <- defineNamespacedVar be macroNamespace keyword $
Syntax (Just e) Nothing dim identifiers rules
loadMacros e be Nothing dim bs
loadMacros e be (Just re) dim args@(List [Atom keyword, (List (Atom syntaxrules : (List identifiers : rules)))] : bs) = do
Atom exKeyword <- expandAtom re (Atom keyword)
exSynRules <- expandAtom re (Atom syntaxrules)
case exSynRules of
Atom "syntax-rules" -> do
_ <- defineNamespacedVar be macroNamespace exKeyword $
Syntax (Just e) (Just re) dim identifiers rules
loadMacros e be (Just re) dim bs
_ -> throwError $ BadSpecialForm "Unable to evaluate form" $ List args
loadMacros _ _ _ _ [] = return $ Nil ""
loadMacros _ _ _ _ form = throwError $ BadSpecialForm "Unable to evaluate form" $ List form