diff --git a/src/Main.hs b/src/Main.hs index 10c7580..30ce69e 100644 --- a/src/Main.hs +++ b/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 = (subparser topCommands <|> pure Repl) - <**> infoOption versionStr (long "version" <> help "Show version") +tricuParser :: Parser AppArgs +tricuParser = AppArgs + <$> 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,23 +511,46 @@ 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) $ - die "tricu arboricx export: at least one --target or --module is required" + when (null targets && null modules && not allFlag) $ + 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" - bundle <- packBundleFromStore store (zip expNames (map snd entries)) - let bundleData = encodeBundle bundle - BL.writeFile out (BL.fromStrict bundleData) - putStrLn $ "Exported bundle with " ++ show (length entries) ++ " export(s) to " ++ out - putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle)) - putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes" + 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) + putStrLn $ "Exported bundle with " ++ show (length entries) ++ " export(s) to " ++ out + 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 @@ -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 diff --git a/src/REPL.hs b/src/REPL.hs index 9bd7adc..d3666b9 100644 --- a/src/REPL.hs +++ b/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 - store <- defaultStorePath +repl = defaultStorePath >>= replWithStore + +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" diff --git a/test/Spec.hs b/test/Spec.hs index aa4bce3..843f94a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -77,13 +77,13 @@ allTestLibsEnv = unsafePerformIO $ do tests :: TestTree tests = testGroup "Tricu Tests" [ lexer - --, parser - --, simpleEvaluation - --, lambdas - --, providedLibraries - --, maybeTests - --, fileEval - --, demos + , parser + , simpleEvaluation + , lambdas + , providedLibraries + , maybeTests + , fileEval + , demos --, decoding --, elimLambdaSingle --, stressElimLambda @@ -94,7 +94,7 @@ tests = testGroup "Tricu Tests" --, binaryParserTests --, httpParsingTests --, contentStoreTests - , viewContractTests + --, viewContractTests --, ioDriverTests ]