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

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

This module contains code to handle R7RS libraries.
NOTE: Libraries are usually referred to as /modules/ in the husk source code.

-}

module Language.Scheme.Libraries
    (
      findModuleFile
    , moduleImport
    ) where
import Language.Scheme.Types
import Language.Scheme.Variables
import Control.Monad.Except

-- |Get the full path to a module file
findModuleFile 
    :: [LispVal]
    -> IOThrowsError LispVal
findModuleFile :: [LispVal] -> IOThrowsError LispVal
findModuleFile [p :: LispVal
p@(Pointer String
_ Env
_)] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
findModuleFile
findModuleFile [String String
file] = do
    -- Good enough now that load searches @lib@ if file not found
    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
String String
file
findModuleFile [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

-- |Import definitions from one environment into another
moduleImport 
    :: Env  -- ^ Environment to import into
    -> Env  -- ^ Environment to import from
    -> [LispVal] -- ^ Identifiers to import
    -> IOThrowsError LispVal
moduleImport :: Env -> Env -> [LispVal] -> IOThrowsError LispVal
moduleImport Env
to Env
from (p :: LispVal
p@(Pointer String
_ Env
_) : [LispVal]
is) = do
  LispVal
i <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  Env -> Env -> [LispVal] -> IOThrowsError LispVal
moduleImport Env
to Env
from (LispVal
i LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
is)
moduleImport Env
to Env
from (Atom String
i : [LispVal]
is) = do
  LispVal
_ <- Env -> Env -> String -> String -> IOThrowsError LispVal
divertBinding Env
to Env
from String
i String
i
  Env -> Env -> [LispVal] -> IOThrowsError LispVal
moduleImport Env
to Env
from [LispVal]
is
moduleImport Env
to Env
from (DottedList [Atom String
iRenamed] (Atom String
iOrig) : [LispVal]
is) = do
  LispVal
_ <- Env -> Env -> String -> String -> IOThrowsError LispVal
divertBinding Env
to Env
from String
iOrig String
iRenamed
  Env -> Env -> [LispVal] -> IOThrowsError LispVal
moduleImport Env
to Env
from [LispVal]
is
moduleImport Env
to Env
_ [] = do
  LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Env -> LispVal
LispEnv Env
to
moduleImport Env
_ Env
_ [LispVal]
err = 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 -> LispError
Default (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ String
"Unexpected argument to moduleImport: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
err

-- |Copy a binding from one env to another
divertBinding
    :: Env  -- ^ Environment to import into
    -> Env  -- ^ Environment to import from
    -> String -- ^ Name of the binding in @from@
    -> String -- ^ Name to use for the binding in @to@
    -> IOThrowsError LispVal
divertBinding :: Env -> Env -> String -> String -> IOThrowsError LispVal
divertBinding Env
to Env
from String
nameOrig String
nameNew = do
  Bool
isMacroBound <- 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 -> Char -> String -> IO Bool
isNamespacedRecBound Env
from Char
macroNamespace String
nameOrig
  Char
namespace <- IO Char -> ExceptT LispError IO Char
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Char -> ExceptT LispError IO Char)
-> IO Char -> ExceptT LispError IO Char
forall a b. (a -> b) -> a -> b
$ if Bool
isMacroBound then Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
macroNamespace
                                        else Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
varNamespace
  LispVal
m <- Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
from Char
namespace String
nameOrig
  Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
to Char
namespace String
nameNew LispVal
m