module Language.Scheme.Libraries
(
findModuleFile
, moduleImport
) where
import qualified Paths_husk_scheme as PHS (getDataFileName)
import Language.Scheme.Types
import Language.Scheme.Util
import Language.Scheme.Variables
import Control.Monad.Error
findModuleFile
:: [LispVal]
-> IOThrowsError LispVal
findModuleFile [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= findModuleFile
findModuleFile [String file]
| file == "scheme/r5rs/base.sld" ||
file == "scheme/r5rs/char.sld" ||
file == "scheme/r5rs/complex.sld" ||
file == "scheme/r5rs/cxr.sld" ||
file == "scheme/r5rs/eval.sld" ||
file == "scheme/r5rs/file.sld" ||
file == "scheme/r5rs/inexact.sld" ||
file == "scheme/r5rs/lazy.sld" ||
file == "scheme/r5rs/load.sld" ||
file == "scheme/r5rs/read.sld" ||
file == "scheme/r5rs/write.sld" ||
file == "scheme/base.sld" ||
file == "husk/pretty-print.sld" ||
file == "scheme/time.sld" ||
file == "scheme/write.sld" = do
path <- liftIO $ PHS.getDataFileName $ "lib/" ++ file
return $ String path
| otherwise = return $ String file
findModuleFile _ = return $ Bool False
moduleImport
:: Env
-> Env
-> [LispVal]
-> IOThrowsError LispVal
moduleImport to from (p@(Pointer _ _) : is) = do
i <- derefPtr p
moduleImport to from (i : is)
moduleImport to from (Atom i : is) = do
_ <- divertBinding to from i i
moduleImport to from is
moduleImport to from (DottedList [Atom iRenamed] (Atom iOrig) : is) = do
_ <- divertBinding to from iOrig iRenamed
moduleImport to from is
moduleImport to from [] = do
return $ LispEnv to
moduleImport _ _ err = do
throwError $ Default $ "Unexpected argument to moduleImport: " ++ show err
divertBinding
:: Env
-> Env
-> String
-> String
-> IOThrowsError LispVal
divertBinding to from nameOrig nameNew = do
isMacroBound <- liftIO $ isNamespacedRecBound from macroNamespace nameOrig
namespace <- liftIO $ case isMacroBound of
True -> return macroNamespace
_ -> return varNamespace
m <- getNamespacedVar from namespace nameOrig
defineNamespacedVar to namespace nameNew m