add Package cache

anoma · Dec 5, 2023 · 1aec7e7 · 1aec7e7
1 parent 7fbc895
commit 1aec7e7
Show file tree

Hide file tree

Showing 3 changed files with 44 additions and 15 deletions.
diff --git a/app/App.hs b/app/App.hs
@@ -5,6 +5,7 @@ import Data.ByteString qualified as ByteString
 import GlobalOptions
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
 import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
+import Juvix.Compiler.Pipeline.Package
 import Juvix.Compiler.Pipeline.Run
 import Juvix.Data.Error qualified as Error
 import Juvix.Extra.Paths.Base hiding (rootBuildDir)
@@ -41,14 +42,26 @@ data RunAppIOArgs = RunAppIOArgs
     _runAppIOArgsRoot :: Root
   }
 
+makeLenses ''RunAppIOArgs
+
 runAppIO ::
   forall r a.
   (Members '[Embed IO, TaggedLock] r) =>
   RunAppIOArgs ->
   Sem (App ': r) a ->
   Sem r a
-runAppIO args@RunAppIOArgs {..} =
-  interpret $ \case
+runAppIO args = evalSingletonCache (readPackageRootIO root) . reAppIO args
+  where
+    root = args ^. runAppIOArgsRoot
+
+reAppIO ::
+  forall r a.
+  (Members '[Embed IO, TaggedLock] r) =>
+  RunAppIOArgs ->
+  Sem (App ': r) a ->
+  Sem (SCache Package ': r) a
+reAppIO args@RunAppIOArgs {..} =
+  reinterpret $ \case
     AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageType `elem` [GlobalStdlib, GlobalPackageDescription, GlobalPackageBase])
     FromAppPathFile p -> embed (prepathToAbsFile invDir (p ^. pathPath))
     GetMainFile m -> getMainFile' m
@@ -84,11 +97,13 @@ runAppIO args@RunAppIOArgs {..} =
     ExitMsg exitCode t -> exitMsg' exitCode t
     SayRaw b -> embed (ByteString.putStr b)
   where
-    getPkg :: Sem r Package
-    getPkg = undefined
-    exitMsg' :: ExitCode -> Text -> Sem r x
-    exitMsg' exitCode t = embed (putStrLn t >> hFlush stdout >> exitWith exitCode)
-    getMainFile' :: Maybe (AppPath File) -> Sem r (Path Abs File)
+    getPkg :: (Members '[SCache Package] r') => Sem r' Package
+    getPkg = cacheSingletonGet
+
+    exitMsg' :: (Members '[Embed IO] r') => ExitCode -> Text -> Sem r' x
+    exitMsg' exitCode t = liftIO (putStrLn t >> hFlush stdout >> exitWith exitCode)
+
+    getMainFile' :: (Members '[SCache Package, Embed IO] r') => Maybe (AppPath File) -> Sem r' (Path Abs File)
     getMainFile' = \case
       Just p -> embed (prepathToAbsFile invDir (p ^. pathPath))
       -- Nothing -> case pkg ^. packageMain of
@@ -97,7 +112,8 @@ runAppIO args@RunAppIOArgs {..} =
         case pkg ^. packageMain of
           Just p -> embed (prepathToAbsFile invDir p)
           Nothing -> missingMainErr
-    missingMainErr :: Sem r x
+
+    missingMainErr :: (Members '[Embed IO] r') => Sem r' x
     missingMainErr =
       exitMsg'
         (ExitFailure 1)

diff --git a/src/Juvix/Compiler/Pipeline/Root.hs b/src/Juvix/Compiler/Pipeline/Root.hs
@@ -8,13 +8,12 @@ import Control.Exception (SomeException)
 import Control.Exception qualified as IO
 import Juvix.Compiler.Pipeline.Package
 import Juvix.Compiler.Pipeline.Root.Base
-import Juvix.Data.Effect.TaggedLock
 import Juvix.Extra.Paths qualified as Paths
 import Juvix.Prelude
 
 findRootAndChangeDir ::
   forall r.
-  (Members '[Embed IO, TaggedLock, Final IO] r) =>
+  (Members '[Embed IO, Final IO] r) =>
   Maybe (Path Abs Dir) ->
   Maybe (Path Abs Dir) ->
   Path Abs Dir ->
@@ -46,14 +45,13 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do
         Nothing -> do
           let cwd = fromMaybe _rootInvokeDir minputFileDir
           packageBaseRootDir <- runFilesIO globalPackageBaseRoot
-          (_rootPackage, _rootRootDir, _rootPackageType) <-
+          (_rootRootDir, _rootPackageType) <-
             if
                 | isPathPrefix packageBaseRootDir cwd ->
-                    return (packageBasePackage, packageBaseRootDir, GlobalPackageBase)
+                    return (packageBaseRootDir, GlobalPackageBase)
                 | otherwise -> do
-                    globalPkg <- readGlobalPackageIO
                     r <- runFilesIO globalRoot
-                    return (globalPkg, r, GlobalStdlib)
+                    return (r, GlobalStdlib)
           let _rootBuildDir = getBuildDir mbuildDir
           return Root {..}
         Just pkgPath -> do
@@ -63,7 +61,6 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do
                 | isPathPrefix packageDescriptionRootDir _rootRootDir = GlobalPackageDescription
                 | otherwise = LocalPackage
               _rootBuildDir = getBuildDir mbuildDir
-          _rootPackage <- readPackageIO _rootRootDir _rootBuildDir
           return Root {..}
 
 getBuildDir :: Maybe (Path Abs Dir) -> BuildDir

diff --git a/src/Juvix/Data/Effect/Cache.hs b/src/Juvix/Data/Effect/Cache.hs
@@ -5,7 +5,10 @@ module Juvix.Data.Effect.Cache
     runCacheEmpty,
     cacheGet,
     cacheLookup,
+    evalSingletonCache,
+    cacheSingletonGet,
     Cache,
+    SCache,
   )
 where
 
@@ -15,6 +18,9 @@ data Cache k v m a where
   CacheGet :: k -> Cache k v m v
   CacheLookup :: k -> Cache k v m (Maybe v)
 
+-- | Singleton cache
+type SCache = Cache ()
+
 makeSem ''Cache
 
 -- | Run a 'Cache' effect purely.
@@ -52,6 +58,16 @@ runCacheEmpty ::
 runCacheEmpty f = runCache f mempty
 {-# INLINE runCacheEmpty #-}
 
+cacheSingletonGet :: (Members '[SCache v] r) => Sem r v
+cacheSingletonGet = cacheGet ()
+
+evalSingletonCache ::
+  Sem (SCache v ': r) v ->
+  Sem (SCache v ': r) a ->
+  Sem r a
+evalSingletonCache f c = evalCacheEmpty @() (const f) c
+{-# INLINE evalSingletonCache #-}
+
 re ::
   forall k v r a.
   (Hashable k) =>