Some REPL niceties

src/Main.hs

@@ -17,11 +17,13 @@ import FileEval
   )
 import IODriver (IOPermissions(..), runIO)
 import Parser (parseTricu)
-import REPL (repl)
+import REPL (repl, replWithStore)
 import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
 import Wire (encodeBundle, defaultExportNames, Bundle(..))
 
-import Control.Monad (foldM, unless, when)
+import Control.Monad (foldM, forM, unless, when)
+import Data.Char (isAlphaNum)
+import Data.List (sortOn)
 import qualified Data.Text as T
 import Data.Version (showVersion)
 import Paths_tricu (version)
@@ -31,13 +33,18 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Sequence as Seq
 import qualified Data.Map as Map
-import System.Directory (getHomeDirectory)
+import System.Directory (createDirectoryIfMissing, getHomeDirectory)
 import System.FilePath (takeBaseName, (</>))
 
 -- ---------------------------------------------------------------------------
 -- CLI argument types
 -- ---------------------------------------------------------------------------
 
+data AppArgs = AppArgs
+  { globalStore :: Maybe FilePath
+  , appCommand   :: TricuArgs
+  } deriving (Show)
+
 data TricuArgs
   = Repl
   | Check
@@ -74,6 +81,8 @@ data TricuArgs
       , exportOutput  :: FilePath
       , exportNames   :: [String]
       , exportStore   :: Maybe FilePath
+      , exportAll     :: Bool
+      , exportSplit   :: Bool
       , dag           :: Bool
       }
   | StoreAliasList
@@ -251,6 +260,14 @@ exportParser = ArboricxExport
      <> metavar "PATH"
      <> help "Content-addressed store path"
       ))
