carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 05:25:28 +03:00
Code Issues Projects Releases Wiki Activity

Added support for (load-once).

Browse Source
This commit is contained in:
Erik Svedäng 2020-05-05 15:00:57 +02:00
parent 26a4b02009
commit ca804beace
7 changed files with 106 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/Main.hs
View File

@ -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

63
core/Core.carp
View File

@ -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"))
())

2
core/Interfaces.carp
View File

@ -1,4 +1,4 @@
(load "Macros.carp")
(load-once "Macros.carp")
;; The 'copy' and 'str' interfaces are defined internally:
;;(definterface copy (λ [&a] a))

19
docs/core/Dynamic.html
View File

@ -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
View File

@ -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
View File

@ -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

1
src/StartingEnv.hs
View File

@ -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