252 lines
9.0 KiB
Haskell
252 lines
9.0 KiB
Haskell
module Main where
|
|
|
|
import ContentStore (initContentStore, loadEnvironment, resolveExportTarget)
|
|
import Server (runServer)
|
|
import Eval (evalTricu, mainResult, result)
|
|
import FileEval
|
|
import Parser (parseTricu)
|
|
import REPL
|
|
import Research
|
|
import Wire
|
|
|
|
import Control.Monad (foldM)
|
|
import Data.Text (Text, unpack)
|
|
import qualified Data.Text as T
|
|
import Data.Version (showVersion)
|
|
import Paths_tricu (version)
|
|
import System.Console.CmdArgs
|
|
import System.Environment (lookupEnv)
|
|
import System.IO (hPutStrLn, stderr)
|
|
import Text.Megaparsec ()
|
|
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import Database.SQLite.Simple (close)
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
data TricuArgs
|
|
= Repl
|
|
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
|
|
| TDecode { file :: [FilePath] }
|
|
| Compile { inputFile :: FilePath, outFile :: FilePath, names :: [String] }
|
|
| Export { hash :: String, exportNameOpt :: String, outFile :: FilePath, names :: [String] }
|
|
| Import { inFile :: FilePath }
|
|
| Serve { host :: String, port :: Int }
|
|
deriving (Show, Data, Typeable)
|
|
|
|
replMode :: TricuArgs
|
|
replMode = Repl
|
|
&= help "Start interactive REPL"
|
|
&= auto
|
|
&= name "repl"
|
|
|
|
evaluateMode :: TricuArgs
|
|
evaluateMode = Evaluate
|
|
{ file = def &= help "Input file path(s) for evaluation.\n \
|
|
\ Defaults to stdin."
|
|
&= name "f" &= typ "FILE"
|
|
, form = TreeCalculus &= typ "FORM"
|
|
&= help "Optional output form: (tree|fsl|ast|ternary|ascii|decode).\n \
|
|
\ Defaults to tricu-compatible `t` tree form."
|
|
&= name "t"
|
|
}
|
|
&= help "Evaluate tricu and return the result of the final expression."
|
|
&= explicit
|
|
&= name "eval"
|
|
|
|
decodeMode :: TricuArgs
|
|
decodeMode = TDecode
|
|
{ file = def
|
|
&= help "Optional input file path to attempt decoding.\n \
|
|
\ Defaults to stdin."
|
|
&= name "f" &= typ "FILE"
|
|
}
|
|
&= help "Decode a Tree Calculus value into a string representation."
|
|
&= explicit
|
|
&= name "decode"
|
|
|
|
exportMode :: TricuArgs
|
|
exportMode = Export
|
|
{ hash = def &= help "Hash or stored term name(s) to export (comma-separated)."
|
|
&= name "h" &= typ "HASH_OR_NAME"
|
|
, exportNameOpt = def &= help "Export name (legacy; use -n NAME for full control)."
|
|
&= name "n" &= typ "NAME"
|
|
, outFile = def &= help "Output file path for the bundle." &= name "o" &= typ "FILE"
|
|
, names = def &= help "Export name(s) for the bundle manifest (comma-separated or repeated -n)."
|
|
&= typ "NAME"
|
|
}
|
|
&= help "Export a Merkle bundle from the content store."
|
|
&= explicit
|
|
&= name "export"
|
|
|
|
importMode :: TricuArgs
|
|
importMode = Import
|
|
{ inFile = def &= help "Path to the bundle file to import."
|
|
&= name "f" &= typ "FILE"
|
|
}
|
|
&= help "Import a Merkle bundle into the content store."
|
|
&= explicit
|
|
&= name "import"
|
|
|
|
compileMode :: TricuArgs
|
|
compileMode = Compile
|
|
{ inputFile = def &= help "Path to the tricu source file (.tri) to compile."
|
|
&= name "f" &= typ "FILE"
|
|
, outFile = def &= help "Output bundle file path (.tri.bundle)."
|
|
&= name "o" &= typ "FILE"
|
|
, names = def &= help "Definition name(s) to export as bundle roots (comma-separated or repeated -x). Defaults to 'main'."
|
|
&= name "x" &= typ "NAME"
|
|
}
|
|
&= help "Compile a tricu source file into a standalone Arboricx portable bundle."
|
|
&= explicit
|
|
&= name "compile"
|
|
|
|
serveMode :: TricuArgs
|
|
serveMode = Serve
|
|
{ host = "127.0.0.1" &= help "Host to bind the server to." &= name "h" &= typ "HOST"
|
|
, port = 8787 &= help "HTTP port to listen on." &= name "p" &= typ "PORT"
|
|
}
|
|
&= help "Start a read-only HTTP server for exporting Arboricx bundles."
|
|
&= explicit
|
|
&= name "server"
|
|
|
|
main :: IO ()
|
|
main = do
|
|
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
|
|
cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, compileMode, exportMode, importMode, serveMode]
|
|
&= help "tricu: Exploring Tree Calculus"
|
|
&= program "tricu"
|
|
&= summary versionStr
|
|
&= versionArg [explicit, name "version", summary versionStr]
|
|
case cmdArgsParsed of
|
|
Repl -> do
|
|
putStrLn "Welcome to the tricu REPL"
|
|
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
|
|
repl
|
|
Evaluate { file = filePaths, form = outputForm } -> do
|
|
maybeDbPath <- lookupEnv "TRICU_DB_PATH"
|
|
evalResult <- case filePaths of
|
|
[] -> do
|
|
initialEnv <- case maybeDbPath of
|
|
Just _ -> do
|
|
conn <- initContentStore
|
|
env <- loadEnvironment conn
|
|
close conn
|
|
return env
|
|
Nothing -> return Map.empty
|
|
input <- getContents
|
|
pure $ runTricuTEnv initialEnv input
|
|
(_:restFilePaths) -> do
|
|
initialEnv <- case maybeDbPath of
|
|
Just _ -> do
|
|
conn <- initContentStore
|
|
env <- loadEnvironment conn
|
|
close conn
|
|
return env
|
|
Nothing -> return Map.empty
|
|
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
|
|
pure $ mainResult finalEnv
|
|
let fRes = formatT outputForm evalResult
|
|
putStr fRes
|
|
TDecode { file = filePaths } -> do
|
|
value <- case filePaths of
|
|
[] -> getContents
|
|
(filePath:_) -> readFile filePath
|
|
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
|
|
Export { hash = hashStr, exportNameOpt = legacyName, names = namesArg, outFile = outFilePath } -> do
|
|
conn <- initContentStore
|
|
let hashList = T.split (== ',') (T.pack hashStr)
|
|
hashes <- mapM (\h -> do
|
|
(resolvedHash, _) <- resolveExportTarget conn (T.unpack h)
|
|
return resolvedHash) hashList
|
|
-- Merge legacy -n and new -n (names); names wins when non-empty
|
|
let allNames = if null namesArg
|
|
then if null legacyName then [] else [legacyName]
|
|
else namesArg
|
|
let expNames = if null allNames
|
|
then defaultExportNames (length hashes)
|
|
else map T.pack allNames
|
|
let exports = zip expNames hashes
|
|
bundleData <- exportNamedBundle conn exports
|
|
BL.writeFile outFilePath (BL.fromStrict bundleData)
|
|
putStrLn $ "Exported bundle with " ++ show (length exports) ++ " export(s) to " ++ outFilePath
|
|
close conn
|
|
Import { inFile = importFile } -> do
|
|
conn <- initContentStore
|
|
bundleData <- BL.readFile importFile
|
|
roots <- importBundle conn (BL.toStrict bundleData)
|
|
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
|
|
mapM_ (\r -> putStrLn $ " " ++ unpack r) roots
|
|
close conn
|
|
Compile { inputFile = compileInputFile, outFile = compileOutFile, names = namesArg } ->
|
|
let exportNames = if null namesArg then [] else map T.pack namesArg
|
|
in compileFile compileInputFile compileOutFile exportNames
|
|
Serve { host = hostStr, port = portNum } -> do
|
|
putStrLn $ "Starting Arboricx bundle server on " ++ hostStr ++ ":" ++ show portNum
|
|
putStrLn $ " GET /bundle/hash/:hash -- primary endpoint"
|
|
putStrLn $ " GET /bundle/name/:name -- convenience endpoint"
|
|
putStrLn $ " Content-Type: application/vnd.arboricx.bundle"
|
|
runServer hostStr portNum
|
|
|
|
runTricu :: String -> String
|
|
runTricu = formatT TreeCalculus . runTricuT
|
|
|
|
runTricuT :: String -> T
|
|
runTricuT input =
|
|
let asts = parseTricu input
|
|
finalEnv = evalTricu Map.empty asts
|
|
in result finalEnv
|
|
|
|
runTricuEnv :: Env -> String -> String
|
|
runTricuEnv env = formatT TreeCalculus . runTricuTEnv env
|
|
|
|
runTricuTEnv :: Env -> String -> T
|
|
runTricuTEnv env input =
|
|
let asts = parseTricu input
|
|
finalEnv = evalTricu env asts
|
|
in result finalEnv
|
|
|
|
runTricuWithEnvT :: String -> (Env, T)
|
|
runTricuWithEnvT input =
|
|
let asts = parseTricu input
|
|
finalEnv = evalTricu Map.empty asts
|
|
in (finalEnv, result finalEnv)
|
|
|
|
runTricuWithEnv :: String -> (Env, String)
|
|
runTricuWithEnv input =
|
|
let asts = parseTricu input
|
|
finalEnv = evalTricu Map.empty asts
|
|
res = result finalEnv
|
|
in (finalEnv, formatT TreeCalculus res)
|
|
|
|
runTricuEnvWithEnvT :: Env -> String -> (Env, T)
|
|
runTricuEnvWithEnvT env input =
|
|
let asts = parseTricu input
|
|
finalEnv = evalTricu env asts
|
|
in (finalEnv, result finalEnv)
|
|
|
|
runTricuEnvWithEnv :: Env -> String -> (Env, String)
|
|
runTricuEnvWithEnv env input =
|
|
let asts = parseTricu input
|
|
finalEnv = evalTricu env asts
|
|
res = result finalEnv
|
|
in (finalEnv, formatT TreeCalculus res)
|
|
|
|
chooseExportName :: String -> String -> [Text] -> IO Text
|
|
chooseExportName explicitName input storedNames
|
|
| not (null explicitName) = return $ T.pack explicitName
|
|
| Just firstName <- firstNonEmpty storedNames = return firstName
|
|
| otherwise = do
|
|
hPutStrLn stderr $
|
|
"No stored name found for export target " ++ input ++ "; using export name 'root'. "
|
|
++ "Use export -n NAME to preserve a semantic name."
|
|
return "root"
|
|
|
|
firstNonEmpty :: [Text] -> Maybe Text
|
|
firstNonEmpty = go
|
|
where
|
|
go [] = Nothing
|
|
go (x:xs)
|
|
| T.null x = go xs
|
|
| otherwise = Just x
|