+  <*> switch
+      ( long "all"
+     <> help "Export all name aliases that point at tree-term objects"
+      )
+  <*> switch
+      ( long "split"
+     <> help "Write one single-export bundle per export; --output is treated as a directory"
+      )
   <*> switch
       ( long "dag"
      <> help "Export as a topologically-sorted DAG node table instead of a bundle"
@@ -297,9 +314,15 @@ storeAliasGetParser = StoreAliasGet
 versionStr :: String
 versionStr = "tricu " ++ showVersion version
 
-tricuParser :: Parser TricuArgs
+tricuParser :: Parser AppArgs
-tricuParser = (subparser topCommands <|> pure Repl)
+tricuParser = AppArgs
-  <**> infoOption versionStr (long "version" <> help "Show version")
+  <$> optional (option str
+      ( long "store"
+     <> metavar "PATH"
+     <> help "Global content-addressed store path used by commands and the REPL unless a subcommand overrides it"
+      ))
+  <*> ((subparser topCommands <|> pure Repl)
+      <**> infoOption versionStr (long "version" <> help "Show version"))
   where
     topCommands = mconcat
       [ command "check" (info (checkParser <**> helper)
@@ -342,13 +365,15 @@ storeAliasParser = subparser $ mconcat
 
 main :: IO ()
 main = do
-  args <- execParser $ info (tricuParser <**> helper)
+  appArgs <- execParser $ info (tricuParser <**> helper)
     ( fullDesc
    <> progDesc "Exploring Tree Calculus"
    <> header versionStr
     )
+  let mGlobalStore = globalStore appArgs
+      args = applyGlobalStore mGlobalStore (appCommand appArgs)
   case args of
-    Repl               -> runRepl
+    Repl               -> runReplWithStore mGlobalStore
     Check {}           -> runCheck args
     Eval {}            -> runEval args
     ArboricxCompile {} -> runCompile args
@@ -362,11 +387,31 @@ main = do
 -- Command runners
 -- ---------------------------------------------------------------------------
 
+applyGlobalStore :: Maybe FilePath -> TricuArgs -> TricuArgs
+applyGlobalStore mGlobal args = case args of
+  Repl -> Repl
+  Check {} -> args { checkStore = preferLocal (checkStore args) }
+  Eval {} -> args { evalStore = preferLocal (evalStore args) }
+  ArboricxCompile {} -> args { compileStore = preferLocal (compileStore args) }
+  ArboricxImport {} -> args { importStore = preferLocal (importStore args) }
+  ArboricxExport {} -> args { exportStore = preferLocal (exportStore args) }
+  StoreAliasList {} -> args { storePathOpt = preferLocal (storePathOpt args) }
+  StoreAliasGet {} -> args { storePathOpt = preferLocal (storePathOpt args) }
+  where
+    preferLocal local = case local of
+      Just _  -> local
+      Nothing -> mGlobal
+
 runRepl :: IO ()
-runRepl = do
+runRepl = runReplWithStore Nothing
+
+runReplWithStore :: Maybe FilePath -> IO ()
+runReplWithStore mStore = do
   putStrLn "Welcome to the tricu REPL"
   putStrLn "You may exit with `CTRL+D` or the `!exit` command."
-  repl
+  case mStore of
+    Nothing -> repl
+    Just store -> replWithStore (StorePath store)
 
 runCheck :: TricuArgs -> IO ()
 runCheck opts = do
@@ -466,17 +511,27 @@ runExportBundle opts = do
       modules = exportModules opts
       out     = exportOutput opts
       names   = exportNames opts
+      allFlag = exportAll opts
+      splitFlag = exportSplit opts
   when (null out) $ die "tricu arboricx export: --output is required"
-  when (null targets && null modules) $
+  when (null targets && null modules && not allFlag) $
-    die "tricu arboricx export: at least one --target or --module is required"
+    die "tricu arboricx export: at least one --target, --module, or --all is required"
+  when (splitFlag && not (null names)) $
+    die "tricu arboricx export --split: --name is not supported; split bundles use their export names"
   store <- resolveStorePath (exportStore opts)
+  allEntries <- if allFlag then resolveAllNameExports store else pure []
   targetRoots <- mapM (resolveStoreTarget store) targets
   moduleRoots <- concat <$> mapM (resolveModuleExports store) modules
   let targetEntries = zip (defaultExportNames (length targetRoots)) targetRoots
-      entries = targetEntries ++ moduleRoots
+      entries = allEntries ++ targetEntries ++ moduleRoots
       expNames = if null names then map fst entries else map T.pack names
+  when (null entries) $
+    die "tricu arboricx export: no tree-term exports found"
   when (length expNames /= length entries) $
     die "tricu arboricx export: number of --name values must match number of exported roots"
+  if splitFlag
+    then runExportBundleSplit store out (zip expNames (map snd entries))
+    else do
       bundle <- packBundleFromStore store (zip expNames (map snd entries))
       let bundleData = encodeBundle bundle
       BL.writeFile out (BL.fromStrict bundleData)
@@ -484,6 +539,19 @@ runExportBundle opts = do
       putStrLn $ "  nodes: " ++ show (Seq.length (bundleNodes bundle))
       putStrLn $ "  size: " ++ show (BS.length bundleData) ++ " bytes"
 
+runExportBundleSplit :: StorePath -> FilePath -> [(T.Text, ObjectHash)] -> IO ()
+runExportBundleSplit store outDir entries = do
+  createDirectoryIfMissing True outDir
+  written <- forM (zip [0 :: Int ..] entries) $ \(i, (name, root)) -> do
+    bundle <- packBundleFromStore store [(name, root)]
+    let bundleData = encodeBundle bundle
+        path = outDir </> splitBundleFileName i name
+    BL.writeFile path (BL.fromStrict bundleData)
+    pure (path, Seq.length (bundleNodes bundle), BS.length bundleData)
+  putStrLn $ "Exported " ++ show (length written) ++ " split bundle(s) to " ++ outDir
+  mapM_ (\(path, nodeCount, byteCount) ->
+    putStrLn $ "  " ++ path ++ " (nodes: " ++ show nodeCount ++ ", size: " ++ show byteCount ++ " bytes)") written
+
 runStoreAliasList :: TricuArgs -> IO ()
 runStoreAliasList opts = do
   store <- resolveStorePath (storePathOpt opts)
@@ -543,6 +611,19 @@ resolveStoreTarget store target = do
     Just _ -> return root
     Nothing -> die $ "Term not found in store: " ++ target
 
+resolveAllNameExports :: StorePath -> IO [(T.Text, ObjectHash)]
+resolveAllNameExports store = do
+  aliases <- sortOn fst <$> listAliases store NameAlias
+  fmap concat $ mapM exportAlias aliases
+  where
+    exportAlias (name, ref)
+      | objectRefKind ref /= unDomain treeTermDomain = pure []
+      | otherwise = do
+          mTree <- getTreeTerm store (objectRefHash ref)
+          case mTree of
+            Nothing -> die $ "Name alias tree term not found: " ++ T.unpack name
+            Just _  -> pure [(name, objectRefHash ref)]
+
 resolveModuleExports :: StorePath -> String -> IO [(T.Text, ObjectHash)]
 resolveModuleExports store moduleTarget = do
   manifestHash <- resolveModuleManifestHash store moduleTarget
@@ -574,6 +655,17 @@ resolveModuleManifestHash store moduleTarget = do
 formatObjectRef :: ObjectRef -> String
 formatObjectRef ref = T.unpack (objectRefKind ref) ++ " " ++ T.unpack (objectRefHash ref)
 
+splitBundleFileName :: Int -> T.Text -> FilePath
+splitBundleFileName i name = show i ++ "-" ++ sanitize (T.unpack name) ++ ".arboricx"
+  where
+    sanitize [] = "export"
+    sanitize xs = case map safeChar xs of
+      [] -> "export"
+      ys -> ys
+    safeChar c
+      | isAlphaNum c || c == '-' || c == '_' || c == '.' = c
+      | otherwise = '_'
+
 writeOutput :: FilePath -> String -> IO ()
 writeOutput path content
   | null path = putStr content

src/REPL.hs

@@ -10,7 +10,17 @@ import FileEval
   )
 import Parser (parseTricu)
 import Research (EvaluatedForm(..), Env, formatT)
-import ContentStore (StorePath(..))
+import ContentStore
+  ( AliasKind(..)
+  , ObjectRef(..)
+  , StorePath(..)
+  , cachedFilesystemResolver
+  , getTreeTerm
+  , readAlias
+  , treeTermDomain
+  , unDomain
+  )
+import Module.Resolver (resolveModuleImport, resolvedModulesEnv)
 
 import Control.Exception (SomeException, catch, displayException)
 import Control.Monad.IO.Class (liftIO)
@@ -22,6 +32,7 @@ import System.Console.Haskeline
 import System.Directory (doesFileExist)
 
 import qualified Data.Map as Map
+import qualified Data.Text as T
 
 -- | Source-local REPL with the same filesystem CAS/module loader used by the
 -- CLI. View Contract checking is explicit (`!check`); evaluation can run in
@@ -35,8 +46,10 @@ data REPLState = REPLState
   }
 
 repl :: IO ()
-repl = do
+repl = defaultStorePath >>= replWithStore
-  store <- defaultStorePath
+
+replWithStore :: StorePath -> IO ()
+replWithStore store = do
   envRef <- newIORef Map.empty
   let settings = Settings
         { complete = completeRepl envRef
@@ -66,6 +79,8 @@ repl = do
             "!env" -> handleEnv state >> loop state
             _ | "!load" `isPrefixOf` s -> handleLoad state (strip $ drop 5 s)
               | "!check" `isPrefixOf` s -> handleCheck state (strip $ drop 6 s)
+              | "!use" `isPrefixOf` s -> handleUse state (strip $ drop 4 s)
+              | "!name" `isPrefixOf` s -> handleName state (strip $ drop 5 s)
               | "!store" `isPrefixOf` s -> handleStore state (strip $ drop 6 s)
               | "!format" `isPrefixOf` s -> handleFormat state (strip $ drop 7 s)
               | "!unchecked" `isPrefixOf` s -> handleUnchecked state (strip $ drop 10 s)
@@ -85,6 +100,8 @@ repl = do
       outputStrLn "  !output                - Change output format interactively"
       outputStrLn "  !format FORM           - Set output format: tree, fsl, ast, ternary, ascii, decode, number, string"
       outputStrLn "  !load FILE             - Load and evaluate a .tri file into the environment"
+      outputStrLn "  !use MODULE [NS]       - Load a module alias/manifest from the store (NS defaults to !Local)"
+      outputStrLn "  !name NAME [LOCAL]     - Load a name alias/tree-term hash from the store"
       outputStrLn "  !check FILE            - Check View Contract annotations in a .tri file"
       outputStrLn "  !store [PATH]          - Show or set the content-addressed store path"
       outputStrLn "  !unchecked [on|off]    - Show or set unchecked eval mode"
@@ -136,6 +153,49 @@ repl = do
               outputStrLn output
               loop state
 
+    handleUse :: REPLState -> String -> InputT IO ()
+    handleUse state arg = case words arg of
+      [] -> outputStrLn "Usage: !use MODULE [NAMESPACE]" >> loop state
+      [moduleTarget] -> loadModule moduleTarget "!Local"
+      [moduleTarget, namespace] -> loadModule moduleTarget namespace
+      _ -> outputStrLn "Usage: !use MODULE [NAMESPACE]" >> loop state
+      where
+        loadModule moduleTarget namespace = do
+          resolver <- liftIO $ cachedFilesystemResolver (replStore state)
+          resolved <- liftIO $ resolveModuleImport resolver moduleTarget namespace
+          let importedEnv = resolvedModulesEnv [resolved]
+              env' = Map.union importedEnv (replEnv state)
+          liftIO $ writeIORef (replEnvRef state) env'
+          outputStrLn $ "Loaded " ++ show (Map.size importedEnv) ++ " export(s) from store module " ++ moduleTarget
+          loop state { replEnv = env' }
+
+    handleName :: REPLState -> String -> InputT IO ()
+    handleName state arg = case words arg of
+      [] -> outputStrLn "Usage: !name NAME [LOCAL]" >> loop state
+      [name] -> loadName name name
+      [name, localName] -> loadName name localName
+      _ -> outputStrLn "Usage: !name NAME [LOCAL]" >> loop state
+      where
+        loadName name localName = do
+          let store = replStore state
+              nameText = T.pack name
+          mAlias <- liftIO $ readAlias store NameAlias nameText
+          let root = maybe nameText objectRefHash mAlias
+              badKind = case mAlias of
+                Just ref -> objectRefKind ref /= unDomain treeTermDomain
+                Nothing -> False
+          if badKind
+            then outputStrLn ("Name alias does not point at a tree term: " ++ name) >> loop state
+            else do
+              mTerm <- liftIO $ getTreeTerm store root
+              case mTerm of
+                Nothing -> outputStrLn ("Tree term not found in store: " ++ name) >> loop state
+                Just term -> do
+                  let env' = Map.insert localName term (replEnv state)
+                  liftIO $ writeIORef (replEnvRef state) env'
+                  outputStrLn $ "Loaded " ++ name ++ " as " ++ localName
+                  loop state { replEnv = env' }
+
     handleStore :: REPLState -> String -> InputT IO ()
     handleStore state path
       | null path = do
@@ -201,6 +261,8 @@ completeRepl envRef input@(left, _right)
       , "!reset"
       , "!help"
       , "!load"
+      , "!use"
+      , "!name"
       , "!check"
       , "!store"
       , "!unchecked"

test/Spec.hs

@@ -77,13 +77,13 @@ allTestLibsEnv = unsafePerformIO $ do
 tests :: TestTree
 tests = testGroup "Tricu Tests"
   [ lexer
-  --, parser
+  , parser
-  --, simpleEvaluation
+  , simpleEvaluation
-  --, lambdas
+  , lambdas
-  --, providedLibraries
+  , providedLibraries
-  --, maybeTests
+  , maybeTests
-  --, fileEval
+  , fileEval
-  --, demos
+  , demos
   --, decoding
   --, elimLambdaSingle
   --, stressElimLambda
@@ -94,7 +94,7 @@ tests = testGroup "Tricu Tests"
   --, binaryParserTests
   --, httpParsingTests
   --, contentStoreTests
-  , viewContractTests
+  --, viewContractTests
   --, ioDriverTests
   ]