Main.hs (22007B)
1 module Main where 2 3 import ContentStore 4 import ContentStore.Bundle 5 import Module.Manifest 6 import System.Exit (die) 7 import Eval (evalTricu, mainResult, result) 8 import FileEval 9 ( LoadedSource(..) 10 , defaultStorePath 11 , evaluateFileWithContextWithStore 12 , evaluateFileWithStore 13 , loadFileWithStore 14 , compileFileWithStore 15 ) 16 import IODriver (IOPermissions(..), runIO) 17 import Parser (parseTricu) 18 import REPL (repl, replWithStore) 19 import Research (T, EvaluatedForm(..), Env, formatT, exportDag) 20 import Wire (encodeBundle, defaultExportNames, Bundle(..)) 21 22 import Control.Monad (foldM, forM, unless, when) 23 import Data.Char (isAlphaNum) 24 import Data.List (sortOn) 25 import qualified Data.Text as T 26 import Data.Version (showVersion) 27 import Paths_tricu (version) 28 import Options.Applicative 29 30 import qualified Data.ByteString as BS 31 import qualified Data.ByteString.Lazy as BL 32 import qualified Data.Sequence as Seq 33 import qualified Data.Map as Map 34 import System.Directory (createDirectoryIfMissing, getHomeDirectory) 35 import System.FilePath (takeBaseName, (</>)) 36 37 -- --------------------------------------------------------------------------- 38 -- CLI argument types 39 -- --------------------------------------------------------------------------- 40 41 data AppArgs = AppArgs 42 { globalStore :: Maybe FilePath 43 , appCommand :: TricuArgs 44 } deriving (Show) 45 46 data TricuArgs 47 = Repl 48 | Eval 49 { evalFiles :: [FilePath] 50 , evalStore :: Maybe FilePath 51 , evalFormat :: EvaluatedForm 52 , evalOutput :: FilePath 53 , evalIo :: Bool 54 , evalAllowRead :: [FilePath] 55 , evalAllowWrite :: [FilePath] 56 , evalAllowReadAll :: Bool 57 , evalAllowWriteAll :: Bool 58 , evalUnsafeIo :: Bool 59 } 60 | ArboricxCompile 61 { compileInput :: FilePath 62 , compileStore :: Maybe FilePath 63 , compileOutput :: FilePath 64 , compileNames :: [String] 65 } 66 | ArboricxImport 67 { importFile :: FilePath 68 , importStore :: Maybe FilePath 69 , importModule :: Maybe String 70 } 71 | ArboricxExport 72 { exportTargets :: [String] 73 , exportModules :: [String] 74 , exportOutput :: FilePath 75 , exportNames :: [String] 76 , exportStore :: Maybe FilePath 77 , exportAll :: Bool 78 , exportSplit :: Bool 79 , dag :: Bool 80 } 81 | StoreAliasList 82 { storeAliasKind :: AliasKind 83 , storePathOpt :: Maybe FilePath 84 } 85 | StoreAliasGet 86 { storeAliasKind :: AliasKind 87 , storeAliasName :: String 88 , storePathOpt :: Maybe FilePath 89 } 90 deriving (Show) 91 92 -- --------------------------------------------------------------------------- 93 -- optparse-applicative parsers 94 -- --------------------------------------------------------------------------- 95 96 readEvaluatedForm :: ReadM EvaluatedForm 97 readEvaluatedForm = eitherReader $ \s -> case s of 98 "tree" -> Right Tree 99 "fsl" -> Right FSL 100 "ast" -> Right AST 101 "ternary" -> Right Ternary 102 "ascii" -> Right Ascii 103 "decode" -> Right Decode 104 "number" -> Right Number 105 "string" -> Right StringLit 106 _ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode, number, string" 107 108 evalParser :: Parser TricuArgs 109 evalParser = Eval 110 <$> many (argument str (metavar "FILE...")) 111 <*> optional (option str 112 ( long "store" 113 <> short 's' 114 <> metavar "PATH" 115 <> help "Content-addressed store path for module import resolution" 116 )) 117 <*> option readEvaluatedForm 118 ( long "format" 119 <> short 'f' 120 <> metavar "FORM" 121 <> value Tree 122 <> help "Output format: tree, fsl, ast, ternary, ascii, decode, number, string" 123 ) 124 <*> option str 125 ( long "output" 126 <> short 'o' 127 <> metavar "FILE" 128 <> value "" 129 <> help "Write output to file instead of stdout" 130 ) 131 <*> switch 132 ( long "io" 133 <> help "Interpret the result as an IO action tree and execute it" 134 ) 135 <*> many (option str 136 ( long "allow-read" 137 <> metavar "PATH" 138 <> help "Allow reading from PATH prefix (repeatable)" 139 )) 140 <*> many (option str 141 ( long "allow-write" 142 <> metavar "PATH" 143 <> help "Allow writing to PATH prefix (repeatable)" 144 )) 145 <*> switch 146 ( long "allow-read-all" 147 <> help "Allow reading from any path" 148 ) 149 <*> switch 150 ( long "allow-write-all" 151 <> help "Allow writing to any path" 152 ) 153 <*> switch 154 ( long "unsafe-io" 155 <> help "Allow unrestricted read and write access" 156 ) 157 158 compileParser :: Parser TricuArgs 159 compileParser = ArboricxCompile 160 <$> option str 161 ( long "file" 162 <> short 'f' 163 <> metavar "FILE" 164 <> value "" 165 <> help "Input .tri source file" 166 ) 167 <*> optional (option str 168 ( long "store" 169 <> short 's' 170 <> metavar "PATH" 171 <> help "Content-addressed store path for module import resolution" 172 )) 173 <*> option str 174 ( long "output" 175 <> short 'o' 176 <> metavar "FILE" 177 <> value "" 178 <> help "Output bundle file path (required)" 179 ) 180 <*> many (option str 181 ( long "name" 182 <> short 'n' 183 <> metavar "NAME" 184 <> help "Definition name(s) to export as bundle roots (repeatable)" 185 )) 186 187 importParser :: Parser TricuArgs 188 importParser = ArboricxImport 189 <$> option str 190 ( long "file" 191 <> short 'f' 192 <> metavar "FILE" 193 <> value "" 194 <> help "Bundle file to import" 195 ) 196 <*> optional (option str 197 ( long "store" 198 <> short 's' 199 <> metavar "PATH" 200 <> help "Content-addressed store path" 201 )) 202 <*> optional (option str 203 ( long "module" 204 <> short 'm' 205 <> metavar "NAME" 206 <> help "Module alias to create for the imported bundle (defaults to bundle file basename)" 207 )) 208 209 exportParser :: Parser TricuArgs 210 exportParser = ArboricxExport 211 <$> many (option str 212 ( long "target" 213 <> short 't' 214 <> metavar "TARGET" 215 <> help "Target hash or name (repeatable)" 216 )) 217 <*> many (option str 218 ( long "module" 219 <> short 'm' 220 <> metavar "MODULE" 221 <> help "Module alias or manifest hash to export (repeatable; bundle export only)" 222 )) 223 <*> option str 224 ( long "output" 225 <> short 'o' 226 <> metavar "FILE" 227 <> value "" 228 <> help "Output file path (required for bundle export)" 229 ) 230 <*> many (option str 231 ( long "name" 232 <> short 'n' 233 <> metavar "NAME" 234 <> help "Export name(s) for the bundle manifest (repeatable)" 235 )) 236 <*> optional (option str 237 ( long "store" 238 <> short 's' 239 <> metavar "PATH" 240 <> help "Content-addressed store path" 241 )) 242 <*> switch 243 ( long "all" 244 <> help "Export all name aliases that point at tree-term objects" 245 ) 246 <*> switch 247 ( long "split" 248 <> help "Write one single-export bundle per export; --output is treated as a directory" 249 ) 250 <*> switch 251 ( long "dag" 252 <> help "Export as a topologically-sorted DAG node table instead of a bundle" 253 ) 254 255 aliasKindReader :: ReadM AliasKind 256 aliasKindReader = eitherReader $ \s -> case s of 257 "names" -> Right NameAlias 258 "name" -> Right NameAlias 259 "modules" -> Right ModuleAlias 260 "module" -> Right ModuleAlias 261 "packages" -> Right PackageAlias 262 "package" -> Right PackageAlias 263 _ -> Left "alias kind must be one of: names, modules, packages" 264 265 storePathParser :: Parser (Maybe FilePath) 266 storePathParser = optional (option str 267 ( long "store" 268 <> short 's' 269 <> metavar "PATH" 270 <> help "Content-addressed store path" 271 )) 272 273 aliasKindParser :: Parser AliasKind 274 aliasKindParser = option aliasKindReader 275 ( long "kind" 276 <> short 'k' 277 <> metavar "KIND" 278 <> value NameAlias 279 <> help "Alias kind: names, modules, packages (default: names)" 280 ) 281 282 storeAliasListParser :: Parser TricuArgs 283 storeAliasListParser = StoreAliasList 284 <$> aliasKindParser 285 <*> storePathParser 286 287 storeAliasGetParser :: Parser TricuArgs 288 storeAliasGetParser = StoreAliasGet 289 <$> aliasKindParser 290 <*> argument str (metavar "NAME") 291 <*> storePathParser 292 293 versionStr :: String 294 versionStr = "tricu " ++ showVersion version 295 296 tricuParser :: Parser AppArgs 297 tricuParser = AppArgs 298 <$> optional (option str 299 ( long "store" 300 <> metavar "PATH" 301 <> help "Global content-addressed store path used by commands and the REPL unless a subcommand overrides it" 302 )) 303 <*> ((subparser topCommands <|> pure Repl) 304 <**> infoOption versionStr (long "version" <> help "Show version")) 305 where 306 topCommands = mconcat 307 [ command "eval" (info (evalParser <**> helper) 308 (progDesc "Evaluate tricu source and print the result of the final expression")) 309 , command "arboricx" (info (arboricxParser <**> helper) 310 (progDesc "Arboricx bundle operations")) 311 , command "store" (info (storeParser <**> helper) 312 (progDesc "Inspect and manage the content-addressed store")) 313 ] 314 315 arboricxParser :: Parser TricuArgs 316 arboricxParser = subparser $ mconcat 317 [ command "compile" (info (compileParser <**> helper) 318 (progDesc "Compile a .tri file into a standalone Arboricx bundle")) 319 , command "import" (info (importParser <**> helper) 320 (progDesc "Import an Arboricx bundle into the content store")) 321 , command "export" (info (exportParser <**> helper) 322 (progDesc "Export one or more terms from the content store")) 323 ] 324 325 storeParser :: Parser TricuArgs 326 storeParser = subparser $ mconcat 327 [ command "alias" (info (storeAliasParser <**> helper) 328 (progDesc "Inspect workspace aliases")) 329 ] 330 331 storeAliasParser :: Parser TricuArgs 332 storeAliasParser = subparser $ mconcat 333 [ command "list" (info (storeAliasListParser <**> helper) 334 (progDesc "List aliases by kind")) 335 , command "get" (info (storeAliasGetParser <**> helper) 336 (progDesc "Resolve an alias by kind and name")) 337 ] 338 339 -- --------------------------------------------------------------------------- 340 -- Entry point 341 -- --------------------------------------------------------------------------- 342 343 main :: IO () 344 main = do 345 appArgs <- execParser $ info (tricuParser <**> helper) 346 ( fullDesc 347 <> progDesc "Exploring Tree Calculus" 348 <> header versionStr 349 ) 350 let mGlobalStore = globalStore appArgs 351 args = applyGlobalStore mGlobalStore (appCommand appArgs) 352 case args of 353 Repl -> runReplWithStore mGlobalStore 354 Eval {} -> runEval args 355 ArboricxCompile {} -> runCompile args 356 ArboricxImport {} -> runImport args 357 ArboricxExport {} -> runExport args 358 StoreAliasList {} -> runStoreAliasList args 359 StoreAliasGet {} -> runStoreAliasGet args 360 361 362 -- --------------------------------------------------------------------------- 363 -- Command runners 364 -- --------------------------------------------------------------------------- 365 366 applyGlobalStore :: Maybe FilePath -> TricuArgs -> TricuArgs 367 applyGlobalStore mGlobal args = case args of 368 Repl -> Repl 369 Eval {} -> args { evalStore = preferLocal (evalStore args) } 370 ArboricxCompile {} -> args { compileStore = preferLocal (compileStore args) } 371 ArboricxImport {} -> args { importStore = preferLocal (importStore args) } 372 ArboricxExport {} -> args { exportStore = preferLocal (exportStore args) } 373 StoreAliasList {} -> args { storePathOpt = preferLocal (storePathOpt args) } 374 StoreAliasGet {} -> args { storePathOpt = preferLocal (storePathOpt args) } 375 where 376 preferLocal local = case local of 377 Just _ -> local 378 Nothing -> mGlobal 379 380 runRepl :: IO () 381 runRepl = runReplWithStore Nothing 382 383 runReplWithStore :: Maybe FilePath -> IO () 384 runReplWithStore mStore = do 385 putStrLn "Welcome to the tricu REPL" 386 putStrLn "You may exit with `CTRL+D` or the `!exit` command." 387 case mStore of 388 Nothing -> repl 389 Just store -> replWithStore (StorePath store) 390 391 runEval :: TricuArgs -> IO () 392 runEval opts = do 393 let files = evalFiles opts 394 form = evalFormat opts 395 out = evalOutput opts 396 resultT <- case files of 397 [] -> do 398 input <- getContents 399 let env = evalTricu Map.empty (parseTricu input) 400 return $ result env 401 _ -> do 402 mStoreOpt <- traverse (pure . StorePath) (evalStore opts) 403 finalEnv <- foldM (evaluateFileWithContextWithStore mStoreOpt) Map.empty files 404 return $ mainResult finalEnv 405 finalT <- if evalIo opts 406 then do 407 let perms = IOPermissions 408 { allowRead = evalAllowRead opts 409 , allowWrite = evalAllowWrite opts 410 , allowReadAll = evalUnsafeIo opts || evalAllowReadAll opts 411 , allowWriteAll = evalUnsafeIo opts || evalAllowWriteAll opts 412 } 413 result <- runIO perms resultT 414 case result of 415 Left err -> die $ "IO error: " ++ err 416 Right val -> pure val 417 else return resultT 418 writeOutput out (formatT form finalT) 419 420 runCompile :: TricuArgs -> IO () 421 runCompile opts = do 422 let input = compileInput opts 423 out = compileOutput opts 424 names = compileNames opts 425 mStore = StorePath <$> compileStore opts 426 when (null out) $ die "tricu arboricx compile: --output is required" 427 when (null input) $ die "tricu arboricx compile: input file is required" 428 let nameTexts = if null names then [] else map T.pack names 429 compileFileWithStore mStore input out nameTexts 430 431 runImport :: TricuArgs -> IO () 432 runImport opts = do 433 let file = importFile opts 434 when (null file) $ die "tricu arboricx import: input file is required" 435 store <- resolveStorePath (importStore opts) 436 bundleData <- BL.readFile file 437 roots <- unpackBundleToStore store (BL.toStrict bundleData) 438 mapM_ (\(name, root) -> 439 writeAlias store NameAlias name (treeTermRef root)) roots 440 let manifest = ModuleManifest [] 441 [ ModuleExport 442 name 443 (treeTermRef root) 444 "arboricx.abi.tree.v1" 445 | (name, root) <- roots 446 ] 447 moduleName = T.pack $ maybe (takeBaseName file) id (importModule opts) 448 manifestHash <- putManifest store manifest 449 writeAlias store ModuleAlias moduleName (ObjectRef (unDomain manifestDomain) manifestHash) 450 putStrLn $ "Imported " ++ show (length roots) ++ " root(s):" 451 mapM_ (\(name, root) -> putStrLn $ " " ++ T.unpack name ++ " -> " ++ T.unpack root) roots 452 putStrLn $ "Created module alias " ++ T.unpack moduleName ++ " -> " ++ T.unpack manifestHash 453 454 runExport :: TricuArgs -> IO () 455 runExport opts = 456 if dag opts 457 then runExportDag opts 458 else runExportBundle opts 459 460 runExportBundle :: TricuArgs -> IO () 461 runExportBundle opts = do 462 let targets = exportTargets opts 463 modules = exportModules opts 464 out = exportOutput opts 465 names = exportNames opts 466 allFlag = exportAll opts 467 splitFlag = exportSplit opts 468 when (null out) $ die "tricu arboricx export: --output is required" 469 when (null targets && null modules && not allFlag) $ 470 die "tricu arboricx export: at least one --target, --module, or --all is required" 471 when (splitFlag && not (null names)) $ 472 die "tricu arboricx export --split: --name is not supported; split bundles use their export names" 473 store <- resolveStorePath (exportStore opts) 474 allEntries <- if allFlag then resolveAllNameExports store else pure [] 475 targetRoots <- mapM (resolveStoreTarget store) targets 476 moduleRoots <- concat <$> mapM (resolveModuleExports store) modules 477 let targetEntries = zip (defaultExportNames (length targetRoots)) targetRoots 478 entries = allEntries ++ targetEntries ++ moduleRoots 479 expNames = if null names then map fst entries else map T.pack names 480 when (null entries) $ 481 die "tricu arboricx export: no tree-term exports found" 482 when (length expNames /= length entries) $ 483 die "tricu arboricx export: number of --name values must match number of exported roots" 484 if splitFlag 485 then runExportBundleSplit store out (zip expNames (map snd entries)) 486 else do 487 bundle <- packBundleFromStore store (zip expNames (map snd entries)) 488 let bundleData = encodeBundle bundle 489 BL.writeFile out (BL.fromStrict bundleData) 490 putStrLn $ "Exported bundle with " ++ show (length entries) ++ " export(s) to " ++ out 491 putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle)) 492 putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes" 493 494 runExportBundleSplit :: StorePath -> FilePath -> [(T.Text, ObjectHash)] -> IO () 495 runExportBundleSplit store outDir entries = do 496 createDirectoryIfMissing True outDir 497 written <- forM (zip [0 :: Int ..] entries) $ \(i, (name, root)) -> do 498 bundle <- packBundleFromStore store [(name, root)] 499 let bundleData = encodeBundle bundle 500 path = outDir </> splitBundleFileName i name 501 BL.writeFile path (BL.fromStrict bundleData) 502 pure (path, Seq.length (bundleNodes bundle), BS.length bundleData) 503 putStrLn $ "Exported " ++ show (length written) ++ " split bundle(s) to " ++ outDir 504 mapM_ (\(path, nodeCount, byteCount) -> 505 putStrLn $ " " ++ path ++ " (nodes: " ++ show nodeCount ++ ", size: " ++ show byteCount ++ " bytes)") written 506 507 runStoreAliasList :: TricuArgs -> IO () 508 runStoreAliasList opts = do 509 store <- resolveStorePath (storePathOpt opts) 510 aliases <- listAliases store (storeAliasKind opts) 511 mapM_ (\(name, ref) -> putStrLn $ T.unpack name ++ " -> " ++ formatObjectRef ref) aliases 512 513 runStoreAliasGet :: TricuArgs -> IO () 514 runStoreAliasGet opts = do 515 store <- resolveStorePath (storePathOpt opts) 516 mRef <- readAlias store (storeAliasKind opts) (T.pack $ storeAliasName opts) 517 case mRef of 518 Nothing -> die $ "alias not found: " ++ storeAliasName opts 519 Just ref -> putStrLn $ storeAliasName opts ++ " -> " ++ formatObjectRef ref 520 521 runExportDag :: TricuArgs -> IO () 522 runExportDag opts = do 523 let targets = exportTargets opts 524 modules = exportModules opts 525 out = exportOutput opts 526 unless (null modules) $ 527 die "tricu arboricx export --dag: --module is only supported for bundle export" 528 case targets of 529 [target] -> do 530 store <- resolveStorePath (exportStore opts) 531 root <- resolveStoreTarget store target 532 maybeTerm <- getTreeTerm store root 533 case maybeTerm of 534 Nothing -> die $ "Term not found: " ++ target 535 Just term -> do 536 let (rootIdx, nodes) = Research.exportDag term 537 output = unlines $ 538 show rootIdx : 539 map (\(tag, refs) -> unwords (tag : map show refs)) nodes 540 writeOutput out output 541 [] -> die "tricu arboricx export --dag: exactly one --target is required" 542 _ -> die "tricu arboricx export --dag: exactly one --target is required" 543 544 -- --------------------------------------------------------------------------- 545 -- Helpers 546 -- --------------------------------------------------------------------------- 547 548 resolveStorePath :: Maybe FilePath -> IO StorePath 549 resolveStorePath (Just path) = return (StorePath path) 550 resolveStorePath Nothing = do 551 home <- getHomeDirectory 552 return (StorePath (home </> ".tricu" </> "store")) 553 554 treeTermRef :: ObjectHash -> ObjectRef 555 treeTermRef = ObjectRef (unDomain treeTermDomain) 556 557 resolveStoreTarget :: StorePath -> String -> IO ObjectHash 558 resolveStoreTarget store target = do 559 mAlias <- readAlias store NameAlias (T.pack target) 560 let root = maybe (T.pack target) objectRefHash mAlias 561 mTree <- getTreeTerm store root 562 case mTree of 563 Just _ -> return root 564 Nothing -> die $ "Term not found in store: " ++ target 565 566 resolveAllNameExports :: StorePath -> IO [(T.Text, ObjectHash)] 567 resolveAllNameExports store = do 568 aliases <- sortOn fst <$> listAliases store NameAlias 569 fmap concat $ mapM exportAlias aliases 570 where 571 exportAlias (name, ref) 572 | objectRefKind ref /= unDomain treeTermDomain = pure [] 573 | otherwise = do 574 mTree <- getTreeTerm store (objectRefHash ref) 575 case mTree of 576 Nothing -> die $ "Name alias tree term not found: " ++ T.unpack name 577 Just _ -> pure [(name, objectRefHash ref)] 578 579 resolveModuleExports :: StorePath -> String -> IO [(T.Text, ObjectHash)] 580 resolveModuleExports store moduleTarget = do 581 manifestHash <- resolveModuleManifestHash store moduleTarget 582 mManifest <- getManifest store manifestHash 583 manifest <- case mManifest of 584 Nothing -> die $ "Module manifest not found in store: " ++ moduleTarget 585 Just value -> return value 586 mapM exportEntry (moduleManifestExports manifest) 587 where 588 exportEntry ex = do 589 let ref = moduleExportObject ex 590 unless (objectRefKind ref == unDomain treeTermDomain) $ 591 die $ "Unsupported module export object kind for " ++ T.unpack (moduleExportName ex) ++ ": " ++ T.unpack (objectRefKind ref) 592 mTree <- getTreeTerm store (objectRefHash ref) 593 case mTree of 594 Nothing -> die $ "Module export tree term not found: " ++ T.unpack (moduleExportName ex) 595 Just _ -> return (moduleExportName ex, objectRefHash ref) 596 597 resolveModuleManifestHash :: StorePath -> String -> IO ObjectHash 598 resolveModuleManifestHash store moduleTarget = do 599 mAlias <- readAlias store ModuleAlias (T.pack moduleTarget) 600 case mAlias of 601 Just ref -> do 602 unless (objectRefKind ref == unDomain manifestDomain) $ 603 die $ "Module alias does not point at a module manifest: " ++ moduleTarget 604 return (objectRefHash ref) 605 Nothing -> return (T.pack moduleTarget) 606 607 formatObjectRef :: ObjectRef -> String 608 formatObjectRef ref = T.unpack (objectRefKind ref) ++ " " ++ T.unpack (objectRefHash ref) 609 610 splitBundleFileName :: Int -> T.Text -> FilePath 611 splitBundleFileName i name = show i ++ "-" ++ sanitize (T.unpack name) ++ ".arboricx" 612 where 613 sanitize [] = "export" 614 sanitize xs = case map safeChar xs of 615 [] -> "export" 616 ys -> ys 617 safeChar c 618 | isAlphaNum c || c == '-' || c == '_' || c == '.' = c 619 | otherwise = '_' 620 621 writeOutput :: FilePath -> String -> IO () 622 writeOutput path content 623 | null path = putStr content 624 | otherwise = writeFile path content 625 626 runTricuTEnv :: Env -> String -> T 627 runTricuTEnv env input = 628 let asts = parseTricu input 629 finalEnv = evalTricu env asts 630 in result finalEnv