mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
Added support for (load-once)
.
This commit is contained in:
parent
26a4b02009
commit
ca804beace
@ -78,7 +78,7 @@ main = do setLocaleEncoding utf8
|
||||
""
|
||||
execMode
|
||||
[]
|
||||
context <- loadFiles startingContext coreModulesToLoad
|
||||
context <- loadFilesOnce startingContext coreModulesToLoad
|
||||
carpProfile <- configPath "profile.carp"
|
||||
hasProfile <- doesFileExist carpProfile
|
||||
context' <- if (not noProfile) && hasProfile
|
||||
|
@ -15,41 +15,40 @@
|
||||
(system-include "core.h")
|
||||
(system-include "carp_memory.h")
|
||||
|
||||
(load "Interfaces.carp")
|
||||
(load "Bool.carp")
|
||||
(load "Macros.carp")
|
||||
(load "Generics.carp")
|
||||
(load "Maybe.carp")
|
||||
(load "Result.carp")
|
||||
(load "Dynamic.carp")
|
||||
(load "Format.carp")
|
||||
(load "Byte.carp")
|
||||
(load "Int.carp")
|
||||
(load "Long.carp")
|
||||
(load "Double.carp")
|
||||
(load "Float.carp")
|
||||
(load "Tuples.carp")
|
||||
(load "StaticArray.carp")
|
||||
(load "Array.carp")
|
||||
(load "Char.carp")
|
||||
(load "String.carp")
|
||||
(load "StdInt.carp")
|
||||
(load "System.carp")
|
||||
(load "IO.carp")
|
||||
(load "Pattern.carp")
|
||||
(load "Debug.carp")
|
||||
(load "Pointer.carp")
|
||||
(load "Format.carp")
|
||||
(load "Random.carp")
|
||||
(load "Map.carp")
|
||||
(load "Heap.carp")
|
||||
(load "Sort.carp")
|
||||
(load "Binary.carp")
|
||||
(load "Control.carp")
|
||||
(load-once "Interfaces.carp")
|
||||
(load-once "Bool.carp")
|
||||
(load-once "Macros.carp")
|
||||
(load-once "Generics.carp")
|
||||
(load-once "Maybe.carp")
|
||||
(load-once "Result.carp")
|
||||
(load-once "Dynamic.carp")
|
||||
(load-once "Format.carp")
|
||||
(load-once "Byte.carp")
|
||||
(load-once "Int.carp")
|
||||
(load-once "Long.carp")
|
||||
(load-once "Double.carp")
|
||||
(load-once "Float.carp")
|
||||
(load-once "Tuples.carp")
|
||||
(load-once "StaticArray.carp")
|
||||
(load-once "Array.carp")
|
||||
(load-once "Char.carp")
|
||||
(load-once "String.carp")
|
||||
(load-once "StdInt.carp")
|
||||
(load-once "System.carp")
|
||||
(load-once "IO.carp")
|
||||
(load-once "Pattern.carp")
|
||||
(load-once "Debug.carp")
|
||||
(load-once "Pointer.carp")
|
||||
(load-once "Format.carp")
|
||||
(load-once "Random.carp")
|
||||
(load-once "Map.carp")
|
||||
(load-once "Heap.carp")
|
||||
(load-once "Sort.carp")
|
||||
(load-once "Binary.carp")
|
||||
(load-once "Control.carp")
|
||||
|
||||
(if (not (dynamic-or (= "windows" (os)) (= "mingw32" (os))))
|
||||
(do
|
||||
(system-include "sys/wait.h")
|
||||
(system-include "unistd.h"))
|
||||
())
|
||||
|
||||
|
@ -1,4 +1,4 @@
|
||||
(load "Macros.carp")
|
||||
(load-once "Macros.carp")
|
||||
|
||||
;; The 'copy' and 'str' interfaces are defined internally:
|
||||
;;(definterface copy (λ [&a] a))
|
||||
|
@ -1973,6 +1973,25 @@ and then to the following argument.</p>
|
||||
|
||||
</p>
|
||||
</div>
|
||||
<div class="binder">
|
||||
<a class="anchor" href="#load-once">
|
||||
<h3 id="load-once">
|
||||
load-once
|
||||
</h3>
|
||||
</a>
|
||||
<div class="description">
|
||||
command
|
||||
</div>
|
||||
<p class="sig">
|
||||
Dynamic
|
||||
</p>
|
||||
<span>
|
||||
|
||||
</span>
|
||||
<p class="doc">
|
||||
|
||||
</p>
|
||||
</div>
|
||||
<div class="binder">
|
||||
<a class="anchor" href="#macro-error">
|
||||
<h3 id="macro-error">
|
||||
|
60
src/Eval.hs
60
src/Eval.hs
@ -536,7 +536,19 @@ primitiveDefmodule xobj ctx@(Context env i typeEnv pathStrings proj lastInput ex
|
||||
|
||||
-- | Command for loading a Carp file.
|
||||
commandLoad :: CommandCallback
|
||||
commandLoad ctx [xobj@(XObj (Str path) i _)] = do
|
||||
commandLoad ctx [xobj@(XObj (Str path) i _)] =
|
||||
loadInternal ctx xobj path i DoesReload
|
||||
commandLoad ctx [x] =
|
||||
return $ evalError ctx ("Invalid args to `load`: " ++ pretty x) (info x)
|
||||
|
||||
commandLoadOnce :: CommandCallback
|
||||
commandLoadOnce ctx [xobj@(XObj (Str path) i _)] =
|
||||
loadInternal ctx xobj path i Frozen
|
||||
commandLoadOnce ctx [x] =
|
||||
return $ evalError ctx ("Invalid args to `load-once`: " ++ pretty x) (info x)
|
||||
|
||||
loadInternal :: Context -> XObj -> String -> Maybe Info -> ReloadMode -> IO (Context, Either EvalError XObj)
|
||||
loadInternal ctx xobj path i reloadMode = do
|
||||
let proj = contextProj ctx
|
||||
libDir <- liftIO $ cachePath $ projectLibDir proj
|
||||
let relativeTo = case i of
|
||||
@ -571,19 +583,25 @@ commandLoad ctx [xobj@(XObj (Str path) i _)] = do
|
||||
Nothing -> ""))
|
||||
if canonicalPath == fileThatLoads
|
||||
then return $ cantLoadSelf ctx path
|
||||
else do let alreadyLoaded = projectAlreadyLoaded proj
|
||||
else do let alreadyLoaded = projectAlreadyLoaded proj ++ frozenPaths proj
|
||||
if canonicalPath `elem` alreadyLoaded
|
||||
then return (ctx, dynamicNil)
|
||||
else do
|
||||
contents <- liftIO $ slurp canonicalPath
|
||||
let files = projectFiles proj
|
||||
files' = if canonicalPath `elem` files
|
||||
files' = if canonicalPath `elem` (map fst files)
|
||||
then files
|
||||
else files ++ [canonicalPath]
|
||||
else files ++ [(canonicalPath, reloadMode)]
|
||||
proj' = proj { projectFiles = files', projectAlreadyLoaded = canonicalPath : alreadyLoaded }
|
||||
newCtx <- liftIO $ executeString True False (ctx { contextProj = proj' }) contents canonicalPath
|
||||
return (newCtx, dynamicNil)
|
||||
where
|
||||
frozenPaths proj =
|
||||
map fst $ filter (isFrozen . snd) (projectFiles proj)
|
||||
|
||||
isFrozen Frozen = True
|
||||
isFrozen _ = False
|
||||
|
||||
fppl ctx =
|
||||
projectFilePathPrintLength (contextProj ctx)
|
||||
invalidPath ctx path =
|
||||
@ -664,15 +682,19 @@ commandLoad ctx [xobj@(XObj (Str path) i _)] = do
|
||||
case res of
|
||||
ret@(Right _) -> return (newCtx, ret)
|
||||
Left _ -> commandLoad ctx [XObj (Str mainToLoad) Nothing Nothing]
|
||||
commandLoad ctx [x] =
|
||||
return $ evalError ctx ("Invalid args to `load`: " ++ pretty x) (info x)
|
||||
|
||||
-- | Load several files in order.
|
||||
loadFiles :: Context -> [FilePath] -> IO Context
|
||||
loadFiles ctxStart filesToLoad = foldM folder ctxStart filesToLoad
|
||||
loadFiles = loadFilesExt commandLoad
|
||||
|
||||
loadFilesOnce :: Context -> [FilePath] -> IO Context
|
||||
loadFilesOnce = loadFilesExt commandLoadOnce
|
||||
|
||||
loadFilesExt :: CommandCallback -> Context -> [FilePath] -> IO Context
|
||||
loadFilesExt loadCmd ctxStart filesToLoad = foldM folder ctxStart filesToLoad
|
||||
where folder :: Context -> FilePath -> IO Context
|
||||
folder ctx file = do
|
||||
(newCtx, ret) <- commandLoad ctx [XObj (Str file) Nothing Nothing]
|
||||
(newCtx, ret) <- loadCmd ctx [XObj (Str file) Nothing Nothing]
|
||||
let fppl = projectFilePathPrintLength (contextProj newCtx)
|
||||
case ret of
|
||||
Left err -> throw (EvalException err)
|
||||
@ -682,16 +704,18 @@ loadFiles ctxStart filesToLoad = foldM folder ctxStart filesToLoad
|
||||
commandReload :: CommandCallback
|
||||
commandReload ctx args = do
|
||||
let paths = projectFiles (contextProj ctx)
|
||||
f :: Context -> FilePath -> IO Context
|
||||
f context filepath = do let proj = contextProj context
|
||||
alreadyLoaded = projectAlreadyLoaded proj
|
||||
if filepath `elem` alreadyLoaded
|
||||
then
|
||||
return context
|
||||
else do
|
||||
contents <- slurp filepath
|
||||
let proj' = proj { projectAlreadyLoaded = filepath : alreadyLoaded }
|
||||
executeString False False (context { contextProj = proj' }) contents filepath
|
||||
f :: Context -> (FilePath, ReloadMode) -> IO Context
|
||||
f context (_, Frozen) = return context
|
||||
f context (filepath, DoesReload) =
|
||||
do let proj = contextProj context
|
||||
alreadyLoaded = projectAlreadyLoaded proj
|
||||
if filepath `elem` alreadyLoaded
|
||||
then
|
||||
return context
|
||||
else do
|
||||
contents <- slurp filepath
|
||||
let proj' = proj { projectAlreadyLoaded = filepath : alreadyLoaded }
|
||||
executeString False False (context { contextProj = proj' }) contents filepath
|
||||
newCtx <- liftIO (foldM f ctx paths)
|
||||
return (newCtx, dynamicNil)
|
||||
|
||||
|
13
src/Obj.hs
13
src/Obj.hs
@ -618,12 +618,21 @@ incrementEnvNestLevel :: Env -> Env
|
||||
incrementEnvNestLevel env = let current = envFunctionNestingLevel env
|
||||
in env { envFunctionNestingLevel = current + 1 }
|
||||
|
||||
-- | This flag is used on Carp source files to decide wether to reload them or not when calling `(reload)` / `:r`
|
||||
data ReloadMode = DoesReload | Frozen deriving Show
|
||||
|
||||
showLoader :: (FilePath, ReloadMode) -> String
|
||||
showLoader (fp, DoesReload) = fp ++ " (reloads)"
|
||||
showLoader (fp, Frozen) = fp ++ " (frozen)"
|
||||
|
||||
|
||||
|
||||
-- | Project (represents a lot of useful information for working at the REPL and building executables)
|
||||
data Project = Project { projectTitle :: String
|
||||
, projectIncludes :: [Includer]
|
||||
, projectCFlags :: [FilePath]
|
||||
, projectLibFlags :: [FilePath]
|
||||
, projectFiles :: [FilePath]
|
||||
, projectFiles :: [(FilePath, ReloadMode)]
|
||||
, projectAlreadyLoaded :: [FilePath]
|
||||
, projectEchoC :: Bool
|
||||
, projectLibDir :: FilePath
|
||||
@ -684,7 +693,7 @@ instance Show Project where
|
||||
, "Includes:\n " ++ joinWith "\n " (map show incl)
|
||||
, "Cflags:\n " ++ joinWith "\n " cFlags
|
||||
, "Library flags:\n " ++ joinWith "\n " libFlags
|
||||
, "Carp source files:\n " ++ joinWith "\n " srcFiles
|
||||
, "Carp source files:\n " ++ joinWith "\n " (map showLoader srcFiles)
|
||||
, "Already loaded:\n " ++ joinWith "\n " alreadyLoaded
|
||||
, "Echo C: " ++ showB echoC
|
||||
, "Echo compilation command: " ++ showB echoCompilationCommand
|
||||
|
@ -329,6 +329,7 @@ dynamicModule = Env { envBindings = bindings
|
||||
, addCommandConfigurable "help" Nothing commandHelp
|
||||
, addCommand "project" 0 commandProject
|
||||
, addCommand "load" 1 commandLoad
|
||||
, addCommand "load-once" 1 commandLoadOnce
|
||||
, addCommand "expand" 1 commandExpand
|
||||
, addCommand "os" 0 commandOS
|
||||
, addCommand "system-include" 1 commandAddSystemInclude
|
||||
|
Loading…
Reference in New Issue
Block a user